From 5424d82176f21ec768a28264b3350620b453d276 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 10 May 2022 17:18:48 +0200 Subject: [PATCH 1/6] Manifest,Everywhere: bump ocamlformat to 0.21.0 --- .ocamlformat | 4 ++-- devtools/git-gas-diff/.ocamlformat | 4 ++-- manifest/main.ml | 2 +- manifest/manifest.ml | 4 +++- opam/internal-devtools.opam | 2 +- opam/tezos-accuser-012-Psithaca.opam | 2 +- opam/tezos-accuser-013-PtJakart.opam | 2 +- opam/tezos-accuser-alpha.opam | 2 +- opam/tezos-baker-012-Psithaca.opam | 2 +- opam/tezos-baker-013-PtJakart.opam | 2 +- opam/tezos-baker-alpha.opam | 2 +- opam/tezos-baking-012-Psithaca-commands.opam | 2 +- opam/tezos-baking-012-Psithaca.opam | 2 +- opam/tezos-baking-013-PtJakart-commands.opam | 2 +- opam/tezos-baking-013-PtJakart.opam | 2 +- opam/tezos-baking-alpha-commands.opam | 2 +- opam/tezos-baking-alpha.opam | 2 +- opam/tezos-base-test-helpers.opam | 2 +- opam/tezos-base.opam | 2 +- opam/tezos-benchmark-012-Psithaca.opam | 2 +- opam/tezos-benchmark-013-PtJakart.opam | 2 +- opam/tezos-benchmark-alpha.opam | 2 +- opam/tezos-benchmark-examples.opam | 2 +- opam/tezos-benchmark-tests.opam | 2 +- opam/tezos-benchmark-type-inference-012-Psithaca.opam | 2 +- opam/tezos-benchmark-type-inference-013-PtJakart.opam | 2 +- opam/tezos-benchmark-type-inference-alpha.opam | 2 +- opam/tezos-benchmark.opam | 2 +- opam/tezos-benchmarks-proto-012-Psithaca.opam | 2 +- opam/tezos-benchmarks-proto-013-PtJakart.opam | 2 +- opam/tezos-benchmarks-proto-alpha.opam | 2 +- opam/tezos-clic.opam | 2 +- opam/tezos-client-000-Ps9mPmXa.opam | 2 +- opam/tezos-client-001-PtCJ7pwo-commands.opam | 2 +- opam/tezos-client-001-PtCJ7pwo.opam | 2 +- opam/tezos-client-002-PsYLVpVv-commands.opam | 2 +- opam/tezos-client-002-PsYLVpVv.opam | 2 +- opam/tezos-client-003-PsddFKi3-commands.opam | 2 +- opam/tezos-client-003-PsddFKi3.opam | 2 +- opam/tezos-client-004-Pt24m4xi-commands.opam | 2 +- opam/tezos-client-004-Pt24m4xi.opam | 2 +- opam/tezos-client-005-PsBabyM1-commands.opam | 2 +- opam/tezos-client-005-PsBabyM1.opam | 2 +- opam/tezos-client-006-PsCARTHA-commands.opam | 2 +- opam/tezos-client-006-PsCARTHA.opam | 2 +- opam/tezos-client-007-PsDELPH1-commands-registration.opam | 2 +- opam/tezos-client-007-PsDELPH1-commands.opam | 2 +- opam/tezos-client-007-PsDELPH1.opam | 2 +- opam/tezos-client-008-PtEdo2Zk-commands-registration.opam | 2 +- opam/tezos-client-008-PtEdo2Zk-commands.opam | 2 +- opam/tezos-client-008-PtEdo2Zk.opam | 2 +- opam/tezos-client-009-PsFLoren-commands-registration.opam | 2 +- opam/tezos-client-009-PsFLoren-commands.opam | 2 +- opam/tezos-client-009-PsFLoren.opam | 2 +- opam/tezos-client-010-PtGRANAD-commands-registration.opam | 2 +- opam/tezos-client-010-PtGRANAD-commands.opam | 2 +- opam/tezos-client-010-PtGRANAD.opam | 2 +- opam/tezos-client-011-PtHangz2-commands-registration.opam | 2 +- opam/tezos-client-011-PtHangz2-commands.opam | 2 +- opam/tezos-client-011-PtHangz2.opam | 2 +- opam/tezos-client-012-Psithaca-commands-registration.opam | 2 +- opam/tezos-client-012-Psithaca-commands.opam | 2 +- opam/tezos-client-012-Psithaca.opam | 2 +- opam/tezos-client-013-PtJakart-commands-registration.opam | 2 +- opam/tezos-client-013-PtJakart-commands.opam | 2 +- opam/tezos-client-013-PtJakart.opam | 2 +- opam/tezos-client-alpha-commands-registration.opam | 2 +- opam/tezos-client-alpha-commands.opam | 2 +- opam/tezos-client-alpha.opam | 2 +- opam/tezos-client-base-unix.opam | 2 +- opam/tezos-client-base.opam | 2 +- opam/tezos-client-commands.opam | 2 +- opam/tezos-client-demo-counter.opam | 2 +- opam/tezos-client-genesis.opam | 2 +- opam/tezos-client-sapling-008-PtEdo2Zk.opam | 2 +- opam/tezos-client-sapling-009-PsFLoren.opam | 2 +- opam/tezos-client-sapling-010-PtGRANAD.opam | 2 +- opam/tezos-client-sapling-011-PtHangz2.opam | 2 +- opam/tezos-client-sapling-012-Psithaca.opam | 2 +- opam/tezos-client-sapling-013-PtJakart.opam | 2 +- opam/tezos-client-sapling-alpha.opam | 2 +- opam/tezos-client.opam | 2 +- opam/tezos-codec.opam | 2 +- opam/tezos-context.opam | 2 +- opam/tezos-crypto.opam | 2 +- opam/tezos-error-monad.opam | 2 +- opam/tezos-event-logging-test-helpers.opam | 2 +- opam/tezos-event-logging.opam | 2 +- opam/tezos-hacl.opam | 2 +- opam/tezos-lwt-result-stdlib.opam | 2 +- opam/tezos-micheline-rewriting.opam | 2 +- opam/tezos-micheline.opam | 2 +- opam/tezos-mockup-commands.opam | 2 +- opam/tezos-mockup-proxy.opam | 2 +- opam/tezos-mockup-registration.opam | 2 +- opam/tezos-mockup.opam | 2 +- opam/tezos-node.opam | 2 +- opam/tezos-openapi.opam | 2 +- opam/tezos-p2p-services.opam | 2 +- opam/tezos-p2p.opam | 2 +- opam/tezos-protocol-008-PtEdo2Zk-parameters.opam | 2 +- opam/tezos-protocol-009-PsFLoren-parameters.opam | 2 +- opam/tezos-protocol-010-PtGRANAD-parameters.opam | 2 +- opam/tezos-protocol-011-PtHangz2-parameters.opam | 2 +- opam/tezos-protocol-012-Psithaca-parameters.opam | 2 +- opam/tezos-protocol-013-PtJakart-parameters.opam | 2 +- opam/tezos-protocol-alpha-parameters.opam | 2 +- opam/tezos-protocol-compiler.opam | 2 +- opam/tezos-protocol-environment.opam | 2 +- opam/tezos-protocol-plugin-007-PsDELPH1-registerer.opam | 2 +- opam/tezos-protocol-plugin-007-PsDELPH1.opam | 2 +- opam/tezos-protocol-plugin-008-PtEdo2Zk-registerer.opam | 2 +- opam/tezos-protocol-plugin-008-PtEdo2Zk.opam | 2 +- opam/tezos-protocol-plugin-009-PsFLoren-registerer.opam | 2 +- opam/tezos-protocol-plugin-009-PsFLoren.opam | 2 +- opam/tezos-protocol-plugin-010-PtGRANAD-registerer.opam | 2 +- opam/tezos-protocol-plugin-010-PtGRANAD.opam | 2 +- opam/tezos-protocol-plugin-011-PtHangz2-registerer.opam | 2 +- opam/tezos-protocol-plugin-011-PtHangz2.opam | 2 +- opam/tezos-protocol-plugin-012-Psithaca-registerer.opam | 2 +- opam/tezos-protocol-plugin-012-Psithaca-tests.opam | 2 +- opam/tezos-protocol-plugin-012-Psithaca.opam | 2 +- opam/tezos-protocol-plugin-013-PtJakart-registerer.opam | 2 +- opam/tezos-protocol-plugin-013-PtJakart-tests.opam | 2 +- opam/tezos-protocol-plugin-013-PtJakart.opam | 2 +- opam/tezos-protocol-plugin-alpha-registerer.opam | 2 +- opam/tezos-protocol-plugin-alpha-tests.opam | 2 +- opam/tezos-protocol-plugin-alpha.opam | 2 +- opam/tezos-protocol-updater.opam | 2 +- opam/tezos-proxy-server-config.opam | 2 +- opam/tezos-proxy-server.opam | 2 +- opam/tezos-proxy.opam | 2 +- opam/tezos-requester.opam | 2 +- opam/tezos-rpc-http-client-unix.opam | 2 +- opam/tezos-rpc-http-client.opam | 2 +- opam/tezos-rpc-http-server.opam | 2 +- opam/tezos-rpc-http.opam | 2 +- opam/tezos-rpc.opam | 2 +- opam/tezos-sapling.opam | 2 +- opam/tezos-sc-rollup-013-PtJakart.opam | 2 +- opam/tezos-sc-rollup-alpha.opam | 2 +- opam/tezos-sc-rollup-client-013-PtJakart.opam | 2 +- opam/tezos-sc-rollup-client-alpha.opam | 2 +- opam/tezos-sc-rollup-node-013-PtJakart.opam | 2 +- opam/tezos-sc-rollup-node-alpha.opam | 2 +- opam/tezos-scoru-wasm.opam | 2 +- opam/tezos-shell-benchmarks.opam | 2 +- opam/tezos-shell-context-test.opam | 2 +- opam/tezos-shell-context.opam | 2 +- opam/tezos-shell-services-test-helpers.opam | 2 +- opam/tezos-shell-services.opam | 2 +- opam/tezos-shell.opam | 2 +- opam/tezos-signer-backends.opam | 2 +- opam/tezos-signer-services.opam | 2 +- opam/tezos-signer.opam | 2 +- opam/tezos-snoop.opam | 2 +- opam/tezos-stdlib-unix.opam | 2 +- opam/tezos-stdlib.opam | 2 +- opam/tezos-store.opam | 2 +- opam/tezos-test-helpers-extra.opam | 2 +- opam/tezos-test-helpers.opam | 2 +- opam/tezos-tooling.opam | 4 ++-- opam/tezos-tps-evaluation.opam | 2 +- opam/tezos-tx-rollup-013-PtJakart.opam | 2 +- opam/tezos-tx-rollup-alpha.opam | 2 +- opam/tezos-tx-rollup-client-013-PtJakart.opam | 2 +- opam/tezos-tx-rollup-client-alpha.opam | 2 +- opam/tezos-tx-rollup-node-013-PtJakart.opam | 2 +- opam/tezos-tx-rollup-node-alpha.opam | 2 +- opam/tezos-validation.opam | 2 +- opam/tezos-validator.opam | 2 +- opam/tezos-version.opam | 2 +- opam/tezos-webassembly-interpreter.opam | 2 +- opam/tezos-workers.opam | 2 +- opam/tezt-performance-regression.opam | 2 +- opam/tezt-self-tests.opam | 2 +- opam/tezt-tezos.opam | 2 +- opam/tezt.opam | 2 +- scripts/lint.sh | 4 ++-- src/lib_time_measurement/.ocamlformat | 4 ++-- src/proto_000_Ps9mPmXa/lib_protocol/.ocamlformat | 4 ++-- src/proto_001_PtCJ7pwo/lib_protocol/.ocamlformat | 4 ++-- src/proto_002_PsYLVpVv/lib_protocol/.ocamlformat | 4 ++-- src/proto_003_PsddFKi3/lib_protocol/.ocamlformat | 4 ++-- src/proto_004_Pt24m4xi/lib_protocol/.ocamlformat | 4 ++-- src/proto_005_PsBABY5H/lib_protocol/.ocamlformat | 4 ++-- src/proto_005_PsBabyM1/lib_protocol/.ocamlformat | 4 ++-- src/proto_006_PsCARTHA/lib_protocol/.ocamlformat | 4 ++-- src/proto_007_PsDELPH1/lib_protocol/.ocamlformat | 4 ++-- src/proto_008_PtEdo2Zk/lib_protocol/.ocamlformat | 4 ++-- src/proto_008_PtEdoTez/lib_protocol/.ocamlformat | 4 ++-- src/proto_009_PsFLoren/lib_protocol/.ocamlformat | 4 ++-- src/proto_010_PtGRANAD/lib_protocol/.ocamlformat | 4 ++-- src/proto_011_PtHangz2/lib_protocol/.ocamlformat | 4 ++-- src/proto_012_Psithaca/lib_protocol/.ocamlformat | 4 ++-- src/proto_012_Psithaca/lib_protocol/test/helpers/.ocamlformat | 4 ++-- src/proto_013_PtJakart/lib_protocol/.ocamlformat | 4 ++-- src/proto_013_PtJakart/lib_protocol/test/helpers/.ocamlformat | 4 ++-- src/proto_alpha/lib_protocol/.ocamlformat | 4 ++-- src/proto_alpha/lib_protocol/test/helpers/.ocamlformat | 4 ++-- src/proto_demo_counter/lib_protocol/.ocamlformat | 4 ++-- src/proto_demo_noops/lib_protocol/.ocamlformat | 4 ++-- src/proto_genesis/lib_protocol/.ocamlformat | 4 ++-- vendors/pyml-plot/lib/.ocamlformat | 1 - 204 files changed, 233 insertions(+), 232 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 5e1158919e85..4d3778114a8a 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,5 @@ -version=0.18.0 +version=0.21.0 +ocaml-version=4.12.1 wrap-fun-args=false let-binding-spacing=compact field-space=loose @@ -14,4 +15,3 @@ doc-comments=before margin=80 module-item-spacing=sparse parens-tuple=always -parens-tuple-patterns=always diff --git a/devtools/git-gas-diff/.ocamlformat b/devtools/git-gas-diff/.ocamlformat index 5e1158919e85..4d3778114a8a 100644 --- a/devtools/git-gas-diff/.ocamlformat +++ b/devtools/git-gas-diff/.ocamlformat @@ -1,4 +1,5 @@ -version=0.18.0 +version=0.21.0 +ocaml-version=4.12.1 wrap-fun-args=false let-binding-spacing=compact field-space=loose @@ -14,4 +15,3 @@ doc-comments=before margin=80 module-item-spacing=sparse parens-tuple=always -parens-tuple-patterns=always diff --git a/manifest/main.ml b/manifest/main.ml index 414f6488cdad..61e2f59a616f 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -176,7 +176,7 @@ let mtime_clock_os = external_sublib mtime "mtime.clock.os" let ocaml_migrate_parsetree = external_lib "ocaml-migrate-parsetree" V.True -let ocamlformat = opam_only "ocamlformat" V.(exactly "0.18.0") +let ocamlformat = opam_only "ocamlformat" V.(exactly "0.21.0") let ocamlgraph = external_lib "ocamlgraph" V.True diff --git a/manifest/manifest.ml b/manifest/manifest.ml index a7d2c2cc5e3f..a78f121ef279 100644 --- a/manifest/manifest.ml +++ b/manifest/manifest.ml @@ -1881,7 +1881,9 @@ let generate_opam ?release for_package (internals : Target.internal list) : let depends = { Opam.package = "dune"; - version = Version.at_least "2.9"; + (* We artificially constrain the version of dune to split the tooling + upgrade. This is temporary. *) + version = Version.(and_list [ at_least "2.9"; less_than "3.0"]); with_test = false; optional = false; } diff --git a/opam/internal-devtools.opam b/opam/internal-devtools.opam index 760982c59403..f9e3b304a32a 100644 --- a/opam/internal-devtools.opam +++ b/opam/internal-devtools.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "num" "re" { >= "1.7.2" } "tezos-protocol-compiler" diff --git a/opam/tezos-accuser-012-Psithaca.opam b/opam/tezos-accuser-012-Psithaca.opam index 75b2bad2629b..c94b02ee6a50 100644 --- a/opam/tezos-accuser-012-Psithaca.opam +++ b/opam/tezos-accuser-012-Psithaca.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-012-Psithaca" "tezos-client-012-Psithaca" diff --git a/opam/tezos-accuser-013-PtJakart.opam b/opam/tezos-accuser-013-PtJakart.opam index 255cd7781e12..e66e95478e2a 100644 --- a/opam/tezos-accuser-013-PtJakart.opam +++ b/opam/tezos-accuser-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-013-PtJakart" "tezos-client-013-PtJakart" diff --git a/opam/tezos-accuser-alpha.opam b/opam/tezos-accuser-alpha.opam index 45588533970b..0b38accaf47c 100644 --- a/opam/tezos-accuser-alpha.opam +++ b/opam/tezos-accuser-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-alpha" "tezos-client-alpha" diff --git a/opam/tezos-baker-012-Psithaca.opam b/opam/tezos-baker-012-Psithaca.opam index d0aad5026d53..3b7d6338bf9e 100644 --- a/opam/tezos-baker-012-Psithaca.opam +++ b/opam/tezos-baker-012-Psithaca.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-012-Psithaca" "tezos-client-012-Psithaca" diff --git a/opam/tezos-baker-013-PtJakart.opam b/opam/tezos-baker-013-PtJakart.opam index 55a749a80ebe..68bd28a4846a 100644 --- a/opam/tezos-baker-013-PtJakart.opam +++ b/opam/tezos-baker-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-013-PtJakart" "tezos-client-013-PtJakart" diff --git a/opam/tezos-baker-alpha.opam b/opam/tezos-baker-alpha.opam index f0b78ef93b3a..74e307325eb9 100644 --- a/opam/tezos-baker-alpha.opam +++ b/opam/tezos-baker-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-alpha" "tezos-client-alpha" diff --git a/opam/tezos-baking-012-Psithaca-commands.opam b/opam/tezos-baking-012-Psithaca-commands.opam index 156b8654d761..e67292a0fdc8 100644 --- a/opam/tezos-baking-012-Psithaca-commands.opam +++ b/opam/tezos-baking-012-Psithaca-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-012-Psithaca" "tezos-stdlib-unix" diff --git a/opam/tezos-baking-012-Psithaca.opam b/opam/tezos-baking-012-Psithaca.opam index 0d0ad00c21db..8622671f7d8d 100644 --- a/opam/tezos-baking-012-Psithaca.opam +++ b/opam/tezos-baking-012-Psithaca.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-version" "tezos-protocol-012-Psithaca" diff --git a/opam/tezos-baking-013-PtJakart-commands.opam b/opam/tezos-baking-013-PtJakart-commands.opam index 9e4a4b5e9035..454fc0547f7e 100644 --- a/opam/tezos-baking-013-PtJakart-commands.opam +++ b/opam/tezos-baking-013-PtJakart-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-013-PtJakart" "tezos-stdlib-unix" diff --git a/opam/tezos-baking-013-PtJakart.opam b/opam/tezos-baking-013-PtJakart.opam index 61f6a9953d4b..59ac063df581 100644 --- a/opam/tezos-baking-013-PtJakart.opam +++ b/opam/tezos-baking-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-version" "tezos-protocol-013-PtJakart" diff --git a/opam/tezos-baking-alpha-commands.opam b/opam/tezos-baking-alpha-commands.opam index 785804517335..fa9bd3d9bda9 100644 --- a/opam/tezos-baking-alpha-commands.opam +++ b/opam/tezos-baking-alpha-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-alpha" "tezos-stdlib-unix" diff --git a/opam/tezos-baking-alpha.opam b/opam/tezos-baking-alpha.opam index 6b05afe2f0c5..c48a93ff5161 100644 --- a/opam/tezos-baking-alpha.opam +++ b/opam/tezos-baking-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-version" "tezos-protocol-alpha" diff --git a/opam/tezos-base-test-helpers.opam b/opam/tezos-base-test-helpers.opam index 96f3cd7c0b66..050ca980a93f 100644 --- a/opam/tezos-base-test-helpers.opam +++ b/opam/tezos-base-test-helpers.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "tezos-event-logging-test-helpers" diff --git a/opam/tezos-base.opam b/opam/tezos-base.opam index 6588a37c4829..f7bd9d7d9e73 100644 --- a/opam/tezos-base.opam +++ b/opam/tezos-base.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-crypto" "data-encoding" { >= "0.5.3" & < "0.6" } diff --git a/opam/tezos-benchmark-012-Psithaca.opam b/opam/tezos-benchmark-012-Psithaca.opam index e83868d809df..40fe328897bc 100644 --- a/opam/tezos-benchmark-012-Psithaca.opam +++ b/opam/tezos-benchmark-012-Psithaca.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-base" "tezos-error-monad" diff --git a/opam/tezos-benchmark-013-PtJakart.opam b/opam/tezos-benchmark-013-PtJakart.opam index 298e99ff0b6b..ed877c4fec69 100644 --- a/opam/tezos-benchmark-013-PtJakart.opam +++ b/opam/tezos-benchmark-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-base" "tezos-error-monad" diff --git a/opam/tezos-benchmark-alpha.opam b/opam/tezos-benchmark-alpha.opam index 43c2097b8f41..8443fd0a3cd5 100644 --- a/opam/tezos-benchmark-alpha.opam +++ b/opam/tezos-benchmark-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-base" "tezos-error-monad" diff --git a/opam/tezos-benchmark-examples.opam b/opam/tezos-benchmark-examples.opam index 53c4894da9bb..bfa22d6bc193 100644 --- a/opam/tezos-benchmark-examples.opam +++ b/opam/tezos-benchmark-examples.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "tezos-crypto" diff --git a/opam/tezos-benchmark-tests.opam b/opam/tezos-benchmark-tests.opam index d40115ce664e..c9d3dd971481 100644 --- a/opam/tezos-benchmark-tests.opam +++ b/opam/tezos-benchmark-tests.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "alcotest-lwt" { with-test & >= "1.5.0" } "tezos-base" {with-test} "tezos-stdlib-unix" {with-test} diff --git a/opam/tezos-benchmark-type-inference-012-Psithaca.opam b/opam/tezos-benchmark-type-inference-012-Psithaca.opam index 7ab51938d803..8bb75616ff5c 100644 --- a/opam/tezos-benchmark-type-inference-012-Psithaca.opam +++ b/opam/tezos-benchmark-type-inference-012-Psithaca.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-error-monad" "tezos-crypto" diff --git a/opam/tezos-benchmark-type-inference-013-PtJakart.opam b/opam/tezos-benchmark-type-inference-013-PtJakart.opam index 08932c7ebbca..610e0120385e 100644 --- a/opam/tezos-benchmark-type-inference-013-PtJakart.opam +++ b/opam/tezos-benchmark-type-inference-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-error-monad" "tezos-crypto" diff --git a/opam/tezos-benchmark-type-inference-alpha.opam b/opam/tezos-benchmark-type-inference-alpha.opam index 2dd5d89e123e..219f32ae512d 100644 --- a/opam/tezos-benchmark-type-inference-alpha.opam +++ b/opam/tezos-benchmark-type-inference-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-error-monad" "tezos-crypto" diff --git a/opam/tezos-benchmark.opam b/opam/tezos-benchmark.opam index a9ce2829df82..9ee0dc69f12c 100644 --- a/opam/tezos-benchmark.opam +++ b/opam/tezos-benchmark.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "tezos-micheline" diff --git a/opam/tezos-benchmarks-proto-012-Psithaca.opam b/opam/tezos-benchmarks-proto-012-Psithaca.opam index 3cfd6226fcd7..be4bac10620c 100644 --- a/opam/tezos-benchmarks-proto-012-Psithaca.opam +++ b/opam/tezos-benchmarks-proto-012-Psithaca.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-base" "tezos-error-monad" diff --git a/opam/tezos-benchmarks-proto-013-PtJakart.opam b/opam/tezos-benchmarks-proto-013-PtJakart.opam index acefceb1dd37..11b8485774c1 100644 --- a/opam/tezos-benchmarks-proto-013-PtJakart.opam +++ b/opam/tezos-benchmarks-proto-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-base" "tezos-error-monad" diff --git a/opam/tezos-benchmarks-proto-alpha.opam b/opam/tezos-benchmarks-proto-alpha.opam index 9a706d72ebb0..89ced3534117 100644 --- a/opam/tezos-benchmarks-proto-alpha.opam +++ b/opam/tezos-benchmarks-proto-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-base" "tezos-error-monad" diff --git a/opam/tezos-clic.opam b/opam/tezos-clic.opam index 66fcd0c609fa..e9c218350f7e 100644 --- a/opam/tezos-clic.opam +++ b/opam/tezos-clic.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "lwt" { >= "5.4.0" } "re" { >= "1.7.2" } diff --git a/opam/tezos-client-000-Ps9mPmXa.opam b/opam/tezos-client-000-Ps9mPmXa.opam index 5113c8c30289..1dc32fbf62f3 100644 --- a/opam/tezos-client-000-Ps9mPmXa.opam +++ b/opam/tezos-client-000-Ps9mPmXa.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-001-PtCJ7pwo-commands.opam b/opam/tezos-client-001-PtCJ7pwo-commands.opam index e255be77b180..3deb8992700a 100644 --- a/opam/tezos-client-001-PtCJ7pwo-commands.opam +++ b/opam/tezos-client-001-PtCJ7pwo-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-001-PtCJ7pwo" "tezos-stdlib-unix" diff --git a/opam/tezos-client-001-PtCJ7pwo.opam b/opam/tezos-client-001-PtCJ7pwo.opam index 2fdc07c500f0..2614f73d86ff 100644 --- a/opam/tezos-client-001-PtCJ7pwo.opam +++ b/opam/tezos-client-001-PtCJ7pwo.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-002-PsYLVpVv-commands.opam b/opam/tezos-client-002-PsYLVpVv-commands.opam index 6928167e8b8c..b2fa6bdef06e 100644 --- a/opam/tezos-client-002-PsYLVpVv-commands.opam +++ b/opam/tezos-client-002-PsYLVpVv-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-002-PsYLVpVv" "tezos-stdlib-unix" diff --git a/opam/tezos-client-002-PsYLVpVv.opam b/opam/tezos-client-002-PsYLVpVv.opam index b65c6c18f3ef..969eba726e15 100644 --- a/opam/tezos-client-002-PsYLVpVv.opam +++ b/opam/tezos-client-002-PsYLVpVv.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-003-PsddFKi3-commands.opam b/opam/tezos-client-003-PsddFKi3-commands.opam index a2abd6887578..1be23a3fe3f7 100644 --- a/opam/tezos-client-003-PsddFKi3-commands.opam +++ b/opam/tezos-client-003-PsddFKi3-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-003-PsddFKi3" "tezos-stdlib-unix" diff --git a/opam/tezos-client-003-PsddFKi3.opam b/opam/tezos-client-003-PsddFKi3.opam index 026342ad7c0a..e4e457b99aa0 100644 --- a/opam/tezos-client-003-PsddFKi3.opam +++ b/opam/tezos-client-003-PsddFKi3.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-004-Pt24m4xi-commands.opam b/opam/tezos-client-004-Pt24m4xi-commands.opam index 659d6231789a..a65fe545cffb 100644 --- a/opam/tezos-client-004-Pt24m4xi-commands.opam +++ b/opam/tezos-client-004-Pt24m4xi-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-004-Pt24m4xi" "tezos-stdlib-unix" diff --git a/opam/tezos-client-004-Pt24m4xi.opam b/opam/tezos-client-004-Pt24m4xi.opam index 26aa17a16836..375cb42efc1f 100644 --- a/opam/tezos-client-004-Pt24m4xi.opam +++ b/opam/tezos-client-004-Pt24m4xi.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-005-PsBabyM1-commands.opam b/opam/tezos-client-005-PsBabyM1-commands.opam index 49cdbd789bc2..e300b30f0367 100644 --- a/opam/tezos-client-005-PsBabyM1-commands.opam +++ b/opam/tezos-client-005-PsBabyM1-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-005-PsBabyM1" "tezos-stdlib-unix" diff --git a/opam/tezos-client-005-PsBabyM1.opam b/opam/tezos-client-005-PsBabyM1.opam index 56777480271a..69559592a2c6 100644 --- a/opam/tezos-client-005-PsBabyM1.opam +++ b/opam/tezos-client-005-PsBabyM1.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-006-PsCARTHA-commands.opam b/opam/tezos-client-006-PsCARTHA-commands.opam index 3ff9861c3b71..c306a1097f80 100644 --- a/opam/tezos-client-006-PsCARTHA-commands.opam +++ b/opam/tezos-client-006-PsCARTHA-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-006-PsCARTHA" "tezos-stdlib-unix" diff --git a/opam/tezos-client-006-PsCARTHA.opam b/opam/tezos-client-006-PsCARTHA.opam index 5a93fd14a50d..d2b8a471022e 100644 --- a/opam/tezos-client-006-PsCARTHA.opam +++ b/opam/tezos-client-006-PsCARTHA.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-007-PsDELPH1-commands-registration.opam b/opam/tezos-client-007-PsDELPH1-commands-registration.opam index 73d59014ed2a..65231c0f9fcc 100644 --- a/opam/tezos-client-007-PsDELPH1-commands-registration.opam +++ b/opam/tezos-client-007-PsDELPH1-commands-registration.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-007-PsDELPH1" "tezos-protocol-environment" diff --git a/opam/tezos-client-007-PsDELPH1-commands.opam b/opam/tezos-client-007-PsDELPH1-commands.opam index 74e0cfc068b5..4b8b084c4f29 100644 --- a/opam/tezos-client-007-PsDELPH1-commands.opam +++ b/opam/tezos-client-007-PsDELPH1-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-007-PsDELPH1" "tezos-stdlib-unix" diff --git a/opam/tezos-client-007-PsDELPH1.opam b/opam/tezos-client-007-PsDELPH1.opam index 3e8e14c82664..91d860b2d4c6 100644 --- a/opam/tezos-client-007-PsDELPH1.opam +++ b/opam/tezos-client-007-PsDELPH1.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-008-PtEdo2Zk-commands-registration.opam b/opam/tezos-client-008-PtEdo2Zk-commands-registration.opam index 431821aa45db..a890700a4d4a 100644 --- a/opam/tezos-client-008-PtEdo2Zk-commands-registration.opam +++ b/opam/tezos-client-008-PtEdo2Zk-commands-registration.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-008-PtEdo2Zk" "tezos-protocol-environment" diff --git a/opam/tezos-client-008-PtEdo2Zk-commands.opam b/opam/tezos-client-008-PtEdo2Zk-commands.opam index 4da833cd8722..dde50606c009 100644 --- a/opam/tezos-client-008-PtEdo2Zk-commands.opam +++ b/opam/tezos-client-008-PtEdo2Zk-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-008-PtEdo2Zk" "tezos-stdlib-unix" diff --git a/opam/tezos-client-008-PtEdo2Zk.opam b/opam/tezos-client-008-PtEdo2Zk.opam index e18ddc0634ed..5b510b611894 100644 --- a/opam/tezos-client-008-PtEdo2Zk.opam +++ b/opam/tezos-client-008-PtEdo2Zk.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-009-PsFLoren-commands-registration.opam b/opam/tezos-client-009-PsFLoren-commands-registration.opam index 64dedeec3d72..b534f37962b6 100644 --- a/opam/tezos-client-009-PsFLoren-commands-registration.opam +++ b/opam/tezos-client-009-PsFLoren-commands-registration.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-009-PsFLoren" "tezos-protocol-environment" diff --git a/opam/tezos-client-009-PsFLoren-commands.opam b/opam/tezos-client-009-PsFLoren-commands.opam index c46ea83e1a43..51fd69a569bc 100644 --- a/opam/tezos-client-009-PsFLoren-commands.opam +++ b/opam/tezos-client-009-PsFLoren-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-009-PsFLoren" "tezos-stdlib-unix" diff --git a/opam/tezos-client-009-PsFLoren.opam b/opam/tezos-client-009-PsFLoren.opam index de4a3229377a..95f339ab93ee 100644 --- a/opam/tezos-client-009-PsFLoren.opam +++ b/opam/tezos-client-009-PsFLoren.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "tezos-base" "tezos-shell-services" diff --git a/opam/tezos-client-010-PtGRANAD-commands-registration.opam b/opam/tezos-client-010-PtGRANAD-commands-registration.opam index b73f2fbf26d8..06c93d0e4121 100644 --- a/opam/tezos-client-010-PtGRANAD-commands-registration.opam +++ b/opam/tezos-client-010-PtGRANAD-commands-registration.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-010-PtGRANAD" "tezos-protocol-environment" diff --git a/opam/tezos-client-010-PtGRANAD-commands.opam b/opam/tezos-client-010-PtGRANAD-commands.opam index b22c2e80d0dd..e5aa1ad6be0c 100644 --- a/opam/tezos-client-010-PtGRANAD-commands.opam +++ b/opam/tezos-client-010-PtGRANAD-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-010-PtGRANAD" "tezos-stdlib-unix" diff --git a/opam/tezos-client-010-PtGRANAD.opam b/opam/tezos-client-010-PtGRANAD.opam index a9cf47fa99ac..191e84b285ac 100644 --- a/opam/tezos-client-010-PtGRANAD.opam +++ b/opam/tezos-client-010-PtGRANAD.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "tezos-base" "tezos-shell-services" diff --git a/opam/tezos-client-011-PtHangz2-commands-registration.opam b/opam/tezos-client-011-PtHangz2-commands-registration.opam index 9a5cfef5952b..ddd9710013fc 100644 --- a/opam/tezos-client-011-PtHangz2-commands-registration.opam +++ b/opam/tezos-client-011-PtHangz2-commands-registration.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-011-PtHangz2" "tezos-protocol-environment" diff --git a/opam/tezos-client-011-PtHangz2-commands.opam b/opam/tezos-client-011-PtHangz2-commands.opam index e539b036ab38..2c2e4fb99ca4 100644 --- a/opam/tezos-client-011-PtHangz2-commands.opam +++ b/opam/tezos-client-011-PtHangz2-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-011-PtHangz2" "tezos-stdlib-unix" diff --git a/opam/tezos-client-011-PtHangz2.opam b/opam/tezos-client-011-PtHangz2.opam index a5726383a2fe..3d90a1f1cd48 100644 --- a/opam/tezos-client-011-PtHangz2.opam +++ b/opam/tezos-client-011-PtHangz2.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "tezos-base" "tezos-shell-services" diff --git a/opam/tezos-client-012-Psithaca-commands-registration.opam b/opam/tezos-client-012-Psithaca-commands-registration.opam index 04017da0a721..2c1af6e85b7a 100644 --- a/opam/tezos-client-012-Psithaca-commands-registration.opam +++ b/opam/tezos-client-012-Psithaca-commands-registration.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-012-Psithaca" "tezos-protocol-environment" diff --git a/opam/tezos-client-012-Psithaca-commands.opam b/opam/tezos-client-012-Psithaca-commands.opam index d001099674b5..bd6d220a7b6a 100644 --- a/opam/tezos-client-012-Psithaca-commands.opam +++ b/opam/tezos-client-012-Psithaca-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-012-Psithaca" "tezos-stdlib-unix" diff --git a/opam/tezos-client-012-Psithaca.opam b/opam/tezos-client-012-Psithaca.opam index e25ef62bd174..eb70932b8304 100644 --- a/opam/tezos-client-012-Psithaca.opam +++ b/opam/tezos-client-012-Psithaca.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "tezos-base" "tezos-shell-services" diff --git a/opam/tezos-client-013-PtJakart-commands-registration.opam b/opam/tezos-client-013-PtJakart-commands-registration.opam index 0f521c652e7e..4f576c0ace1b 100644 --- a/opam/tezos-client-013-PtJakart-commands-registration.opam +++ b/opam/tezos-client-013-PtJakart-commands-registration.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-013-PtJakart" "tezos-protocol-013-PtJakart-parameters" diff --git a/opam/tezos-client-013-PtJakart-commands.opam b/opam/tezos-client-013-PtJakart-commands.opam index dad512379f6d..4607b3e5ce63 100644 --- a/opam/tezos-client-013-PtJakart-commands.opam +++ b/opam/tezos-client-013-PtJakart-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-013-PtJakart" "tezos-protocol-013-PtJakart-parameters" diff --git a/opam/tezos-client-013-PtJakart.opam b/opam/tezos-client-013-PtJakart.opam index 488a25670b49..76fa51ca96bf 100644 --- a/opam/tezos-client-013-PtJakart.opam +++ b/opam/tezos-client-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "tezos-base" "tezos-shell-services" diff --git a/opam/tezos-client-alpha-commands-registration.opam b/opam/tezos-client-alpha-commands-registration.opam index 46dadbb11877..e146d0d6a449 100644 --- a/opam/tezos-client-alpha-commands-registration.opam +++ b/opam/tezos-client-alpha-commands-registration.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-alpha" "tezos-protocol-alpha-parameters" diff --git a/opam/tezos-client-alpha-commands.opam b/opam/tezos-client-alpha-commands.opam index 28d7b50c5fe2..d0d3d2f0caf7 100644 --- a/opam/tezos-client-alpha-commands.opam +++ b/opam/tezos-client-alpha-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-alpha" "tezos-protocol-alpha-parameters" diff --git a/opam/tezos-client-alpha.opam b/opam/tezos-client-alpha.opam index e92414a12faa..d2a129051c97 100644 --- a/opam/tezos-client-alpha.opam +++ b/opam/tezos-client-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "tezos-base" "tezos-shell-services" diff --git a/opam/tezos-client-base-unix.opam b/opam/tezos-client-base-unix.opam index 3a30983ca412..8b99e04276c2 100644 --- a/opam/tezos-client-base-unix.opam +++ b/opam/tezos-client-base-unix.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-rpc-http" "tezos-rpc-http-client-unix" diff --git a/opam/tezos-client-base.opam b/opam/tezos-client-base.opam index 992f5d4c3417..cba682218282 100644 --- a/opam/tezos-client-base.opam +++ b/opam/tezos-client-base.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-rpc" "tezos-shell-services" diff --git a/opam/tezos-client-commands.opam b/opam/tezos-client-commands.opam index e673fa6bc5f2..993f18cea56c 100644 --- a/opam/tezos-client-commands.opam +++ b/opam/tezos-client-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-rpc" "tezos-clic" diff --git a/opam/tezos-client-demo-counter.opam b/opam/tezos-client-demo-counter.opam index 2e456a9a671f..92d1f0bd78cc 100644 --- a/opam/tezos-client-demo-counter.opam +++ b/opam/tezos-client-demo-counter.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-genesis.opam b/opam/tezos-client-genesis.opam index 8e0f6d2cbb3f..478dfc3a10f8 100644 --- a/opam/tezos-client-genesis.opam +++ b/opam/tezos-client-genesis.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-client-base" diff --git a/opam/tezos-client-sapling-008-PtEdo2Zk.opam b/opam/tezos-client-sapling-008-PtEdo2Zk.opam index a092eb029e43..2f829d647a7e 100644 --- a/opam/tezos-client-sapling-008-PtEdo2Zk.opam +++ b/opam/tezos-client-sapling-008-PtEdo2Zk.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-crypto" "tezos-stdlib-unix" diff --git a/opam/tezos-client-sapling-009-PsFLoren.opam b/opam/tezos-client-sapling-009-PsFLoren.opam index b0358fa31b79..46493f127595 100644 --- a/opam/tezos-client-sapling-009-PsFLoren.opam +++ b/opam/tezos-client-sapling-009-PsFLoren.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-crypto" "tezos-stdlib-unix" diff --git a/opam/tezos-client-sapling-010-PtGRANAD.opam b/opam/tezos-client-sapling-010-PtGRANAD.opam index 4216414ba61c..d8f135133d9a 100644 --- a/opam/tezos-client-sapling-010-PtGRANAD.opam +++ b/opam/tezos-client-sapling-010-PtGRANAD.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-crypto" "tezos-stdlib-unix" diff --git a/opam/tezos-client-sapling-011-PtHangz2.opam b/opam/tezos-client-sapling-011-PtHangz2.opam index f30a90dc789c..4b01cbebdb29 100644 --- a/opam/tezos-client-sapling-011-PtHangz2.opam +++ b/opam/tezos-client-sapling-011-PtHangz2.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-crypto" "tezos-stdlib-unix" diff --git a/opam/tezos-client-sapling-012-Psithaca.opam b/opam/tezos-client-sapling-012-Psithaca.opam index 0a6e69bb19f1..23b7a2573519 100644 --- a/opam/tezos-client-sapling-012-Psithaca.opam +++ b/opam/tezos-client-sapling-012-Psithaca.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-crypto" "tezos-stdlib-unix" diff --git a/opam/tezos-client-sapling-013-PtJakart.opam b/opam/tezos-client-sapling-013-PtJakart.opam index 8b403d07b03b..041c0a4a72d6 100644 --- a/opam/tezos-client-sapling-013-PtJakart.opam +++ b/opam/tezos-client-sapling-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-crypto" "tezos-stdlib-unix" diff --git a/opam/tezos-client-sapling-alpha.opam b/opam/tezos-client-sapling-alpha.opam index 55013891fec2..2f46c70167a0 100644 --- a/opam/tezos-client-sapling-alpha.opam +++ b/opam/tezos-client-sapling-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-crypto" "tezos-stdlib-unix" diff --git a/opam/tezos-client.opam b/opam/tezos-client.opam index 384d887b36d2..40229a9bc727 100644 --- a/opam/tezos-client.opam +++ b/opam/tezos-client.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-rpc-http-client" "tezos-stdlib-unix" diff --git a/opam/tezos-codec.opam b/opam/tezos-codec.opam index d46f7ca850c5..2ae4830ee6d3 100644 --- a/opam/tezos-codec.opam +++ b/opam/tezos-codec.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "data-encoding" { >= "0.5.3" & < "0.6" } "tezos-base" "tezos-client-base-unix" diff --git a/opam/tezos-context.opam b/opam/tezos-context.opam index b25a2e8d00f7..441886846a3b 100644 --- a/opam/tezos-context.opam +++ b/opam/tezos-context.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib" "irmin" { >= "3.2.0" & < "3.3.0" } diff --git a/opam/tezos-crypto.opam b/opam/tezos-crypto.opam index 9e65bf005f8a..65d1dab74b7f 100644 --- a/opam/tezos-crypto.opam +++ b/opam/tezos-crypto.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "data-encoding" { >= "0.5.3" & < "0.6" } "tezos-lwt-result-stdlib" diff --git a/opam/tezos-error-monad.opam b/opam/tezos-error-monad.opam index baf7314d05f5..e0a675ca4813 100644 --- a/opam/tezos-error-monad.opam +++ b/opam/tezos-error-monad.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ocaml" { >= "4.07" } "tezos-stdlib" "data-encoding" { >= "0.5.3" & < "0.6" } diff --git a/opam/tezos-event-logging-test-helpers.opam b/opam/tezos-event-logging-test-helpers.opam index 9ffd18f5ecce..0a7a21e9c7e7 100644 --- a/opam/tezos-event-logging-test-helpers.opam +++ b/opam/tezos-event-logging-test-helpers.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-lwt-result-stdlib" "data-encoding" { >= "0.5.3" & < "0.6" } diff --git a/opam/tezos-event-logging.opam b/opam/tezos-event-logging.opam index c21c60e6f9a4..9103c70f42b5 100644 --- a/opam/tezos-event-logging.opam +++ b/opam/tezos-event-logging.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "data-encoding" { >= "0.5.3" & < "0.6" } "tezos-error-monad" diff --git a/opam/tezos-hacl.opam b/opam/tezos-hacl.opam index 2096b9a9f69c..3a7c8ec10889 100644 --- a/opam/tezos-hacl.opam +++ b/opam/tezos-hacl.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ocaml" { >= "4.08" } "hacl-star" { >= "0.4.2" & < "0.5" } "hacl-star-raw" diff --git a/opam/tezos-lwt-result-stdlib.opam b/opam/tezos-lwt-result-stdlib.opam index 7452e623572b..1d36be179cda 100644 --- a/opam/tezos-lwt-result-stdlib.opam +++ b/opam/tezos-lwt-result-stdlib.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ocaml" { >= "4.12" } "lwt" { >= "5.4.0" } "alcotest-lwt" { with-test & >= "1.5.0" } diff --git a/opam/tezos-micheline-rewriting.opam b/opam/tezos-micheline-rewriting.opam index c26a77c9c633..905e645004d3 100644 --- a/opam/tezos-micheline-rewriting.opam +++ b/opam/tezos-micheline-rewriting.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "zarith" { >= "1.12" & < "1.13" } "zarith_stubs_js" "tezos-stdlib" diff --git a/opam/tezos-micheline.opam b/opam/tezos-micheline.opam index ad0780311351..626e3f3678ee 100644 --- a/opam/tezos-micheline.opam +++ b/opam/tezos-micheline.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "uutf" "zarith" { >= "1.12" & < "1.13" } diff --git a/opam/tezos-mockup-commands.opam b/opam/tezos-mockup-commands.opam index 9eb149fec3b1..271ed12c55c3 100644 --- a/opam/tezos-mockup-commands.opam +++ b/opam/tezos-mockup-commands.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-client-commands" "tezos-client-base" diff --git a/opam/tezos-mockup-proxy.opam b/opam/tezos-mockup-proxy.opam index 89667ea6daf1..31e419ac8395 100644 --- a/opam/tezos-mockup-proxy.opam +++ b/opam/tezos-mockup-proxy.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-client-base" "tezos-protocol-environment" diff --git a/opam/tezos-mockup-registration.opam b/opam/tezos-mockup-registration.opam index 8c18a94b5f69..9ffd94bb98b6 100644 --- a/opam/tezos-mockup-registration.opam +++ b/opam/tezos-mockup-registration.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-client-base" "tezos-shell-services" diff --git a/opam/tezos-mockup.opam b/opam/tezos-mockup.opam index f8a7067cd7e5..6098e7f1afd5 100644 --- a/opam/tezos-mockup.opam +++ b/opam/tezos-mockup.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-client-base" "tezos-mockup-proxy" diff --git a/opam/tezos-node.opam b/opam/tezos-node.opam index d443c10898f7..d14ee3b6f0e7 100644 --- a/opam/tezos-node.opam +++ b/opam/tezos-node.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-version" "tezos-stdlib-unix" diff --git a/opam/tezos-openapi.opam b/opam/tezos-openapi.opam index 0ced83fba89a..03a1adfe29be 100644 --- a/opam/tezos-openapi.opam +++ b/opam/tezos-openapi.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ezjsonm" { >= "1.1.0" } "json-data-encoding" { >= "0.11" & < "0.12" } "tezt" diff --git a/opam/tezos-p2p-services.opam b/opam/tezos-p2p-services.opam index 247f207583c1..6fefdfffa94f 100644 --- a/opam/tezos-p2p-services.opam +++ b/opam/tezos-p2p-services.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" ] build: [ diff --git a/opam/tezos-p2p.opam b/opam/tezos-p2p.opam index de340fd3ff32..f48a97133be2 100644 --- a/opam/tezos-p2p.opam +++ b/opam/tezos-p2p.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "lwt-watcher" { = "0.2" } "lwt-canceler" { >= "0.3" & < "0.4" } "ringo" { = "0.8" } diff --git a/opam/tezos-protocol-008-PtEdo2Zk-parameters.opam b/opam/tezos-protocol-008-PtEdo2Zk-parameters.opam index 7a9de122a4aa..4e1fd1c8a042 100644 --- a/opam/tezos-protocol-008-PtEdo2Zk-parameters.opam +++ b/opam/tezos-protocol-008-PtEdo2Zk-parameters.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-environment" "tezos-protocol-008-PtEdo2Zk" diff --git a/opam/tezos-protocol-009-PsFLoren-parameters.opam b/opam/tezos-protocol-009-PsFLoren-parameters.opam index ae7dabf0e9b4..9c8f6d50ceb2 100644 --- a/opam/tezos-protocol-009-PsFLoren-parameters.opam +++ b/opam/tezos-protocol-009-PsFLoren-parameters.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-environment" "tezos-protocol-009-PsFLoren" diff --git a/opam/tezos-protocol-010-PtGRANAD-parameters.opam b/opam/tezos-protocol-010-PtGRANAD-parameters.opam index e982d1b0f156..743c8311e3fa 100644 --- a/opam/tezos-protocol-010-PtGRANAD-parameters.opam +++ b/opam/tezos-protocol-010-PtGRANAD-parameters.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-environment" "tezos-protocol-010-PtGRANAD" diff --git a/opam/tezos-protocol-011-PtHangz2-parameters.opam b/opam/tezos-protocol-011-PtHangz2-parameters.opam index c1216a807ac5..e4f3ae7617c7 100644 --- a/opam/tezos-protocol-011-PtHangz2-parameters.opam +++ b/opam/tezos-protocol-011-PtHangz2-parameters.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-environment" "tezos-protocol-011-PtHangz2" diff --git a/opam/tezos-protocol-012-Psithaca-parameters.opam b/opam/tezos-protocol-012-Psithaca-parameters.opam index 69f82924d7c7..db41c578de30 100644 --- a/opam/tezos-protocol-012-Psithaca-parameters.opam +++ b/opam/tezos-protocol-012-Psithaca-parameters.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-environment" "tezos-protocol-012-Psithaca" diff --git a/opam/tezos-protocol-013-PtJakart-parameters.opam b/opam/tezos-protocol-013-PtJakart-parameters.opam index d277449d0956..197ee0dd081e 100644 --- a/opam/tezos-protocol-013-PtJakart-parameters.opam +++ b/opam/tezos-protocol-013-PtJakart-parameters.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-environment" "tezos-protocol-013-PtJakart" diff --git a/opam/tezos-protocol-alpha-parameters.opam b/opam/tezos-protocol-alpha-parameters.opam index bb41e46f503b..b405a5278508 100644 --- a/opam/tezos-protocol-alpha-parameters.opam +++ b/opam/tezos-protocol-alpha-parameters.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-environment" "tezos-protocol-alpha" diff --git a/opam/tezos-protocol-compiler.opam b/opam/tezos-protocol-compiler.opam index c6610099b53c..b7008a4b6556 100644 --- a/opam/tezos-protocol-compiler.opam +++ b/opam/tezos-protocol-compiler.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ocaml" { >= "4.12.1" & < "4.13" } "tezos-base" "tezos-protocol-environment" diff --git a/opam/tezos-protocol-environment.opam b/opam/tezos-protocol-environment.opam index fa569484e7fe..3048f3912b0e 100644 --- a/opam/tezos-protocol-environment.opam +++ b/opam/tezos-protocol-environment.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ocaml" { >= "4.12" } "tezos-stdlib" "tezos-crypto" diff --git a/opam/tezos-protocol-plugin-007-PsDELPH1-registerer.opam b/opam/tezos-protocol-plugin-007-PsDELPH1-registerer.opam index d224ed8388eb..9780f194fab3 100644 --- a/opam/tezos-protocol-plugin-007-PsDELPH1-registerer.opam +++ b/opam/tezos-protocol-plugin-007-PsDELPH1-registerer.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-embedded-protocol-007-PsDELPH1" "tezos-protocol-plugin-007-PsDELPH1" diff --git a/opam/tezos-protocol-plugin-007-PsDELPH1.opam b/opam/tezos-protocol-plugin-007-PsDELPH1.opam index 4a50fb24bf19..19b4f75d3ecb 100644 --- a/opam/tezos-protocol-plugin-007-PsDELPH1.opam +++ b/opam/tezos-protocol-plugin-007-PsDELPH1.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-007-PsDELPH1" ] diff --git a/opam/tezos-protocol-plugin-008-PtEdo2Zk-registerer.opam b/opam/tezos-protocol-plugin-008-PtEdo2Zk-registerer.opam index d35f66b3d9f1..4c23267c6672 100644 --- a/opam/tezos-protocol-plugin-008-PtEdo2Zk-registerer.opam +++ b/opam/tezos-protocol-plugin-008-PtEdo2Zk-registerer.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-embedded-protocol-008-PtEdo2Zk" "tezos-protocol-plugin-008-PtEdo2Zk" diff --git a/opam/tezos-protocol-plugin-008-PtEdo2Zk.opam b/opam/tezos-protocol-plugin-008-PtEdo2Zk.opam index 2a40cf9ad97c..57b9725e312b 100644 --- a/opam/tezos-protocol-plugin-008-PtEdo2Zk.opam +++ b/opam/tezos-protocol-plugin-008-PtEdo2Zk.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-008-PtEdo2Zk" ] diff --git a/opam/tezos-protocol-plugin-009-PsFLoren-registerer.opam b/opam/tezos-protocol-plugin-009-PsFLoren-registerer.opam index 13d49ca444f3..33b093a005e2 100644 --- a/opam/tezos-protocol-plugin-009-PsFLoren-registerer.opam +++ b/opam/tezos-protocol-plugin-009-PsFLoren-registerer.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-embedded-protocol-009-PsFLoren" "tezos-protocol-plugin-009-PsFLoren" diff --git a/opam/tezos-protocol-plugin-009-PsFLoren.opam b/opam/tezos-protocol-plugin-009-PsFLoren.opam index 9cdf8da6adf3..b586dd81d551 100644 --- a/opam/tezos-protocol-plugin-009-PsFLoren.opam +++ b/opam/tezos-protocol-plugin-009-PsFLoren.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-009-PsFLoren" ] diff --git a/opam/tezos-protocol-plugin-010-PtGRANAD-registerer.opam b/opam/tezos-protocol-plugin-010-PtGRANAD-registerer.opam index e7ccee16cf5b..551b22670ea5 100644 --- a/opam/tezos-protocol-plugin-010-PtGRANAD-registerer.opam +++ b/opam/tezos-protocol-plugin-010-PtGRANAD-registerer.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-embedded-protocol-010-PtGRANAD" "tezos-protocol-plugin-010-PtGRANAD" diff --git a/opam/tezos-protocol-plugin-010-PtGRANAD.opam b/opam/tezos-protocol-plugin-010-PtGRANAD.opam index 154c844e12a6..fd0b2c8ba84d 100644 --- a/opam/tezos-protocol-plugin-010-PtGRANAD.opam +++ b/opam/tezos-protocol-plugin-010-PtGRANAD.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-010-PtGRANAD" ] diff --git a/opam/tezos-protocol-plugin-011-PtHangz2-registerer.opam b/opam/tezos-protocol-plugin-011-PtHangz2-registerer.opam index 8d2105873e02..e68a8abaa272 100644 --- a/opam/tezos-protocol-plugin-011-PtHangz2-registerer.opam +++ b/opam/tezos-protocol-plugin-011-PtHangz2-registerer.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-embedded-protocol-011-PtHangz2" "tezos-protocol-plugin-011-PtHangz2" diff --git a/opam/tezos-protocol-plugin-011-PtHangz2.opam b/opam/tezos-protocol-plugin-011-PtHangz2.opam index 068e1e439b80..b29f1966633d 100644 --- a/opam/tezos-protocol-plugin-011-PtHangz2.opam +++ b/opam/tezos-protocol-plugin-011-PtHangz2.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-011-PtHangz2" ] diff --git a/opam/tezos-protocol-plugin-012-Psithaca-registerer.opam b/opam/tezos-protocol-plugin-012-Psithaca-registerer.opam index 619128831c42..a10f6ef612a8 100644 --- a/opam/tezos-protocol-plugin-012-Psithaca-registerer.opam +++ b/opam/tezos-protocol-plugin-012-Psithaca-registerer.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-embedded-protocol-012-Psithaca" "tezos-protocol-plugin-012-Psithaca" diff --git a/opam/tezos-protocol-plugin-012-Psithaca-tests.opam b/opam/tezos-protocol-plugin-012-Psithaca-tests.opam index 7bea3f1dc5d6..0f3f60972566 100644 --- a/opam/tezos-protocol-plugin-012-Psithaca-tests.opam +++ b/opam/tezos-protocol-plugin-012-Psithaca-tests.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" {with-test} "tezos-base-test-helpers" {with-test} "alcotest-lwt" { with-test & >= "1.5.0" } diff --git a/opam/tezos-protocol-plugin-012-Psithaca.opam b/opam/tezos-protocol-plugin-012-Psithaca.opam index d0655731328a..540e39e9a6f1 100644 --- a/opam/tezos-protocol-plugin-012-Psithaca.opam +++ b/opam/tezos-protocol-plugin-012-Psithaca.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-012-Psithaca" ] diff --git a/opam/tezos-protocol-plugin-013-PtJakart-registerer.opam b/opam/tezos-protocol-plugin-013-PtJakart-registerer.opam index 8f3664102fcc..056c51fe6ff8 100644 --- a/opam/tezos-protocol-plugin-013-PtJakart-registerer.opam +++ b/opam/tezos-protocol-plugin-013-PtJakart-registerer.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-embedded-protocol-013-PtJakart" "tezos-protocol-plugin-013-PtJakart" diff --git a/opam/tezos-protocol-plugin-013-PtJakart-tests.opam b/opam/tezos-protocol-plugin-013-PtJakart-tests.opam index f3c4851955e6..951219685351 100644 --- a/opam/tezos-protocol-plugin-013-PtJakart-tests.opam +++ b/opam/tezos-protocol-plugin-013-PtJakart-tests.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" {with-test} "tezos-base-test-helpers" {with-test} "alcotest-lwt" { with-test & >= "1.5.0" } diff --git a/opam/tezos-protocol-plugin-013-PtJakart.opam b/opam/tezos-protocol-plugin-013-PtJakart.opam index f9a472d5c000..5cb9ee796553 100644 --- a/opam/tezos-protocol-plugin-013-PtJakart.opam +++ b/opam/tezos-protocol-plugin-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-013-PtJakart" ] diff --git a/opam/tezos-protocol-plugin-alpha-registerer.opam b/opam/tezos-protocol-plugin-alpha-registerer.opam index d13e4c43b101..388edd02e1fa 100644 --- a/opam/tezos-protocol-plugin-alpha-registerer.opam +++ b/opam/tezos-protocol-plugin-alpha-registerer.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-embedded-protocol-alpha" "tezos-protocol-plugin-alpha" diff --git a/opam/tezos-protocol-plugin-alpha-tests.opam b/opam/tezos-protocol-plugin-alpha-tests.opam index c3d622d05478..95e68f6672a8 100644 --- a/opam/tezos-protocol-plugin-alpha-tests.opam +++ b/opam/tezos-protocol-plugin-alpha-tests.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" {with-test} "tezos-base-test-helpers" {with-test} "alcotest-lwt" { with-test & >= "1.5.0" } diff --git a/opam/tezos-protocol-plugin-alpha.opam b/opam/tezos-protocol-plugin-alpha.opam index 50a802fe875f..6b1eb6d74d02 100644 --- a/opam/tezos-protocol-plugin-alpha.opam +++ b/opam/tezos-protocol-plugin-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-alpha" ] diff --git a/opam/tezos-protocol-updater.opam b/opam/tezos-protocol-updater.opam index d8557b15e28d..f8b206f05e74 100644 --- a/opam/tezos-protocol-updater.opam +++ b/opam/tezos-protocol-updater.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "tezos-micheline" diff --git a/opam/tezos-proxy-server-config.opam b/opam/tezos-proxy-server-config.opam index ff8c8a3a963d..184f63d4a589 100644 --- a/opam/tezos-proxy-server-config.opam +++ b/opam/tezos-proxy-server-config.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "tezos-test-helpers" {with-test} diff --git a/opam/tezos-proxy-server.opam b/opam/tezos-proxy-server.opam index e9b9fe830a4b..1a1e441227f3 100644 --- a/opam/tezos-proxy-server.opam +++ b/opam/tezos-proxy-server.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "cmdliner" { >= "1.1.0" } diff --git a/opam/tezos-proxy.opam b/opam/tezos-proxy.opam index 70e590cd6987..6b7ebf846ae2 100644 --- a/opam/tezos-proxy.opam +++ b/opam/tezos-proxy.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ringo-lwt" { = "0.8" } "tezos-base" "tezos-clic" diff --git a/opam/tezos-requester.opam b/opam/tezos-requester.opam index c02169496614..1fbd313affd1 100644 --- a/opam/tezos-requester.opam +++ b/opam/tezos-requester.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "lwt-watcher" { = "0.2" } diff --git a/opam/tezos-rpc-http-client-unix.opam b/opam/tezos-rpc-http-client-unix.opam index 6703abe00262..4323f8beb0bd 100644 --- a/opam/tezos-rpc-http-client-unix.opam +++ b/opam/tezos-rpc-http-client-unix.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib-unix" "tezos-base" "cohttp-lwt-unix" { >= "2.2.0" } diff --git a/opam/tezos-rpc-http-client.opam b/opam/tezos-rpc-http-client.opam index 9b2536729420..765fb64592b7 100644 --- a/opam/tezos-rpc-http-client.opam +++ b/opam/tezos-rpc-http-client.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "resto-cohttp-client" { >= "0.6" & < "0.7" } "tezos-rpc-http" diff --git a/opam/tezos-rpc-http-server.opam b/opam/tezos-rpc-http-server.opam index e25c3b71be07..e50afbfb0522 100644 --- a/opam/tezos-rpc-http-server.opam +++ b/opam/tezos-rpc-http-server.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "resto-cohttp-server" { >= "0.6" & < "0.7" } diff --git a/opam/tezos-rpc-http.opam b/opam/tezos-rpc-http.opam index 59bf2ef23ca0..cb23ffbe9e48 100644 --- a/opam/tezos-rpc-http.opam +++ b/opam/tezos-rpc-http.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "resto-cohttp" { >= "0.6" & < "0.7" } ] diff --git a/opam/tezos-rpc.opam b/opam/tezos-rpc.opam index c29ab94b69a5..1123fee2589b 100644 --- a/opam/tezos-rpc.opam +++ b/opam/tezos-rpc.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "data-encoding" { >= "0.5.3" & < "0.6" } "tezos-error-monad" "resto" { >= "0.6" & < "0.7" } diff --git a/opam/tezos-sapling.opam b/opam/tezos-sapling.opam index 28c14d8c84ef..7ab03516d4bd 100644 --- a/opam/tezos-sapling.opam +++ b/opam/tezos-sapling.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "conf-rust" "integers" "integers_stubs_js" diff --git a/opam/tezos-sc-rollup-013-PtJakart.opam b/opam/tezos-sc-rollup-013-PtJakart.opam index 997232392e9b..ed66986dfc5b 100644 --- a/opam/tezos-sc-rollup-013-PtJakart.opam +++ b/opam/tezos-sc-rollup-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "tezos-base" "tezos-protocol-013-PtJakart" diff --git a/opam/tezos-sc-rollup-alpha.opam b/opam/tezos-sc-rollup-alpha.opam index 2ca4f71be3bf..103ed5c131e6 100644 --- a/opam/tezos-sc-rollup-alpha.opam +++ b/opam/tezos-sc-rollup-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "tezos-base" "tezos-protocol-alpha" diff --git a/opam/tezos-sc-rollup-client-013-PtJakart.opam b/opam/tezos-sc-rollup-client-013-PtJakart.opam index 5f0e2271f27a..7ab3289d2d4e 100644 --- a/opam/tezos-sc-rollup-client-013-PtJakart.opam +++ b/opam/tezos-sc-rollup-client-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-client-base" "tezos-client-013-PtJakart" diff --git a/opam/tezos-sc-rollup-client-alpha.opam b/opam/tezos-sc-rollup-client-alpha.opam index 230fad6a46c1..e51d54cd6408 100644 --- a/opam/tezos-sc-rollup-client-alpha.opam +++ b/opam/tezos-sc-rollup-client-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-client-base" "tezos-client-alpha" diff --git a/opam/tezos-sc-rollup-node-013-PtJakart.opam b/opam/tezos-sc-rollup-node-013-PtJakart.opam index 7dce715ae76c..e92da7dd7f52 100644 --- a/opam/tezos-sc-rollup-node-013-PtJakart.opam +++ b/opam/tezos-sc-rollup-node-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-client-commands" "tezos-stdlib-unix" diff --git a/opam/tezos-sc-rollup-node-alpha.opam b/opam/tezos-sc-rollup-node-alpha.opam index f514dd8f17e3..4b66159ab325 100644 --- a/opam/tezos-sc-rollup-node-alpha.opam +++ b/opam/tezos-sc-rollup-node-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-client-commands" "tezos-stdlib-unix" diff --git a/opam/tezos-scoru-wasm.opam b/opam/tezos-scoru-wasm.opam index bb3f6d3fc678..47abd0ddef46 100644 --- a/opam/tezos-scoru-wasm.opam +++ b/opam/tezos-scoru-wasm.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-webassembly-interpreter" ] build: [ diff --git a/opam/tezos-shell-benchmarks.opam b/opam/tezos-shell-benchmarks.opam index 0de1bb1d17cf..4f69c77fa882 100644 --- a/opam/tezos-shell-benchmarks.opam +++ b/opam/tezos-shell-benchmarks.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-stdlib" "tezos-base" "tezos-error-monad" diff --git a/opam/tezos-shell-context-test.opam b/opam/tezos-shell-context-test.opam index 72dcffe469e9..ca589af1760b 100644 --- a/opam/tezos-shell-context-test.opam +++ b/opam/tezos-shell-context-test.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-shell-context" {with-test} "alcotest-lwt" { with-test & >= "1.5.0" } "tezos-test-helpers" {with-test} diff --git a/opam/tezos-shell-context.opam b/opam/tezos-shell-context.opam index e27b3a26cc64..cb9f048e4c09 100644 --- a/opam/tezos-shell-context.opam +++ b/opam/tezos-shell-context.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-environment" "tezos-context" diff --git a/opam/tezos-shell-services-test-helpers.opam b/opam/tezos-shell-services-test-helpers.opam index 6a4f4dcee5a9..6f7ff8f0ebab 100644 --- a/opam/tezos-shell-services-test-helpers.opam +++ b/opam/tezos-shell-services-test-helpers.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-shell-services" "tezos-test-helpers" diff --git a/opam/tezos-shell-services.opam b/opam/tezos-shell-services.opam index 5ccd01363880..f5692d41179d 100644 --- a/opam/tezos-shell-services.opam +++ b/opam/tezos-shell-services.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-p2p-services" "tezos-version" diff --git a/opam/tezos-shell.opam b/opam/tezos-shell.opam index bc707db7e31b..840ff9caa361 100644 --- a/opam/tezos-shell.opam +++ b/opam/tezos-shell.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "lwt-watcher" { = "0.2" } "lwt-canceler" { >= "0.3" & < "0.4" } "prometheus" diff --git a/opam/tezos-signer-backends.opam b/opam/tezos-signer-backends.opam index b77143f95417..7dc01e054eea 100644 --- a/opam/tezos-signer-backends.opam +++ b/opam/tezos-signer-backends.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib" "tezos-client-base" diff --git a/opam/tezos-signer-services.opam b/opam/tezos-signer-services.opam index 778ca5cdb923..89ec6b160f97 100644 --- a/opam/tezos-signer-services.opam +++ b/opam/tezos-signer-services.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-rpc" "tezos-client-base" diff --git a/opam/tezos-signer.opam b/opam/tezos-signer.opam index a742ad01d805..0b6c9d0e9187 100644 --- a/opam/tezos-signer.opam +++ b/opam/tezos-signer.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-client-base" "tezos-client-base-unix" diff --git a/opam/tezos-snoop.opam b/opam/tezos-snoop.opam index ad814941b53d..e04c9bcc4d23 100644 --- a/opam/tezos-snoop.opam +++ b/opam/tezos-snoop.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "tezos-clic" diff --git a/opam/tezos-stdlib-unix.opam b/opam/tezos-stdlib-unix.opam index 3b1a9dc3b5fc..06df884d86e4 100644 --- a/opam/tezos-stdlib-unix.opam +++ b/opam/tezos-stdlib-unix.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "base-unix" "tezos-error-monad" "tezos-lwt-result-stdlib" diff --git a/opam/tezos-stdlib.opam b/opam/tezos-stdlib.opam index 969a08cbd274..873ce9abe47e 100644 --- a/opam/tezos-stdlib.opam +++ b/opam/tezos-stdlib.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ocaml" { >= "4.08" } "ppx_inline_test" "hex" { >= "1.3.0" } diff --git a/opam/tezos-store.opam b/opam/tezos-store.opam index 2ef4f48be0b0..0c97c1c21b10 100644 --- a/opam/tezos-store.opam +++ b/opam/tezos-store.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-shell-services" "tezos-base" "tezos-version" diff --git a/opam/tezos-test-helpers-extra.opam b/opam/tezos-test-helpers-extra.opam index abd6933c141e..fa64f751bcd2 100644 --- a/opam/tezos-test-helpers-extra.opam +++ b/opam/tezos-test-helpers-extra.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ocaml" { >= "4.08" } "tezos-base" "tezos-crypto" diff --git a/opam/tezos-test-helpers.opam b/opam/tezos-test-helpers.opam index 4e8a2995f4e3..e424a6b7e514 100644 --- a/opam/tezos-test-helpers.opam +++ b/opam/tezos-test-helpers.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ocaml" { >= "4.08" } "uri" "fmt" { >= "0.8.7" } diff --git a/opam/tezos-tooling.opam b/opam/tezos-tooling.opam index 53c6541f36fe..560ccd4283f8 100644 --- a/opam/tezos-tooling.opam +++ b/opam/tezos-tooling.opam @@ -8,9 +8,9 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "bisect_ppx" { >= "2.7.0" } - "ocamlformat" { = "0.18.0" } + "ocamlformat" { = "0.21.0" } "parsexp" {with-test} "base-unix" ] diff --git a/opam/tezos-tps-evaluation.opam b/opam/tezos-tps-evaluation.opam index 8a6837dcf1e5..5ebd5c6db4e2 100644 --- a/opam/tezos-tps-evaluation.opam +++ b/opam/tezos-tps-evaluation.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_blob" "tezos-base" "caqti" diff --git a/opam/tezos-tx-rollup-013-PtJakart.opam b/opam/tezos-tx-rollup-013-PtJakart.opam index 1c3aa9ecbdc7..1280475ec760 100644 --- a/opam/tezos-tx-rollup-013-PtJakart.opam +++ b/opam/tezos-tx-rollup-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "index" { >= "1.6.0" & < "1.7.0" } "tezos-base" diff --git a/opam/tezos-tx-rollup-alpha.opam b/opam/tezos-tx-rollup-alpha.opam index aded7775ef6d..c1c431a3d99e 100644 --- a/opam/tezos-tx-rollup-alpha.opam +++ b/opam/tezos-tx-rollup-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_inline_test" "index" { >= "1.6.0" & < "1.7.0" } "tezos-base" diff --git a/opam/tezos-tx-rollup-client-013-PtJakart.opam b/opam/tezos-tx-rollup-client-013-PtJakart.opam index d5801e3554d1..679e68de1160 100644 --- a/opam/tezos-tx-rollup-client-013-PtJakart.opam +++ b/opam/tezos-tx-rollup-client-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-013-PtJakart" "tezos-client-013-PtJakart" diff --git a/opam/tezos-tx-rollup-client-alpha.opam b/opam/tezos-tx-rollup-client-alpha.opam index 4b0ef34d0d73..49b956ce8dbc 100644 --- a/opam/tezos-tx-rollup-client-alpha.opam +++ b/opam/tezos-tx-rollup-client-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-alpha" "tezos-client-alpha" diff --git a/opam/tezos-tx-rollup-node-013-PtJakart.opam b/opam/tezos-tx-rollup-node-013-PtJakart.opam index 057b930ddff2..1f2e1ce7006f 100644 --- a/opam/tezos-tx-rollup-node-013-PtJakart.opam +++ b/opam/tezos-tx-rollup-node-013-PtJakart.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-013-PtJakart" "tezos-client-013-PtJakart" diff --git a/opam/tezos-tx-rollup-node-alpha.opam b/opam/tezos-tx-rollup-node-alpha.opam index 036afe856cf2..31439a83cc1e 100644 --- a/opam/tezos-tx-rollup-node-alpha.opam +++ b/opam/tezos-tx-rollup-node-alpha.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-protocol-alpha" "tezos-client-alpha" diff --git a/opam/tezos-validation.opam b/opam/tezos-validation.opam index 442185b5ad4c..ddc5db388f1c 100644 --- a/opam/tezos-validation.opam +++ b/opam/tezos-validation.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-context" "tezos-shell-context" diff --git a/opam/tezos-validator.opam b/opam/tezos-validator.opam index 766006339866..c08bce43e6a1 100644 --- a/opam/tezos-validator.opam +++ b/opam/tezos-validator.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-context" "tezos-stdlib-unix" diff --git a/opam/tezos-version.opam b/opam/tezos-version.opam index 6df92da864bd..643ad00b3ca8 100644 --- a/opam/tezos-version.opam +++ b/opam/tezos-version.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ppx_deriving" "tezos-base" "dune-configurator" diff --git a/opam/tezos-webassembly-interpreter.opam b/opam/tezos-webassembly-interpreter.opam index 97c845c8d35a..493def6638c9 100644 --- a/opam/tezos-webassembly-interpreter.opam +++ b/opam/tezos-webassembly-interpreter.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "Apache License 2.0" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } ] build: [ ["rm" "-r" "vendors"] diff --git a/opam/tezos-workers.opam b/opam/tezos-workers.opam index 27f7a26e5a6f..56b360afab66 100644 --- a/opam/tezos-workers.opam +++ b/opam/tezos-workers.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezos-base" "tezos-stdlib-unix" "ringo" { = "0.8" } diff --git a/opam/tezt-performance-regression.opam b/opam/tezt-performance-regression.opam index 338cfbdec5c3..6a0819e1b895 100644 --- a/opam/tezt-performance-regression.opam +++ b/opam/tezt-performance-regression.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezt" "uri" "cohttp-lwt-unix" { >= "2.2.0" } diff --git a/opam/tezt-self-tests.opam b/opam/tezt-self-tests.opam index f7c0c0cda7c8..f753e2c1c305 100644 --- a/opam/tezt-self-tests.opam +++ b/opam/tezt-self-tests.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezt" "tezt-tezos" ] diff --git a/opam/tezt-tezos.opam b/opam/tezt-tezos.opam index da0902d6056a..f55106c1908f 100644 --- a/opam/tezt-tezos.opam +++ b/opam/tezt-tezos.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "tezt" "tezt-performance-regression" "uri" diff --git a/opam/tezt.opam b/opam/tezt.opam index 55dea9601ece..d8e2a9d93d76 100644 --- a/opam/tezt.opam +++ b/opam/tezt.opam @@ -8,7 +8,7 @@ bug-reports: "https://gitlab.com/tezos/tezos/issues" dev-repo: "git+https://gitlab.com/tezos/tezos.git" license: "MIT" depends: [ - "dune" { >= "2.9" } + "dune" { >= "2.9" & < "3.0" } "ocaml" { >= "4.12" } "re" { >= "1.7.2" } "lwt" { >= "5.4.0" } diff --git a/scripts/lint.sh b/scripts/lint.sh index 6c6857154aaf..7ba59a245d61 100755 --- a/scripts/lint.sh +++ b/scripts/lint.sh @@ -37,7 +37,8 @@ say () { make_dot_ocamlformat () { local path="$1" cat > "$path" < Date: Fri, 13 May 2022 18:48:36 +0200 Subject: [PATCH 2/6] CI,Build: bump opam repo commit hash --- .gitlab/ci/templates.yml | 2 +- scripts/version.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab/ci/templates.yml b/.gitlab/ci/templates.yml index c8e804d6d75c..f012860e7536 100644 --- a/.gitlab/ci/templates.yml +++ b/.gitlab/ci/templates.yml @@ -2,7 +2,7 @@ variables: # /!\ CI_REGISTRY is overriden to use a private Docker registry mirror in AWS ECR # in GitLab namespaces `nomadic-labs` and `tezos` ## This value MUST be the same as `opam_repository_tag` in `scripts/version.sh` - build_deps_image_version: 46a9a0a355c4c2dbe4c9ce4b00ed48211209035d + build_deps_image_version: a7625be431dad945344a4246010aca17de78e5d7 build_deps_image_name: "${CI_REGISTRY}/tezos/opam-repository" GIT_STRATEGY: fetch GIT_DEPTH: "1" diff --git a/scripts/version.sh b/scripts/version.sh index aca84a9ebc90..094724fa0d14 100755 --- a/scripts/version.sh +++ b/scripts/version.sh @@ -25,7 +25,7 @@ export full_opam_repository_tag=de5b1f98a1c16bd8c90f22d03e82a0633b7554dc ## opam_repository is an additional, tezos-specific opam repository. ## This value MUST be the same as `build_deps_image_version` in `.gitlab/ci/templates.yml export opam_repository_url=https://gitlab.com/tezos/opam-repository -export opam_repository_tag=46a9a0a355c4c2dbe4c9ce4b00ed48211209035d +export opam_repository_tag=a7625be431dad945344a4246010aca17de78e5d7 export opam_repository_git=$opam_repository_url.git export opam_repository=$opam_repository_git\#$opam_repository_tag -- GitLab From 80c788902c0bd3536237e79e0dd77b0136d3a0bb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 9 May 2022 17:33:19 +0200 Subject: [PATCH 3/6] CI: do not fail on malformed doc With the more recent version of odoc, more errors have appeared so we deactivate the check temporarily. --- .gitlab/ci/test/lints.yml | 7 +++++-- docs/Makefile | 6 +++++- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/.gitlab/ci/test/lints.yml b/.gitlab/ci/test/lints.yml index 6e20eac988fa..93dfa2616ddc 100644 --- a/.gitlab/ci/test/lints.yml +++ b/.gitlab/ci/test/lints.yml @@ -14,8 +14,11 @@ misc_checks: - make -C tests_python typecheck # Ensure that all unit tests are restricted to their opam package - make lint-tests-pkg - # Ensure there are no mli docstring syntax errors in alpha protocol - - ODOC_WARN_ERROR=true dune build @src/proto_alpha/lib_protocol/doc + # FIXME: https://gitlab.com/tezos/tezos/-/issues/2971 + # The new version of odoc (2.1.0) is stricter than the old version (1.5.3), + # we temporarily deactivate the odoc checks. + ## Ensure there are no mli docstring syntax errors in alpha protocol + #- ODOC_WARN_ERROR=true dune build @src/proto_alpha/lib_protocol/doc # check that the hack-module patch applies cleanly - git apply devtools/protocol-print/add-hack-module.patch # check that yes-wallet builds correctly diff --git a/docs/Makefile b/docs/Makefile index e0a967ba81e9..5564b5f4788c 100644 --- a/docs/Makefile +++ b/docs/Makefile @@ -69,7 +69,11 @@ odoc-lite: main docexes mkdir -p $(TMPDOCDIR)/ rsync --recursive --links --perms --exclude="src/proto_0*" \ ../src ../tezt ../vendors ../dune ../dune-project $(TMPDOCDIR)/ - cd $(TMPDOCDIR); ODOC_WARN_ERROR=true dune build @doc + # FIXME: https://gitlab.com/tezos/tezos/-/issues/2971 + # The new version of odoc (2.1.0) is stricter than the old version (1.5.3), + # we temporarily deactivate the odoc checks. + # cd $(TMPDOCDIR); ODOC_WARN_ERROR=true dune build @doc + cd $(TMPDOCDIR); dune build @doc @rm -rf _build/api/odoc @mkdir -p _build/api @cp -r $(TMPDOCDIR)/_build/default/_doc _build/api/odoc -- GitLab From 883e236e6db1b70c9a3c100afe215fab6bbd71c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 11 May 2022 08:40:27 +0200 Subject: [PATCH 4/6] Misc: tweak some comments to make upcoming ocamlformat no-op These comments are formatted in specific ways which cause the new version of ocamlformat to change them. We preemptively change the indentation to anticipate the upcoming change. --- src/lib_client_base/pbkdf.ml | 33 ++-- src/lib_client_base/pbkdf.mli | 39 ++--- src/lib_stdlib/circular_buffer.ml | 267 +++++++++++++++--------------- 3 files changed, 169 insertions(+), 170 deletions(-) diff --git a/src/lib_client_base/pbkdf.ml b/src/lib_client_base/pbkdf.ml index 191754ff0a9c..e887a671976f 100644 --- a/src/lib_client_base/pbkdf.ml +++ b/src/lib_client_base/pbkdf.ml @@ -56,22 +56,23 @@ module SHA256 = Make (Hacl.Hash.SHA256) module SHA512 = Make (Hacl.Hash.SHA512) (* Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: + modification, are permitted provided that the following conditions are met: -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) diff --git a/src/lib_client_base/pbkdf.mli b/src/lib_client_base/pbkdf.mli index 1a2fe47ca94e..c6e07264be39 100644 --- a/src/lib_client_base/pbkdf.mli +++ b/src/lib_client_base/pbkdf.mli @@ -19,22 +19,23 @@ module SHA256 : S module SHA512 : S (* Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) diff --git a/src/lib_stdlib/circular_buffer.ml b/src/lib_stdlib/circular_buffer.ml index 5236920d0886..5353af601e68 100644 --- a/src/lib_stdlib/circular_buffer.ml +++ b/src/lib_stdlib/circular_buffer.ml @@ -53,34 +53,33 @@ let create ?(maxlength = 1 lsl 15) ?(fresh_buf_size = 2000) () = (* [get_buf_with_offset t write_len] Find a place where [write_len] data can be written onto the buffer [t]. -Multiple situtation can arise + Multiple situtation can arise -1) STARTS preceeds END, - _____START____________________END_______ -[_______|ddddddddddddddddddddddd|________] -|<--Y-->|<----- data ---------->|<---X-->| + 1) STARTS preceeds END, + _____START____________________END_______ + [_______|ddddddddddddddddddddddd|________] + |<--Y-->|<----- data ---------->|<---X-->| - 1.1) either X zone can contain [write_len], - 1.2) or Y zone can contain [write_len], - 1.3) or neither is big enough,we create a temporary buffer of size [write_len] + 1.1) either X zone can contain [write_len], + 1.2) or Y zone can contain [write_len], + 1.3) or neither is big enough,we create a temporary buffer of size [write_len] -2) END preceeds START , - ______END____________________START______ -[ddddddd|_______________________|dddddd__] + 2) END preceeds START , + ______END____________________START______ + [ddddddd|_______________________|dddddd__] - 2.1) either the free zone between END and START can contain [write_len], - 2.2) or we create a temporary buffer of size [write_len] + 2.1) either the free zone between END and START can contain [write_len], + 2.2) or we create a temporary buffer of size [write_len] -3) START and END are identical - 3.1) - ____START_END___________________________ -[_______|________________________________]=> t.full = false + 3) START and END are identical + 3.1) + ____START_END___________________________ + [_______|________________________________]=> t.full = false - 3.2) - ____END_START___________________________ -[ddddddd|dddddddddddddddddddddddddddddd__] => t.full = true - - *) + 3.2) + ____END_START___________________________ + [ddddddd|dddddddddddddddddddddddddddddd__] => t.full = true +*) (* Pre-condition: write_len > 0 *) let get_buf_with_offset t write_len = (* Case 3.1 -> put the pointers at the beginning of the buffer which @@ -115,64 +114,64 @@ let get_buf_with_offset t write_len = After a correct write the following property holds: -'o' stands for old data -'_' for free zone -'w' for just written data -'r' is the returned record - -- initial situation STARTS preceeds END, - ___________________START___________END_________ -[_____________________|oooooooooooooo|__________] -|<--------X zone----->| |<-Y zone->| - - - either X zone can contain [write_len], - ___________________START_________OLD_END__NEW_END -[_____________________|oooooooooooooo|wwwwwwww|_] = r.buf - |<------>| - |r.length| - | - r.offset - - - or Y zone can contain [write_len], - _________NEW_END____START_________OLD_END______ -[wwwwwwwwwwww|________|oooooooooooooo|__________] = r.buf -|<-r.length->| -| -r.offset=0 - - - or neither is big enough,we create a temporary buffer of size [write_len] - ___________________START___________END_________ |<---max_len---->| -[_____________________|oooooooooooooo|__________] [wwwwwwwwwwww____]= r.buf - |<-r.length->| - | - r.offset=0 -- END preceeds START , - ______END____________________START______ -[ooooooo|_______________________|oooooo__] - - - either empty zone can contain [write_len] and a little bit more, - _____OLD__END______NEW_END___START______ -[ooooooo|wwwwwwwwwwwwwwww|______|oooooo__] - |<------>| - |r.length| - | - r.offset - - either empty zone can contain [write_len], - _____OLD__END___________NEW_END_START___ -[ooooooo|wwwwwwwwwwwwwwwwwwwwwww|oooooo__] - |<------>| - |r.length| + 'o' stands for old data + '_' for free zone + 'w' for just written data + 'r' is the returned record + + - initial situation STARTS preceeds END, + ___________________START___________END_________ + [_____________________|oooooooooooooo|__________] + |<--------X zone----->| |<-Y zone->| + + - either X zone can contain [write_len], + ___________________START_________OLD_END__NEW_END + [_____________________|oooooooooooooo|wwwwwwww|_] = r.buf + |<------>| + |r.length| + | + r.offset + + - or Y zone can contain [write_len], + _________NEW_END____START_________OLD_END______ + [wwwwwwwwwwww|________|oooooooooooooo|__________] = r.buf + |<-r.length->| | - r.offset - t.full = true - - - or we create a temporary buffer of size [max_len] - ______END____________________START______ |<--------max_len----------->| -[ooooooo|_______________________|oooooo__] [wwwwwwwwwwwwwwwwwwwwwwww____] - |<-------r.length----------->| - | - r.offset=0 - *) + r.offset=0 + + - or neither is big enough,we create a temporary buffer of size [write_len] + ___________________START___________END_________ |<---max_len---->| + [_____________________|oooooooooooooo|__________] [wwwwwwwwwwww____]= r.buf + |<-r.length->| + | + r.offset=0 + - END preceeds START , + ______END____________________START______ + [ooooooo|_______________________|oooooo__] + + - either empty zone can contain [write_len] and a little bit more, + _____OLD__END______NEW_END___START______ + [ooooooo|wwwwwwwwwwwwwwww|______|oooooo__] + |<------>| + |r.length| + | + r.offset + - either empty zone can contain [write_len], + _____OLD__END___________NEW_END_START___ + [ooooooo|wwwwwwwwwwwwwwwwwwwwwww|oooooo__] + |<------>| + |r.length| + | + r.offset + t.full = true + + - or we create a temporary buffer of size [max_len] + ______END____________________START______ |<--------max_len----------->| + [ooooooo|_______________________|oooooo__] [wwwwwwwwwwwwwwwwwwwwwwww____] + |<-------r.length----------->| + | + r.offset=0 +*) let write ~maxlen ~fill_using t = if maxlen < 0 then invalid_arg "Circular_buffer.write: negative length." ; if maxlen = 0 then @@ -195,62 +194,60 @@ let write ~maxlen ~fill_using t = [data.buf] and update [t.data_start] pointer accordingly. data are blit into buffer [into] at [offset]. -if data.buf is not the circular buffer, it is supposed to be a -dedicated buffer allocated at write time and we have no bookkeeping -to do on the circular buffer. - -Else starting from - - ______START____________END_____ -[________|ddddd|ddddddddd|______] [dddddddddddddddddddddddd____] - |<--->|<------->| |<---------------------->| - d1 d3 d2 -It is required to read fully d1, d2, and then d3 in that order. - -We can have a parial read for each chunk leading to a new data chunk d1' - _________START_________END_____ -[___________|dd|ddddddddd|______] [dddddddddddddddddddddddd____] - |<>|<------->| |<---------------------->| - d1' d3 d2 -but the remainder has to be consumed to ensure that further readings - will succeed. - ____________START______END_____ -[______________|ddddddddd|______] [dddddddddddddddddddddddd____] - |<------->| |<---------------------->| - d3 d2 -When reading extra allocated chunk we don't have to do any bookkeeping - ____________START______END_____ -[______________|ddddddddd|______] [___________|dddddddddddd____] - |<------->| |<---------->| - d3 d2' - -Each time we read a chunk in the circular buffer we move start at the -end of chunk we just read. - -Most of the time START points to the begining of the next chunk to -read, but in one case starting from this situation (where d2 - was to big to fit after d1) - - _______END____START____ -[dddd|dddd|_____|dddd|__] -| d2 | d3 | | d1 | - -reading d1 then d2 leads to - - _______END___________START -[dddd|dddd|_____________|__] - -Thats why we do - t.data_start <- data.offset + len ; -and not - t.data_start <- t.data_start + len ; - -An alternative would be to remember that the last bytes of the buffer -where not used, and to check whether start should be set at the -begining of the buffer at each read. - - *) - + if data.buf is not the circular buffer, it is supposed to be a + dedicated buffer allocated at write time and we have no bookkeeping + to do on the circular buffer. + + Else starting from + + ______START____________END_____ + [________|ddddd|ddddddddd|______] [dddddddddddddddddddddddd____] + |<--->|<------->| |<---------------------->| + d1 d3 d2 + It is required to read fully d1, d2, and then d3 in that order. + + We can have a parial read for each chunk leading to a new data chunk d1' + _________START_________END_____ + [___________|dd|ddddddddd|______] [dddddddddddddddddddddddd____] + |<>|<------->| |<---------------------->| + d1' d3 d2 + but the remainder has to be consumed to ensure that further readings + will succeed. + ____________START______END_____ + [______________|ddddddddd|______] [dddddddddddddddddddddddd____] + |<------->| |<---------------------->| + d3 d2 + When reading extra allocated chunk we don't have to do any bookkeeping + ____________START______END_____ + [______________|ddddddddd|______] [___________|dddddddddddd____] + |<------->| |<---------->| + d3 d2' + + Each time we read a chunk in the circular buffer we move start at the + end of chunk we just read. + + Most of the time START points to the begining of the next chunk to + read, but in one case starting from this situation (where d2 + was to big to fit after d1) + + _______END____START____ + [dddd|dddd|_____|dddd|__] + | d2 | d3 | | d1 | + + reading d1 then d2 leads to + + _______END___________START + [dddd|dddd|_____________|__] + + Thats why we do + t.data_start <- data.offset + len ; + and not + t.data_start <- t.data_start + len ; + + An alternative would be to remember that the last bytes of the buffer + where not used, and to check whether start should be set at the + begining of the buffer at each read. +*) let read data ?(len = data.length) t ~into ~offset = if len > data.length then invalid_arg "Circular_buffer.read: len > (length data)." ; -- GitLab From 6513cc5a4f693e2406baac0e960eacd38787262a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 11 May 2022 08:40:05 +0200 Subject: [PATCH 5/6] Env-v4: add missing .ocamlformat-ignore entry --- src/lib_protocol_environment/sigs/v4/.ocamlformat-ignore | 1 + 1 file changed, 1 insertion(+) diff --git a/src/lib_protocol_environment/sigs/v4/.ocamlformat-ignore b/src/lib_protocol_environment/sigs/v4/.ocamlformat-ignore index 154496fb51f6..7f52a3bab367 100644 --- a/src/lib_protocol_environment/sigs/v4/.ocamlformat-ignore +++ b/src/lib_protocol_environment/sigs/v4/.ocamlformat-ignore @@ -1,3 +1,4 @@ +bls_signature.mli bytes.mli char.mli format.mli -- GitLab From 2a008cc93638dbfc9b17ee555043493604c938fa Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 13 May 2022 22:16:46 +0200 Subject: [PATCH 6/6] Everywhere: autoformat with newer ocamlformat --- devtools/git-gas-diff/bin/main.ml | 56 +- docs/doc_gen/rpc_doc.ml | 4 +- manifest/main.ml | 23 +- manifest/manifest.ml | 133 ++- .../yes-wallet/test/bench_signature_perf.ml | 10 +- scripts/yes-wallet/yes_wallet.ml | 2 +- scripts/yes-wallet/yes_wallet_lib.ml | 32 +- src/bin_client/client_protocols_commands.ml | 2 +- src/bin_client/client_rpc_commands.ml | 24 +- src/bin_client/main_client.ml | 2 +- .../test/proto_test_injection/main.ml | 2 +- src/bin_codec/codec.ml | 6 +- src/bin_node/node_config_file.ml | 20 +- src/bin_node/node_identity_command.ml | 8 +- src/bin_node/node_reconstruct_command.ml | 6 +- src/bin_node/node_replay_command.ml | 20 +- src/bin_node/node_run_command.ml | 20 +- src/bin_node/node_shared_arg.ml | 8 +- src/bin_node/node_snapshot_command.ml | 6 +- src/bin_node/node_upgrade_command.ml | 6 +- src/bin_openapi/rpc_openapi.ml | 2 +- src/bin_sandbox/command_accusations.ml | 31 +- .../command_daemons_protocol_change.ml | 8 +- src/bin_sandbox/command_ledger_baking.ml | 4 +- src/bin_sandbox/command_ledger_wallet.ml | 26 +- .../command_node_synchronization.ml | 12 +- src/bin_sandbox/command_prevalidation.ml | 2 +- src/bin_sandbox/command_voting.ml | 9 +- src/bin_sandbox/main.ml | 2 +- src/bin_signer/handler.ml | 24 +- src/bin_signer/main_signer.ml | 2 +- src/bin_signer/socket_daemon.ml | 2 +- src/bin_snoop/commands.ml | 6 +- src/bin_snoop/dep_graph.ml | 4 +- src/bin_snoop/display.ml | 8 +- src/bin_snoop/latex_pp.ml | 2 +- src/bin_snoop/main_snoop.ml | 10 +- src/bin_snoop/report.ml | 6 +- .../benchmark_tps_command.ml | 12 +- src/bin_tps_evaluation/gas.ml | 4 +- src/bin_tps_evaluation/gas_tps_command.ml | 2 +- src/bin_validation/validator.ml | 4 +- src/lib_base/block_header.ml | 8 +- src/lib_base/block_locator.ml | 12 +- src/lib_base/bounded.ml | 1 - src/lib_base/fitness.ml | 6 +- src/lib_base/p2p_connection.ml | 10 +- src/lib_base/p2p_identity.ml | 4 +- src/lib_base/p2p_peer.ml | 13 +- src/lib_base/p2p_point.ml | 32 +- src/lib_base/sized.ml | 8 +- src/lib_base/test/test_p2p_addr.ml | 4 +- src/lib_base/test/test_sized.ml | 8 +- src/lib_base/test/test_time.ml | 7 +- src/lib_base/test_helpers/tz_arbitrary.ml | 2 +- src/lib_base/test_helpers/tztest.ml | 2 +- src/lib_base/time.ml | 16 +- src/lib_base/unix/protocol_files.ml | 6 +- src/lib_benchmark/costlang.ml | 84 +- src/lib_benchmark/crypto_samplers.ml | 6 +- src/lib_benchmark/csv.ml | 2 +- src/lib_benchmark/fixed_point_transform.ml | 26 +- src/lib_benchmark/inference.ml | 8 +- .../micheline_with_hash_consing.ml | 12 +- .../lib_micheline_rewriting/path.ml | 8 +- .../lib_micheline_rewriting/pattern.ml | 34 +- .../lib_micheline_rewriting/rewrite.ml | 12 +- .../structural_compare.ml | 34 +- src/lib_benchmark/measure.ml | 4 +- src/lib_benchmark/model.ml | 8 +- src/lib_benchmark/override.ml | 2 +- src/lib_benchmark/registration.ml | 4 +- src/lib_benchmark/scikit.ml | 2 +- src/lib_benchmark/sparse_vec.ml | 8 +- src/lib_benchmark/test/test_probe.ml | 8 +- src/lib_clic/clic.ml | 148 ++- src/lib_clic/test/test_clic.ml | 6 +- src/lib_client_base/client_aliases.ml | 2 +- src/lib_client_base/client_confirmations.ml | 4 +- src/lib_client_base/client_keys.ml | 30 +- src/lib_client_base/test/bip39_tests.ml | 3 +- src/lib_client_base_unix/client_config.ml | 18 +- .../client_context_unix.ml | 2 +- src/lib_client_base_unix/client_main_run.ml | 17 +- .../test/test_mockup_wallet.ml | 6 +- .../client_admin_commands.ml | 2 +- .../client_event_logging_commands.ml | 2 +- .../client_keys_commands.ml | 48 +- .../client_p2p_commands.ml | 2 +- src/lib_context/context.ml | 16 +- src/lib_context/context_dump.ml | 10 +- src/lib_context/helpers/context.ml | 8 +- .../helpers/merkle_proof_encoding.ml | 32 +- src/lib_context/sigs/config.ml | 6 +- src/lib_context/test/test_context.ml | 4 +- src/lib_context/test/test_merkle_proof.ml | 8 +- src/lib_crypto/aggregate_signature.ml | 16 +- src/lib_crypto/base58.ml | 6 +- src/lib_crypto/blake2B.ml | 18 +- src/lib_crypto/crypto_box.ml | 6 +- src/lib_crypto/ed25519.ml | 2 +- src/lib_crypto/p256.ml | 2 +- src/lib_crypto/pvss.ml | 11 +- src/lib_crypto/signature.ml | 44 +- src/lib_crypto/test-unix/test_crypto_box.ml | 2 +- src/lib_crypto/test/test_bls12_381.ml | 4 +- src/lib_crypto/test/test_crypto_box.ml | 2 +- .../test/test_deterministic_nonce.ml | 2 +- src/lib_crypto/test/test_ed25519.ml | 4 +- src/lib_crypto/test/test_merkle.ml | 16 +- src/lib_crypto/test/test_p256.ml | 4 +- src/lib_crypto/test/test_prop_signature.ml | 8 +- src/lib_crypto/test/test_pvss.ml | 10 +- src/lib_crypto/test/test_run.ml | 2 +- src/lib_crypto/test/test_signature.ml | 8 +- src/lib_crypto/test/test_timelock.ml | 20 +- src/lib_crypto/timelock.ml | 12 +- src/lib_error_monad/error_classification.ml | 8 +- src/lib_event_logging/internal_event.ml | 2 +- .../test_helpers/mock_sink.ml | 6 +- src/lib_hacl/gen/api_json.ml | 8 +- src/lib_hacl/gen/gen.ml | 126 ++- src/lib_hacl/hacl.ml | 14 +- src/lib_hacl/test/test.ml | 8 +- src/lib_hacl/test/test_hacl.ml | 24 +- .../bare/structs/list.ml | 260 +++--- .../bare/structs/monad.ml | 32 +- .../bare/structs/option.ml | 24 +- .../bare/structs/result.ml | 14 +- .../bare/structs/withExceptions.ml | 12 +- .../test/test_fuzzing_helpers.ml | 16 +- .../test/test_fuzzing_tests.ml | 98 +- .../test/test_hashtbl.ml | 2 +- .../traced/structs/monad.ml | 12 +- src/lib_micheline/micheline_diff.ml | 20 +- src/lib_micheline/micheline_encoding.ml | 8 +- src/lib_micheline/micheline_parser.ml | 117 +-- src/lib_micheline/micheline_printer.ml | 24 +- src/lib_micheline/test/assert.ml | 12 +- src/lib_micheline/test/test_diff.ml | 10 +- src/lib_micheline/test/test_parser.ml | 32 +- src/lib_mockup/local_services.ml | 22 +- src/lib_mockup/migration.ml | 2 +- src/lib_mockup/mockup_wallet.ml | 2 +- src/lib_mockup/persistence.ml | 2 +- src/lib_openapi/api.ml | 30 +- src/lib_openapi/convert.ml | 44 +- src/lib_openapi/json.ml | 2 +- src/lib_openapi/openapi.ml | 17 +- src/lib_p2p/p2p.ml | 4 +- src/lib_p2p/p2p_acl.ml | 4 +- src/lib_p2p/p2p_conn.ml | 2 +- src/lib_p2p/p2p_connect_handler.ml | 8 +- src/lib_p2p/p2p_directory.ml | 8 +- src/lib_p2p/p2p_discovery.ml | 2 +- src/lib_p2p/p2p_fd.ml | 2 +- src/lib_p2p/p2p_io_scheduler.ml | 7 +- src/lib_p2p/p2p_maintenance.ml | 10 +- src/lib_p2p/p2p_peer_state.ml | 2 +- src/lib_p2p/p2p_pool.ml | 24 +- src/lib_p2p/p2p_socket.ml | 16 +- src/lib_p2p/test/node.ml | 2 +- src/lib_p2p/test/p2p_test_utils.ml | 6 +- src/lib_p2p/test/process.ml | 32 +- src/lib_p2p/test/test_p2p_banned_peers.ml | 4 +- src/lib_p2p/test/test_p2p_buffer_reader.ml | 2 +- src/lib_p2p/test/test_p2p_io_scheduler.ml | 4 +- src/lib_p2p/test/test_p2p_logging.ml | 16 +- src/lib_p2p/test/test_p2p_node.ml | 4 +- src/lib_p2p/test/test_p2p_pool.ml | 12 +- src/lib_p2p/test/test_p2p_socket.ml | 36 +- .../bin/main_embedded_packer.ml | 2 +- src/lib_protocol_compiler/bin/main_packer.ml | 2 +- src/lib_protocol_compiler/bin/replace.ml | 2 +- src/lib_protocol_compiler/compiler.ml | 4 +- .../environment_V0.ml | 2 +- .../environment_V0.mli | 2 +- .../environment_V1.ml | 4 +- .../environment_V1.mli | 4 +- .../environment_V2.ml | 4 +- .../environment_V2.mli | 4 +- .../environment_V3.ml | 4 +- .../environment_V3.mli | 4 +- .../environment_V4.ml | 4 +- .../environment_V4.mli | 4 +- .../environment_V5.ml | 4 +- .../environment_V5.mli | 4 +- .../environment_V6.ml | 4 +- .../environment_V6.mli | 4 +- .../environment_cache.ml | 4 +- .../environment_context.ml | 20 +- .../environment_protocol_T.ml | 1 - src/lib_protocol_environment/proxy_context.ml | 2 +- .../sigs/v0/int32.mli | 1 - .../sigs/v0/int64.mli | 1 - .../sigs/v0/pervasives.mli | 1 - .../sigs/v0/string.mli | 1 - .../structs/v0/error_monad_traversors.ml | 72 +- .../structs/v3/lwtreslib_list_combine.ml | 6 +- .../test/test_cache.ml | 38 +- .../test/test_mem_context.ml | 4 +- .../test/test_mem_context_array_theory.ml | 2 +- src/lib_proxy/light_internal.ml | 14 +- src/lib_proxy/proxy_getter.ml | 12 +- src/lib_proxy/proxy_services.ml | 10 +- src/lib_proxy/test/light_lib.ml | 6 +- src/lib_proxy/test/test_fuzzing_light.ml | 8 +- .../proxy_server_config.ml | 16 +- .../test/test_proxy_server_config.ml | 4 +- src/lib_requester/requester.ml | 9 +- .../test/test_fuzzing_requester.ml | 6 +- src/lib_requester/test/test_requester.ml | 16 +- src/lib_rpc/RPC_context.ml | 2 +- src/lib_rpc/RPC_encoding.ml | 8 +- src/lib_rpc/RPC_service.ml | 4 +- src/lib_rpc/RPC_service.mli | 4 +- src/lib_rpc_http/RPC_client.ml | 2 +- src/lib_rpc_http/RPC_client_errors.ml | 18 +- src/lib_rpc_http/RPC_client_unix.ml | 2 +- src/lib_rpc_http/RPC_server.ml | 8 +- src/lib_rpc_http/test/test_rpc_http.ml | 10 +- .../bindings/rustzcash_ctypes_gen.ml | 2 +- src/lib_sapling/core.ml | 2 +- src/lib_sapling/forge.ml | 20 +- src/lib_sapling/rustzcash.ml | 2 +- src/lib_sapling/storage.ml | 22 +- src/lib_sapling/test/example.ml | 10 +- src/lib_sapling/test/test_keys.ml | 10 +- src/lib_sapling/test/test_merkle.ml | 4 +- src/lib_sapling/test/test_sapling.ml | 52 +- src/lib_shell/block_directory.ml | 14 +- src/lib_shell/block_validator.ml | 20 +- src/lib_shell/block_validator.mli | 3 +- src/lib_shell/block_validator_process.ml | 10 +- src/lib_shell/bootstrap_pipeline.ml | 8 +- src/lib_shell/chain_directory.ml | 10 +- src/lib_shell/chain_validator.ml | 9 +- src/lib_shell/distributed_db_requester.ml | 4 +- src/lib_shell/injection_directory.ml | 8 +- src/lib_shell/monitor_directory.ml | 10 +- src/lib_shell/node.ml | 4 +- src/lib_shell/p2p_reader.ml | 4 +- src/lib_shell/peer_validator.ml | 6 +- src/lib_shell/prevalidator.ml | 42 +- src/lib_shell/prevalidator.mli | 4 +- src/lib_shell/prevalidator_classification.ml | 14 +- .../prevalidator_pending_operations.ml | 12 +- src/lib_shell/protocol_validator.ml | 2 +- src/lib_shell/synchronisation_heuristic.ml | 16 +- src/lib_shell/test/generators.ml | 2 +- src/lib_shell/test/generators_tree.ml | 22 +- .../test/test_consensus_heuristic.ml | 14 +- src/lib_shell/test/test_locator.ml | 16 +- src/lib_shell/test/test_prevalidation_t.ml | 4 +- .../test/test_prevalidator_classification.ml | 8 +- ..._prevalidator_classification_operations.ml | 20 +- .../test_prevalidator_pending_operations.ml | 10 +- .../test/test_synchronisation_heuristic.ml | 5 +- .../test_synchronisation_heuristic_fuzzy.ml | 2 +- src/lib_shell/validator.ml | 2 +- src/lib_shell/worker_directory.ml | 2 +- .../bloomer_benchmarks.ml | 2 +- .../encoding_benchmarks_helpers.ml | 10 +- src/lib_shell_benchmarks/io_benchmarks.ml | 44 +- src/lib_shell_benchmarks/io_helpers.ml | 30 +- src/lib_shell_benchmarks/io_stats.ml | 6 +- src/lib_shell_services/block_services.ml | 54 +- src/lib_shell_services/history_mode.ml | 12 +- .../peer_validator_worker_state.ml | 2 +- .../prevalidator_worker_state.ml | 8 +- src/lib_shell_services/store_errors.ml | 4 +- src/lib_signer_backends/encrypted.ml | 12 +- src/lib_signer_backends/http_gen.ml | 12 +- .../test/test_encrypted.ml | 4 +- .../unix/ledger.available.ml | 22 +- src/lib_signer_backends/unix/remote.ml | 12 +- src/lib_signer_backends/unix/socket.ml | 26 +- src/lib_stdlib/bloomer.ml | 6 +- src/lib_stdlib/circular_buffer.ml | 4 +- src/lib_stdlib/compare.ml | 24 +- src/lib_stdlib/hash_queue.ml | 2 +- src/lib_stdlib/lwt_dropbox.ml | 4 +- src/lib_stdlib/lwt_idle_waiter.ml | 4 +- src/lib_stdlib/lwt_pipe.ml | 12 +- src/lib_stdlib/lwt_utils.ml | 2 +- src/lib_stdlib/readOnlyArray.ml | 2 +- src/lib_stdlib/tag.ml | 6 +- .../test-unix/test_circular_buffer_fuzzy.ml | 6 +- .../test-unix/test_hash_queue_lwt.ml | 10 +- src/lib_stdlib/test/test_arrays.ml | 26 +- src/lib_stdlib/test/test_hash_queue.ml | 12 +- src/lib_stdlib/test/test_tzList.ml | 4 +- src/lib_stdlib/test/test_tzString.ml | 2 +- src/lib_stdlib/tzList.ml | 2 +- src/lib_stdlib/tzString.ml | 6 +- src/lib_stdlib_unix/animation.ml | 2 +- src/lib_stdlib_unix/file_descriptor_sink.ml | 8 +- src/lib_stdlib_unix/file_event_sink.ml | 2 +- src/lib_stdlib_unix/lwt_log_sink_unix.ml | 10 +- src/lib_stdlib_unix/utils.ml | 2 +- src/lib_store/block_store.ml | 36 +- src/lib_store/cemented_block_store.ml | 12 +- src/lib_store/consistency.ml | 47 +- src/lib_store/floating_block_store.ml | 6 +- src/lib_store/reconstruction.ml | 14 +- src/lib_store/snapshots.ml | 48 +- src/lib_store/store.ml | 70 +- src/lib_store/test/alpha_utils.ml | 26 +- src/lib_store/test/test_block_store.ml | 24 +- src/lib_store/test/test_cemented_store.ml | 6 +- .../test/test_history_mode_switch.ml | 34 +- src/lib_store/test/test_reconstruct.ml | 4 +- src/lib_store/test/test_snapshots.ml | 22 +- src/lib_store/test/test_store.ml | 19 +- src/lib_store/test/test_testchain.ml | 12 +- src/lib_store/test/test_utils.ml | 26 +- src/lib_test/assert.ml | 6 +- src/lib_test/assert_lib.ml | 8 +- src/lib_test/qcheck2_helpers.ml | 8 +- src/lib_test/qcheck_extra.ml | 4 +- src/lib_test/qcheck_helpers.ml | 14 +- src/lib_time_measurement/ppx/time_ppx.ml | 2 +- src/lib_validation/block_validation.ml | 32 +- src/lib_validation/protocol_logging.ml | 2 +- src/lib_version/exe/get_git_info.ml | 4 +- src/lib_version/test/test_parser.ml | 16 +- src/lib_workers/worker.ml | 22 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 85 +- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- .../client_proto_programs_commands.ml | 7 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 85 +- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- .../client_proto_programs_commands.ml | 7 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 85 +- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- .../client_proto_programs_commands.ml | 7 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 85 +- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- .../client_proto_programs_commands.ml | 7 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/injection.ml | 20 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- .../client_proto_programs_commands.ml | 22 +- .../lib_client/client_proto_context.ml | 8 +- .../lib_client/client_proto_fa12.ml | 6 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/injection.ml | 20 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- .../client_proto_context_commands.ml | 6 +- .../client_proto_multisig_commands.ml | 3 +- .../client_proto_programs_commands.ml | 22 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_fa12.ml | 6 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- .../client_proto_programs_commands.ml | 11 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_fa12.ml | 12 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/injection.ml | 22 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- src/proto_008_PtEdo2Zk/lib_client/mockup.ml | 4 +- src/proto_008_PtEdo2Zk/lib_client/proxy.ml | 12 +- .../client_proto_context_commands.ml | 8 +- .../client_proto_fa12_commands.ml | 6 +- .../client_proto_multisig_commands.ml | 3 +- .../client_proto_programs_commands.ml | 26 +- .../client_sapling_commands.ml | 4 +- .../lib_client_sapling/context.ml | 6 +- .../lib_client_sapling/wallet.ml | 2 +- src/proto_008_PtEdo2Zk/lib_plugin/plugin.ml | 34 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_fa12.ml | 12 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/client_proto_utils.ml | 4 +- .../lib_client/injection.ml | 16 +- src/proto_009_PsFLoren/lib_client/limit.ml | 6 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- src/proto_009_PsFLoren/lib_client/mockup.ml | 4 +- src/proto_009_PsFLoren/lib_client/proxy.ml | 12 +- .../client_proto_context_commands.ml | 8 +- .../client_proto_fa12_commands.ml | 6 +- .../client_proto_multisig_commands.ml | 3 +- .../client_proto_programs_commands.ml | 22 +- .../client_sapling_commands.ml | 4 +- .../lib_client_sapling/context.ml | 6 +- .../lib_client_sapling/wallet.ml | 2 +- src/proto_009_PsFLoren/lib_plugin/plugin.ml | 34 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_fa12.ml | 12 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/client_proto_utils.ml | 4 +- .../lib_client/injection.ml | 20 +- src/proto_010_PtGRANAD/lib_client/limit.ml | 6 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- src/proto_010_PtGRANAD/lib_client/mockup.ml | 4 +- src/proto_010_PtGRANAD/lib_client/proxy.ml | 12 +- .../client_proto_context_commands.ml | 8 +- .../client_proto_fa12_commands.ml | 6 +- .../client_proto_multisig_commands.ml | 3 +- .../client_proto_programs_commands.ml | 22 +- .../client_proto_stresstest_commands.ml | 4 +- .../client_sapling_commands.ml | 4 +- .../lib_client_sapling/context.ml | 6 +- .../lib_client_sapling/wallet.ml | 2 +- src/proto_010_PtGRANAD/lib_plugin/plugin.ml | 38 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_fa12.ml | 12 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/client_proto_utils.ml | 4 +- .../lib_client/injection.ml | 20 +- src/proto_011_PtHangz2/lib_client/limit.ml | 6 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- src/proto_011_PtHangz2/lib_client/mockup.ml | 4 +- .../test/test_michelson_v1_macros.ml | 8 +- .../lib_client/test/test_proxy.ml | 6 +- .../client_proto_context_commands.ml | 8 +- .../client_proto_fa12_commands.ml | 6 +- .../client_proto_multisig_commands.ml | 3 +- .../client_proto_programs_commands.ml | 10 +- .../client_proto_stresstest_commands.ml | 4 +- .../client_sapling_commands.ml | 4 +- .../lib_client_sapling/context.ml | 6 +- .../lib_client_sapling/wallet.ml | 2 +- src/proto_011_PtHangz2/lib_plugin/plugin.ml | 48 +- .../lib_benchmark/autocomp.ml | 26 +- .../lib_benchmark_type_inference/inference.ml | 130 +-- .../lib_benchmark_type_inference/monads.ml | 2 +- .../test/test_inference.ml | 34 +- .../lib_benchmark_type_inference/type.ml | 43 +- .../lib_benchmark/michelson_mcmc_samplers.ml | 6 +- .../lib_benchmark/michelson_samplers.ml | 12 +- .../lib_benchmark/mikhailsky_to_michelson.ml | 8 +- src/proto_012_Psithaca/lib_benchmark/rules.ml | 2 +- .../lib_benchmark/test/test_autocompletion.ml | 8 +- .../lib_benchmarks_proto/cache_benchmarks.ml | 10 +- .../encodings_benchmarks.ml | 10 +- .../global_constants_storage_benchmarks.ml | 6 +- .../interpreter_benchmarks.ml | 88 +- .../interpreter_workload.ml | 308 +++---- .../sapling_generation.ml | 16 +- .../lib_benchmarks_proto/size.ml | 2 +- .../translator_benchmarks.ml | 4 +- .../translator_workload.ml | 2 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_fa12.ml | 12 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/client_proto_utils.ml | 4 +- .../lib_client/injection.ml | 22 +- src/proto_012_Psithaca/lib_client/limit.ml | 6 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- src/proto_012_Psithaca/lib_client/mockup.ml | 6 +- .../lib_client/operation_result.ml | 8 +- .../test/test_michelson_v1_macros.ml | 8 +- .../lib_client/test/test_proxy.ml | 6 +- .../client_proto_context_commands.ml | 44 +- .../client_proto_fa12_commands.ml | 6 +- .../client_proto_multisig_commands.ml | 3 +- .../client_proto_programs_commands.ml | 10 +- .../client_proto_stresstest_commands.ml | 4 +- .../client_proto_utils_commands.ml | 3 +- .../client_sapling_commands.ml | 4 +- .../lib_client_sapling/context.ml | 6 +- .../lib_client_sapling/wallet.ml | 2 +- .../lib_delegate/baking_actions.ml | 6 +- .../lib_delegate/baking_cache.ml | 4 +- .../lib_delegate/baking_commands.ml | 2 +- .../lib_delegate/baking_lib.ml | 2 +- .../lib_delegate/baking_nonces.ml | 3 +- .../lib_delegate/baking_scheduling.ml | 8 +- .../lib_delegate/baking_state.ml | 18 +- .../lib_delegate/block_forge.ml | 9 +- .../lib_delegate/client_baking_blocks.ml | 3 +- .../client_baking_denunciation.ml | 12 +- .../lib_delegate/operation_pool.ml | 11 +- .../lib_delegate/operation_worker.ml | 6 +- .../lib_delegate/state_transitions.ml | 32 +- .../test/mockup_simulator/mockup_simulator.ml | 14 +- .../lib_delegate/test/test_scenario.ml | 78 +- src/proto_012_Psithaca/lib_plugin/plugin.ml | 50 +- .../lib_plugin/test/generators.ml | 2 +- .../lib_plugin/test/test_consensus_filter.ml | 4 +- .../lib_plugin/test/test_utils.ml | 6 +- .../lib_protocol/test/helpers/account.ml | 6 +- .../lib_protocol/test/helpers/block.ml | 9 +- .../lib_protocol/test/helpers/context.ml | 8 +- .../test/helpers/contract_helpers.ml | 2 +- .../lib_protocol/test/helpers/expr.ml | 4 +- .../lib_protocol/test/helpers/incremental.ml | 11 +- .../helpers/liquidity_baking_generator.ml | 6 +- .../test/helpers/liquidity_baking_machine.ml | 39 +- .../test/helpers/lqt_fa12_repr.ml | 4 +- .../lib_protocol/test/helpers/op.ml | 4 +- .../test/helpers/sapling_helpers.ml | 6 +- .../test/helpers/test_global_constants.ml | 14 +- .../test/integration/consensus/test_baking.ml | 8 +- .../consensus/test_deactivation.ml | 8 +- .../integration/consensus/test_delegation.ml | 64 +- .../consensus/test_double_baking.ml | 4 +- .../consensus/test_double_endorsement.ml | 10 +- .../consensus/test_double_preendorsement.ml | 4 +- .../consensus/test_frozen_deposits.ml | 40 +- .../consensus/test_participation.ml | 6 +- .../consensus/test_preendorsement_functor.ml | 8 +- .../test/integration/consensus/test_seed.ml | 8 +- .../test/integration/gas/test_gas_levels.ml | 24 +- .../test_global_constants_storage.ml | 4 +- .../michelson/test_lazy_storage_diff.ml | 11 +- .../integration/michelson/test_sapling.ml | 8 +- .../michelson/test_ticket_balance_key.ml | 18 +- .../michelson/test_ticket_scanner.ml | 50 +- .../michelson/test_ticket_storage.ml | 56 +- .../integration/michelson/test_timelock.ml | 12 +- .../michelson/test_typechecking.ml | 6 +- .../integration/operations/test_activation.ml | 2 +- .../operations/test_combined_operations.ml | 26 +- .../integration/operations/test_voting.ml | 12 +- .../test/integration/test_liquidity_baking.ml | 2 - .../test/integration/test_token.ml | 74 +- .../test/pbt/liquidity_baking_pbt.ml | 26 +- .../test/pbt/test_script_comparison.ml | 55 +- .../lib_protocol/test/pbt/test_tez_repr.ml | 8 +- .../bin_sc_rollup_client/configuration.ml | 4 +- .../bin_sc_rollup_node/inbox.ml | 4 +- .../bin_sc_rollup_node/layer1.ml | 4 +- .../bin_tx_rollup_client/configuration.ml | 4 +- .../lib_benchmark/autocomp.ml | 26 +- .../lib_benchmark_type_inference/inference.ml | 130 +-- .../lib_benchmark_type_inference/monads.ml | 2 +- .../test/test_inference.ml | 34 +- .../lib_benchmark_type_inference/type.ml | 43 +- .../lib_benchmark/michelson_mcmc_samplers.ml | 6 +- .../lib_benchmark/michelson_samplers.ml | 12 +- .../lib_benchmark/mikhailsky_to_michelson.ml | 8 +- src/proto_013_PtJakart/lib_benchmark/rules.ml | 2 +- .../lib_benchmark/test/test_autocompletion.ml | 8 +- .../lib_benchmarks_proto/cache_benchmarks.ml | 10 +- .../carbonated_map_benchmarks.ml | 4 +- .../encodings_benchmarks.ml | 10 +- .../global_constants_storage_benchmarks.ml | 6 +- .../interpreter_benchmarks.ml | 96 +- .../interpreter_workload.ml | 310 +++---- .../sapling_generation.ml | 16 +- .../lib_benchmarks_proto/ticket_benchmarks.ml | 12 +- .../translator_benchmarks.ml | 4 +- .../translator_workload.ml | 2 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_fa12.ml | 12 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/client_proto_utils.ml | 4 +- .../lib_client/injection.ml | 22 +- src/proto_013_PtJakart/lib_client/limit.ml | 6 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- src/proto_013_PtJakart/lib_client/mockup.ml | 6 +- .../lib_client/operation_result.ml | 8 +- .../test/test_michelson_v1_macros.ml | 8 +- .../lib_client/test/test_proxy.ml | 6 +- .../client_proto_context_commands.ml | 44 +- .../client_proto_fa12_commands.ml | 6 +- .../client_proto_multisig_commands.ml | 3 +- .../client_proto_programs_commands.ml | 10 +- .../client_proto_stresstest_commands.ml | 2 +- .../client_proto_utils_commands.ml | 3 +- .../client_sapling_commands.ml | 4 +- .../lib_client_sapling/context.ml | 6 +- .../lib_client_sapling/wallet.ml | 2 +- .../lib_delegate/baking_actions.ml | 6 +- .../lib_delegate/baking_cache.ml | 4 +- .../lib_delegate/baking_commands.ml | 2 +- .../lib_delegate/baking_lib.ml | 2 +- .../lib_delegate/baking_nonces.ml | 3 +- .../lib_delegate/baking_scheduling.ml | 8 +- .../lib_delegate/baking_state.ml | 18 +- .../lib_delegate/block_forge.ml | 9 +- .../lib_delegate/client_baking_blocks.ml | 3 +- .../client_baking_denunciation.ml | 12 +- .../lib_delegate/node_rpc.ml | 2 +- .../lib_delegate/operation_pool.ml | 11 +- .../lib_delegate/operation_worker.ml | 6 +- .../lib_delegate/state_transitions.ml | 32 +- .../test/mockup_simulator/mockup_simulator.ml | 20 +- .../lib_delegate/test/test_scenario.ml | 78 +- src/proto_013_PtJakart/lib_plugin/plugin.ml | 40 +- .../lib_plugin/test/generators.ml | 2 +- .../lib_plugin/test/test_consensus_filter.ml | 4 +- .../lib_plugin/test/test_utils.ml | 6 +- .../lib_protocol/test/helpers/account.ml | 6 +- .../lib_protocol/test/helpers/block.ml | 9 +- .../lib_protocol/test/helpers/context.ml | 8 +- .../test/helpers/contract_helpers.ml | 2 +- .../lib_protocol/test/helpers/expr.ml | 4 +- .../lib_protocol/test/helpers/incremental.ml | 11 +- .../helpers/liquidity_baking_generator.ml | 6 +- .../test/helpers/liquidity_baking_machine.ml | 39 +- .../test/helpers/lqt_fa12_repr.ml | 4 +- .../lib_protocol/test/helpers/op.ml | 2 +- .../test/helpers/sapling_helpers.ml | 8 +- .../test/helpers/test_global_constants.ml | 14 +- .../test/integration/consensus/test_baking.ml | 8 +- .../consensus/test_deactivation.ml | 8 +- .../integration/consensus/test_delegation.ml | 38 +- .../consensus/test_double_baking.ml | 6 +- .../consensus/test_double_endorsement.ml | 10 +- .../consensus/test_double_preendorsement.ml | 4 +- .../consensus/test_frozen_deposits.ml | 44 +- .../consensus/test_participation.ml | 6 +- .../consensus/test_preendorsement_functor.ml | 8 +- .../test/integration/consensus/test_seed.ml | 8 +- .../test/integration/gas/test_gas_levels.ml | 24 +- .../michelson/test_block_time_instructions.ml | 4 +- .../test_global_constants_storage.ml | 4 +- .../michelson/test_lazy_storage_diff.ml | 11 +- .../michelson/test_patched_contracts.ml | 2 +- .../integration/michelson/test_sapling.ml | 8 +- .../michelson/test_script_cache.ml | 13 +- .../michelson/test_script_typed_ir_size.ml | 4 +- .../michelson/test_ticket_accounting.ml | 222 ++--- .../michelson/test_ticket_balance.ml | 46 +- .../michelson/test_ticket_balance_key.ml | 14 +- .../test_ticket_lazy_storage_diff.ml | 122 +-- .../michelson/test_ticket_manager.ml | 46 +- .../michelson/test_ticket_operations_diff.ml | 158 ++-- .../michelson/test_ticket_scanner.ml | 52 +- .../michelson/test_ticket_storage.ml | 56 +- .../integration/michelson/test_timelock.ml | 12 +- .../michelson/test_typechecking.ml | 14 +- .../integration/operations/test_activation.ml | 2 +- .../operations/test_combined_operations.ml | 28 +- .../integration/operations/test_sc_rollup.ml | 18 +- .../integration/operations/test_tx_rollup.ml | 172 ++-- .../integration/operations/test_voting.ml | 10 +- .../test/integration/test_frozen_bonds.ml | 14 +- .../test/integration/test_liquidity_baking.ml | 4 +- .../integration/test_storage_functions.ml | 6 +- .../test/integration/test_token.ml | 66 +- .../test/pbt/liquidity_baking_pbt.ml | 26 +- .../test/pbt/refutation_game_pbt.ml | 40 +- .../test/pbt/test_carbonated_map.ml | 98 +- .../test/pbt/test_script_comparison.ml | 59 +- .../lib_protocol/test/pbt/test_tez_repr.ml | 8 +- .../test/pbt/test_tx_rollup_l2_encoding.ml | 2 +- .../lib_protocol/test/unit/test_gas_monad.ml | 2 +- .../lib_protocol/test/unit/test_round_repr.ml | 8 +- .../test/unit/test_sc_rollup_storage.ml | 230 +++-- .../test/unit/test_skip_list_repr.ml | 2 +- .../test/unit/test_tx_rollup_l2.ml | 38 +- .../test/unit/test_tx_rollup_l2_apply.ml | 284 +++--- src/proto_013_PtJakart/lib_tx_rollup/RPC.ml | 12 +- .../lib_tx_rollup/batcher.ml | 6 +- .../lib_tx_rollup/common.ml | 2 +- .../lib_tx_rollup/context.ml | 4 +- .../lib_tx_rollup/daemon.ml | 18 +- .../lib_tx_rollup/injector.ml | 14 +- .../lib_tx_rollup/interpreter.ml | 14 +- .../lib_tx_rollup/prover_apply.ml | 2 +- src/proto_013_PtJakart/lib_tx_rollup/state.ml | 24 +- .../lib_tx_rollup/stores.ml | 20 +- .../bin_sc_rollup_client/configuration.ml | 4 +- .../bin_sc_rollup_node/commitment.ml | 12 +- .../bin_sc_rollup_node/commitment_event.ml | 2 +- .../bin_sc_rollup_node/configuration.ml | 8 +- src/proto_alpha/bin_sc_rollup_node/daemon.ml | 6 +- .../bin_sc_rollup_node/daemon_event.ml | 2 +- src/proto_alpha/bin_sc_rollup_node/event.ml | 2 +- src/proto_alpha/bin_sc_rollup_node/inbox.ml | 2 +- .../bin_sc_rollup_node/inbox_event.ml | 2 +- .../bin_sc_rollup_node/interpreter_event.ml | 2 +- src/proto_alpha/bin_sc_rollup_node/layer1.ml | 4 +- .../bin_sc_rollup_node/layer1_event.ml | 2 +- .../bin_sc_rollup_node/node_context.ml | 2 +- .../bin_tx_rollup_client/commands.ml | 14 +- .../bin_tx_rollup_client/configuration.ml | 4 +- src/proto_alpha/lib_benchmark/autocomp.ml | 26 +- .../lib_benchmark_type_inference/inference.ml | 130 +-- .../lib_benchmark_type_inference/monads.ml | 2 +- .../test/test_inference.ml | 34 +- .../lib_benchmark_type_inference/type.ml | 43 +- .../lib_benchmark/michelson_mcmc_samplers.ml | 6 +- .../lib_benchmark/michelson_samplers.ml | 14 +- .../lib_benchmark/mikhailsky_to_michelson.ml | 8 +- src/proto_alpha/lib_benchmark/rules.ml | 2 +- .../lib_benchmark/test/test_autocompletion.ml | 8 +- .../lib_benchmarks_proto/cache_benchmarks.ml | 10 +- .../carbonated_map_benchmarks.ml | 4 +- .../encodings_benchmarks.ml | 10 +- .../global_constants_storage_benchmarks.ml | 6 +- .../interpreter_benchmarks.ml | 96 +- .../interpreter_workload.ml | 310 +++---- .../sapling_generation.ml | 16 +- .../sc_rollup_benchmarks.ml | 16 +- .../lib_benchmarks_proto/ticket_benchmarks.ml | 12 +- .../translator_benchmarks.ml | 4 +- .../translator_workload.ml | 2 +- .../tx_rollup_benchmarks.ml | 23 +- .../lib_client/client_proto_context.ml | 6 +- .../lib_client/client_proto_fa12.ml | 12 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/client_proto_utils.ml | 4 +- src/proto_alpha/lib_client/injection.ml | 22 +- src/proto_alpha/lib_client/limit.ml | 6 +- .../lib_client/michelson_v1_emacs.ml | 6 +- .../lib_client/michelson_v1_error_reporter.ml | 2 +- .../lib_client/michelson_v1_macros.ml | 145 ++- .../lib_client/michelson_v1_parser.ml | 20 +- .../lib_client/michelson_v1_printer.ml | 6 +- src/proto_alpha/lib_client/mockup.ml | 6 +- .../lib_client/operation_result.ml | 8 +- .../test/test_michelson_v1_macros.ml | 8 +- src/proto_alpha/lib_client/test/test_proxy.ml | 6 +- .../client_proto_context_commands.ml | 44 +- .../client_proto_fa12_commands.ml | 6 +- .../client_proto_multisig_commands.ml | 3 +- .../client_proto_programs_commands.ml | 10 +- .../client_proto_stresstest_commands.ml | 16 +- .../client_proto_utils_commands.ml | 3 +- .../client_sapling_commands.ml | 4 +- src/proto_alpha/lib_client_sapling/context.ml | 6 +- src/proto_alpha/lib_client_sapling/wallet.ml | 2 +- .../lib_delegate/baking_actions.ml | 6 +- src/proto_alpha/lib_delegate/baking_cache.ml | 4 +- .../lib_delegate/baking_commands.ml | 2 +- src/proto_alpha/lib_delegate/baking_lib.ml | 18 +- .../lib_delegate/baking_scheduling.ml | 8 +- src/proto_alpha/lib_delegate/baking_state.ml | 18 +- src/proto_alpha/lib_delegate/block_forge.ml | 9 +- .../lib_delegate/client_baking_blocks.ml | 3 +- .../client_baking_denunciation.ml | 12 +- src/proto_alpha/lib_delegate/node_rpc.ml | 2 +- .../lib_delegate/operation_pool.ml | 11 +- .../lib_delegate/operation_worker.ml | 6 +- .../lib_delegate/state_transitions.ml | 32 +- .../test/mockup_simulator/mockup_simulator.ml | 20 +- .../lib_delegate/test/test_scenario.ml | 78 +- src/proto_alpha/lib_plugin/plugin.ml | 54 +- src/proto_alpha/lib_plugin/test/generators.ml | 2 +- .../lib_plugin/test/test_consensus_filter.ml | 4 +- src/proto_alpha/lib_plugin/test/test_utils.ml | 6 +- src/proto_alpha/lib_protocol/amendment.ml | 2 +- src/proto_alpha/lib_protocol/apply.ml | 44 +- src/proto_alpha/lib_protocol/apply.mli | 3 +- src/proto_alpha/lib_protocol/apply_results.ml | 202 ++-- src/proto_alpha/lib_protocol/baking.ml | 2 +- src/proto_alpha/lib_protocol/bond_id_repr.ml | 2 +- .../lib_protocol/cache_memory_helpers.ml | 6 +- .../lib_protocol/carbonated_map.ml | 8 +- src/proto_alpha/lib_protocol/contract_repr.ml | 8 +- .../lib_protocol/contract_services.ml | 2 +- .../lib_protocol/contract_storage.ml | 10 +- .../lib_protocol/delegate_storage.ml | 8 +- .../lib_protocol/dependent_bool.ml | 16 +- .../lib_protocol/destination_repr.ml | 8 +- src/proto_alpha/lib_protocol/fitness_repr.ml | 6 +- .../lib_protocol/gas_comparable_input_size.ml | 2 +- src/proto_alpha/lib_protocol/gas_monad.ml | 11 +- .../lib_protocol/global_constants_storage.ml | 2 +- src/proto_alpha/lib_protocol/indexable.ml | 8 +- .../lib_protocol/lazy_storage_diff.ml | 3 +- .../lib_protocol/lazy_storage_kind.ml | 20 +- src/proto_alpha/lib_protocol/main.ml | 64 +- src/proto_alpha/lib_protocol/merkle_list.ml | 44 +- .../lib_protocol/michelson_v1_gas.ml | 20 +- .../lib_protocol/michelson_v1_primitives.ml | 4 +- .../lib_protocol/operation_repr.ml | 143 ++- src/proto_alpha/lib_protocol/raw_context.ml | 18 +- src/proto_alpha/lib_protocol/receipt_repr.ml | 23 +- src/proto_alpha/lib_protocol/round_repr.ml | 30 +- src/proto_alpha/lib_protocol/sampler.ml | 16 +- src/proto_alpha/lib_protocol/sapling_repr.ml | 2 +- .../lib_protocol/sapling_storage.ml | 18 +- .../lib_protocol/sapling_validator.ml | 8 +- .../lib_protocol/sc_rollup_arith.ml | 32 +- .../lib_protocol/sc_rollup_costs.ml | 10 +- .../lib_protocol/sc_rollup_game_repr.ml | 8 +- .../lib_protocol/sc_rollup_inbox_repr.ml | 2 +- .../sc_rollup_management_protocol.ml | 16 +- .../lib_protocol/sc_rollup_repr.ml | 2 +- .../lib_protocol/sc_rollup_storage.ml | 187 ++-- .../lib_protocol/sc_rollup_storage.mli | 16 +- src/proto_alpha/lib_protocol/script_cache.ml | 10 +- .../lib_protocol/script_comparable.ml | 56 +- src/proto_alpha/lib_protocol/script_int.ml | 2 +- .../lib_protocol/script_interpreter.ml | 243 +++-- .../lib_protocol/script_interpreter_defs.ml | 85 +- .../lib_protocol/script_ir_annot.ml | 18 +- .../lib_protocol/script_ir_translator.ml | 864 +++++++++--------- .../lib_protocol/script_ir_translator.mli | 62 +- src/proto_alpha/lib_protocol/script_map.ml | 2 +- .../lib_protocol/script_typed_ir_size.ml | 8 +- src/proto_alpha/lib_protocol/seed_repr.ml | 4 +- .../lib_protocol/skip_list_repr.ml | 4 +- src/proto_alpha/lib_protocol/storage.ml | 114 +-- src/proto_alpha/lib_protocol/storage.mli | 2 +- .../lib_protocol/storage_description.ml | 18 +- .../lib_protocol/storage_functors.ml | 90 +- .../lib_protocol/test/helpers/account.ml | 6 +- .../lib_protocol/test/helpers/block.ml | 9 +- .../lib_protocol/test/helpers/context.ml | 18 +- .../lib_protocol/test/helpers/expr.ml | 4 +- .../lib_protocol/test/helpers/incremental.ml | 11 +- .../helpers/liquidity_baking_generator.ml | 6 +- .../test/helpers/liquidity_baking_machine.ml | 39 +- .../test/helpers/lqt_fa12_repr.ml | 4 +- .../lib_protocol/test/helpers/op.ml | 2 +- .../test/helpers/sapling_helpers.ml | 8 +- .../test/helpers/test_global_constants.ml | 14 +- .../test/helpers/tx_rollup_l2_helpers.ml | 2 +- .../test/integration/consensus/test_baking.ml | 6 +- .../integration/consensus/test_delegation.ml | 38 +- .../consensus/test_double_baking.ml | 4 +- .../consensus/test_double_endorsement.ml | 6 +- .../consensus/test_double_preendorsement.ml | 4 +- .../consensus/test_frozen_deposits.ml | 42 +- .../consensus/test_participation.ml | 4 +- .../consensus/test_preendorsement_functor.ml | 8 +- .../test/integration/consensus/test_seed.ml | 2 +- .../test/integration/gas/test_gas_levels.ml | 24 +- .../michelson/test_block_time_instructions.ml | 4 +- .../michelson/test_lazy_storage_diff.ml | 11 +- .../michelson/test_patched_contracts.ml | 2 +- .../integration/michelson/test_sapling.ml | 8 +- .../michelson/test_script_cache.ml | 13 +- .../michelson/test_script_typed_ir_size.ml | 4 +- .../michelson/test_ticket_accounting.ml | 220 ++--- .../michelson/test_ticket_balance.ml | 60 +- .../michelson/test_ticket_balance_key.ml | 14 +- .../test_ticket_lazy_storage_diff.ml | 122 +-- .../michelson/test_ticket_manager.ml | 46 +- .../michelson/test_ticket_operations_diff.ml | 156 ++-- .../michelson/test_ticket_scanner.ml | 52 +- .../michelson/test_ticket_storage.ml | 56 +- .../integration/michelson/test_timelock.ml | 12 +- .../michelson/test_typechecking.ml | 14 +- .../integration/operations/test_activation.ml | 2 +- .../operations/test_combined_operations.ml | 14 +- .../integration/operations/test_sc_rollup.ml | 26 +- .../integration/operations/test_tx_rollup.ml | 173 ++-- .../integration/operations/test_voting.ml | 10 +- .../test/integration/test_constants.ml | 4 +- .../test/integration/test_frozen_bonds.ml | 20 +- .../test/integration/test_liquidity_baking.ml | 4 +- .../integration/test_storage_functions.ml | 6 +- .../test/integration/test_token.ml | 62 +- .../test/pbt/liquidity_baking_pbt.ml | 26 +- .../test/pbt/test_carbonated_map.ml | 98 +- .../test/pbt/test_script_comparison.ml | 59 +- .../lib_protocol/test/pbt/test_tez_repr.ml | 8 +- .../test/pbt/test_tx_rollup_l2_encoding.ml | 4 +- .../lib_protocol/test/unit/test_gas_monad.ml | 2 +- .../lib_protocol/test/unit/test_round_repr.ml | 8 +- .../test_sc_rollup_management_protocol.ml | 10 +- .../test/unit/test_sc_rollup_storage.ml | 280 +++--- .../test/unit/test_skip_list_repr.ml | 2 +- .../test/unit/test_tx_rollup_l2.ml | 38 +- .../test/unit/test_tx_rollup_l2_apply.ml | 284 +++--- src/proto_alpha/lib_protocol/tez_repr.ml | 6 +- .../lib_protocol/ticket_accounting.ml | 4 +- .../lib_protocol/ticket_lazy_storage_diff.ml | 2 +- .../lib_protocol/ticket_operations_diff.ml | 4 +- .../lib_protocol/ticket_scanner.ml | 22 +- .../tx_rollup_commitment_storage.ml | 7 +- .../lib_protocol/tx_rollup_inbox_storage.ml | 6 +- .../lib_protocol/tx_rollup_l2_apply.ml | 38 +- .../lib_protocol/tx_rollup_l2_batch.ml | 8 +- .../lib_protocol/tx_rollup_l2_context.ml | 4 +- .../lib_protocol/tx_rollup_message_repr.ml | 2 +- .../lib_protocol/tx_rollup_state_repr.ml | 20 +- src/proto_alpha/lib_protocol/vote_repr.ml | 4 +- src/proto_alpha/lib_tx_rollup/RPC.ml | 6 +- src/proto_alpha/lib_tx_rollup/accuser.ml | 15 +- src/proto_alpha/lib_tx_rollup/batcher.ml | 10 +- src/proto_alpha/lib_tx_rollup/common.ml | 2 +- src/proto_alpha/lib_tx_rollup/context.ml | 4 +- src/proto_alpha/lib_tx_rollup/daemon.ml | 34 +- src/proto_alpha/lib_tx_rollup/dispatcher.ml | 4 +- src/proto_alpha/lib_tx_rollup/injector.ml | 14 +- src/proto_alpha/lib_tx_rollup/interpreter.ml | 14 +- src/proto_alpha/lib_tx_rollup/prover_apply.ml | 2 +- src/proto_alpha/lib_tx_rollup/state.ml | 10 +- src/proto_alpha/lib_tx_rollup/stores.ml | 22 +- src/tooling/run_js_inline_tests.ml | 12 +- tezt/lib/base.ml | 2 +- tezt/lib/check.ml | 22 +- tezt/lib/cli.ml | 2 +- tezt/lib/log.ml | 16 +- tezt/lib/process.ml | 6 +- tezt/lib/runner.ml | 12 +- tezt/lib/test.ml | 35 +- tezt/lib_performance_regression/grafana.ml | 6 +- tezt/lib_performance_regression/influxDB.ml | 10 +- tezt/lib_performance_regression/long_test.ml | 10 +- tezt/lib_tezos/account.ml | 4 +- tezt/lib_tezos/accuser.ml | 2 +- tezt/lib_tezos/baker.ml | 2 +- tezt/lib_tezos/client.ml | 12 +- tezt/lib_tezos/cluster.ml | 2 +- tezt/lib_tezos/daemon.ml | 6 +- tezt/lib_tezos/node.ml | 32 +- tezt/lib_tezos/protocol.ml | 6 +- tezt/lib_tezos/proxy_server.ml | 4 +- tezt/lib_tezos/sc_rollup_client.ml | 6 +- tezt/lib_tezos/sc_rollup_node.ml | 4 +- tezt/lib_tezos/signer.ml | 2 +- tezt/lib_tezos/tez.ml | 8 +- tezt/lib_tezos/tezos_regression.ml | 2 +- tezt/lib_tezos/tx_rollup_node.ml | 6 +- tezt/long_tests/block_validation.ml | 2 +- tezt/long_tests/prt_client.ml | 2 +- tezt/long_tests/qcheck_rpc.ml | 14 +- tezt/long_tests/script_cache.ml | 13 +- tezt/manual_tests/migration_voting.ml | 2 +- tezt/snoop/perform_benchmarks.ml | 6 +- tezt/snoop/prepare_data.ml | 2 +- tezt/tests/RPC_test.ml | 10 +- tezt/tests/baker_test.ml | 4 +- tezt/tests/baking.ml | 6 +- tezt/tests/big_map_all.ml | 5 +- tezt/tests/bootstrap.ml | 2 +- tezt/tests/cache_cache.ml | 2 +- tezt/tests/cli_tezos.ml | 2 +- tezt/tests/client_commands.ml | 2 +- tezt/tests/client_config.ml | 2 +- tezt/tests/client_run_view.ml | 10 +- tezt/tests/demo_counter.ml | 3 +- tezt/tests/deposits_limit.ml | 4 +- tezt/tests/double_bake.ml | 4 +- tezt/tests/encoding.ml | 12 +- tezt/tests/forge.ml | 4 +- tezt/tests/global_constants.ml | 6 +- tezt/tests/hash_data.ml | 2 +- tezt/tests/large_metadata.ml | 8 +- tezt/tests/light.ml | 16 +- tezt/tests/main.ml | 2 +- tezt/tests/manager_operations.ml | 17 +- tezt/tests/mockup.ml | 36 +- tezt/tests/monitor_operations.ml | 2 +- tezt/tests/normalize.ml | 4 +- tezt/tests/prevalidator.ml | 56 +- tezt/tests/protocol_migration.ml | 6 +- tezt/tests/protocol_table_update.ml | 8 +- tezt/tests/proxy.ml | 36 +- tezt/tests/proxy_server_test.ml | 10 +- tezt/tests/reject_malformed_micheline.ml | 2 +- tezt/tests/replace_by_fees.ml | 4 +- tezt/tests/run_script.ml | 2 +- tezt/tests/sapling.ml | 4 +- tezt/tests/sc_rollup.ml | 41 +- tezt/tests/signer_test.ml | 2 +- tezt/tests/stresstest_command.ml | 21 +- tezt/tests/tenderbake.ml | 6 +- tezt/tests/tx_rollup.ml | 16 +- tezt/tests/tx_rollup_node.ml | 117 ++- tezt/tests/views.ml | 2 +- tezt/tests/voting.ml | 6 +- tezt/vesting_contract_test/main.ml | 2 +- tezt/vesting_contract_test/state.ml | 4 +- tezt/vesting_contract_test/test_michelson.ml | 4 +- tezt/vesting_contract_test/vesting_test.ml | 9 +- 1013 files changed, 9856 insertions(+), 10218 deletions(-) diff --git a/devtools/git-gas-diff/bin/main.ml b/devtools/git-gas-diff/bin/main.ml index 4ca974968675..d6e687237ee4 100644 --- a/devtools/git-gas-diff/bin/main.ml +++ b/devtools/git-gas-diff/bin/main.ml @@ -95,14 +95,14 @@ module Decimal = struct let decimals = max decimals1 decimals2 in let pow10 = abs (decimals1 - decimals2) in let scale_value v = Big_int.(v * power_int_positive_int 10 pow10) in - let (value1, value2) = + let value1, value2 = if decimals1 >= decimals2 then (value1, scale_value value2) else (scale_value value1, value2) in (value1, value2, decimals) let add r1 r2 = - let (value1, value2, decimals) = scale r1 r2 in + let value1, value2, decimals = scale r1 r2 in {value = Big_int.add_big_int value1 value2; decimals} let opp r = {r with value = Big_int.minus_big_int r.value} @@ -118,11 +118,11 @@ module Decimal = struct } let ge r1 r2 = - let (value1, value2, _decimals) = scale r1 r2 in + let value1, value2, _decimals = scale r1 r2 in Big_int.ge_big_int value1 value2 let gt r1 r2 = - let (value1, value2, _decimals) = scale r1 r2 in + let value1, value2, _decimals = scale r1 r2 in Big_int.gt_big_int value1 value2 let re = Re.Posix.re "([0-9]+)(\\.([0-9]*))?" @@ -140,7 +140,7 @@ module Decimal = struct let to_string {value; decimals} = let pow10 = Big_int.power_int_positive_int 10 decimals in - let (int_part, dec_part) = Big_int.quomod_big_int value pow10 in + let int_part, dec_part = Big_int.quomod_big_int value pow10 in let int_part = Big_int.string_of_big_int int_part in let dec_part = if Big_int.(eq_big_int dec_part zero_big_int) then "" @@ -166,7 +166,7 @@ module Decimal = struct reference value [ref_v], close to the lower percent. *) let pct v ref_v = let open Big_int in - let (v, ref_v, _decimals) = scale v ref_v in + let v, ref_v, _decimals = scale v ref_v in let v = mult_big_int v (big_int_of_int 100) in try Some {value = div_big_int v ref_v; decimals = 0} with Division_by_zero -> None @@ -460,27 +460,27 @@ module Synths = struct if length = 0 then Garbage else match (get_diff line.[0], get_kind line) with - | (None, _) -> Garbage - | (Some _, _) when is_git_garbage -> Garbage - | (Some _, None) -> Unsupported - | (Some diff, Some kind) -> Diff (diff, kind) + | None, _ -> Garbage + | Some _, _ when is_git_garbage -> Garbage + | Some _, None -> Unsupported + | Some diff, Some kind -> Diff (diff, kind) let same_kind kind1 kind2 = match (kind1, kind2) with - | (Estimated _, Estimated _) - | (Consumed _, Consumed _) - | (Gas_remaining _, Gas_remaining _) - | (Gas_limit _, Gas_limit _) - | (Remaining_gas _, Remaining_gas _) - | (Baker_fee _, Baker_fee _) - | (Payload_fee _, Payload_fee _) - | (Fee _, Fee _) - | (Hash, Hash) - | (Tezos_client, Tezos_client) - | (Operation_hash, Operation_hash) - | (New_contract, New_contract) - | (To, To) - | (Parameter, Parameter) -> + | Estimated _, Estimated _ + | Consumed _, Consumed _ + | Gas_remaining _, Gas_remaining _ + | Gas_limit _, Gas_limit _ + | Remaining_gas _, Remaining_gas _ + | Baker_fee _, Baker_fee _ + | Payload_fee _, Payload_fee _ + | Fee _, Fee _ + | Hash, Hash + | Tezos_client, Tezos_client + | Operation_hash, Operation_hash + | New_contract, New_contract + | To, To + | Parameter, Parameter -> true | _ (* we shouldn't be using a joker here... *) -> false @@ -526,11 +526,11 @@ module Synths = struct None let extract_value kind = - let+ (v, _, _) = builder kind in + let+ v, _, _ = builder kind in v let builders old_kind new_kind = - let* (old_v, getter, setter) = builder old_kind in + let* old_v, getter, setter = builder old_kind in let+ new_v = extract_value new_kind in (old_v, new_v, getter, setter) @@ -548,10 +548,10 @@ module Synths = struct let old = synth.old + old_v in let new_ = synth.new_ + new_v in let loss = match win with Dec -> new_v - old_v | Inc -> old_v - new_v in - let (max_loss, max_loss_pct) = + let max_loss, max_loss_pct = update_max line_nb old_v synth.max_loss synth.max_loss_pct loss in - let (max_gain, max_gain_pct) = + let max_gain, max_gain_pct = update_max line_nb old_v synth.max_gain synth.max_gain_pct (opp loss) in let open Stdlib in diff --git a/docs/doc_gen/rpc_doc.ml b/docs/doc_gen/rpc_doc.ml index 1c87a8b5f2c5..01e9eb74af4d 100644 --- a/docs/doc_gen/rpc_doc.ml +++ b/docs/doc_gen/rpc_doc.ml @@ -272,7 +272,7 @@ module Description = struct service ; Option.iter (fun input -> - let (schema, bin_schema) = Lazy.force input in + let schema, bin_schema = Lazy.force input in pp_content ppf ~tag:"pre" @@ -408,7 +408,7 @@ let make_index node required_version = ("shell", "Shell", Some "/shell/rpc_introduction.rst.inc", [""], shell_dir) :: protocol_dirs in - let (_version, name, intro, path, dir) = + let _version, name, intro, path, dir = WithExceptions.Option.get ~loc:__LOC__ @@ List.find (fun (version, _name, _intro, _path, _dir) -> diff --git a/manifest/main.ml b/manifest/main.ml index 61e2f59a616f..505ca3b87d83 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -562,9 +562,7 @@ let tezos_hacl = (List.map (fun l -> H (of_atom_list l)) Stdlib.List.( - ["run"; "gen/gen.exe"] - :: - ["-api"; "gen/api.json"] + ["run"; "gen/gen.exe"] :: ["-api"; "gen/api.json"] :: List.map (fun s -> ["-stubs"; s]) js_stubs)); ]; ]; @@ -1138,10 +1136,10 @@ let _tezos_tooling = bisect_ppx; (* These next are only used in the CI, we add this dependency so that it is added to tezos/opam-repository. *) - ocamlformat; + ocamlformat (* TODO: https://gitlab.com/tezos/tezos/-/issues/2860 Disabled until compatible with ocaml 4.14 *) - (* ometrics; *) + (* ometrics; *); ] let _tezos_tooling_js_inline_tests = @@ -1257,8 +1255,7 @@ let _tezos_p2p_tests = "262144"; (* 1 << 18 = 256kB *) "--max-download-speed"; - "1048576"; - (* 1 << 20 = 1MB *) + "1048576" (* 1 << 20 = 1MB *); ]); alias_rule "runtest_p2p_socket_ipv4" @@ -3955,16 +3952,15 @@ let _tezos_node = let deps_for_protocol protocol = let is_optional = match (Protocol.status protocol, Protocol.number protocol) with - | (_, V 000) -> + | _, V 000 -> (* The node always needs to be linked with this protocol for Mainnet. *) false - | (Active, V _) -> + | Active, V _ -> (* Active protocols cannot be optional because of a bug that results in inconsistent hashes. Once this bug is fixed, this exception can be removed. *) false - | ((Frozen | Overridden | Not_mainnet), _) | (Active, (Alpha | Other)) - -> + | (Frozen | Overridden | Not_mainnet), _ | Active, (Alpha | Other) -> (* Other protocols are optional. *) true in @@ -4023,9 +4019,8 @@ let _tezos_client = let deps_for_protocol protocol = let is_optional = match (Protocol.status protocol, Protocol.number protocol) with - | (Active, V _) -> false - | ((Frozen | Overridden | Not_mainnet), _) | (Active, (Alpha | Other)) - -> + | Active, V _ -> false + | (Frozen | Overridden | Not_mainnet), _ | Active, (Alpha | Other) -> true in let targets = diff --git a/manifest/manifest.ml b/manifest/manifest.ml index a78f121ef279..43f910a35084 100644 --- a/manifest/manifest.ml +++ b/manifest/manifest.ml @@ -202,10 +202,10 @@ module Dune = struct [ S (match (kind, names) with - | (Library, [_]) -> "library" - | (Library, _) -> "libraries" - | (Executable, [_]) -> "executable" - | (Executable, _) -> "executables"); + | Library, [_] -> "library" + | Library, _ -> "libraries" + | Executable, [_] -> "executable" + | Executable, _ -> "executables"); (match names with | [name] -> [S "name"; S name] | _ -> S "names" :: of_atom_list names); @@ -231,11 +231,11 @@ module Dune = struct (if inline_tests then let modes : mode list = match (modes, js_of_ocaml) with - | (None, None) -> + | None, None -> (* Make the default dune behavior explicit *) [Native] - | (None, Some _) -> [Native; JS] - | (Some modes, _) -> + | None, Some _ -> [Native; JS] + | Some modes, _ -> (* always preserve mode if specified *) modes in @@ -243,18 +243,17 @@ module Dune = struct S "inline_tests"; [S "flags"; S "-verbose"]; S "modes" - :: - of_list - (List.map - (function - | JS -> - (* We don't run inline_tests in JS by default because of the issue #1947. - In short, we don't want [dune runtest] to depend on node. - Remove this code after we switch to dune.3.0 - and address https://gitlab.com/tezos/tezos/-/issues/1947 *) - E - | mode -> S (string_of_mode mode)) - modes); + :: of_list + (List.map + (function + | JS -> + (* We don't run inline_tests in JS by default because of the issue #1947. + In short, we don't want [dune runtest] to depend on node. + Remove this code after we switch to dune.3.0 + and address https://gitlab.com/tezos/tezos/-/issues/1947 *) + E + | mode -> S (string_of_mode mode)) + modes); ] else E); (match preprocess with @@ -300,12 +299,12 @@ module Dune = struct ?deps_dune ?action ?locks ?package name = let deps = match (deps, alias_deps, deps_dune) with - | (_ :: _, _, Some _) | (_, _ :: _, Some _) -> + | _ :: _, _, Some _ | _, _ :: _, Some _ -> invalid_arg "Dune.alias_rule: cannot specify both ~deps_dune and ~deps or \ ~alias_deps" - | ([], [], Some deps) -> deps - | (_, _, None) -> + | [], [], Some deps -> deps + | _, _, None -> List.map (fun x -> S x) deps @ List.map (fun x -> [S "alias"; S x]) alias_deps |> of_list @@ -438,16 +437,16 @@ module Version = struct let ( && ) a b = match (a, b) with - | (True, x) | (x, True) -> x - | (False, _) | (_, False) -> False + | True, x | x, True -> x + | False, _ | _, False -> False | _ -> And (a, b) let and_list = List.fold_left ( && ) True let ( || ) a b = match (a, b) with - | (True, _) | (_, True) -> True - | (False, x) | (x, False) -> x + | True, _ | _, True -> True + | False, x | x, False -> x | _ -> Or (a, b) let or_list = List.fold_left ( || ) False @@ -514,8 +513,8 @@ module Opam = struct description; x_opam_monorepo_opam_provided; } = - let (depopts, depends) = List.partition (fun dep -> dep.optional) depends in - let (depopts, conflicts) = + let depopts, depends = List.partition (fun dep -> dep.optional) depends in + let depopts, conflicts = (* Opam documentation says this about [depopts]: "If you require specific versions, add a [conflicts] field with the ones that won't work." @@ -637,10 +636,9 @@ module Opam = struct in let pp_dependency fmt {package; version; with_test; _} = match (version, with_test) with - | (True, false) -> pp_string fmt package - | (True, true) -> - Format.fprintf fmt "@[%a {with-test}@]" pp_string package - | (version, false) -> + | True, false -> pp_string fmt package + | True, true -> Format.fprintf fmt "@[%a {with-test}@]" pp_string package + | version, false -> Format.fprintf fmt "@[%a { %a }@]" @@ -648,7 +646,7 @@ module Opam = struct package (pp_version_constraint ~in_and:false) version - | (version, true) -> + | version, true -> Format.fprintf fmt "@[%a { with-test & %a }@]" @@ -737,11 +735,10 @@ end = struct let s_expr_of_entry (name, payload) = Dune.[S name; payload] let to_s_expr (t : t) = - let (any, names) = + let any, names = List.partition_map (function - | (Any, entry) -> Left entry - | (Profile name, entry) -> Right (name, entry)) + | Any, entry -> Left entry | Profile name, entry -> Right (name, entry)) t in let names = @@ -776,8 +773,8 @@ end = struct (fun (name, entries) -> Dune.( S name - :: - of_list (List.map s_expr_of_entry (List.sort compare_key entries)))) + :: of_list + (List.map s_expr_of_entry (List.sort compare_key entries)))) (List.sort compare_key (String_map.bindings names)) in Dune.(S "env" :: of_list l) @@ -949,7 +946,7 @@ module Target = struct | Private_library name | Public_executable ({public_name = name; _}, _) | Private_executable (name, _) - | Test_executable {names = (name, _); _} -> + | Test_executable {names = name, _; _} -> name) let rec names_for_dune = function @@ -974,7 +971,7 @@ module Target = struct | Private_library internal_name -> Ok internal_name | Public_executable ({public_name = name; _}, _) | Private_executable (name, _) - | Test_executable {names = (name, _); _} -> + | Test_executable {names = name, _; _} -> Error name) let iter_internal_by_path f = @@ -1082,19 +1079,19 @@ module Target = struct in List.flatten (List.map (get_opens []) deps) @ opens in - let (js_compatible, js_of_ocaml) = + let js_compatible, js_of_ocaml = match (js_compatible, js_of_ocaml) with - | (Some false, Some _) -> + | Some false, Some _ -> invalid_arg "Target.internal: cannot specify both `~js_compatible:false` and \ `~js_of_ocaml`" - | (Some true, Some jsoo) -> (true, Some jsoo) - | (Some true, None) -> (true, Some Dune.[]) - | (None, Some jsoo) -> (true, Some jsoo) - | (Some false, None) | (None, None) -> (false, None) + | Some true, Some jsoo -> (true, Some jsoo) + | Some true, None -> (true, Some Dune.[]) + | None, Some jsoo -> (true, Some jsoo) + | Some false, None | None, None -> (false, None) in let kind = make_kind names in - let (preprocess, inline_tests) = + let preprocess, inline_tests = match inline_tests with | None -> (preprocess, false) | Some (Inline_tests_backend target) -> ( @@ -1145,7 +1142,7 @@ module Target = struct "for targets which provide private executables such as %S, you \ must specify ~opam (set it to \"\" for no opam file)" name - | Test_executable {names = (name, _); _} -> + | Test_executable {names = name, _; _} -> invalid_argf "for targets which provide test executables such as %S, you \ must specify ~opam (set it to \"\" for no opam file)" @@ -1189,10 +1186,10 @@ module Target = struct let static_cclibs = Option.value static_cclibs ~default:[] in let modules = match (modules, all_modules_except) with - | (None, None) -> All - | (Some modules, None) -> Modules modules - | (None, Some all_modules_except) -> All_modules_except all_modules_except - | (Some _, Some _) -> + | None, None -> All + | Some modules, None -> Modules modules + | None, Some all_modules_except -> All_modules_except all_modules_except + | Some _, Some _ -> invalid_arg "Target.internal: cannot specify both ?modules and \ ?all_modules_except" @@ -1213,7 +1210,7 @@ module Target = struct | Some modes -> List.mem Dune.Native modes in match (kind, opam, dep_files) with - | (Test_executable {names; run = true}, Some package, _) -> + | Test_executable {names; run = true}, Some package, _ -> let runtest_js_rules = if run_js then List.map @@ -1229,13 +1226,13 @@ module Target = struct else [] in runtest_rules @ runtest_js_rules - | (Test_executable {names = (name, _); run = false; _}, _, _ :: _) -> + | Test_executable {names = name, _; run = false; _}, _, _ :: _ -> invalid_argf "for targets which provide test executables such as %S, \ [~dep_files] is only meaningful for runtest alias. It cannot be \ used together with [runtest:false]" name - | (_, _, _ :: _) -> assert false + | _, _, _ :: _ -> assert false | _ -> [] in let dune = @@ -1491,7 +1488,7 @@ let write filename f = x let generate_dune ~dune_file_has_static_profile (internal : Target.internal) = - let (libraries, empty_files_to_create) = + let libraries, empty_files_to_create = let empty_files_to_create = ref [] in let rec get_library (dep : Target.t) = let name = @@ -1594,8 +1591,8 @@ let generate_dune ~dune_file_has_static_profile (internal : Target.internal) = let preprocess = let make_pp (PPS (target, args) : Target.preprocessor) = match Target.names_for_dune target with - | (name, []) -> Dune.pps ~args name - | (hd, (_ :: _ as tl)) -> + | name, [] -> Dune.pps ~args name + | hd, (_ :: _ as tl) -> invalid_arg ("preprocessor target has multiple names, don't know which one to \ choose: " @@ -1635,7 +1632,7 @@ let generate_dune ~dune_file_has_static_profile (internal : Target.internal) = in let package = match (internal.kind, internal.opam) with - | (Public_executable _, Some opam) -> Some opam + | Public_executable _, Some opam -> Some opam | _ -> None in let instrumentation = @@ -1649,7 +1646,7 @@ let generate_dune ~dune_file_has_static_profile (internal : Target.internal) = in List.filter_map (fun x -> x) [bisect_ppx; time_measurement_ppx] in - let ((kind : Dune.kind), internal_names, public_names) = + let (kind : Dune.kind), internal_names, public_names = let get_internal_name {Target.internal_name; _} = internal_name in let get_public_name {Target.public_name; _} = public_name in match internal.kind with @@ -1661,7 +1658,7 @@ let generate_dune ~dune_file_has_static_profile (internal : Target.internal) = List.map get_internal_name (head :: tail), List.map get_public_name (head :: tail) ) | Private_executable (head, tail) -> (Executable, head :: tail, []) - | Test_executable {names = (head, tail); _} -> (Executable, head :: tail, []) + | Test_executable {names = head, tail; _} -> (Executable, head :: tail, []) in let documentation = match internal.documentation with @@ -1837,7 +1834,7 @@ let generate_opam ?release for_package (internals : Target.internal list) : Opam.t = let for_release = release <> None in let map l f = List.map f l in - let (depends, x_opam_monorepo_opam_provided) = + let depends, x_opam_monorepo_opam_provided = List.split @@ map internals @@ fun internal -> let with_test = @@ -1883,7 +1880,7 @@ let generate_opam ?release for_package (internals : Target.internal list) : Opam.package = "dune"; (* We artificially constrain the version of dune to split the tooling upgrade. This is temporary. *) - version = Version.(and_list [ at_least "2.9"; less_than "3.0"]); + version = Version.(and_list [at_least "2.9"; less_than "3.0"]); with_test = false; optional = false; } @@ -2191,7 +2188,7 @@ let check_js_of_ocaml () = | Public_library {public_name; _} -> public_name | Private_library internal_name -> internal_name | Public_executable ({public_name = name; _}, _) -> name - | Private_executable (name, _) | Test_executable {names = (name, _); _} -> + | Private_executable (name, _) | Test_executable {names = name, _; _} -> Filename.concat path name in let missing_from_target = ref String_map.empty in @@ -2305,7 +2302,7 @@ let check_circular_opam_deps () = let usage_msg = "Usage: " ^ Sys.executable_name ^ " [OPTIONS]" -let (packages_dir, release, remove_extra_files) = +let packages_dir, release, remove_extra_files = let packages_dir = ref "packages" in let url = ref "" in let sha256 = ref "" in @@ -2334,13 +2331,13 @@ let (packages_dir, release, remove_extra_files) = Arg.parse spec anon_fun usage_msg ; let release = match (!url, !sha256, !sha512, !version) with - | ("", "", "", "") -> None - | ("", _, _, _) | (_, "", _, _) | (_, _, "", _) | (_, _, _, "") -> + | "", "", "", "" -> None + | "", _, _, _ | _, "", _, _ | _, _, "", _ | _, _, _, "" -> prerr_endline "Error: either all of --url, --sha256, --sha512 and --release must \ be specified, or none of them." ; exit 1 - | (url, sha256, sha512, version) -> + | url, sha256, sha512, version -> Some {version; url = {url; sha256; sha512}} in (!packages_dir, release, !remove_extra_files) diff --git a/scripts/yes-wallet/test/bench_signature_perf.ml b/scripts/yes-wallet/test/bench_signature_perf.ml index 30c11624dbf4..074786d8d2d0 100644 --- a/scripts/yes-wallet/test/bench_signature_perf.ml +++ b/scripts/yes-wallet/test/bench_signature_perf.ml @@ -41,15 +41,15 @@ let wrong_keys = function Signature.P256 -> keys_p | Ed25519 -> keys_e | Secp256k1 -> keys_s let wrong_pk algo = - let (_, pk, _) = wrong_keys algo in + let _, pk, _ = wrong_keys algo in pk let pk algo = - let (_, pk, _) = keys algo in + let _, pk, _ = keys algo in pk let sk algo = - let (_, _, sk) = keys algo in + let _, _, sk = keys algo in sk let fake_sk algo = @@ -106,11 +106,11 @@ let time ~yes_crypto ~algo size datas = Format.eprintf "Compacting memory...@?" ; Gc.compact () ; Format.eprintf "timing Ko check..." ; - let (time_check_ko, _) = Ko.check algo signed datas in + let time_check_ko, _ = Ko.check algo signed datas in Format.eprintf "Compacting memory...@?" ; Gc.compact () ; Format.eprintf "timing Ok check...@?" ; - let (time_check_ok, _) = Ok.check algo signed datas in + let time_check_ok, _ = Ok.check algo signed datas in Format.eprintf "end.@." ; Format.printf "%s,%d,%f,%f@." diff --git a/scripts/yes-wallet/yes_wallet.ml b/scripts/yes-wallet/yes_wallet.ml index 66b6babbe5a8..525825c7184f 100644 --- a/scripts/yes-wallet/yes_wallet.ml +++ b/scripts/yes-wallet/yes_wallet.ml @@ -172,7 +172,7 @@ let () = in aux argv in - let (options, argv) = + let options, argv = List.partition (fun arg -> (String.length arg > 0 && String.get arg 0 = '-') diff --git a/scripts/yes-wallet/yes_wallet_lib.ml b/scripts/yes-wallet/yes_wallet_lib.ml index f8cc0daa36dc..b49196122b25 100644 --- a/scripts/yes-wallet/yes_wallet_lib.ml +++ b/scripts/yes-wallet/yes_wallet_lib.ml @@ -63,7 +63,7 @@ let pk_json (alias, _pkh, pk) = (* P-256 pk : 33+1 bytes ed25519 pk sk : 32+1 bytes - *) +*) let sk_of_pk (pk_s : string) : string = let open Tezos_crypto.Signature in @@ -199,7 +199,7 @@ let get_delegates (proto : protocol) context match proto with | Florence -> let open Tezos_protocol_009_PsFLoren.Protocol in - let* (ctxt, _) = + let* ctxt, _ = let*! r = Alpha_context.prepare context @@ -211,7 +211,7 @@ let get_delegates (proto : protocol) context Lwt.return @@ Environment.wrap_tzresult r in (* Loop on delegates to extract keys and compute the total stake. *) - let* (delegates, total_stake) = + let* delegates, total_stake = Alpha_context.Delegate.fold ctxt ~init:(Ok ([], Alpha_context.Tez.zero)) @@ -220,7 +220,7 @@ let get_delegates (proto : protocol) context let*! r = Alpha_context.Roll.delegate_pubkey ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r in - let*? (key_list_acc, staking_balance_acc) = acc in + let*? key_list_acc, staking_balance_acc = acc in let* staking_balance = let*! r = Alpha_context.Delegate.staking_balance ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r @@ -259,7 +259,7 @@ let get_delegates (proto : protocol) context delegates | Granada -> let open Tezos_protocol_010_PtGRANAD.Protocol in - let* (ctxt, _, _) = + let* ctxt, _, _ = let*! r = Alpha_context.prepare context @@ -271,7 +271,7 @@ let get_delegates (proto : protocol) context Lwt.return @@ Environment.wrap_tzresult r in (* Loop on delegates to extract keys and compute the total stake. *) - let* (delegates, total_stake) = + let* delegates, total_stake = Alpha_context.Delegate.fold ctxt ~init:(Ok ([], Alpha_context.Tez.zero)) @@ -280,7 +280,7 @@ let get_delegates (proto : protocol) context let*! r = Alpha_context.Roll.delegate_pubkey ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r in - let*? (key_list_acc, staking_balance_acc) = acc in + let*? key_list_acc, staking_balance_acc = acc in let* staking_balance = let*! r = Alpha_context.Delegate.staking_balance ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r @@ -319,7 +319,7 @@ let get_delegates (proto : protocol) context delegates | Hangzhou -> let open Tezos_protocol_011_PtHangz2.Protocol in - let* (ctxt, _, _) = + let* ctxt, _, _ = let*! r = Alpha_context.prepare context @@ -331,7 +331,7 @@ let get_delegates (proto : protocol) context Lwt.return @@ Environment.wrap_tzresult r in (* Loop on delegates to extract keys and compute the total stake. *) - let* (delegates, total_stake) = + let* delegates, total_stake = Alpha_context.Delegate.fold ctxt ~init:(Ok ([], Alpha_context.Tez.zero)) @@ -340,7 +340,7 @@ let get_delegates (proto : protocol) context let*! r = Alpha_context.Roll.delegate_pubkey ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r in - let*? (key_list_acc, staking_balance_acc) = acc in + let*? key_list_acc, staking_balance_acc = acc in let* staking_balance = let*! r = Alpha_context.Delegate.staking_balance ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r @@ -379,14 +379,14 @@ let get_delegates (proto : protocol) context delegates | Ithaca -> let open Tezos_protocol_012_Psithaca.Protocol in - let* (ctxt, _, _) = + let* ctxt, _, _ = let*! r = Alpha_context.prepare context ~level ~predecessor_timestamp ~timestamp in Lwt.return @@ Environment.wrap_tzresult r in (* Loop on delegates to extract keys and compute the total stake. *) - let* (delegates, total_stake) = + let* delegates, total_stake = Alpha_context.Delegate.fold ctxt ~order:`Sorted @@ -396,7 +396,7 @@ let get_delegates (proto : protocol) context let*! r = Alpha_context.Delegate.pubkey ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r in - let*? (key_list_acc, staking_balance_acc) = acc in + let*? key_list_acc, staking_balance_acc = acc in let* staking_balance = let*! r = Alpha_context.Delegate.staking_balance ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r @@ -435,14 +435,14 @@ let get_delegates (proto : protocol) context delegates | Alpha -> let open Tezos_protocol_alpha.Protocol in - let* (ctxt, _, _) = + let* ctxt, _, _ = let*! r = Alpha_context.prepare context ~level ~predecessor_timestamp ~timestamp in Lwt.return @@ Environment.wrap_tzresult r in (* Loop on delegates to extract keys and compute the total stake. *) - let* (delegates, total_stake) = + let* delegates, total_stake = Alpha_context.Delegate.fold ctxt ~order:`Sorted @@ -452,7 +452,7 @@ let get_delegates (proto : protocol) context let*! r = Alpha_context.Delegate.pubkey ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r in - let*? (key_list_acc, staking_balance_acc) = acc in + let*? key_list_acc, staking_balance_acc = acc in let* staking_balance = let*! r = Alpha_context.Delegate.staking_balance ctxt pkh in Lwt.return @@ Environment.wrap_tzresult r diff --git a/src/bin_client/client_protocols_commands.ml b/src/bin_client/client_protocols_commands.ml index 80487e480fcb..b81c7e5e04c8 100644 --- a/src/bin_client/client_protocols_commands.ml +++ b/src/bin_client/client_protocols_commands.ml @@ -65,7 +65,7 @@ let commands () = (fun () dirname (cctxt : #Client_context.full) -> Lwt.catch (fun () -> - let* (_hash, proto) = + let* _hash, proto = Tezos_base_unix.Protocol_files.read_dir dirname in let*! injection_result = diff --git a/src/bin_client/client_rpc_commands.ml b/src/bin_client/client_rpc_commands.ml index 3fac63ff06c5..4c3d217a44bd 100644 --- a/src/bin_client/client_rpc_commands.ml +++ b/src/bin_client/client_rpc_commands.ml @@ -174,9 +174,9 @@ let editor_fill_in ?(show_optionals = true) schema = let editor_cmd = let ed = match (Sys.getenv_opt "EDITOR", Sys.getenv_opt "VISUAL") with - | (Some ed, _) -> ed - | (None, Some ed) -> ed - | (None, None) when Sys.win32 -> + | Some ed, _ -> ed + | None, Some ed -> ed + | None, None when Sys.win32 -> (* TODO: I have no idea what I'm doing here *) "notepad.exe" | _ -> @@ -284,16 +284,16 @@ let list url (cctxt : #Client_context.full) = ( RPC_service.MethMap.cardinal services, Resto.StringMap.bindings subdirs ) with - | (0, []) -> () - | (0, [(n, solo)]) -> display ppf (path @ [n], tpath @ [n], solo) - | (_, items) when count tree >= 3 && path <> [] -> + | 0, [] -> () + | 0, [(n, solo)] -> display ppf (path @ [n], tpath @ [n], solo) + | _, items when count tree >= 3 && path <> [] -> Format.fprintf ppf "@[+ %s/@,%a@]" (String.concat "/" path) (display_list tpath) items - | (_, items) when count tree >= 3 && path <> [] -> + | _, items when count tree >= 3 && path <> [] -> Format.fprintf ppf "@[+ %s@,%a@,%a@]" @@ -302,13 +302,13 @@ let list url (cctxt : #Client_context.full) = (path, tpath, services) (display_list tpath) items - | (0, (n, t) :: items) -> + | 0, (n, t) :: items -> Format.fprintf ppf "%a" display (path @ [n], tpath @ [n], t) ; List.iter (fun (n, t) -> Format.fprintf ppf "@,%a" display (path @ [n], tpath @ [n], t)) items - | (_, items) -> + | _, items -> display_services ppf (path, tpath, services) ; List.iter (fun (n, t) -> @@ -463,9 +463,9 @@ let call ?body meth raw_url (cctxt : #Client_context.full) = body is not given. In that case, the body should be an empty JSON object. *) match (meth, body) with - | (_, Some _) -> body - | (`DELETE, None) | (`GET, None) -> None - | (`PATCH, None) | (`PUT, None) | (`POST, None) -> Some (`O []) + | _, Some _ -> body + | `DELETE, None | `GET, None -> None + | `PATCH, None | `PUT, None | `POST, None -> Some (`O []) in let* answer = cctxt#generic_media_type_call meth ?body uri in let*! () = display_answer cctxt answer in diff --git a/src/bin_client/main_client.ml b/src/bin_client/main_client.ml index fedc870401d6..6f02d400f1e1 100644 --- a/src/bin_client/main_client.ml +++ b/src/bin_client/main_client.ml @@ -174,7 +174,7 @@ let select_commands ctxt {chain; block; protocol; _} = let open Lwt_syntax in let timeout = timeout_seconds () in let* network = check_network ~timeout ctxt in - let* (_, commands_for_version) = + let* _, commands_for_version = get_commands_for_version ~timeout ctxt network chain block protocol in Lwt.return_ok diff --git a/src/bin_client/test/proto_test_injection/main.ml b/src/bin_client/test/proto_test_injection/main.ml index 75d87688ce25..b35c94fe78ad 100644 --- a/src/bin_client/test/proto_test_injection/main.ml +++ b/src/bin_client/test/proto_test_injection/main.ml @@ -47,7 +47,7 @@ let operation_receipt_encoding = Data_encoding.unit let operation_data_and_receipt_encoding = Data_encoding.conv - (function ((), ()) -> ()) + (function (), () -> ()) (fun () -> ((), ())) Data_encoding.unit diff --git a/src/bin_codec/codec.ml b/src/bin_codec/codec.ml index 40721ee9ede1..2d849f6c2acc 100644 --- a/src/bin_codec/codec.ml +++ b/src/bin_codec/codec.ml @@ -50,7 +50,7 @@ let parse_config_args argv = (* The context used during argument parsing. We switch to a real context that is created based on some of the parsed arguments. *) let ctxt = Client_context.null_printer in - let* (base_dir, argv) = Clic.parse_global_options global_options ctxt argv in + let* base_dir, argv = Clic.parse_global_options global_options ctxt argv in let* base_dir = match base_dir with | None -> @@ -76,7 +76,7 @@ let main commands = let open Lwt_result_syntax in let executable_name = Filename.basename Sys.executable_name in let run () = - let (argv, autocomplete) = + let argv, autocomplete = (* for shell aliases *) let rec move_autocomplete_token_upfront acc = function | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args -> @@ -103,7 +103,7 @@ let main commands = (if Unix.isatty Unix.stderr then Ansi else Plain) Short) ; let*! () = Tezos_base_unix.Internal_event_unix.init () in - let* (base_dir, argv) = parse_config_args argv in + let* base_dir, argv = parse_config_args argv in let ctxt = new Client_context_unix.unix_logger ~base_dir in let commands = Clic.add_manual diff --git a/src/bin_node/node_config_file.ml b/src/bin_node/node_config_file.ml index e57bdda321c0..c04345662cd7 100644 --- a/src/bin_node/node_config_file.ml +++ b/src/bin_node/node_config_file.ml @@ -835,7 +835,7 @@ let rpc : rpc Data_encoding.t = let open Data_encoding in conv (fun {cors_origins; cors_headers; listen_addrs; tls; acl; media_type} -> - let (cert, key) = + let cert, key = match tls with | None -> (None, None) | Some {cert; key} -> (Some cert, Some key) @@ -858,15 +858,15 @@ let rpc : rpc Data_encoding.t = media_type ) -> let tls = match (cert, key) with - | (None, _) | (_, None) -> None - | (Some cert, Some key) -> Some {cert; key} + | None, _ | _, None -> None + | Some cert, Some key -> Some {cert; key} in let listen_addrs = match (listen_addrs, legacy_listen_addr) with - | (Some addrs, None) -> addrs - | (None, Some addr) -> [addr] - | (None, None) -> default_rpc.listen_addrs - | (Some _, Some _) -> + | Some addrs, None -> addrs + | None, Some addr -> [addr] + | None, None -> default_rpc.listen_addrs + | Some _, Some _ -> Stdlib.failwith "Config file: Use only \"listen-addrs\" and not (legacy) \ \"listen-addr\"." @@ -1505,9 +1505,9 @@ let resolve_addr ~default_addr ?(no_peer_id_expected = true) ?default_port | Ok {addr; port; peer_id} -> let service_port = match (port, default_port) with - | (Some port, _) -> port - | (None, Some default_port) -> default_port - | (None, None) -> default_p2p_port + | Some port, _ -> port + | None, Some default_port -> default_port + | None, None -> default_p2p_port in let service = string_of_int service_port in let node = if addr = "" || addr = "_" then default_addr else addr in diff --git a/src/bin_node/node_identity_command.ml b/src/bin_node/node_identity_command.ml index 5eb0020960dd..b56dfb449b64 100644 --- a/src/bin_node/node_identity_command.ml +++ b/src/bin_node/node_identity_command.ml @@ -30,7 +30,7 @@ let get_config data_dir config_file expected_pow = let open Lwt_result_syntax in let* cfg = match (data_dir, config_file) with - | (None, None) -> + | None, None -> let default_config = Node_config_file.default_data_dir // Node_data_version.default_config_file_name @@ -38,14 +38,14 @@ let get_config data_dir config_file expected_pow = let*! config_file_exists = Lwt_unix.file_exists default_config in if config_file_exists then Node_config_file.read default_config else return Node_config_file.default_config - | (None, Some config_file) -> Node_config_file.read config_file - | (Some data_dir, None) -> + | None, Some config_file -> Node_config_file.read config_file + | Some data_dir, None -> let* cfg = Node_config_file.read (data_dir // Node_data_version.default_config_file_name) in return {cfg with data_dir} - | (Some data_dir, Some config_file) -> + | Some data_dir, Some config_file -> let* cfg = Node_config_file.read config_file in return {cfg with data_dir} in diff --git a/src/bin_node/node_reconstruct_command.ml b/src/bin_node/node_reconstruct_command.ml index d7afd6d1b482..f57919064155 100644 --- a/src/bin_node/node_reconstruct_command.ml +++ b/src/bin_node/node_reconstruct_command.ml @@ -57,10 +57,10 @@ module Term = struct match (node_config.blockchain_network.genesis_parameters, sandbox_file) with - | (None, None) -> return_none - | (Some parameters, None) -> + | None, None -> return_none + | Some parameters, None -> return_some (parameters.context_key, parameters.values) - | (_, Some filename) -> ( + | _, Some filename -> ( let*! r = Lwt_utils_unix.Json.read_file filename in match r with | Error _err -> diff --git a/src/bin_node/node_replay_command.ml b/src/bin_node/node_replay_command.ml index 2108e68bc7a7..3ad28e8a6c5e 100644 --- a/src/bin_node/node_replay_command.ml +++ b/src/bin_node/node_replay_command.ml @@ -166,7 +166,7 @@ let replay ~singleprocess (config : Node_config_file.t) blocks = config.shell.block_validator_limits.operation_metadata_size_limit; } in - let* (validator_process, store) = + let* validator_process, store = if singleprocess then let* store = Store.init @@ -236,7 +236,7 @@ let replay ~singleprocess (config : Node_config_file.t) blocks = match predecessor_opt with | None -> tzfail Cannot_replay_orphan | Some predecessor -> - let*! (_, savepoint_level) = + let*! _, savepoint_level = Store.Chain.savepoint main_chain_store in if Store.Block.level block <= savepoint_level then @@ -318,19 +318,19 @@ let replay ~singleprocess (config : Node_config_file.t) blocks = (exp : Block_validation.operation_metadata list list) (got : Block_validation.operation_metadata list list) = match (exp, got) with - | ([], []) -> return_unit - | ([], _ :: _) | (_ :: _, []) -> assert false - | ([] :: exps, [] :: gots) -> + | [], [] -> return_unit + | [], _ :: _ | _ :: _, [] -> assert false + | [] :: exps, [] :: gots -> check_receipts (succ i) 0 exps gots - | ((_ :: _) :: _, [] :: _) | ([] :: _, (_ :: _) :: _) -> + | (_ :: _) :: _, [] :: _ | [] :: _, (_ :: _) :: _ -> assert false - | ((exp :: exps) :: expss, (got :: gots) :: gotss) -> + | (exp :: exps) :: expss, (got :: gots) :: gotss -> let* () = let equal a b = match (a, b) with | Block_validation.(Metadata a, Metadata b) -> Bytes.equal a b - | (Too_large_metadata, Too_large_metadata) -> true + | Too_large_metadata, Too_large_metadata -> true | _ -> false in if not (equal exp got) then @@ -517,8 +517,8 @@ module Manpage = struct `P ("The environment variable $(b,TEZOS_LOG) is used to fine-tune what is \ going to be logged. The syntax is \ - $(b,TEZOS_LOG='
 ->  [ ; ...]') where section is \ - one of $(i," ^ log_sections + $(b,TEZOS_LOG='
 ->  [ ; ...]') where section is one \ + of $(i," ^ log_sections ^ ") and level is one of $(i,fatal), $(i,error), $(i,warn), \ $(i,notice), $(i,info) or $(i,debug). A $(b,*) can be used as a \ wildcard in sections, i.e. $(b, client* -> debug). The rules are \ diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index 790d1d4d4c52..c13138fc983f 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -243,7 +243,7 @@ let init_node ?sandbox ?target ~identity ~singleprocess Event.(emit disabled_config_validation) () else Lwt.return_unit in - let* (discovery_addr, discovery_port) = + let* discovery_addr, discovery_port = match config.p2p.discovery_addr with | None -> let*! () = Event.(emit disabled_discovery_addr) () in @@ -254,7 +254,7 @@ let init_node ?sandbox ?target ~identity ~singleprocess | [] -> failwith "Cannot resolve P2P discovery address: %S" addr | (addr, port) :: _ -> return (Some addr, Some port)) in - let* (listening_addr, listening_port) = + let* listening_addr, listening_port = match config.p2p.listen_addr with | None -> let*! () = Event.(emit disabled_listen_addr) () in @@ -267,11 +267,11 @@ let init_node ?sandbox ?target ~identity ~singleprocess in let* p2p_config = match (listening_addr, sandbox) with - | (Some addr, Some _) when Ipaddr.V6.(compare addr unspecified) = 0 -> + | Some addr, Some _ when Ipaddr.V6.(compare addr unspecified) = 0 -> return_none - | (Some addr, Some _) when not (Ipaddr.V6.is_private addr) -> + | Some addr, Some _ when not (Ipaddr.V6.is_private addr) -> tzfail (Non_private_sandbox addr) - | (None, Some _) -> return_none + | None, Some _ -> return_none | _ -> let* trusted_points = Node_config_file.resolve_bootstrap_addrs @@ -302,10 +302,10 @@ let init_node ?sandbox ?target ~identity ~singleprocess in let* sandbox_param = match (config.blockchain_network.genesis_parameters, sandbox) with - | (None, None) -> return_none - | (Some parameters, None) -> + | None, None -> return_none + | Some parameters, None -> return_some (parameters.context_key, parameters.values) - | (_, Some filename) -> + | _, Some filename -> let* json = trace (Invalid_sandbox_file filename) @@ Lwt_utils_unix.Json.read_file filename @@ -727,8 +727,8 @@ module Manpage = struct `P ("The environment variable $(b,TEZOS_LOG) is used to fine-tune what is \ going to be logged. The syntax is \ - $(b,TEZOS_LOG='
 ->  [ ; ...]') where section is \ - one of $(i," ^ log_sections + $(b,TEZOS_LOG='
 ->  [ ; ...]') where section is one \ + of $(i," ^ log_sections ^ ") and level is one of $(i,fatal), $(i,error), $(i,warn), \ $(i,notice), $(i,info) or $(i,debug). A $(b,*) can be used as a \ wildcard in sections, i.e. $(b, node* -> debug). The rules are \ diff --git a/src/bin_node/node_shared_arg.ml b/src/bin_node/node_shared_arg.ml index e0544b98855c..8f58af68d67e 100644 --- a/src/bin_node/node_shared_arg.ml +++ b/src/bin_node/node_shared_arg.ml @@ -130,7 +130,7 @@ let load_net_config = function | BuiltIn net -> return net | Url uri -> - let*! (resp, body) = Cohttp_lwt_unix.Client.get uri in + let*! resp, body = Cohttp_lwt_unix.Client.get uri in let*! body_str = Cohttp_lwt.Body.to_string body in let* netconfig = match resp.status with @@ -795,14 +795,14 @@ let read_and_patch_config_file ?(may_override_network = false) in let* synchronisation_threshold = match (bootstrap_threshold, synchronisation_threshold) with - | (Some _, Some _) -> + | Some _, Some _ -> tzfail (Invalid_command_line_arguments "--bootstrap-threshold is deprecated; use \ --synchronisation-threshold instead. Do not use both at the same \ time.") - | (None, Some threshold) | (Some threshold, None) -> return_some threshold - | (None, None) -> return_none + | None, Some threshold | Some threshold, None -> return_some threshold + | None, None -> return_none in let* network_data = match network with diff --git a/src/bin_node/node_snapshot_command.ml b/src/bin_node/node_snapshot_command.ml index a2904755688f..e6f0ef238058 100644 --- a/src/bin_node/node_snapshot_command.ml +++ b/src/bin_node/node_snapshot_command.ml @@ -200,10 +200,10 @@ module Term = struct match (node_config.blockchain_network.genesis_parameters, sandbox_file) with - | (None, None) -> return_none - | (Some parameters, None) -> + | None, None -> return_none + | Some parameters, None -> return_some (parameters.context_key, parameters.values) - | (_, Some filename) -> ( + | _, Some filename -> ( let*! r = Lwt_utils_unix.Json.read_file filename in match r with | Error _err -> diff --git a/src/bin_node/node_upgrade_command.ml b/src/bin_node/node_upgrade_command.ml index 4fff8274b9a2..3d68bd28090b 100644 --- a/src/bin_node/node_upgrade_command.ml +++ b/src/bin_node/node_upgrade_command.ml @@ -87,10 +87,10 @@ module Term = struct ( config.blockchain_network.genesis_parameters, sandbox_file ) with - | (None, None) -> return_none - | (Some parameters, None) -> + | None, None -> return_none + | Some parameters, None -> return_some (parameters.context_key, parameters.values) - | (_, Some filename) -> ( + | _, Some filename -> ( let*! r = Lwt_utils_unix.Json.read_file filename in match r with | Error _err -> diff --git a/src/bin_openapi/rpc_openapi.ml b/src/bin_openapi/rpc_openapi.ml index 297f1c4ae5ca..cc9a2a9d7246 100644 --- a/src/bin_openapi/rpc_openapi.ml +++ b/src/bin_openapi/rpc_openapi.ml @@ -27,7 +27,7 @@ open Tezos_openapi let main () = (* Parse command line arguments. *) - let (version, filename) = + let version, filename = if Array.length Sys.argv <> 3 then ( prerr_endline "Usage: rpc_openapi \n\n\ diff --git a/src/bin_sandbox/command_accusations.ml b/src/bin_sandbox/command_accusations.ml index 60e4e6ebb3fa..4426258e903f 100644 --- a/src/bin_sandbox/command_accusations.ml +++ b/src/bin_sandbox/command_accusations.ml @@ -13,7 +13,7 @@ let little_mesh_with_bakers ?base_port ?generate_kiln_config state ~protocol EF.[af "Ready to start"; af "Root path deleted."] in let block_interval = 1 in - let (protocol, baker_list) = + let protocol, baker_list = let open Tezos_protocol in let bakers = List.take protocol.bootstrap_accounts bakers in let timestamp_delay = @@ -73,9 +73,9 @@ let little_mesh_with_bakers ?base_port ?generate_kiln_config state ~protocol let* _ = Tezos_client.Keyed.initialize state bak in return (client, bak) in - let* (client_0, baker_0) = baker 0 in - let* (client_1, baker_1) = baker 1 in - let* (client_2, baker_2) = baker 2 in + let* client_0, baker_0 = baker 0 in + let* client_1, baker_1 = baker 1 in + let* client_2, baker_2 = baker 2 in Interactive_test.Pauser.add_commands state Interactive_test.Commands.( @@ -157,7 +157,7 @@ let little_mesh_with_bakers ?base_port ?generate_kiln_config state ~protocol let wait_for_operation_in_mempools state ~nodes:all_nodes ~kind ~client_exec how = - let (init, combine) = + let init, combine = match how with `At_least_one -> (false, ( || )) | `All -> (true, ( && )) in Helpers.wait_for state ~attempts:default_attempts ~seconds:8. (fun _ -> @@ -177,7 +177,7 @@ let wait_for_operation_in_mempools state ~nodes:all_nodes ~kind ~client_exec how let simple_double_baking ~starting_level ?generate_kiln_config ~state ~protocol ~base_port node_exec client_exec () = - let* (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) = + let* all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2 = little_mesh_with_bakers ~bakers:1 ~protocol @@ -389,8 +389,7 @@ let simple_double_endorsement ~starting_level ?generate_kiln_config ~state in Asynchronous_result.return () | _ -> - let* (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) - = + let* all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2 = little_mesh_with_bakers ~bakers:2 ~protocol @@ -490,10 +489,8 @@ let simple_double_endorsement ~starting_level ?generate_kiln_config ~state | `A [one] -> (Jqo.field ~k:"endorsement" one, Jqo.field ~k:"slot" one) | _ -> assert false in - let (inlined_endorsement_1, slot) = - transform_endorsement endorsement_0 - in - let (inlined_endorsement_2, _) = transform_endorsement endorsement_1 in + let inlined_endorsement_1, slot = transform_endorsement endorsement_0 in + let inlined_endorsement_2, _ = transform_endorsement endorsement_1 in `O [ ("branch", head_hash_json); @@ -576,7 +573,7 @@ let with_accusers ~state ~protocol ~base_port node_exec accuser_exec client_exec () = let* () = Helpers.clear_root state in let block_interval = 2 in - let (protocol, baker_0_account) = + let protocol, baker_0_account = let d = protocol in let open Tezos_protocol in let baker = List.hd_exn d.bootstrap_accounts in @@ -594,7 +591,7 @@ let with_accusers ~state ~protocol ~base_port node_exec accuser_exec client_exec Test_scenario.Topology.( net_in_the_middle "AT-" (mesh "Mid" 3) (mesh "Main" 4) (mesh "Acc" 4)) in - let (mesh_nodes, intermediary_nodes, accuser_nodes) = + let mesh_nodes, intermediary_nodes, accuser_nodes = Test_scenario.Topology.build topology ~base_port @@ -633,9 +630,9 @@ let with_accusers ~state ~protocol ~base_port node_exec accuser_exec client_exec let* _ = Tezos_client.Keyed.initialize state bak in return (client, bak) in - let* (client_0, baker_0) = baker 0 in - let* (client_1, baker_1) = baker 1 in - let* (client_2, baker_2) = baker 2 in + let* client_0, baker_0 = baker 0 in + let* client_1, baker_1 = baker 1 in + let* client_2, baker_2 = baker 2 in Interactive_test.Pauser.add_commands state Interactive_test.Commands.( diff --git a/src/bin_sandbox/command_daemons_protocol_change.ml b/src/bin_sandbox/command_daemons_protocol_change.ml index 161a966bd7d5..601ece57d945 100644 --- a/src/bin_sandbox/command_daemons_protocol_change.ml +++ b/src/bin_sandbox/command_daemons_protocol_change.ml @@ -100,7 +100,7 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports second_accuser_exec; ] in - let* (nodes, protocol) = + let* nodes, protocol = Test_scenario.network_with_protocol ?external_peer_ports ~protocol @@ -163,7 +163,7 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports in Tezos_protocol.bootstrap_accounts protocol |> List.filter_mapi ~f:(fun idx acc -> - let (node, client) = pick_a_node_and_client idx in + let node, client = pick_a_node_and_client idx in let key = Tezos_protocol.Account.name acc in if List.mem ~equal:String.equal no_daemons_for key then None else @@ -202,7 +202,7 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports let* () = List_sequential.iter keys_and_daemons ~f:(fun (acc, client, daemons) -> let* () = Tezos_client.wait_for_node_bootstrap state client in - let (key, priv) = Tezos_protocol.Account.(name acc, private_key acc) in + let key, priv = Tezos_protocol.Account.(name acc, private_key acc) in let* () = Tezos_client.import_secret_key state client ~name:key ~key:priv in @@ -290,7 +290,7 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports return (Some hash) | _ -> let admin = make_admin client in - let* (_, new_protocol_hash) = + let* _, new_protocol_hash = Tezos_admin_client.inject_protocol admin state diff --git a/src/bin_sandbox/command_ledger_baking.ml b/src/bin_sandbox/command_ledger_baking.ml index 45f1c8bca803..82706bcbfdcc 100644 --- a/src/bin_sandbox/command_ledger_baking.ml +++ b/src/bin_sandbox/command_ledger_baking.ml @@ -359,7 +359,7 @@ let run state ~protocol ~node_exec ~client_exec ~admin_exec ~size ~base_port let other_baker_account = fst (List.nth_exn protocol.Tezos_protocol.bootstrap_accounts 1) in - let* (nodes, protocol) = + let* nodes, protocol = Test_scenario.network_with_protocol ~protocol ~size @@ -417,7 +417,7 @@ let run state ~protocol ~node_exec ~client_exec ~admin_exec ~size ~base_port Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level) in let* chain_id = get_chain_id state ~client:(client 0) in - let* (baker, ledger_account) = + let* baker, ledger_account = setup_baking_ledger state uri ~client:(client 0) ~protocol in Interactive_test.Pauser.add_commands diff --git a/src/bin_sandbox/command_ledger_wallet.ml b/src/bin_sandbox/command_ledger_wallet.ml index 5a73c83c0c6e..013b39458281 100644 --- a/src/bin_sandbox/command_ledger_wallet.ml +++ b/src/bin_sandbox/command_ledger_wallet.ml @@ -4,7 +4,7 @@ open Internal_pervasives (********************* TEST UTILS **********************) let client_async_cmd state ~client args ~f = - let* (status, res) = + let* status, res = Running_processes.Async.run_cmdf ~id_base:"client_async_cmd" state @@ -45,7 +45,7 @@ let find_and_print_signature_hash ?(display_expectation = true) state process = | Some matches -> Some (Group.get matches 1)) in (* Dbg.e EF.(wf "find_and_print_signature_hash") ; *) - let* (output, error, _) = + let* output, error, _ = Running_processes.Async.fold_process process ~init:("", "", not display_expectation) @@ -175,9 +175,9 @@ let expect_from_output ~expectation ~message (proc_res : Process_result.t) = in let all_output = String.concat ~sep:"\n" (proc_res#out @ proc_res#err) in match (success, String.substr_index all_output ~pattern) with - | (false, Some _) -> return () - | (false, None) -> nope "cannot find the right error message" - | (true, _) -> nope "command succeeded??") + | false, Some _ -> return () + | false, None -> nope "cannot find the right error message" + | true, _ -> nope "command succeeded??") (********************* TEST SECTIONS ***************************) @@ -300,7 +300,7 @@ let voting_tests state ~client ~src ~with_rejections ~protocol_kind (fun ppf () -> wf ppf "Period: `%i`" 1); ] (fun () -> - let* (_, proc) = + let* _, proc = Tezos_client.client_cmd state ~client:(client 0) @@ -448,7 +448,7 @@ let manager_tz_delegation_tests state ~client ~ledger_key ~ledger_account ~protocol_kind ~ledger_account) in - let* (_, proc_result) = + let* _, proc_result = Tezos_client.client_cmd state ~client @@ -1184,7 +1184,7 @@ module Wallet_scenario = struct | _other -> no (List.find_map_exn enum_assoc ~f:(function - | (k, this) when Poly.(v = this) -> Some k + | k, this when Poly.(v = this) -> Some k | _ -> None)) let if_voting t = run_if `Voting t @@ -1241,7 +1241,7 @@ let run state ~pp_error ~protocol ~protocol_kind ~node_exec ~client_exec let* _ledger_account = Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri in - let (protocol, baker_0_account, _baker_0_balance) = + let protocol, baker_0_account, _baker_0_balance = let open Tezos_protocol in let d = protocol in let baker = List.nth_exn d.bootstrap_accounts 0 in @@ -1257,7 +1257,7 @@ let run state ~pp_error ~protocol ~protocol_kind ~node_exec ~client_exec fst baker, snd baker ) in - let* (nodes, protocol) = + let* nodes, protocol = Test_scenario.network_with_protocol ~protocol ~size @@ -1339,7 +1339,7 @@ let run state ~pp_error ~protocol ~protocol_kind ~node_exec ~client_exec (Tezos_protocol.Account.pubkey_hash ledger_account)); ] (fun ~user_answer -> - let* (_, proc) = + let* _, proc = Tezos_client.client_cmd state ~client:client_0 @@ -1481,7 +1481,7 @@ let run state ~pp_error ~protocol ~protocol_kind ~node_exec ~client_exec pp_warning_ledger_takes_a_while ~adjective:"big"; ] (fun ~user_answer -> - let* (_, proc) = + let* _, proc = sign state ~client:signer ~bytes:batch_transaction_bytes in expect_from_output @@ -1517,7 +1517,7 @@ let run state ~pp_error ~protocol ~protocol_kind ~node_exec ~client_exec ~parameter:"unit" ~init_storage:"Unit" in - let* (_, proc_result) = + let* _, proc_result = Tezos_client.client_cmd state ~client:client_0 diff --git a/src/bin_sandbox/command_node_synchronization.ml b/src/bin_sandbox/command_node_synchronization.ml index 31f4f4b083c1..3ce821e3f3e9 100644 --- a/src/bin_sandbox/command_node_synchronization.ml +++ b/src/bin_sandbox/command_node_synchronization.ml @@ -76,7 +76,7 @@ let run state ~node_exec ~client_exec ~primary_history_mode let* _ = Test_scenario.Network.(start_up state ~client_exec (make all_nodes)) in - let (baker_account, _) = List.hd_exn baker_list in + let baker_account, _ = List.hd_exn baker_list in let baker = Tezos_client.Keyed.make primary_client @@ -161,9 +161,9 @@ let run state ~node_exec ~client_exec ~primary_history_mode in let* () = match (should_synch, are_synch) with - | (false, true) -> + | false, true -> fail (`Scenario_error "Nodes are not expected to be synchronized") - | (true, false) -> + | true, false -> fail (`Scenario_error "Nodes are expected to be synchronized") | _ -> return () in @@ -194,8 +194,8 @@ let run state ~node_exec ~client_exec ~primary_history_mode in let* () = match (should_synch, are_nodes_connected) with - | (true, false) -> fail (`Scenario_error "Expecting nodes to be connected") - | (false, true) -> + | true, false -> fail (`Scenario_error "Expecting nodes to be connected") + | false, true -> fail (`Scenario_error "Expecting nodes to not be connected") | _ -> return () in @@ -224,7 +224,7 @@ let cmd () = ~command_name:"node-synchronization" () in - let (term, info) = + let term, info = Test_command_line.Run_command.make ~pp_error (const diff --git a/src/bin_sandbox/command_prevalidation.ml b/src/bin_sandbox/command_prevalidation.ml index b33031833a71..1b2e6a24660f 100644 --- a/src/bin_sandbox/command_prevalidation.ml +++ b/src/bin_sandbox/command_prevalidation.ml @@ -3,7 +3,7 @@ open Internal_pervasives open Console let run state node_exec client_exec () = - let* (nodes, _protocol) = + let* nodes, _protocol = Test_scenario.network_with_protocol ~size:2 state ~node_exec ~client_exec in match nodes with diff --git a/src/bin_sandbox/command_voting.ml b/src/bin_sandbox/command_voting.ml index 377eb9ff2678..4732beab0180 100644 --- a/src/bin_sandbox/command_voting.ml +++ b/src/bin_sandbox/command_voting.ml @@ -170,7 +170,7 @@ let run state ~winner_path ~demo_path ~protocol ~node_exec ~client_exec state EF.[af "Ready to start"; af "Root path deleted."] in - let (protocol, baker_0_account, baker_0_balance) = + let protocol, baker_0_account, baker_0_balance = let open Tezos_protocol in let baker = List.nth_exn protocol.bootstrap_accounts 0 in ( { @@ -184,7 +184,7 @@ let run state ~winner_path ~demo_path ~protocol ~node_exec ~client_exec fst baker, snd baker ) in - let* (nodes, protocol) = + let* nodes, protocol = Test_scenario.network_with_protocol ~protocol ~size @@ -431,7 +431,7 @@ let run state ~winner_path ~demo_path ~protocol ~node_exec ~client_exec return () else return () in - let* (res, hash) = + let* res, hash = Tezos_admin_client.inject_protocol admin_0 state ~path:tmpdir in let* () = @@ -1031,8 +1031,7 @@ $ Arg.( `\"--with-ledger=ledger://...\"` option in which case some steps \ have to be interactive. In this case, the option \ `--serialize-proposals` is recommended, because if it is not \ - provided, the proposal vote will be a “Sign Unverified” \ - operation."; + provided, the proposal vote will be a “Sign Unverified” operation."; ] in Cmd.info ~doc ~man "voting" diff --git a/src/bin_sandbox/main.ml b/src/bin_sandbox/main.ml index ccc66277371d..d86a7e43aeed 100644 --- a/src/bin_sandbox/main.ml +++ b/src/bin_sandbox/main.ml @@ -42,7 +42,7 @@ module Small_utilities = struct let netstat_ports ~pp_error () = let open Cmdliner in let open Term in - let (term, info) = + let term, info = Test_command_line.Run_command.make ~pp_error (const (fun state -> diff --git a/src/bin_signer/handler.ml b/src/bin_signer/handler.ml index 23aa20ec25b5..34f769a316fd 100644 --- a/src/bin_signer/handler.ml +++ b/src/bin_signer/handler.ml @@ -85,7 +85,7 @@ module High_watermark = struct let open Lwt_result_syntax in let round = Option.value ~default:0l round_opt in match (previous_round_opt, previous_signature_opt) with - | (None, None) -> + | None, None -> if previous_level >= level then failwith "%s level %ld not above high watermark %ld" @@ -93,7 +93,7 @@ module High_watermark = struct level previous_level else return_none - | (None, Some signature) -> + | None, Some signature -> if previous_level > level then failwith "%s level %ld below high watermark %ld" @@ -108,7 +108,7 @@ module High_watermark = struct level else return_some signature else return_none - | (Some previous_round, None) -> + | Some previous_round, None -> if previous_level > level then failwith "%s level %ld not above high watermark %ld" @@ -124,7 +124,7 @@ module High_watermark = struct previous_level previous_round else return_none - | (Some previous_round, Some signature) -> + | Some previous_round, Some signature -> if previous_level > level then failwith "%s level %ld below high watermark %ld" @@ -163,7 +163,7 @@ module High_watermark = struct else let hash = Blake2B.hash_bytes [bytes] in let chain_id = Chain_id.of_bytes_exn (Bytes.sub bytes 1 4) in - let* (level, round_opt) = get_level_and_round () in + let* level, round_opt = get_level_and_round () in let* o = match Option.bind @@ -242,9 +242,9 @@ let check_magic_byte magic_bytes data = let check_authorization cctxt pkh data require_auth signature = let open Lwt_result_syntax in match (require_auth, signature) with - | (false, _) -> return_unit - | (true, None) -> failwith "missing authentication signature field" - | (true, Some signature) -> + | false, _ -> return_unit + | true, None -> failwith "missing authentication signature field" + | true, Some signature -> let to_sign = Signer_messages.Sign.Request.to_sign ~pkh ~data in let* keys = Authorized_key.load cctxt in if @@ -262,7 +262,7 @@ let sign ?magic_bytes ~check_high_watermark ~require_auth in let* () = check_magic_byte magic_bytes data in let* () = check_authorization cctxt pkh data require_auth signature in - let* (name, _pkh, sk_uri) = Client_keys.get_key cctxt pkh in + let* name, _pkh, sk_uri = Client_keys.get_key cctxt pkh in let*! () = Events.(emit signing_data) name in let sign = Client_keys.sign cctxt sk_uri in if check_high_watermark then @@ -277,7 +277,7 @@ let deterministic_nonce (cctxt : #Client_context.wallet) Events.(emit request_for_deterministic_nonce) (Bytes.length data, pkh) in let* () = check_authorization cctxt pkh data require_auth signature in - let* (name, _pkh, sk_uri) = Client_keys.get_key cctxt pkh in + let* name, _pkh, sk_uri = Client_keys.get_key cctxt pkh in let*! () = Events.(emit creating_nonce) name in Client_keys.deterministic_nonce sk_uri data @@ -289,14 +289,14 @@ let deterministic_nonce_hash (cctxt : #Client_context.wallet) Events.(emit request_for_deterministic_nonce_hash) (Bytes.length data, pkh) in let* () = check_authorization cctxt pkh data require_auth signature in - let* (name, _pkh, sk_uri) = Client_keys.get_key cctxt pkh in + let* name, _pkh, sk_uri = Client_keys.get_key cctxt pkh in let*! () = Events.(emit creating_nonce_hash) name in Client_keys.deterministic_nonce_hash sk_uri data let supports_deterministic_nonces (cctxt : #Client_context.wallet) pkh = let open Lwt_result_syntax in let*! () = Events.(emit request_for_supports_deterministic_nonces) pkh in - let* (name, _pkh, sk_uri) = Client_keys.get_key cctxt pkh in + let* name, _pkh, sk_uri = Client_keys.get_key cctxt pkh in let*! () = Events.(emit supports_deterministic_nonces) name in Client_keys.supports_deterministic_nonces sk_uri diff --git a/src/bin_signer/main_signer.ml b/src/bin_signer/main_signer.ml index 231e2faf8e41..2d4312228ae7 100644 --- a/src/bin_signer/main_signer.ml +++ b/src/bin_signer/main_signer.ml @@ -345,7 +345,7 @@ module Signer_config = struct let parse_config_args ctx argv = let open Lwt_result_syntax in - let* ((base_dir, require_auth, password_filename), remaining) = + let* (base_dir, require_auth, password_filename), remaining = Clic.parse_global_options (global_options ()) ctx argv in return diff --git a/src/bin_signer/socket_daemon.ml b/src/bin_signer/socket_daemon.ml index d2929ffa0e05..ac920945e0d4 100644 --- a/src/bin_signer/socket_daemon.ml +++ b/src/bin_signer/socket_daemon.ml @@ -110,7 +110,7 @@ let run ?magic_bytes ?timeout ~check_high_watermark ~require_auth let* fds = bind path in let rec loop fd = let open Lwt_syntax in - let* (cfd, _) = Lwt_unix.accept fd in + let* cfd, _ = Lwt_unix.accept fd in Lwt.dont_wait (fun () -> Unit.catch_s (fun () -> diff --git a/src/bin_snoop/commands.ml b/src/bin_snoop/commands.ml index c54f585e346a..ebfe76144620 100644 --- a/src/bin_snoop/commands.ml +++ b/src/bin_snoop/commands.ml @@ -839,7 +839,7 @@ let usage () = ~global_options:Global_options.options commands_with_man -let (original_args, autocomplete) = +let original_args, autocomplete = (* for shell aliases *) let rec move_autocomplete_token_upfront acc = function | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args -> @@ -852,7 +852,7 @@ let (original_args, autocomplete) = | _ :: args -> move_autocomplete_token_upfront [] args | [] -> ([], None) -let (list_solvers, list_models) = +let list_solvers, list_models = ignore Clic.( setup_formatter @@ -862,7 +862,7 @@ let (list_solvers, list_models) = let result = Lwt_main.run (let open Lwt_result_syntax in - let* (list_flags, args) = + let* list_flags, args = Clic.parse_global_options Global_options.options () original_args in match autocomplete with diff --git a/src/bin_snoop/dep_graph.ml b/src/bin_snoop/dep_graph.ml index a08740d01348..c3beeab906b1 100644 --- a/src/bin_snoop/dep_graph.ml +++ b/src/bin_snoop/dep_graph.ml @@ -158,7 +158,7 @@ module Solver = struct {dependencies = deps; undecided_variables = undecided; meta = n.meta} let rec propagate_solved state (n : 'a solved) solved_but_not_propagated = - let (solved_but_not_propagated, unsolved) = + let solved_but_not_propagated, unsolved = List.fold_left (fun (solved_acc, unsolved_acc) unsolved -> Fv_set.fold @@ -183,7 +183,7 @@ module Solver = struct let solve {solved; unsolved} = assert (solved = []) ; - let (roots, others) = + let roots, others = List.partition (fun (node : 'a unsolved) -> Fv_set.is_empty node.dependencies diff --git a/src/bin_snoop/display.ml b/src/bin_snoop/display.ml index 8c0402404aa2..cb8a3fabccbe 100644 --- a/src/bin_snoop/display.ml +++ b/src/bin_snoop/display.ml @@ -168,7 +168,7 @@ let empirical_data (workload_data : (Sparse_vec.String.t * float) list) = Ok (named_columns, timings) let column_is_constant (m : Matrix.t) = - let (rows, cols) = Matrix.shape m in + let rows, cols = Matrix.shape m in assert (cols = 1) ; let fst = Matrix.get m 0 0 in let flg = ref true in @@ -183,7 +183,7 @@ let prune_problem problem : (Free_variable.t * Matrix.t) list * Matrix.t = match problem with | Inference.Degenerate _ -> assert false | Inference.Non_degenerate {input; output; nmap; _} -> - let (_, cols) = Matrix.shape input in + let _, cols = Matrix.shape input in let named_columns = List.init ~when_negative_length:() cols (fun c -> let name = Inference.NMap.nth_exn nmap c in @@ -222,7 +222,7 @@ let validator (problem : Inference.problem) (solution : Inference.solution) = | Inference.Non_degenerate {input; _} -> let {Inference.weights; _} = solution in let predicted = Matrix.numpy_mul input weights in - let (columns, timings) = prune_problem problem in + let columns, timings = prune_problem problem in let columns = List.map (fun (c, m) -> (Format.asprintf "%a" Free_variable.pp c, m)) @@ -238,7 +238,7 @@ let validator (problem : Inference.problem) (solution : Inference.solution) = let empirical (workload_data : (Sparse_vec.String.t * float) list) : (int * (col:int -> unit Plot.t), string) result = let open Result_syntax in - let* (columns, timings) = empirical_data workload_data in + let* columns, timings = empirical_data workload_data in let* plots = plot_scatter "Empirical" columns [timings] in let nrows = List.length plots in Ok (nrows, fun ~col -> plot_stacked 0 col plots) diff --git a/src/bin_snoop/latex_pp.ml b/src/bin_snoop/latex_pp.ml index 1901a2f4b2b3..e4660cecddfd 100644 --- a/src/bin_snoop/latex_pp.ml +++ b/src/bin_snoop/latex_pp.ml @@ -129,7 +129,7 @@ and pp_blob : Format.formatter -> Latex_syntax.blob -> unit = and pp_table : Format.formatter -> Latex_syntax.table -> unit = fun fmtr table -> match table with - | (spec, rows) -> + | spec, rows -> let width = Latex_syntax.spec_width spec in if not diff --git a/src/bin_snoop/main_snoop.ml b/src/bin_snoop/main_snoop.ml index 3f8deb457bdb..c2eb08db8800 100644 --- a/src/bin_snoop/main_snoop.ml +++ b/src/bin_snoop/main_snoop.ml @@ -177,7 +177,7 @@ and infer_cmd_full_auto model_name workload_data solver | _ -> None in let solver = solver_of_string solver infer_opts in - let (graph, measurements) = Dep_graph.load_files model_name workload_files in + let graph, measurements = Dep_graph.load_files model_name workload_files in if Dep_graph.G.is_empty graph then ( Format.eprintf "Empty dependency graph.@." ; exit 1) ; @@ -193,7 +193,7 @@ and infer_cmd_full_auto model_name workload_data solver Dep_graph.D.output_graph oc graph ; close_out oc) infer_opts.dot_file ; - let (map, report) = + let map, report = Dep_graph.T.fold (fun workload_file (overrides_map, report) -> Format.eprintf "Processing: %s@." workload_file ; @@ -248,11 +248,11 @@ and infer_cmd_full_auto model_name workload_data solver in perform_save_solution map infer_opts ; match (infer_opts.report, report) with - | (Cmdline.NoReport, _) -> () - | (Cmdline.ReportToStdout, Some report) -> + | Cmdline.NoReport, _ -> () + | Cmdline.ReportToStdout, Some report -> let s = Report.to_latex report in Format.printf "%s" s - | (Cmdline.ReportToFile output_file, Some report) -> + | Cmdline.ReportToFile output_file, Some report -> let s = Report.to_latex report in Lwt_main.run (let open Lwt_syntax in diff --git a/src/bin_snoop/report.ml b/src/bin_snoop/report.ml index 7ed4beeb6ff6..9e5ec8476432 100644 --- a/src/bin_snoop/report.ml +++ b/src/bin_snoop/report.ml @@ -241,7 +241,9 @@ let inferred_params_table (solution : Inference.solution) = (fun l -> Latex_syntax.Row (List.map (fun x -> [maths x]) l)) lines in - let rows = Latex_syntax.Hline :: hdr :: data @ [Latex_syntax.Hline] in + let rows = + (Latex_syntax.Hline :: hdr :: data) @ [Latex_syntax.Hline] + in Some (spec, rows)) let overrides_table (overrides : float Free_variable.Map.t) = @@ -259,7 +261,7 @@ let overrides_table (overrides : float Free_variable.Map.t) = overrides [] in - let rows = Latex_syntax.Hline :: hdr :: data @ [Latex_syntax.Hline] in + let rows = (Latex_syntax.Hline :: hdr :: data) @ [Latex_syntax.Hline] in Some (spec, rows) module Int_set = Set.Make (Int) diff --git a/src/bin_tps_evaluation/benchmark_tps_command.ml b/src/bin_tps_evaluation/benchmark_tps_command.ml index 07e96f9e6930..fbc74390a173 100644 --- a/src/bin_tps_evaluation/benchmark_tps_command.ml +++ b/src/bin_tps_evaluation/benchmark_tps_command.ml @@ -162,7 +162,7 @@ let run_benchmark ~lift_protocol_limits ~provided_tps_of_injection ~blocks_total in Log.info "Accounts to use: %d" total_bootstraps ; Log.info "Spinning up the network..." ; - let (regular_transaction_fee, regular_transaction_gas_limit) = + let regular_transaction_fee, regular_transaction_gas_limit = Gas.deduce_fee_and_gas_limit gas_tps_estimation_results.transaction_costs.regular in @@ -184,7 +184,7 @@ let run_benchmark ~lift_protocol_limits ~provided_tps_of_injection ~blocks_total let default_accounts_balance = (max_single_transaction_fee + Constants.gas_safety_margin) * blocks_total in - let* (node, client) = + let* node, client = Client.init_with_protocol ~nodes_args:Node.[Connections 0; Synchronisation_threshold 0] ~parameter_file @@ -223,16 +223,14 @@ let run_benchmark ~lift_protocol_limits ~provided_tps_of_injection ~blocks_total Client.spawn_stresstest ~fee:regular_transaction_fee ~gas_limit:regular_transaction_gas_limit - ~tps: - target_tps_of_injection + ~tps:target_tps_of_injection (* The stresstest command allows a small probability of creating new accounts along the way. We do not want that, so we set it to 0. *) ~fresh_probability:0.0 ~single_op_per_pkh_per_block:true ~smart_contract_parameters - ~source_aliases: - (make_delegates Constants.default_bootstraps_count) + ~source_aliases:(make_delegates Constants.default_bootstraps_count) (* It is essential not to pass all accounts via aliases because every alias has to be normalized and that's an extra call of the client per account. This does not scale well. On the other hand, if we @@ -319,7 +317,7 @@ let register () = let previous_count = Cli.get_int ~default:10 "regression-previous-sample-count" in - let* (defacto_tps_of_injection, empirical_tps) = + let* defacto_tps_of_injection, empirical_tps = run_benchmark ~lift_protocol_limits ~provided_tps_of_injection diff --git a/src/bin_tps_evaluation/gas.ml b/src/bin_tps_evaluation/gas.ml index dabcfb5ca42d..7226cf5df97d 100644 --- a/src/bin_tps_evaluation/gas.ml +++ b/src/bin_tps_evaluation/gas.ml @@ -26,7 +26,7 @@ module Contracts = Tezos_client_alpha_commands.Client_proto_stresstest_contracts let weighted_average (xs : (float * float) list) = - let (total_weight, total_sum) = + let total_weight, total_sum = List.fold_left (fun (total_weight, total_sum) (weight, value) -> (total_weight +. weight, total_sum +. (value *. weight))) @@ -115,7 +115,7 @@ let calculate_smart_contract_parameters (average_block : Average_block.t) | None -> Stdlib.failwith ("no gas cost estimation for: " ^ alias) | Some (_, x) -> x in - let (invocation_fee, invocation_gas_limit) = + let invocation_fee, invocation_gas_limit = deduce_fee_and_gas_limit gas_estimation in ( alias, diff --git a/src/bin_tps_evaluation/gas_tps_command.ml b/src/bin_tps_evaluation/gas_tps_command.ml index c962af5233f4..b66bbf897ecd 100644 --- a/src/bin_tps_evaluation/gas_tps_command.ml +++ b/src/bin_tps_evaluation/gas_tps_command.ml @@ -39,7 +39,7 @@ let estimate_gas_tps ~average_block_path () = ~base:(Either.right (protocol, Some protocol_constants)) [] in - let* (node, client) = + let* node, client = Client.init_with_protocol ~nodes_args:Node.[Connections 0; Synchronisation_threshold 0] ~parameter_file diff --git a/src/bin_validation/validator.ml b/src/bin_validation/validator.ml index 1a15084952be..800933188f12 100644 --- a/src/bin_validation/validator.ml +++ b/src/bin_validation/validator.ml @@ -288,7 +288,7 @@ let run input output = operations ~cache) in - let (block_application_result, cache) = + let block_application_result, cache = match block_application_result with | Error [Validation_errors.Inconsistent_hash _] as err -> (* This is a special case added for Hangzhou that could @@ -470,7 +470,7 @@ let run input output = let main ?socket_dir () = let open Lwt_result_syntax in let canceler = Lwt_canceler.create () in - let*! (in_channel, out_channel) = + let*! in_channel, out_channel = match socket_dir with | Some socket_dir -> let*! () = Tezos_base_unix.Internal_event_unix.init () in diff --git a/src/lib_base/block_header.ml b/src/lib_base/block_header.ml index 8243a031f6c1..60977443493f 100644 --- a/src/lib_base/block_header.ml +++ b/src/lib_base/block_header.ml @@ -100,10 +100,10 @@ include Compare.Make (struct let ( >> ) = Compare.or_else in let rec list compare xs ys = match (xs, ys) with - | ([], []) -> 0 - | (_ :: _, []) -> -1 - | ([], _ :: _) -> 1 - | (x :: xs, y :: ys) -> compare x y >> fun () -> list compare xs ys + | [], [] -> 0 + | _ :: _, [] -> -1 + | [], _ :: _ -> 1 + | x :: xs, y :: ys -> compare x y >> fun () -> list compare xs ys in Block_hash.compare b1.shell.predecessor b2.shell.predecessor >> fun () -> compare b1.protocol_data b2.protocol_data >> fun () -> diff --git a/src/lib_base/block_locator.ml b/src/lib_base/block_locator.ml index ca3b205edce6..a47d59729c23 100644 --- a/src/lib_base/block_locator.ml +++ b/src/lib_base/block_locator.ml @@ -132,7 +132,7 @@ end = struct (Int32.rem (TzEndian.get_int32 seed 0) n, Hacl.Hash.SHA256.digest seed) let next (step, counter, seed) = - let (random_gap, seed) = + let random_gap, seed = if step <= 1l then (0l, seed) else draw seed (Int32.succ (Int32.div step 2l)) in @@ -147,18 +147,18 @@ let estimated_length seed {head_hash; history; _} = let rec loop acc state = function | [] -> acc | _ :: hist -> - let (step, state) = Step.next state in + let step, state = Step.next state in loop (acc + step) state hist in let state = Step.init seed head_hash in - let (step, state) = Step.next state in + let step, state = Step.next state in loop step state history let fold ~f ~init {head_hash; history; _} seed = let rec loop state acc = function | [] | [_] -> acc | block :: (pred :: rem as hist) -> - let (step, state) = Step.next state in + let step, state = Step.next state in let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in loop state acc hist in @@ -183,7 +183,7 @@ let fold_truncate ~f ~init ~save_point ~limit {head_hash; history; _} seed = let rec loop state step_sum acc = function | [] | [_] -> acc | block :: (pred :: rem as hist) -> - let (step, state) = Step.next state in + let step, state = Step.next state in let new_step_sum = step + step_sum in if new_step_sum >= limit then f acc ~block ~pred:save_point ~step ~strict_step:false @@ -209,7 +209,7 @@ let compute ~get_predecessor ~caboose ~size head_hash head_header seed = let rec loop acc size state current_block_hash = if size = 0 then Lwt.return acc else - let (step, state) = Step.next state in + let step, state = Step.next state in let* o = get_predecessor current_block_hash step in match o with | None -> diff --git a/src/lib_base/bounded.ml b/src/lib_base/bounded.ml index a2d3860de4ae..d31bd44a0fb1 100644 --- a/src/lib_base/bounded.ml +++ b/src/lib_base/bounded.ml @@ -46,7 +46,6 @@ module Int32 = struct module Make (B : BOUNDS) = struct include Compare.Int32 (* This includes [type t = int32] *) - include B let to_int32 x = x diff --git a/src/lib_base/fitness.ml b/src/lib_base/fitness.ml index 70034843402d..481a294a7097 100644 --- a/src/lib_base/fitness.ml +++ b/src/lib_base/fitness.ml @@ -48,11 +48,11 @@ include Compare.Make (struct let compare f1 f2 = let rec compare_rec f1 f2 = match (f1, f2) with - | ([], []) -> 0 - | (i1 :: f1, i2 :: f2) -> + | [], [] -> 0 + | i1 :: f1, i2 :: f2 -> let i = compare_bytes i1 i2 in if i = 0 then compare_rec f1 f2 else i - | (_, _) -> assert false + | _, _ -> assert false in let len = compare (List.length f1) (List.length f2) in if len = 0 then compare_rec f1 f2 else len diff --git a/src/lib_base/p2p_connection.ml b/src/lib_base/p2p_connection.ml index 96dde73f83c8..2a1ba2bac113 100644 --- a/src/lib_base/p2p_connection.ml +++ b/src/lib_base/p2p_connection.ml @@ -53,12 +53,12 @@ module Id = struct let of_point (addr, port) = (addr, Some port) let to_point = function - | (_, None) -> None - | (addr, Some port) -> Some (addr, port) + | _, None -> None + | addr, Some port -> Some (addr, port) let to_point_exn = function - | (_, None) -> invalid_arg "to_point_exn" - | (addr, Some port) -> (addr, port) + | _, None -> invalid_arg "to_point_exn" + | addr, Some port -> (addr, port) let encoding = let open Data_encoding in @@ -138,7 +138,7 @@ module Info = struct let pp pp_meta ppf { incoming; - id_point = (remote_addr, remote_port); + id_point = remote_addr, remote_port; remote_socket_port; peer_id; announced_version; diff --git a/src/lib_base/p2p_identity.ml b/src/lib_base/p2p_identity.ml index 5b9ab7e0f9b8..27898bf52ca9 100644 --- a/src/lib_base/p2p_identity.ml +++ b/src/lib_base/p2p_identity.ml @@ -55,7 +55,7 @@ let encoding = let generate_with_bound ?yield_every ?max pow_target = let open Error_monad.Lwt_syntax in - let (secret_key, public_key, peer_id) = Crypto_box.random_keypair () in + let secret_key, public_key, peer_id = Crypto_box.random_keypair () in let+ proof_of_work_stamp = Crypto_box.generate_proof_of_work ?yield_every ?max public_key pow_target in @@ -65,7 +65,7 @@ let generate ?yield_every pow_target = generate_with_bound ?yield_every pow_target let generate_with_pow_target_0 () = - let (secret_key, public_key, peer_id) = Crypto_box.random_keypair () in + let secret_key, public_key, peer_id = Crypto_box.random_keypair () in let proof_of_work_stamp = Crypto_box.generate_proof_of_work_with_target_0 public_key in diff --git a/src/lib_base/p2p_peer.ml b/src/lib_base/p2p_peer.ml index 1277f0edc488..e1809a75988f 100644 --- a/src/lib_base/p2p_peer.ml +++ b/src/lib_base/p2p_peer.ml @@ -72,13 +72,12 @@ module State = struct let raw_filter (f : Filter.t) (s : t) = match (f, s) with - | (Accepted, Accepted) -> true - | (Accepted, (Running | Disconnected)) | ((Running | Disconnected), Accepted) - -> + | Accepted, Accepted -> true + | Accepted, (Running | Disconnected) | (Running | Disconnected), Accepted -> false - | (Running, Running) -> true - | (Disconnected, Disconnected) -> true - | (Running, Disconnected) | (Disconnected, Running) -> false + | Running, Running -> true + | Disconnected, Disconnected -> true + | Running, Disconnected | Disconnected, Running -> false let filter filters state = List.exists (fun f -> raw_filter f state) filters end @@ -213,7 +212,7 @@ module Pool_event = struct "An event that may happen during maintenance of and other operations \ on the connection to a specific peer." @@ conv - (fun {kind; timestamp; point = (addr, port)} -> + (fun {kind; timestamp; point = addr, port} -> (kind, timestamp, addr, port)) (fun (kind, timestamp, addr, port) -> {kind; timestamp; point = (addr, port)}) diff --git a/src/lib_base/p2p_point.ml b/src/lib_base/p2p_point.ml index a8bba8208626..9f6b65ea42bb 100644 --- a/src/lib_base/p2p_point.ml +++ b/src/lib_base/p2p_point.ml @@ -77,9 +77,9 @@ module Id = struct let {addr; port; _} = addr_port_id_of_string_exn str in let port = match (port, default_port) with - | (Some port, _) -> port - | (None, Some port) -> port - | (None, None) -> invalid_arg "P2p_point.of_string_exn: no port" + | Some port, _ -> port + | None, Some port -> port + | None, None -> invalid_arg "P2p_point.of_string_exn: no port" in match Ipaddr.of_string_exn addr with | V4 addr -> (Ipaddr.v6_of_v4 addr, port) @@ -164,10 +164,10 @@ module State = struct let of_peerid_state state pi = match (state, pi) with - | (Requested, _) -> Requested - | (Accepted _, Some pi) -> Accepted pi - | (Running _, Some pi) -> Running pi - | (Disconnected, _) -> Disconnected + | Requested, _ -> Requested + | Accepted _, Some pi -> Accepted pi + | Running _, Some pi -> Running pi + | Disconnected, _ -> Disconnected | _ -> invalid_arg "state_of_state_peerid" let pp_digram ppf = function @@ -225,17 +225,17 @@ module State = struct let raw_filter (f : Filter.t) (s : t) = match (f, s) with - | (Requested, Requested) -> true - | (Requested, (Accepted _ | Running _ | Disconnected)) - | ((Accepted | Running | Disconnected), Requested) -> + | Requested, Requested -> true + | Requested, (Accepted _ | Running _ | Disconnected) + | (Accepted | Running | Disconnected), Requested -> false - | (Accepted, Accepted _) -> true - | (Accepted, (Running _ | Disconnected)) - | ((Running | Disconnected), Accepted _) -> + | Accepted, Accepted _ -> true + | Accepted, (Running _ | Disconnected) + | (Running | Disconnected), Accepted _ -> false - | (Running, Running _) -> true - | (Disconnected, Disconnected) -> true - | (Running, Disconnected) | (Disconnected, Running _) -> false + | Running, Running _ -> true + | Disconnected, Disconnected -> true + | Running, Disconnected | Disconnected, Running _ -> false let filter filters state = List.exists (fun f -> raw_filter f state) filters end diff --git a/src/lib_base/sized.ml b/src/lib_base/sized.ml index af3a5581b66c..e131993e62e4 100644 --- a/src/lib_base/sized.ml +++ b/src/lib_base/sized.ml @@ -117,7 +117,7 @@ module MakeSizedSet (S : TzLwtreslib.Set.S) = struct empty let partition f t = - let (s1, s2) = S.partition f t.set in + let s1, s2 = S.partition f t.set in let n = S.cardinal s1 in ({cardinal = n; set = s1}, {cardinal = t.cardinal - n; set = s2}) @@ -136,7 +136,7 @@ module MakeSizedSet (S : TzLwtreslib.Set.S) = struct let choose_opt t = S.choose_opt t.set let split e t = - let (l, b, r) = S.split e t.set in + let l, b, r = S.split e t.set in let n = S.cardinal l in if b then ({cardinal = n; set = l}, b, {cardinal = t.cardinal - n - 1; set = r}) @@ -260,7 +260,7 @@ module MakeSizedMap (M : TzLwtreslib.Map.S) = struct empty let partition f t = - let (m1, m2) = M.partition f t.map in + let m1, m2 = M.partition f t.map in let n = M.cardinal m1 in ({cardinal = n; map = m1}, {cardinal = t.cardinal - n; map = m2}) @@ -279,7 +279,7 @@ module MakeSizedMap (M : TzLwtreslib.Map.S) = struct let choose_opt t = M.choose_opt t.map let split key t = - let (l, data, r) = M.split key t.map in + let l, data, r = M.split key t.map in let n = M.cardinal l in match data with | Some _ -> diff --git a/src/lib_base/test/test_p2p_addr.ml b/src/lib_base/test/test_p2p_addr.ml index 7facc0a97c20..234c5358d2d2 100644 --- a/src/lib_base/test/test_p2p_addr.ml +++ b/src/lib_base/test/test_p2p_addr.ml @@ -113,8 +113,8 @@ let eq l r = in let eq_peer_id idl idr = match (idl, idr) with - | (None, None) -> true - | (Some idl, Some idr) -> P2p_peer_id.(idl = idr) + | None, None -> true + | Some idl, Some idr -> P2p_peer_id.(idl = idr) | _ -> false in eq_addr l.addr r.addr && l.port = r.port && eq_peer_id l.peer_id r.peer_id diff --git a/src/lib_base/test/test_sized.ml b/src/lib_base/test/test_sized.ml index a0939384934b..8891f701bae7 100644 --- a/src/lib_base/test/test_sized.ml +++ b/src/lib_base/test/test_sized.ml @@ -114,7 +114,7 @@ module SizedSet_test = struct ~name:"partition" Gen.(pair generator (fun1 Observable.int bool)) (fun (s, f) -> - let (s1, s2) = SizedSet.partition (Fn.apply f) s in + let s1, s2 = SizedSet.partition (Fn.apply f) s in assert_consistent s1 && assert_consistent s2) let split = @@ -122,7 +122,7 @@ module SizedSet_test = struct ~name:"split" Gen.(pair generator small_nat) (fun (s, v) -> - let (s1, _, s2) = SizedSet.split v s in + let s1, _, s2 = SizedSet.split v s in assert_consistent s1 && assert_consistent s2) let add_seq = @@ -262,7 +262,7 @@ module SizedMap_test = struct ~name:"partition" Gen.(pair generator (fun2 Observable.int Observable.int bool)) (fun (m, f) -> - let (s1, s2) = SizedMap.partition (Fn.apply f) m in + let s1, s2 = SizedMap.partition (Fn.apply f) m in assert_consistent s1 && assert_consistent s2) let split = @@ -270,7 +270,7 @@ module SizedMap_test = struct ~name:"split" Gen.(pair generator small_nat) (fun (m, v) -> - let (s1, _, s2) = SizedMap.split v m in + let s1, _, s2 = SizedMap.split v m in assert_consistent s1 && assert_consistent s2) let add_seq = diff --git a/src/lib_base/test/test_time.ml b/src/lib_base/test/test_time.ml index bc2782bd4a06..dd04375ec052 100644 --- a/src/lib_base/test/test_time.ml +++ b/src/lib_base/test/test_time.ml @@ -145,9 +145,9 @@ module System = struct |> map (fun (date, time) -> Ptime.of_date_time (date, (time, 0)) |> Option.get)) - let (min_day, min_ps) = Ptime.min |> Ptime.to_span |> Ptime.Span.to_d_ps + let min_day, min_ps = Ptime.min |> Ptime.to_span |> Ptime.Span.to_d_ps - let (max_day, max_ps) = Ptime.max |> Ptime.to_span |> Ptime.Span.to_d_ps + let max_day, max_ps = Ptime.max |> Ptime.to_span |> Ptime.Span.to_d_ps (** Gen.T of {!t} from days + picoseconds, parsed through {!Ptime.Span.of_d_ps}. *) let t_dps_gen : t Gen.t = @@ -188,8 +188,7 @@ module System = struct *) let of_protocol_to_protocol_roundtrip_or_outside_rfc3339_with_gen gen = Test.make - ~name: - "System.[of|to]_protocol roundtrip or outside RFC3339 range" + ~name:"System.[of|to]_protocol roundtrip or outside RFC3339 range" (* Use both generators, otherwise statistically, we will almost never hit the RFC3339 time range. *) ~print:Protocol.print diff --git a/src/lib_base/test_helpers/tz_arbitrary.ml b/src/lib_base/test_helpers/tz_arbitrary.ml index daad950ef7a6..c7c72a84040a 100644 --- a/src/lib_base/test_helpers/tz_arbitrary.ml +++ b/src/lib_base/test_helpers/tz_arbitrary.ml @@ -54,7 +54,7 @@ let port_opt = QCheck.option port (* could not craft a [p2p_identity QCheck.gen], we use instead a constant [unit -> p2p_identity] which will be applied at each - testing points. *) + testing points. *) let peer_id = QCheck.option QCheck.(map P2p_identity.generate_with_pow_target_0 unit) diff --git a/src/lib_base/test_helpers/tztest.ml b/src/lib_base/test_helpers/tztest.ml index eda4185665dc..6ae8f99f7ccf 100644 --- a/src/lib_base/test_helpers/tztest.ml +++ b/src/lib_base/test_helpers/tztest.ml @@ -46,7 +46,7 @@ let tztest (name : string) (speed : Alcotest.speed_level) (f : unit -> 'a Lwt.t) Lwt.fail Alcotest.Test_error) let tztest_qcheck ?count ~name generator f = - let (name, speed, run) = + let name, speed, run = QCheck_alcotest.to_alcotest ( QCheck.Test.make ?count ~name generator @@ fun x -> match Lwt_main.run (f x) with diff --git a/src/lib_base/time.ml b/src/lib_base/time.ml index 47eb4eac0c79..c00acc4cb3e0 100644 --- a/src/lib_base/time.ml +++ b/src/lib_base/time.ml @@ -27,12 +27,12 @@ let max_daysL = (* [= 2932896L] which is less than [Stdlib.max_int] even on 32-bit architecture. This ensures [Int64.to_int] is accurate no matter what. *) - let (max_days, _) = Ptime.(Span.to_d_ps (to_span max)) in + let max_days, _ = Ptime.(Span.to_d_ps (to_span max)) in Int64.of_int max_days let min_daysL = (* Same as [max_daysL] but min. *) - let (min_days, _) = Ptime.(Span.to_d_ps (to_span min)) in + let min_days, _ = Ptime.(Span.to_d_ps (to_span min)) in Int64.of_int min_days module Protocol = struct @@ -47,14 +47,14 @@ module Protocol = struct let add = Int64.add let of_ptime t = - let (days, ps) = Ptime.Span.to_d_ps (Ptime.to_span t) in + let days, ps = Ptime.Span.to_d_ps (Ptime.to_span t) in let s_days = Int64.mul (Int64.of_int days) 86_400L in Int64.add s_days (Int64.div ps 1_000_000_000_000L) let to_ptime t = let daysL = Int64.div t 86_400L in let ps = Int64.mul (Int64.rem t 86_400L) 1_000_000_000_000L in - let (daysL, ps) = + let daysL, ps = if ps < 0L then (* [Ptime.Span.of_d_ps] only accepts picoseconds in the range 0L-86_399_999_999_999_999L. Subtract a day and add a day's worth of picoseconds if need be. *) (Int64.pred daysL, Int64.(add ps (mul 86_400L 1_000_000_000_000L))) @@ -229,7 +229,7 @@ module System = struct | None -> invalid_arg "Time.of_seconds" let to_seconds x = - let (days, ps) = Ptime.(Span.to_d_ps (to_span x)) in + let days, ps = Ptime.(Span.to_d_ps (to_span x)) in let s_days = Int64.mul (Int64.of_int days) 86_400L in Int64.add s_days (Int64.div ps 1_000_000_000_000L) @@ -326,9 +326,9 @@ module System = struct let recent a1 a2 = match (a1, a2) with - | (None, None) -> None - | (None, (Some _ as a)) | ((Some _ as a), None) -> a - | (Some (_, t1), Some (_, t2)) -> if t1 < t2 then a2 else a1 + | None, None -> None + | None, (Some _ as a) | (Some _ as a), None -> a + | Some (_, t1), Some (_, t2) -> if t1 < t2 then a2 else a1 let hash t = Int64.to_int (to_seconds t) diff --git a/src/lib_base/unix/protocol_files.ml b/src/lib_base/unix/protocol_files.ml index 2933b1b30d1d..5d39dc6b5f3d 100644 --- a/src/lib_base/unix/protocol_files.ml +++ b/src/lib_base/unix/protocol_files.ml @@ -24,11 +24,11 @@ let find_component dirname module_name = let implementation = (dirname // name_lowercase) ^ ".ml" in let interface = implementation ^ "i" in match (Sys.file_exists implementation, Sys.file_exists interface) with - | (false, _) -> Stdlib.failwith @@ "No such file: " ^ implementation - | (true, false) -> + | false, _ -> Stdlib.failwith @@ "No such file: " ^ implementation + | true, false -> let+ implementation = Lwt_utils_unix.read_file implementation in {name = module_name; interface = None; implementation} - | (true, true) -> + | true, true -> let+ interface = Lwt_utils_unix.read_file interface and+ implementation = Lwt_utils_unix.read_file implementation in {name = module_name; interface = Some interface; implementation} diff --git a/src/lib_benchmark/costlang.ml b/src/lib_benchmark/costlang.ml index 6a4f442c92e9..ade53d92c3e9 100644 --- a/src/lib_benchmark/costlang.ml +++ b/src/lib_benchmark/costlang.ml @@ -692,7 +692,7 @@ functor let lift2 f x y = match (x, y) with - | (Dynamic d, Dynamic e) -> dyn (f d e) + | Dynamic d, Dynamic e -> dyn (f d e) | _ -> assert false let false_ = dyn X.false_ @@ -855,44 +855,42 @@ module Fold_constants (X : S) = struct let arith_op op_i op_f op_x x y = match (x, y) with - | (Int i, Int j) -> Int (op_i i j) - | (Float i, Float j) -> Float (op_f i j) - | (Int i, Float j) -> Float (op_f (float_of_int i) j) - | (Float i, Int j) -> Float (op_f i (float_of_int j)) - | (Not_const term, Int i) -> Not_const (op_x term (X.int i)) - | (Int i, Not_const term) -> Not_const (op_x (X.int i) term) - | (Not_const term, Float i) -> Not_const (op_x term (X.float i)) - | (Float i, Not_const term) -> Not_const (op_x (X.float i) term) - | (Not_const x, Not_const y) -> Not_const (op_x x y) - | (Bool _, _) | (_, Bool _) -> assert false + | Int i, Int j -> Int (op_i i j) + | Float i, Float j -> Float (op_f i j) + | Int i, Float j -> Float (op_f (float_of_int i) j) + | Float i, Int j -> Float (op_f i (float_of_int j)) + | Not_const term, Int i -> Not_const (op_x term (X.int i)) + | Int i, Not_const term -> Not_const (op_x (X.int i) term) + | Not_const term, Float i -> Not_const (op_x term (X.float i)) + | Float i, Not_const term -> Not_const (op_x (X.float i) term) + | Not_const x, Not_const y -> Not_const (op_x x y) + | Bool _, _ | _, Bool _ -> assert false let ( + ) x y = match (x, y) with - | (Int 0, term) | (Float 0.0, term) | (term, Int 0) | (term, Float 0.0) -> - term + | Int 0, term | Float 0.0, term | term, Int 0 | term, Float 0.0 -> term | _ -> arith_op ( + ) ( +. ) X.( + ) x y let ( * ) x y = match (x, y) with - | (Int 0, _) | (Float 0.0, _) | (_, Int 0) | (_, Float 0.0) -> Int 0 - | (Int 1, term) | (Float 1.0, term) | (term, Int 1) | (term, Float 1.0) -> - term + | Int 0, _ | Float 0.0, _ | _, Int 0 | _, Float 0.0 -> Int 0 + | Int 1, term | Float 1.0, term | term, Int 1 | term, Float 1.0 -> term | _ -> arith_op ( * ) ( *. ) X.( * ) x y let ( - ) x y = match (x, y) with - | (term, Int 0) | (term, Float 0.0) -> term + | term, Int 0 | term, Float 0.0 -> term | _ -> arith_op ( - ) ( -. ) X.( - ) x y let ( / ) x y = match (x, y) with - | (term, Int 1) -> term - | (term, Float 1.0) -> term + | term, Int 1 -> term + | term, Float 1.0 -> term (* The next cases are here to avoid introducing floating point constants from the division *) - | (Int i, Int j) -> Not_const X.(int i / int j) - | (Float i, Float j) -> Not_const X.(float i / float j) - | (Int i, Float j) -> Not_const X.(int i / float j) - | (Float i, Int j) -> Not_const X.(float i / int j) + | Int i, Int j -> Not_const X.(int i / int j) + | Float i, Float j -> Not_const X.(float i / float j) + | Int i, Float j -> Not_const X.(int i / float j) + | Float i, Int j -> Not_const X.(float i / int j) | _ -> arith_op ( / ) ( /. ) X.( / ) x y let max = arith_op max max X.max @@ -930,29 +928,29 @@ module Fold_constants (X : S) = struct let lt x y = match (x, y) with - | (Int i, Int j) -> Bool (i < j) - | (Float i, Float j) -> Bool (i < j) - | (Float i, Int j) -> Bool (i < float_of_int j) - | (Int i, Float j) -> Bool (float_of_int i < j) - | (Not_const term, Int i) -> Not_const X.(lt term (int i)) - | (Int i, Not_const term) -> Not_const X.(lt (int i) term) - | (Not_const term, Float i) -> Not_const X.(lt term (float i)) - | (Float i, Not_const term) -> Not_const X.(lt (float i) term) - | (Not_const x, Not_const y) -> Not_const X.(lt x y) - | (Bool _, _) | (_, Bool _) -> assert false + | Int i, Int j -> Bool (i < j) + | Float i, Float j -> Bool (i < j) + | Float i, Int j -> Bool (i < float_of_int j) + | Int i, Float j -> Bool (float_of_int i < j) + | Not_const term, Int i -> Not_const X.(lt term (int i)) + | Int i, Not_const term -> Not_const X.(lt (int i) term) + | Not_const term, Float i -> Not_const X.(lt term (float i)) + | Float i, Not_const term -> Not_const X.(lt (float i) term) + | Not_const x, Not_const y -> Not_const X.(lt x y) + | Bool _, _ | _, Bool _ -> assert false let eq x y = match (x, y) with - | (Int i, Int j) -> Bool (i = j) - | (Float i, Float j) -> Bool (i = j) - | (Float i, Int j) -> Bool (i = float_of_int j) - | (Int i, Float j) -> Bool (float_of_int i = j) - | (Not_const term, Int i) -> Not_const X.(eq term (int i)) - | (Int i, Not_const term) -> Not_const X.(eq (int i) term) - | (Not_const term, Float i) -> Not_const X.(eq term (float i)) - | (Float i, Not_const term) -> Not_const X.(eq (float i) term) - | (Not_const x, Not_const y) -> Not_const X.(eq x y) - | (Bool _, _) | (_, Bool _) -> assert false + | Int i, Int j -> Bool (i = j) + | Float i, Float j -> Bool (i = j) + | Float i, Int j -> Bool (i = float_of_int j) + | Int i, Float j -> Bool (float_of_int i = j) + | Not_const term, Int i -> Not_const X.(eq term (int i)) + | Int i, Not_const term -> Not_const X.(eq (int i) term) + | Not_const term, Float i -> Not_const X.(eq term (float i)) + | Float i, Not_const term -> Not_const X.(eq (float i) term) + | Not_const x, Not_const y -> Not_const X.(eq x y) + | Bool _, _ | _, Bool _ -> assert false let lam ~name (f : 'a repr -> 'b repr) = Not_const (X.lam ~name (fun x -> prj (f (inj x)))) diff --git a/src/lib_benchmark/crypto_samplers.ml b/src/lib_benchmark/crypto_samplers.ml index ee3ed68570ba..fa4d8fe3590d 100644 --- a/src/lib_benchmark/crypto_samplers.ml +++ b/src/lib_benchmark/crypto_samplers.ml @@ -80,15 +80,15 @@ module Make_finite_key_pool (Arg : Param_S) : Finite_key_pool_S = struct triple let pk state = - let (_, pk, _) = get_next state in + let _, pk, _ = get_next state in pk let pkh state = - let (pkh, _, _) = get_next state in + let pkh, _, _ = get_next state in pkh let sk state = - let (_, _, sk) = get_next state in + let _, _, sk = get_next state in sk let all = get_next diff --git a/src/lib_benchmark/csv.ml b/src/lib_benchmark/csv.ml index 1b3695cccfdf..af998fc60705 100644 --- a/src/lib_benchmark/csv.ml +++ b/src/lib_benchmark/csv.ml @@ -88,7 +88,7 @@ exception Empty_csv_file let import ~filename ?(separator = ',') () : csv = Format.eprintf "Importing %s@." filename ; let lines = read_lines filename in - let (header, rows) = + let header, rows = match lines with | [] -> raise Empty_csv_file | header :: tail -> (header, tail) diff --git a/src/lib_benchmark/fixed_point_transform.ml b/src/lib_benchmark/fixed_point_transform.ml index c8a2f85fa282..6f6877b528a6 100644 --- a/src/lib_benchmark/fixed_point_transform.ml +++ b/src/lib_benchmark/fixed_point_transform.ml @@ -260,9 +260,9 @@ module Fixed_point_arithmetic (Lang : Fixed_point_lang_sig) = struct (* Split a float into sign/exponent/mantissa *) let split bits = - let (sign, rest) = take 1 bits in - let (expo, rest) = take 11 rest in - let (mant, _) = take 52 rest in + let sign, rest = take 1 bits in + let expo, rest = take 11 rest in + let mant, _ = take 52 rest in (sign, expo, mant) (* Convert bits of exponent to int. *) @@ -284,14 +284,14 @@ module Fixed_point_arithmetic (Lang : Fixed_point_lang_sig) = struct Lang.size Lang.repr = assert (precision > 0) ; assert_fp_is_correct x ; - let (_sign, exp, mant) = decompose x in + let _sign, exp, mant = decompose x in let exp = Int64.to_int @@ exponent_bits_to_int exp in - let (bits, _) = take precision mant in + let bits, _ = take precision mant in (* the mantissa is always implicitly prefixed by one (except for denormalized numbers, excluded here) *) let bits = 1L :: bits in (* convert mantissa to sum of powers of 2 computed with shifts *) - let (_, result_opt) = + let _, result_opt = List.fold_left (fun (k, term_opt) bit -> if bit = 1L then @@ -368,7 +368,7 @@ end = struct let rec lift_binop op x y = match (x, y) with - | (Term x, Term y) -> Term (op x y) + | Term x, Term y -> Term (op x y) | _ -> lift_binop op (cast_safe x) (cast_safe y) let gensym : unit -> string = @@ -392,12 +392,12 @@ end = struct let ( * ) x y = match (x, y) with - | (Term x, Term y) -> Term X.(x * y) - | (Term x, Const y) | (Const y, Term x) -> + | Term x, Term y -> Term X.(x * y) + | Term x, Const y | Const y, Term x -> (* let-bind the non-constant term to avoid copying it. *) Term (X.let_ ~name:(gensym ()) x (fun x -> FPA.approx_mult precision x y)) - | (Const x, Const y) -> Const (x *. y) + | Const x, Const y -> Const (x *. y) let ( / ) = lift_binop X.( / ) @@ -424,9 +424,9 @@ end = struct let app (type a b) (fn : (a -> b) repr) (arg : a repr) : b repr = match (fn, arg) with - | (Term fn, Term arg) -> Term (X.app fn arg) - | (Term fn, Const f) -> Term (X.app fn (X.float f)) - | (Const _, _) -> assert false + | Term fn, Term arg -> Term (X.app fn arg) + | Term fn, Const f -> Term (X.app fn (X.float f)) + | Const _, _ -> assert false let let_ (type a b) ~name (m : a repr) (fn : a repr -> b repr) : b repr = match m with diff --git a/src/lib_benchmark/inference.ml b/src/lib_benchmark/inference.ml index 36496d4c42e7..cec67cb677f5 100644 --- a/src/lib_benchmark/inference.ml +++ b/src/lib_benchmark/inference.ml @@ -194,7 +194,7 @@ let make_problem_from_workloads : Free_variable.Sparse_vec.is_empty affine.linear_comb) lines then - let (predicted, measured) = + let predicted, measured = List.map (fun (Full (affine, Quantity q)) -> (affine.const, q)) lines |> List.split in @@ -210,7 +210,7 @@ let make_problem_from_workloads : in Degenerate {predicted; measured} else - let (input, output, nmap) = line_list_to_ols lines in + let input, output, nmap = line_list_to_ols lines in Non_degenerate {lines; input; output; nmap} let make_problem : @@ -238,7 +238,7 @@ let make_problem : let fv_to_string fv = Format.asprintf "%a" Free_variable.pp fv let to_list_of_rows (m : Scikit.Matrix.t) : float list list = - let (lines, cols) = Scikit.Matrix.shape m in + let lines, cols = Scikit.Matrix.shape m in let init n f = List.init ~when_negative_length:() n f |> (* lines/column count cannot be negative *) @@ -258,7 +258,7 @@ let of_list_of_rows (m : float list list) : Scikit.Matrix.t = mat let model_matrix_to_csv (m : Scikit.Matrix.t) (nmap : NMap.t) : Csv.csv = - let (_, cols) = Scikit.Matrix.shape m in + let _, cols = Scikit.Matrix.shape m in let names = List.init ~when_negative_length:() cols (fun i -> fv_to_string (NMap.nth_exn nmap i)) diff --git a/src/lib_benchmark/lib_micheline_rewriting/micheline_with_hash_consing.ml b/src/lib_benchmark/lib_micheline_rewriting/micheline_with_hash_consing.ml index 8cec30a8fa8a..be04ebed7d82 100644 --- a/src/lib_benchmark/lib_micheline_rewriting/micheline_with_hash_consing.ml +++ b/src/lib_benchmark/lib_micheline_rewriting/micheline_with_hash_consing.ml @@ -159,15 +159,15 @@ struct let rec term_lists_equal (lx : node list) (ly : node list) = match (lx, ly) with - | ([], _ :: _) | (_ :: _, []) -> false - | ([], []) -> true - | (hx :: tlx, hy :: tly) -> terms_equal hx hy && term_lists_equal tlx tly + | [], _ :: _ | _ :: _, [] -> false + | [], [] -> true + | hx :: tlx, hy :: tly -> terms_equal hx hy && term_lists_equal tlx tly let rec string_lists_equal (lx : string list) (ly : string list) = match (lx, ly) with - | ([], _ :: _) | (_ :: _, []) -> false - | ([], []) -> true - | (hx :: tlx, hy :: tly) -> + | [], _ :: _ | _ :: _, [] -> false + | [], [] -> true + | hx :: tlx, hy :: tly -> Compare.String.equal hx hy && string_lists_equal tlx tly let prim (head : head) (subterms : node list) (annots : string list) = diff --git a/src/lib_benchmark/lib_micheline_rewriting/path.ml b/src/lib_benchmark/lib_micheline_rewriting/path.ml index b5f020d8e577..fecf7dec9811 100644 --- a/src/lib_benchmark/lib_micheline_rewriting/path.ml +++ b/src/lib_benchmark/lib_micheline_rewriting/path.ml @@ -57,10 +57,10 @@ module Without_hash_consing : S = struct let rec compare path1 path2 = match (path1.rev_path_desc, path2.rev_path_desc) with - | (Root, Root) -> 0 - | (Root, _) -> -1 - | (_, Root) -> 1 - | (At_index (i1, p1), At_index (i2, p2)) -> + | Root, Root -> 0 + | Root, _ -> -1 + | _, Root -> 1 + | At_index (i1, p1), At_index (i2, p2) -> let c = Compare.Int.compare i1 i2 in if c = 0 then compare p1 p2 else c diff --git a/src/lib_benchmark/lib_micheline_rewriting/pattern.ml b/src/lib_benchmark/lib_micheline_rewriting/pattern.ml index a8b2b2ec2ca9..bd251ca44218 100644 --- a/src/lib_benchmark/lib_micheline_rewriting/pattern.ml +++ b/src/lib_benchmark/lib_micheline_rewriting/pattern.ml @@ -181,32 +181,32 @@ struct let rec pattern_matches_aux : type f. (X.t, f) pattern -> node -> bool = fun patt node -> match (patt.patt_desc, node) with - | (Patt_focus patt, _) -> pattern_matches_aux patt node - | (Patt_any, _) -> true - | (Patt_int None, Int (_, _z)) -> true - | (Patt_int (Some zpred), Int (_, z)) -> zpred z - | (Patt_string None, String (_, _s)) -> true - | (Patt_string (Some spred), String (_, s)) -> spred s - | (Patt_bytes None, Bytes (_, _b)) -> true - | (Patt_bytes (Some bpred), Bytes (_, s)) -> bpred s - | (Patt_prim (hpred, subpatts), Prim (_, head, subterms, _)) -> ( + | Patt_focus patt, _ -> pattern_matches_aux patt node + | Patt_any, _ -> true + | Patt_int None, Int (_, _z) -> true + | Patt_int (Some zpred), Int (_, z) -> zpred z + | Patt_string None, String (_, _s) -> true + | Patt_string (Some spred), String (_, s) -> spred s + | Patt_bytes None, Bytes (_, _b) -> true + | Patt_bytes (Some bpred), Bytes (_, s) -> bpred s + | Patt_prim (hpred, subpatts), Prim (_, head, subterms, _) -> ( match hpred with | Patt_head_equal h -> if X.compare h head = 0 then list_matches subpatts subterms else false | Patt_pred pred -> if pred head then list_matches subpatts subterms else false) - | (Patt_seq subpatts, Seq (_, subterms)) -> list_matches subpatts subterms + | Patt_seq subpatts, Seq (_, subterms) -> list_matches subpatts subterms | _ -> false and list_matches : type f. (X.t, f) pattern_list -> node list -> bool = fun patts nodes -> match (patts, nodes) with - | (Patt_list_any, _) -> true - | (Patt_list_empty, []) -> true - | (Patt_list_empty, _ :: _) -> false - | (Patt_list_cons (_, _, _), []) -> false - | (Patt_list_cons (p, lpatt, _), n :: lnodes) -> + | Patt_list_any, _ -> true + | Patt_list_empty, [] -> true + | Patt_list_empty, _ :: _ -> false + | Patt_list_cons (_, _, _), [] -> false + | Patt_list_cons (p, lpatt, _), n :: lnodes -> pattern_matches_aux p n && list_matches lpatt lnodes let pattern_matches (patt : t) (node : node) = @@ -218,7 +218,7 @@ struct | Int _ | String _ | Bytes _ -> if pattern_matches patt node then position :: acc else acc | Prim (_, _, subterms, _) | Seq (_, subterms) -> - let (_, acc) = + let _, acc = List.fold_left (fun (index, acc) subterm -> let position = Path.at_index index position in @@ -361,7 +361,7 @@ end = struct | Int _ | String _ | Bytes _ -> if pattern_matches patt node then position :: acc else acc | Prim (_, _, subterms, _) | Seq (_, subterms) -> - let (_, acc) = + let _, acc = List.fold_left (fun (index, acc) subterm -> let position = Path.at_index index position in diff --git a/src/lib_benchmark/lib_micheline_rewriting/rewrite.ml b/src/lib_benchmark/lib_micheline_rewriting/rewrite.ml index 739ee967f43c..ffd1943d23d3 100644 --- a/src/lib_benchmark/lib_micheline_rewriting/rewrite.ml +++ b/src/lib_benchmark/lib_micheline_rewriting/rewrite.ml @@ -105,15 +105,15 @@ module Make and get_subterm_at : node list -> int -> forward_path -> node = fun subterms index path -> match (subterms, index) with - | ([], _) -> + | [], _ -> let msg = Printf.sprintf "get_subterm_at: non-empty path (%s)" (string_of_forward_path path) in raise (Rewrite_error (msg, None)) - | (hd :: _, 0) -> get_subterm_aux ~term:hd ~path - | (_ :: tl, _) -> get_subterm_at tl (index - 1) path + | hd :: _, 0 -> get_subterm_aux ~term:hd ~path + | _ :: tl, _ -> get_subterm_at tl (index - 1) path let get_subterm : term:node -> path:path -> node = fun ~term ~path -> @@ -137,11 +137,11 @@ module Make and subst_at : node list -> int -> forward_path -> node -> node list = fun subterms index path replacement -> match (subterms, index) with - | ([], _) -> + | [], _ -> let msg = Printf.sprintf "subst_at: empty list (%d)" index in raise (Rewrite_error (msg, None)) - | (hd :: tl, 0) -> subst_aux ~term:hd ~path ~replacement :: tl - | (hd :: tl, _) -> hd :: subst_at tl (index - 1) path replacement + | hd :: tl, 0 -> subst_aux ~term:hd ~path ~replacement :: tl + | hd :: tl, _ -> hd :: subst_at tl (index - 1) path replacement let subst : term:('l, head) Micheline.node -> path:Path.t -> replacement:node -> node diff --git a/src/lib_benchmark/lib_micheline_rewriting/structural_compare.ml b/src/lib_benchmark/lib_micheline_rewriting/structural_compare.ml index 3b89efe13f90..b7d25ba2c5ad 100644 --- a/src/lib_benchmark/lib_micheline_rewriting/structural_compare.ml +++ b/src/lib_benchmark/lib_micheline_rewriting/structural_compare.ml @@ -33,28 +33,28 @@ let rec compare : int = fun ~prim_compare node1 node2 -> match (node1, node2) with - | (Int (_, z1), Int (_, z2)) -> Z.compare z1 z2 - | (Int _, _) -> -1 - | (String _, Int _) -> 1 - | (String (_, s1), String (_, s2)) -> String.compare s1 s2 - | (String _, _) -> -1 - | (Bytes _, Int _) | (Bytes _, String _) -> 1 - | (Bytes (_, b1), Bytes (_, b2)) -> Bytes.compare b1 b2 - | (Bytes _, _) -> -1 - | (Prim _, Int _) | (Prim _, String _) | (Prim _, Bytes _) -> 1 - | (Prim (_, prim1, subterms1, _), Prim (_, prim2, subterms2, _)) -> + | Int (_, z1), Int (_, z2) -> Z.compare z1 z2 + | Int _, _ -> -1 + | String _, Int _ -> 1 + | String (_, s1), String (_, s2) -> String.compare s1 s2 + | String _, _ -> -1 + | Bytes _, Int _ | Bytes _, String _ -> 1 + | Bytes (_, b1), Bytes (_, b2) -> Bytes.compare b1 b2 + | Bytes _, _ -> -1 + | Prim _, Int _ | Prim _, String _ | Prim _, Bytes _ -> 1 + | Prim (_, prim1, subterms1, _), Prim (_, prim2, subterms2, _) -> let c = prim_compare prim1 prim2 in if c <> 0 then c else list_compare ~prim_compare subterms1 subterms2 - | (Prim _, _) -> -1 - | (Seq _, Int _) | (Seq _, String _) | (Seq _, Bytes _) | (Seq _, Prim _) -> 1 - | (Seq (_, subterms1), Seq (_, subterms2)) -> + | Prim _, _ -> -1 + | Seq _, Int _ | Seq _, String _ | Seq _, Bytes _ | Seq _, Prim _ -> 1 + | Seq (_, subterms1), Seq (_, subterms2) -> list_compare ~prim_compare subterms1 subterms2 and list_compare ~prim_compare subterms1 subterms2 = match (subterms1, subterms2) with - | ([], []) -> 0 - | ([], _ :: _) -> -1 - | (_ :: _, []) -> 1 - | (hd1 :: tl1, hd2 :: tl2) -> + | [], [] -> 0 + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | hd1 :: tl1, hd2 :: tl2 -> let c = compare ~prim_compare hd1 hd2 in if c <> 0 then c else list_compare ~prim_compare tl1 tl2 diff --git a/src/lib_benchmark/measure.ml b/src/lib_benchmark/measure.ml index 10386cc3ea12..f52fa1d74e93 100644 --- a/src/lib_benchmark/measure.ml +++ b/src/lib_benchmark/measure.ml @@ -422,7 +422,7 @@ let collect_stats : 'a workload_data -> workloads_stats = let time_dist_data = List.rev_map (fun {qty; _} -> qty) workload_data |> Array.of_list in - let (min, max) = farray_min_max time_dist_data in + let min, max = farray_min_max time_dist_data in let dist = Emp.of_raw_data time_dist_data in let mean = Emp.Float.empirical_mean dist in let var = Emp.Float.empirical_variance dist in @@ -620,7 +620,7 @@ let make_timing_probe (type t) (module O : Compare.COMPARABLE with type t = t) = { Generator.apply = (fun aspect closure -> - let (dt, r) = Time.measure_and_return closure in + let dt, r = Time.measure_and_return closure in Stdlib.Hashtbl.add table aspect dt ; r); aspects = diff --git a/src/lib_benchmark/model.ml b/src/lib_benchmark/model.ml index 86c504a0082e..799ac6e5f9ef 100644 --- a/src/lib_benchmark/model.ml +++ b/src/lib_benchmark/model.ml @@ -42,8 +42,8 @@ let rec elim_arities : type elt m1 m2 a. (elt, m1, a) arity -> (elt, m2, a) arity -> (m1, m2) eq = fun (type elt m1 m2 a) (ar1 : (elt, m1, a) arity) (ar2 : (elt, m2, a) arity) -> match (ar1, ar2) with - | (Zero_arity, Zero_arity) -> (Eq : (m1, m2) eq) - | (Succ_arity a1, Succ_arity a2) -> ( + | Zero_arity, Zero_arity -> (Eq : (m1, m2) eq) + | Succ_arity a1, Succ_arity a2 -> ( match elim_arities a1 a2 with Eq -> (Eq : (m1, m2) eq)) | _ -> . @@ -102,7 +102,7 @@ let apply_model : 'arg -> 'arg model -> applied = match arity with | Zero_arity -> f | Succ_arity ar -> - let (arg, rest) = arg in + let arg, rest = arg in apply conv ar (X.app f (conv arg)) rest let applied = apply X.int arity model elim @@ -128,7 +128,7 @@ module Instantiate (X : Costlang.S) (M : Model_impl) : match arity with | Zero_arity -> f | Succ_arity ar -> - let (arg, rest) = arg in + let arg, rest = arg in apply conv ar (X.app f (conv arg)) rest let model elim = apply X.int arity model elim diff --git a/src/lib_benchmark/override.ml b/src/lib_benchmark/override.ml index f7fe3c22f466..cc8890ca9e72 100644 --- a/src/lib_benchmark/override.ml +++ b/src/lib_benchmark/override.ml @@ -38,7 +38,7 @@ let add_into_map name duration map = let load_file ~filename map = let lines = Csv.import ~filename () in - let (header, values) = + let header, values = match lines with | [] | [_] | _ :: _ :: _ :: _ -> Stdlib.failwith "Override.load: invalid csv" diff --git a/src/lib_benchmark/registration.ml b/src/lib_benchmark/registration.ml index 0ae08dc94e0f..0d4f1bb26f76 100644 --- a/src/lib_benchmark/registration.ml +++ b/src/lib_benchmark/registration.ml @@ -72,8 +72,8 @@ let all_benchmarks_with_all_of (tags : string list) : Benchmark.t list = let rec list_equal l1 l2 = match (l1, l2) with - | ([], []) -> true - | (x :: t, y :: u) -> String.equal x y && list_equal t u + | [], [] -> true + | x :: t, y :: u -> String.equal x y && list_equal t u | _ -> false let all_benchmarks_with_exactly (tags : string list) : Benchmark.t list = diff --git a/src/lib_benchmark/scikit.ml b/src/lib_benchmark/scikit.ml index aaffc78d92ca..3f9c0d5cb3e1 100644 --- a/src/lib_benchmark/scikit.ml +++ b/src/lib_benchmark/scikit.ml @@ -34,7 +34,7 @@ end module LinearModel = struct let assert_matrix_nontrivial (m : Matrix.t) = - let (l, c) = Matrix.shape m in + let l, c = Matrix.shape m in assert (l <> 0 && c <> 0) let ridge ~(alpha : float) ?(fit_intercept : bool = false) diff --git a/src/lib_benchmark/sparse_vec.ml b/src/lib_benchmark/sparse_vec.ml index 547d5de2dd4b..7ed5a369d2cc 100644 --- a/src/lib_benchmark/sparse_vec.ml +++ b/src/lib_benchmark/sparse_vec.ml @@ -141,14 +141,14 @@ module Make (M : Tezos_error_monad.TzLwtreslib.Map.S) : let swap vec i j = match (M.find_opt i vec, M.find_opt j vec) with - | (None, None) -> vec - | (Some elt, None) -> + | None, None -> vec + | Some elt, None -> let vec = set vec i R.zero in set vec j elt - | (None, Some elt) -> + | None, Some elt -> let vec = set vec j R.zero in set vec i elt - | (Some e1, Some e2) -> + | Some e1, Some e2 -> let vec = set vec i e2 in set vec j e1 diff --git a/src/lib_benchmark/test/test_probe.ml b/src/lib_benchmark/test/test_probe.ml index 3f35d9980bb2..ca985f295bb0 100644 --- a/src/lib_benchmark/test/test_probe.ml +++ b/src/lib_benchmark/test/test_probe.ml @@ -32,10 +32,10 @@ module Aspect = struct let compare (x : t) (y : t) = match (x, y) with - | (Hashing_Sha256, Hashing_Sha256) -> 0 - | (Hashing_Blake2b, Hashing_Blake2b) -> 0 - | (Hashing_Blake2b, Hashing_Sha256) -> -1 - | (Hashing_Sha256, Hashing_Blake2b) -> 1 + | Hashing_Sha256, Hashing_Sha256 -> 0 + | Hashing_Blake2b, Hashing_Blake2b -> 0 + | Hashing_Blake2b, Hashing_Sha256 -> -1 + | Hashing_Sha256, Hashing_Blake2b -> 1 end type workload = Blake2b of {nbytes : int} | Sha256 of {nbytes : int} diff --git a/src/lib_clic/clic.ml b/src/lib_clic/clic.ml index 75569eb0ab8a..8c076c084d0b 100644 --- a/src/lib_clic/clic.ml +++ b/src/lib_clic/clic.ml @@ -152,7 +152,7 @@ let trim s = TzString.split_no_empty '\n' s |> List.map String.trim |> String.concat "\n" let print_desc ppf doc = - let (short, long) = + let short, long = match String.index_opt doc '\n' with | None -> (doc, None) | Some len -> @@ -363,7 +363,7 @@ let print_command : type ex_command = Ex : _ command -> ex_command let group_commands commands = - let (grouped, ungrouped) = + let grouped, ungrouped = List.fold_left (fun (grouped, ungrouped) (Ex (Command {group; _}) as command) -> match group with @@ -968,21 +968,21 @@ let make_args_dict_consume ?command spec args = | Some (arity, long) -> ( let* () = check_help_flag ?command tl in match (arity, tl) with - | (0, tl') -> + | 0, tl' -> make_args_dict completing arities (add_occurrence long "" acc) tl' - | (1, value :: tl') -> + | 1, value :: tl' -> make_args_dict completing arities (add_occurrence long value acc) tl' - | (1, []) when completing -> return (acc, []) - | (1, []) -> tzfail (Option_expected_argument (arg, None)) - | (_, _) -> + | 1, [] when completing -> return (acc, []) + | 1, [] -> tzfail (Option_expected_argument (arg, None)) + | _, _ -> Stdlib.failwith "cli_entries: Arguments with arity not equal to 1 or 0 \ unsupported") @@ -1006,24 +1006,24 @@ let make_args_dict_filter ?command spec args = | Some (arity, long) -> ( let* () = check_help_flag ?command tl in match (arity, tl) with - | (0, tl) -> + | 0, tl -> make_args_dict arities (add_occurrence long "" dict, other_args) tl - | (1, value :: tl') -> + | 1, value :: tl' -> make_args_dict arities (add_occurrence long value dict, other_args) tl' - | (1, []) -> tzfail (Option_expected_argument (arg, command)) - | (_, _) -> + | 1, [] -> tzfail (Option_expected_argument (arg, command)) + | _, _ -> Stdlib.failwith "cli_entries: Arguments with arity not equal to 1 or 0 \ unsupported") | None -> make_args_dict arities (dict, arg :: other_args) tl) in - let+ (dict, remaining) = + let+ dict, remaining = make_args_dict (make_arities_dict spec StringMap.empty) (StringMap.empty, []) @@ -1041,8 +1041,8 @@ let seq_of_param param = let non_terminal_seq ~suffix param next = match (suffix, param Stop) with - | ([], _) -> invalid_arg "Clic.non_terminal_seq: empty suffix" - | (_, Param (n, desc, parameter, Stop)) -> + | [], _ -> invalid_arg "Clic.non_terminal_seq: empty suffix" + | _, Param (n, desc, parameter, Stop) -> NonTerminalSeq (n, desc, parameter, suffix, next) | _ -> invalid_arg "Clic.non_terminal_seq" @@ -1104,8 +1104,8 @@ let exec (type ctx) int -> ctx -> (a, ctx) params -> a -> string list -> unit tzresult Lwt.t = fun i ctx spec cb params -> match (spec, params) with - | (Stop, _) -> cb ctx - | (Seq (_, _, {converter; _}), seq) -> + | Stop, _ -> cb ctx + | Seq (_, _, {converter; _}), seq -> let rec do_seq i acc = function | [] -> return (List.rev acc) | p :: rest -> @@ -1117,20 +1117,20 @@ let exec (type ctx) in let* parsed = do_seq i [] seq in cb parsed ctx - | (NonTerminalSeq (_, _, {converter; _}, suffix, next), seq) -> + | NonTerminalSeq (_, _, {converter; _}, suffix, next), seq -> let rec do_seq i acc = function | [] -> return (List.rev acc, []) | p :: rest as params -> (* try to match suffix first *) let rec match_suffix = function - | (param :: params, suffix :: suffixes) when param = suffix -> + | param :: params, suffix :: suffixes when param = suffix -> match_suffix (params, suffixes) - | (params, []) -> + | params, [] -> (* all of the suffix parts have been matched *) (params, true) - | (_, _) -> (params, false) + | _, _ -> (params, false) in - let (unmatched_rest, matched) = match_suffix (params, suffix) in + let unmatched_rest, matched = match_suffix (params, suffix) in if matched then return (List.rev acc, unmatched_rest) else (* if suffix is not match, try to continue with the sequence *) @@ -1138,10 +1138,10 @@ let exec (type ctx) let* v = converter ctx p in do_seq (succ i) (v :: acc) rest) in - let* (parsed, rest) = do_seq i [] seq in + let* parsed, rest = do_seq i [] seq in exec (succ i) ctx next (cb parsed) rest - | (Prefix (n, next), p :: rest) when n = p -> exec (succ i) ctx next cb rest - | (Param (_, _, {converter; _}, next), p :: rest) -> + | Prefix (n, next), p :: rest when n = p -> exec (succ i) ctx next cb rest + | Param (_, _, {converter; _}, next), p :: rest -> let* v = Error_monad.catch_es (fun () -> converter ctx p) |> trace (Bad_argument (i, p)) @@ -1205,47 +1205,46 @@ let insert_in_dispatch_tree : type ctx. ctx tree -> ctx command -> ctx tree = in let conv_autocomplete = Option.map (fun a c -> a (conv c)) in match (t, c) with - | (TEmpty, Stop) -> TStop command - | (TEmpty, Seq (_, _, {autocomplete; _})) -> + | TEmpty, Stop -> TStop command + | TEmpty, Seq (_, _, {autocomplete; _}) -> TSeq (command, conv_autocomplete autocomplete) - | (TEmpty, Param (_, _, {autocomplete; _}, next)) -> + | TEmpty, Param (_, _, {autocomplete; _}, next) -> let autocomplete = conv_autocomplete autocomplete in TParam {tree = insert_tree TEmpty next; stop = None; autocomplete} - | (TEmpty, NonTerminalSeq (name, desc, {autocomplete; _}, suffix, next)) -> + | TEmpty, NonTerminalSeq (name, desc, {autocomplete; _}, suffix, next) -> let autocomplete = conv_autocomplete autocomplete in let tree = suffix_to_tree suffix next in TNonTerminalSeq {stop = None; tree; autocomplete; suffix; name; desc} - | (TEmpty, Prefix (n, next)) -> + | TEmpty, Prefix (n, next) -> TPrefix {stop = None; prefix = [(n, insert_tree TEmpty next)]} - | (TStop cmd, Param (_, _, {autocomplete; _}, next)) -> + | TStop cmd, Param (_, _, {autocomplete; _}, next) -> let autocomplete = conv_autocomplete autocomplete in if not (has_options cmd) then TParam {tree = insert_tree TEmpty next; stop = Some cmd; autocomplete} else Stdlib.failwith "Command cannot have both prefix and options" - | (TStop cmd, Prefix (n, next)) -> + | TStop cmd, Prefix (n, next) -> TPrefix {stop = Some cmd; prefix = [(n, insert_tree TEmpty next)]} - | (TStop cmd, NonTerminalSeq (name, desc, {autocomplete; _}, suffix, next)) - -> + | TStop cmd, NonTerminalSeq (name, desc, {autocomplete; _}, suffix, next) -> let autocomplete = conv_autocomplete autocomplete in let tree = suffix_to_tree suffix next in TNonTerminalSeq {stop = Some cmd; tree; autocomplete; suffix; name; desc} - | (TParam t, Param (_, _, _, next)) -> + | TParam t, Param (_, _, _, next) -> TParam {t with tree = insert_tree t.tree next} - | (TPrefix ({prefix; _} as l), Prefix (n, next)) -> + | TPrefix ({prefix; _} as l), Prefix (n, next) -> let rec insert_prefix = function | [] -> [(n, insert_tree TEmpty next)] | (n', t) :: rest when n = n' -> (n, insert_tree t next) :: rest | item :: rest -> item :: insert_prefix rest in TPrefix {l with prefix = insert_prefix prefix} - | (TPrefix ({stop = None; _} as l), Stop) -> + | TPrefix ({stop = None; _} as l), Stop -> TPrefix {l with stop = Some command} - | (TParam ({stop = None; _} as l), Stop) -> + | TParam ({stop = None; _} as l), Stop -> TParam {l with stop = Some command} - | (TParam t, Prefix (_n, next)) -> + | TParam t, Prefix (_n, next) -> TParam {t with tree = insert_tree t.tree next} - | (TNonTerminalSeq t, NonTerminalSeq (n, desc, _, suffix, next)) -> + | TNonTerminalSeq t, NonTerminalSeq (n, desc, _, suffix, next) -> if n <> t.name || desc <> t.desc || t.suffix <> suffix (* we should match the parameter too but this would require a bit of refactoring*) @@ -1256,7 +1255,7 @@ let insert_in_dispatch_tree : type ctx. ctx tree -> ctx command -> ctx tree = else let params = suffix_to_params suffix next in TNonTerminalSeq {t with tree = insert_tree t.tree params} - | (_, _) -> + | _, _ -> Stdlib.failwith (Format.asprintf "Clic.Command_tree.insert: conflicting commands \"%a\"" @@ -1298,9 +1297,9 @@ let find_command tree initial_arguments = | [] -> assert false | [command] -> tzfail (Help (Some command)) | more -> tzfail (Unterminated_command (initial_arguments, more))) - | (TStop c, []) -> return (c, empty_args_dict, initial_arguments) - | (TStop (Command {options; _} as command), remaining) -> ( - let* (args_dict, unparsed) = + | TStop c, [] -> return (c, empty_args_dict, initial_arguments) + | TStop (Command {options; _} as command), remaining -> ( + let* args_dict, unparsed = make_args_dict_filter ~command options remaining in match unparsed with @@ -1309,31 +1308,31 @@ let find_command tree initial_arguments = if String.length hd > 0 && hd.[0] = '-' then tzfail (Unknown_option (hd, Some command)) else tzfail (Extra_arguments (unparsed, command))) - | (TSeq ((Command {options; _} as command), _), remaining) -> + | TSeq ((Command {options; _} as command), _), remaining -> if List.exists (function "-h" | "--help" -> true | _ -> false) remaining then tzfail (Help (Some command)) else - let+ (dict, remaining) = + let+ dict, remaining = make_args_dict_filter ~command options remaining in (command, dict, List.rev_append acc remaining) - | (TNonTerminalSeq {stop = None; _}, ([] | ("-h" | "--help") :: _)) -> + | TNonTerminalSeq {stop = None; _}, ([] | ("-h" | "--help") :: _) -> tzfail (Unterminated_command (initial_arguments, gather_commands tree)) - | (TNonTerminalSeq {stop = Some c; _}, []) -> + | TNonTerminalSeq {stop = Some c; _}, [] -> return (c, empty_args_dict, initial_arguments) | ( (TNonTerminalSeq {tree; suffix; _} as nts), (parameter :: arguments' as remaining) ) -> (* try to match suffix first *) let rec match_suffix matched_acc = function - | (param :: params, suffix :: suffixes) when param = suffix -> + | param :: params, suffix :: suffixes when param = suffix -> match_suffix (param :: matched_acc) (params, suffixes) - | (_, []) -> + | _, [] -> (* all of the suffix parts have been matched *) true - | (_, _) -> false + | _, _ -> false in let matched = match_suffix [] (remaining, suffix) in if matched then @@ -1342,21 +1341,21 @@ let find_command tree initial_arguments = else (* continue traversing with the current node (non-terminal sequence) *) traverse nts arguments' (parameter :: acc) - | (TPrefix {stop = Some cmd; _}, []) -> + | TPrefix {stop = Some cmd; _}, [] -> return (cmd, empty_args_dict, initial_arguments) - | (TPrefix {stop = None; prefix}, ([] | ("-h" | "--help") :: _)) -> + | TPrefix {stop = None; prefix}, ([] | ("-h" | "--help") :: _) -> tzfail (Unterminated_command (initial_arguments, gather_assoc prefix)) - | (TPrefix {prefix; _}, hd_arg :: tl) -> ( + | TPrefix {prefix; _}, hd_arg :: tl -> ( match List.assoc ~equal:String.equal hd_arg prefix with | None -> tzfail (Command_not_found (List.rev acc, gather_assoc prefix)) | Some tree' -> traverse tree' tl (hd_arg :: acc)) - | (TParam {stop = None; _}, ([] | ("-h" | "--help") :: _)) -> + | TParam {stop = None; _}, ([] | ("-h" | "--help") :: _) -> tzfail (Unterminated_command (initial_arguments, gather_commands tree)) - | (TParam {stop = Some c; _}, []) -> + | TParam {stop = Some c; _}, [] -> return (c, empty_args_dict, initial_arguments) - | (TParam {tree; _}, parameter :: arguments') -> + | TParam {tree; _}, parameter :: arguments' -> traverse tree arguments' (parameter :: acc) - | (TEmpty, _) -> tzfail (Command_not_found (List.rev acc, [])) + | TEmpty, _ -> tzfail (Command_not_found (List.rev acc, [])) in traverse tree initial_arguments [] @@ -1421,14 +1420,14 @@ let complete_options (type ctx) continuation args args_spec ind (ctx : ctx) = | Some (arity, long) -> ( let seen = StringSet.add long seen in match (arity, tl) with - | (0, args) when ind = 0 -> + | 0, args when ind = 0 -> let+ cont_args = continuation args 0 in remaining_spec seen args_spec @ cont_args - | (0, args) -> help args (ind - 1) seen - | (1, _) when ind = 1 -> + | 0, args -> help args (ind - 1) seen + | 1, _ when ind = 1 -> let* res = complete_spec arg args_spec in return (Option.value ~default:[] res) - | (1, _ :: tl) -> help tl (ind - 2) seen + | 1, _ :: tl -> help tl (ind - 2) seen | _ -> Stdlib.failwith "cli_entries internal error, invalid arity") | None -> continuation args ind) in @@ -1454,7 +1453,7 @@ let complete_next_tree cctxt = | TEmpty -> return_nil let rec args_starting_from_suffix original_suffix ind matched_args = function - | ((s :: s_rest as suffix), a :: a_rest) -> + | (s :: s_rest as suffix), a :: a_rest -> if s = a then args_starting_from_suffix original_suffix @@ -1472,7 +1471,7 @@ let rec args_starting_from_suffix original_suffix ind matched_args = function (* After there is a suffix match, the rest of the suffix has to be matched in the following args, unless it's empty. *) None - | (unmatched_suffix, args) + | unmatched_suffix, args (* Partial or full suffix match found *) when Compare.List_lengths.(unmatched_suffix < original_suffix) -> Some (matched_args @ args, ind) @@ -1484,20 +1483,19 @@ let complete_tree cctxt tree index args = if ind = 0 then complete_next_tree cctxt tree else match (tree, args) with - | (TSeq _, _) -> complete_next_tree cctxt tree - | ((TNonTerminalSeq {tree; suffix; _} as this_tree), _ :: _tl) -> ( + | TSeq _, _ -> complete_next_tree cctxt tree + | (TNonTerminalSeq {tree; suffix; _} as this_tree), _ :: _tl -> ( match args_starting_from_suffix suffix ind [] (suffix, args) with | Some (args, ind) -> help tree args ind | _ -> complete_next_tree cctxt this_tree) - | (TPrefix {prefix; _}, hd :: tl) -> ( + | TPrefix {prefix; _}, hd :: tl -> ( match List.assoc ~equal:String.equal hd prefix with | None -> return_nil | Some p -> help p tl (ind - 1)) - | (TParam {tree; _}, _ :: tl) -> help tree tl (ind - 1) - | (TStop (Command {options; conv; _}), args) -> + | TParam {tree; _}, _ :: tl -> help tree tl (ind - 1) + | TStop (Command {options; conv; _}), args -> complete_options (fun _ _ -> return_nil) args options ind (conv cctxt) - | ((TParam _ | TPrefix _ | TNonTerminalSeq _), []) | (TEmpty, _) -> - return_nil + | (TParam _ | TPrefix _ | TNonTerminalSeq _), [] | TEmpty, _ -> return_nil in help tree args index @@ -1534,7 +1532,7 @@ let autocompletion ~script ~cur_arg ~prev_arg ~args ~global_options commands let parse_global_options global_options ctx args = let open Lwt_result_syntax in - let* (dict, remaining) = make_args_dict_consume global_options args in + let* dict, remaining = make_args_dict_consume global_options args in let* nested = parse_arg global_options dict ctx in return (nested, remaining) @@ -1553,7 +1551,7 @@ let dispatch commands ctx args = tzfail (Help None) | [("-h" | "--help")] -> tzfail (Help None) | _ -> - let* (command, args_dict, filtered_args) = find_command tree args in + let* command, args_dict, filtered_args = find_command tree args in exec command ctx filtered_args args_dict type error += No_manual_entry of string list @@ -1732,9 +1730,9 @@ let pp_cli_errors ppf ~executable_name ~global_options ~default errs = let rec pp acc errs = let return command = match (command, acc) with - | (None, _) -> acc - | (Some command, Some commands) -> Some (command @ commands) - | (Some command, None) -> Some command + | None, _ -> acc + | Some command, Some commands -> Some (command @ commands) + | Some command, None -> Some command in match errs with | [] -> None diff --git a/src/lib_clic/test/test_clic.ml b/src/lib_clic/test/test_clic.ml index 6b660cec7348..53530e4db672 100644 --- a/src/lib_clic/test/test_clic.ml +++ b/src/lib_clic/test/test_clic.ml @@ -96,8 +96,8 @@ let expect_result line pr exp got = let* got = protect got in if match (got, exp) with - | (Ok got, Ok exp) -> got = exp - | (Error got, Error exp) -> + | Ok got, Ok exp -> got = exp + | Error got, Error exp -> let got = Format.asprintf "%a" pp_print_trace got in Stringext.find_from got ~pattern:exp <> None | _ -> false @@ -332,7 +332,7 @@ let int_param ~autocomplete next = let test_autocompletion_case ~commands ~args ~expected () = let open Lwt_result_syntax in let script = "script" in - let (prev_arg, cur_arg) = + let prev_arg, cur_arg = match List.rev args with | [] -> (script, "") | [cur_arg] -> (script, cur_arg) diff --git a/src/lib_client_base/client_aliases.ml b/src/lib_client_base/client_aliases.ml index fd4c7fe1881f..efcbe644febf 100644 --- a/src/lib_client_base/client_aliases.ml +++ b/src/lib_client_base/client_aliases.ml @@ -197,7 +197,7 @@ module Alias (Entity : Entity) = struct let* mtime = wallet#last_modification_time Entity.name in let cache = peek_cache wallet in match (mtime, cache) with - | (Some fresh_mtime, Some {mtime = Some cache_mtime; _}) + | Some fresh_mtime, Some {mtime = Some cache_mtime; _} when fresh_mtime = cache_mtime -> return (WithExceptions.Option.get ~loc:__LOC__ cache) | _ -> diff --git a/src/lib_client_base/client_confirmations.ml b/src/lib_client_base/client_confirmations.ml index a4bbb04fa937..3eecb9fabe73 100644 --- a/src/lib_client_base/client_confirmations.ml +++ b/src/lib_client_base/client_confirmations.ml @@ -152,7 +152,7 @@ let wait_for_operation_inclusion (ctxt : #Client_context.full) ~chain | Error err -> Lwt.fail (WrapError err)) | None -> Lwt.return_unit in - let* (stream, stop) = Shell_services.Monitor.heads ctxt chain in + let* stream, stop = Shell_services.Monitor.heads ctxt chain in let*! o = Lwt_stream.get stream in match o with | None -> assert false @@ -289,7 +289,7 @@ let wait_for_bootstrapped ?(retry = fun f x -> f x) ctxt#error "Progress not monitored anymore\n%!" in ()) ; - let* (stream, _stop) = retry Monitor_services.bootstrapped ctxt in + let* stream, _stop = retry Monitor_services.bootstrapped ctxt in let*! () = Lwt_stream.iter_s (fun (hash, time) -> diff --git a/src/lib_client_base/client_keys.ml b/src/lib_client_base/client_keys.ml index 22a2aa533f20..6c0f200bcb7d 100644 --- a/src/lib_client_base/client_keys.ml +++ b/src/lib_client_base/client_keys.ml @@ -269,7 +269,7 @@ module Public_key = Client_aliases.Alias (struct Json_only ~title:"Locator_only" uri_encoding - (function (uri, None) -> Some uri | (_, Some _) -> None) + (function uri, None -> Some uri | _, Some _ -> None) (fun uri -> (uri, None)); case Json_only @@ -277,7 +277,7 @@ module Public_key = Client_aliases.Alias (struct (obj2 (req "locator" uri_encoding) (req "key" Signature.Public_key.encoding)) - (function (uri, Some key) -> Some (uri, key) | (_, None) -> None) + (function uri, Some key -> Some (uri, key) | _, None -> None) (fun (uri, key) -> (uri, Some key)); ] end) @@ -407,7 +407,7 @@ module Aggregate_alias = struct Json_only uri_encoding ~title:"Locator_only" - (function (uri, None) -> Some uri | (_, Some _) -> None) + (function uri, None -> Some uri | _, Some _ -> None) (fun uri -> (uri, None)); case Json_only @@ -415,7 +415,7 @@ module Aggregate_alias = struct (obj2 (req "locator" uri_encoding) (req "key" Aggregate_signature.Public_key.encoding)) - (function (uri, Some key) -> Some (uri, key) | (_, None) -> None) + (function uri, Some key -> Some (uri, key) | _, None -> None) (fun (uri, key) -> (uri, Some key)); ] end) @@ -653,11 +653,11 @@ let sign cctxt ?watermark sk_uri buf = | Some name -> ( let* r = Public_key.find cctxt name in match r with - | (_, None) -> + | _, None -> let* pk = public_key pk_uri in let* () = Public_key.update cctxt name (pk_uri, Some pk) in return pk - | (_, Some pubkey) -> return pubkey) + | _, Some pubkey -> return pubkey) in let* () = fail_unless @@ -725,8 +725,8 @@ let register_keys cctxt xs = we take it. *) let join_keys keys1_opt keys2 = match (keys1_opt, keys2) with - | (Some (_, Some _, None), (_, None, None)) -> keys1_opt - | (Some (_, _, Some _), _) -> keys1_opt + | Some (_, Some _, None), (_, None, None) -> keys1_opt + | Some (_, _, Some _), _ -> keys1_opt | _ -> Some keys2 (* For efficiency, this function avoids loading the wallet, except for @@ -795,18 +795,18 @@ let get_key cctxt pkh = let open Lwt_result_syntax in let* r = raw_get_key cctxt pkh in match r with - | (pkh, Some pk, Some sk) -> return (pkh, pk, sk) - | (_pkh, _pk, None) -> + | pkh, Some pk, Some sk -> return (pkh, pk, sk) + | _pkh, _pk, None -> failwith "Unknown secret key for %a" Signature.Public_key_hash.pp pkh - | (_pkh, None, _sk) -> + | _pkh, None, _sk -> failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh let get_public_key cctxt pkh = let open Lwt_result_syntax in let* r = raw_get_key cctxt pkh in match r with - | (pkh, Some pk, _sk) -> return (pkh, pk) - | (_pkh, None, _sk) -> + | pkh, Some pk, _sk -> return (pkh, pk) + | _pkh, None, _sk -> failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh let get_keys (cctxt : #Client_context.wallet) = @@ -964,13 +964,13 @@ let aggregate_sign cctxt sk_uri buf = | Some name -> ( let* r = Aggregate_alias.Public_key.find cctxt name in match r with - | (_, None) -> + | _, None -> let* pk = aggregate_public_key pk_uri in let* () = Aggregate_alias.Public_key.update cctxt name (pk_uri, Some pk) in return pk - | (_, Some pubkey) -> return pubkey) + | _, Some pubkey -> return pubkey) in let* () = fail_unless diff --git a/src/lib_client_base/test/bip39_tests.ml b/src/lib_client_base/test/bip39_tests.ml index b2ca8af8a74a..0259f73e026d 100644 --- a/src/lib_client_base/test/bip39_tests.ml +++ b/src/lib_client_base/test/bip39_tests.ml @@ -244,8 +244,7 @@ let vectors = let pp_diff ppf (l1, l2) = match (List.length l1, List.length l2) with - | (n, m) when n <> m -> - Format.fprintf ppf "Mnemonic size differs: %d vs %d" n m + | n, m when n <> m -> Format.fprintf ppf "Mnemonic size differs: %d vs %d" n m | _ -> ignore @@ ListLabels.fold_left2 l1 l2 ~init:0 ~f:(fun i w1 w2 -> diff --git a/src/lib_client_base_unix/client_config.ml b/src/lib_client_base_unix/client_config.ml index ec054f86850f..484cd696e894 100644 --- a/src/lib_client_base_unix/client_config.ml +++ b/src/lib_client_base_unix/client_config.ml @@ -349,7 +349,7 @@ let endpoint_parameter () = ("only http and https endpoints are supported: " ^ x)) in match (Uri.query parsed, Uri.fragment parsed) with - | ([], None) -> return parsed + | [], None -> return parsed | _ -> tzfail (Invalid_endpoint_arg @@ -678,7 +678,7 @@ let config_show_mockup (cctxt : #Client_context.full) (protocol_hash_opt : Protocol_hash.t option) (base_dir : string) = let open Lwt_result_syntax in let* () = fail_on_non_mockup_dir cctxt in - let* (mockup, _) = + let* mockup, _ = Tezos_mockup.Persistence.get_mockup_context_from_disk ~base_dir ~protocol_hash:protocol_hash_opt @@ -732,7 +732,7 @@ let config_init_mockup cctxt protocol_hash_opt bootstrap_accounts_file mockup_protocol_constants protocol_constants_file) in - let* (mockup, _) = + let* mockup, _ = Tezos_mockup.Persistence.get_mockup_context_from_disk ~base_dir ~protocol_hash:protocol_hash_opt @@ -989,21 +989,21 @@ let build_endpoint addr port tls = let light_mode_checks mode endpoint sources = let open Lwt_result_syntax in match (mode, sources) with - | (`Mode_client, None) | (`Mode_mockup, None) | (`Mode_proxy, None) -> + | `Mode_client, None | `Mode_mockup, None | `Mode_proxy, None -> (* No --mode light, no --sources; good *) return_unit - | (`Mode_client, Some _) | (`Mode_mockup, Some _) | (`Mode_proxy, Some _) -> + | `Mode_client, Some _ | `Mode_mockup, Some _ | `Mode_proxy, Some _ -> (* --sources without the light mode: wrong *) failwith "--sources is specified whereas mode is %s. --sources should only be \ used with --mode light." @@ client_mode_to_string mode - | (`Mode_light, None) -> + | `Mode_light, None -> (* --mode light without --sources: wrong *) failwith "--mode light requires passing --sources. Example --sources file: %s" Tezos_proxy.Light.example_sources - | (`Mode_light, Some sources) -> + | `Mode_light, Some sources -> let sources_uris = Tezos_proxy.Light.sources_config_to_uris sources in if List.mem ~equal:Uri.equal endpoint sources_uris then return_unit else @@ -1185,9 +1185,7 @@ let parse_config_args (ctx : #Client_context.full) argv = Format.eprintf "%s is not a directory.@." config_dir ; exit 1) ; let* () = - unless - (client_mode = `Mode_mockup) - (fun () -> + unless (client_mode = `Mode_mockup) (fun () -> let*! () = Lwt_utils_unix.create_dir config_dir in return_unit) in diff --git a/src/lib_client_base_unix/client_context_unix.ml b/src/lib_client_base_unix/client_context_unix.ml index 9ce5f4b3f03c..cba77c520aae 100644 --- a/src/lib_client_base_unix/client_context_unix.ml +++ b/src/lib_client_base_unix/client_context_unix.ml @@ -69,7 +69,7 @@ class unix_wallet ~base_dir ~password_filename : Client_context.wallet = in Lwt.return (fd, sighandler) in - let* (fd, sh) = lock () in + let* fd, sh = lock () in (* catch might be useless if f always uses the error monad *) let* res = Lwt.finalize f (fun () -> diff --git a/src/lib_client_base_unix/client_main_run.ml b/src/lib_client_base_unix/client_main_run.ml index ae321ecb8579..a4be8f354b2f 100644 --- a/src/lib_client_base_unix/client_main_run.ml +++ b/src/lib_client_base_unix/client_main_run.ml @@ -87,7 +87,7 @@ let setup_remote_signer (module C : M) client_config match List.filter_map (function - | (_, known_pkh, _, Some known_sk_uri) + | _, known_pkh, _, Some known_sk_uri when List.exists (fun pkh -> Signature.Public_key_hash.equal pkh known_pkh) pkhs -> @@ -176,7 +176,7 @@ let setup_default_proxy_client_config parsed_args base_dir rpc_config mode = base_dir | _ -> return_unit in - let (chain, block, confirmations, password_filename, protocol, sources) = + let chain, block, confirmations, password_filename, protocol, sources = match parsed_args with | None -> ( Client_config.default_chain, @@ -218,11 +218,11 @@ let setup_default_proxy_client_config parsed_args base_dir rpc_config mode = in let get_mode () = match (mode, sources) with - | (`Mode_proxy, _) -> return Tezos_proxy.Proxy_services.Proxy_client - | (`Mode_light, None) -> + | `Mode_proxy, _ -> return Tezos_proxy.Proxy_services.Proxy_client + | `Mode_light, None -> failwith "--sources MUST be specified when --mode light is specified" - | (`Mode_light, Some sources_config) -> + | `Mode_light, Some sources_config -> let*! () = warn_if_duplicates_light_sources printer sources_config.uris in @@ -275,8 +275,7 @@ let setup_mockup_rpc_client_config ~bootstrap_accounts_json:None in let* b = Tezos_mockup.Persistence.classify_base_dir base_dir in - let* ((mockup_env, {chain = chain_id; rpc_context; protocol_data}), mem_only) - = + let* (mockup_env, {chain = chain_id; rpc_context; protocol_data}), mem_only = match b with | Tezos_mockup.Persistence.Base_dir_is_empty | Tezos_mockup.Persistence.Base_dir_is_file @@ -322,7 +321,7 @@ let main (module C : M) ~select_commands = let open Lwt_result_syntax in let global_options = C.global_options () in let executable_name = Filename.basename Sys.executable_name in - let (original_args, autocomplete) = + let original_args, autocomplete = (* for shell aliases *) let rec move_autocomplete_token_upfront acc = function | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args -> @@ -363,7 +362,7 @@ let main (module C : M) ~select_commands = ~verbose_rpc_error_diagnostics:false in let*! r = - let* (parsed, remaining) = C.parse_config_args full original_args in + let* parsed, remaining = C.parse_config_args full original_args in let parsed_config_file = parsed.Client_config.parsed_config_file and parsed_args = parsed.Client_config.parsed_args and config_commands = parsed.Client_config.config_commands in diff --git a/src/lib_client_base_unix/test/test_mockup_wallet.ml b/src/lib_client_base_unix/test/test_mockup_wallet.ml index c156eef2ee46..2bbd65103283 100644 --- a/src/lib_client_base_unix/test/test_mockup_wallet.ml +++ b/src/lib_client_base_unix/test/test_mockup_wallet.ml @@ -63,8 +63,8 @@ let testable_string_list_ignoring_order : string list Alcotest.testable = let validate_key (_, pk_hash, pk_sig_opt, sk_uri_opt) = let open Lwt_result_syntax in match (pk_sig_opt, sk_uri_opt) with - | (Some pk_sig, Some sk_uri) -> ( - let* (pk_hash_from_sk, pk_sig_from_sk_opt) = + | Some pk_sig, Some sk_uri -> ( + let* pk_hash_from_sk, pk_sig_from_sk_opt = let* pk = Client_keys.neuterize sk_uri in Client_keys.public_key_hash pk in @@ -82,7 +82,7 @@ let validate_key (_, pk_hash, pk_sig_opt, sk_uri_opt) = "PK is consistent with SK" pk_sig pk_sig_from_sk)) - | (_, _) -> failwith "Key has no public signature or secret key" + | _, _ -> failwith "Key has no public signature or secret key" (** Check that names in [key_list] match the ones in [accounts_names], ignoring order *) diff --git a/src/lib_client_commands/client_admin_commands.ml b/src/lib_client_commands/client_admin_commands.ml index 7c69dd897d00..0b9731720eb3 100644 --- a/src/lib_client_commands/client_admin_commands.ml +++ b/src/lib_client_commands/client_admin_commands.ml @@ -95,7 +95,7 @@ let commands () = no_options (fixed ["show"; "current"; "checkpoint"]) (fun () (cctxt : #Client_context.full) -> - let* (checkpoint_hash, checkpoint_level) = + let* checkpoint_hash, checkpoint_level = Shell_services.Chain.Levels.checkpoint cctxt ~chain:cctxt#chain () in let*! () = diff --git a/src/lib_client_commands/client_event_logging_commands.ml b/src/lib_client_commands/client_event_logging_commands.ml index b1f22268113c..2ad43de4487d 100644 --- a/src/lib_client_commands/client_event_logging_commands.ml +++ b/src/lib_client_commands/client_event_logging_commands.ml @@ -161,7 +161,7 @@ let commands () = let time_query = Option.merge (fun a b -> `And (a, b)) since until in - let* (errors_and_warnings, ()) = + let* errors_and_warnings, () = File_event_sink.Query.fold ?only_names ?on_unknown diff --git a/src/lib_client_commands/client_keys_commands.ml b/src/lib_client_commands/client_keys_commands.ml index d91e1d7ebbfb..077bb9d693f4 100644 --- a/src/lib_client_commands/client_keys_commands.ml +++ b/src/lib_client_commands/client_keys_commands.ml @@ -131,7 +131,7 @@ let gen_keys_containing ?(encrypted = false) ?(prefix = false) ?(force = false) with Not_found -> false in let rec loop attempts = - let (public_key_hash, public_key, secret_key) = + let public_key_hash, public_key, secret_key = Signature.generate_key () in let hash = @@ -183,10 +183,10 @@ let rec input_fundraiser_params (cctxt : #Client_context.io_wallet) = let prompt = if default then "(Y/n/q)" else "(y/N/q)" in let* gen = cctxt#prompt "%s %s: " msg prompt in match (default, String.lowercase_ascii gen) with - | (default, "") -> return default - | (_, "y") -> return_true - | (_, "n") -> return_false - | (_, "q") -> failwith "Exit by user request." + | default, "" -> return default + | _, "y" -> return_true + | _, "n" -> return_false + | _, "q" -> failwith "Exit by user request." | _ -> get_boolean_answer cctxt ~msg ~default in let* email = cctxt#prompt "Enter the e-mail used for the paper wallet: " in @@ -285,7 +285,7 @@ let generate_test_keys = let* source_list = List.init_es ~when_negative_length:[] n (fun i -> let alias = Format.sprintf "bootstrap%d" (i + 6) in - let (pkh, pk, sk) = + let pkh, pk, sk = Signature.generate_key ~algo:Signature.Ed25519 () in let*? pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in @@ -338,7 +338,7 @@ module Bls_commands = struct (Bip39.to_words mnemonic) in let seed = Mnemonic.to_32_bytes mnemonic in - let (pkh, pk, sk) = Aggregate_signature.generate_key ~seed () in + let pkh, pk, sk = Aggregate_signature.generate_key ~seed () in let*? pk_uri = Tezos_signer_backends.Unencrypted.Aggregate.make_pk pk in let* sk_uri = if encrypted then @@ -361,14 +361,14 @@ module Bls_commands = struct let* pkh_str = Aggregate_alias.Public_key_hash.to_source pkh in let*! () = match (pk, sk) with - | (None, None) -> cctxt#message "%s: %s" name pkh_str - | (_, Some uri) -> + | None, None -> cctxt#message "%s: %s" name pkh_str + | _, Some uri -> let scheme = Option.value ~default:"aggregate_unencrypted" @@ Uri.scheme (uri : aggregate_sk_uri :> Uri.t) in cctxt#message "%s: %s (%s sk known)" name pkh_str scheme - | (Some _, _) -> cctxt#message "%s: %s (pk known)" name pkh_str + | Some _, _ -> cctxt#message "%s: %s (pk known)" name pkh_str in return_unit) aggregate_keys_list @@ -405,7 +405,7 @@ module Bls_commands = struct let* name = Aggregate_alias.Secret_key.of_fresh cctxt false name in let* pk_uri = aggregate_neuterize sk_uri in let* () = aggregate_fail_if_already_registered cctxt force pk_uri name in - let* (pkh, public_key) = + let* pkh, public_key = import_aggregate_secret_key ~io:(cctxt :> Client_context.io_wallet) pk_uri in let*! () = @@ -482,7 +482,7 @@ let commands network : Client_context.full Clic.command list = (prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop) (fun (force, algo) name (cctxt : Client_context.full) -> let* name = Secret_key.of_fresh cctxt force name in - let (pkh, pk, sk) = Signature.generate_key ~algo () in + let pkh, pk, sk = Signature.generate_key ~algo () in let*? pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in let* sk_uri = Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk @@ -499,7 +499,7 @@ let commands network : Client_context.full Clic.command list = (prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop) (fun (force, algo, encrypted) name (cctxt : Client_context.full) -> let* name = Secret_key.of_fresh cctxt force name in - let (pkh, pk, sk) = Signature.generate_key ~algo () in + let pkh, pk, sk = Signature.generate_key ~algo () in let*? pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in let* sk_uri = if encrypted then @@ -602,7 +602,7 @@ let commands network : Client_context.full Clic.command list = let* name = Secret_key.of_fresh cctxt force name in let* pk_uri = Client_keys.neuterize sk_uri in let* () = fail_if_already_registered cctxt force pk_uri name in - let* (pkh, public_key) = + let* pkh, public_key = Client_keys.import_secret_key ~io:(cctxt :> Client_context.io_wallet) pk_uri @@ -633,7 +633,7 @@ let commands network : Client_context.full Clic.command list = in let* pk_uri = Client_keys.neuterize sk_uri in let* () = fail_if_already_registered cctxt force pk_uri name in - let* (pkh, _public_key) = Client_keys.public_key_hash pk_uri in + let* pkh, _public_key = Client_keys.public_key_hash pk_uri in register_key cctxt ~force (pkh, pk_uri, sk_uri) name); ]) @ [ @@ -646,7 +646,7 @@ let commands network : Client_context.full Clic.command list = @@ Public_key.fresh_alias_param @@ Client_keys.pk_uri_param @@ stop) (fun force name pk_uri (cctxt : Client_context.full) -> let* name = Public_key.of_fresh cctxt force name in - let* (pkh, public_key) = Client_keys.public_key_hash pk_uri in + let* pkh, public_key = Client_keys.public_key_hash pk_uri in let* () = Public_key_hash.add ~force cctxt name pkh in let*! () = cctxt#message @@ -677,14 +677,14 @@ let commands network : Client_context.full Clic.command list = let* v = Public_key_hash.to_source pkh in let*! () = match (pk, sk) with - | (None, None) -> cctxt#message "%s: %s" name v - | (_, Some uri) -> + | None, None -> cctxt#message "%s: %s" name v + | _, Some uri -> let scheme = Option.value ~default:"unencrypted" @@ Uri.scheme (uri : sk_uri :> Uri.t) in cctxt#message "%s: %s (%s sk known)" name v scheme - | (Some _, _) -> cctxt#message "%s: %s (pk known)" name v + | Some _, _ -> cctxt#message "%s: %s (pk known)" name v in return_unit) l); @@ -764,8 +764,7 @@ let commands network : Client_context.full Clic.command list = ~desc:"Compute deterministic nonce." no_options (prefixes ["generate"; "nonce"; "for"] - @@ Public_key_hash.alias_param - @@ prefixes ["from"] + @@ Public_key_hash.alias_param @@ prefixes ["from"] @@ string ~name:"data" ~desc:"string from which to deterministically generate the nonce" @@ -787,8 +786,7 @@ let commands network : Client_context.full Clic.command list = ~desc:"Compute deterministic nonce hash." no_options (prefixes ["generate"; "nonce"; "hash"; "for"] - @@ Public_key_hash.alias_param - @@ prefixes ["from"] + @@ Public_key_hash.alias_param @@ prefixes ["from"] @@ string ~name:"data" ~desc: @@ -860,7 +858,7 @@ let commands network : Client_context.full Clic.command list = in let* pk_uri = neuterize unencrypted_sk_uri in let* () = fail_if_already_registered cctxt force pk_uri name in - let* (pkh, public_key) = + let* pkh, public_key = import_secret_key ~io:(cctxt :> Client_context.io_wallet) pk_uri in let* () = @@ -881,7 +879,7 @@ let commands network : Client_context.full Clic.command list = @@ PVSS_secret_key.fresh_alias_param @@ stop) (fun force name (cctxt : Client_context.full) -> let* name = PVSS_secret_key.of_fresh cctxt force name in - let (pk, sk) = Pvss_secp256k1.generate_keys () in + let pk, sk = Pvss_secp256k1.generate_keys () in let* () = PVSS_public_key.add ~force cctxt name pk in let* sk_uri = Tezos_signer_backends.Encrypted.encrypt_pvss_key cctxt sk diff --git a/src/lib_client_commands/client_p2p_commands.ml b/src/lib_client_commands/client_p2p_commands.ml index c67a28b846dc..b97b17454e0f 100644 --- a/src/lib_client_commands/client_p2p_commands.ml +++ b/src/lib_client_commands/client_p2p_commands.ml @@ -64,7 +64,7 @@ let commands () = let*! () = cctxt#message "GLOBAL STATS" in let*! () = cctxt#message " %a" P2p_stat.pp stat in let*! () = cctxt#message "CONNECTIONS" in - let (incoming, outgoing) = + let incoming, outgoing = List.partition (fun c -> c.P2p_connection.Info.incoming) conns in let*! () = diff --git a/src/lib_context/context.ml b/src/lib_context/context.ml index 9506a98d2d6c..8b2084fa6c2c 100644 --- a/src/lib_context/context.ml +++ b/src/lib_context/context.ml @@ -474,7 +474,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct let key_to_string k = String.concat ";" k in let rec key_to_merkle_tree t target = match (Store.Tree.destruct t, target) with - | (_, []) -> + | _, [] -> (* We cannot use this case as the base case, because a merkle_node is a map from string to something. In this case, we have no key to put in the map's domain. *) @@ -482,7 +482,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct (Invalid_argument (Printf.sprintf "Reached end of key (top-level key was: %s)" @@ key_to_string key)) - | (_, [hd]) -> + | _, [hd] -> let finally key = (* get_tree is safe because we iterate on keys *) let* tree = Store.Tree.get_tree t [key] in @@ -504,7 +504,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct String.Map.add key v acc) String.Map.empty l - | (`Node _, target_hd :: target_tl) -> + | `Node _, target_hd :: target_tl -> let continue key = (* get_tree is safe because we iterate on keys *) let* tree = Store.Tree.get_tree t [key] in @@ -523,7 +523,7 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct String.Map.add key atom acc) String.Map.empty l - | (`Contents _, _) -> + | `Contents _, _ -> raise (Invalid_argument (Printf.sprintf @@ -782,9 +782,9 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct | `Blob h -> (`Blob, Context_hash.to_bytes (Hash.to_context_hash h)) | `Node h -> (`Node, Context_hash.to_bytes (Hash.to_context_hash h))) (function - | (`Blob, h) -> + | `Blob, h -> `Blob (Hash.of_context_hash (Context_hash.of_bytes_exn h)) - | (`Node, h) -> + | `Node, h -> `Node (Hash.of_context_hash (Context_hash.of_bytes_exn h))) (obj2 (req "kind" kind_encoding) (req "value" bytes)) end @@ -859,10 +859,10 @@ module Make (Encoding : module type of Tezos_context_encoding.Context) = struct (`Contents, Context_hash.to_bytes (Hash.to_context_hash h)) | Node h -> (`Node, Context_hash.to_bytes (Hash.to_context_hash h))) (function - | (`Contents, h) -> + | `Contents, h -> let h = Hash.of_context_hash (Context_hash.of_bytes_exn h) in Contents (h, ()) - | (`Node, h) -> + | `Node, h -> Node (Hash.of_context_hash (Context_hash.of_bytes_exn h))) (obj2 (req "kind" kind_encoding) (req "value" bytes)) diff --git a/src/lib_context/context_dump.ml b/src/lib_context/context_dump.ml index 1092b154f06c..c02ffb535f7c 100644 --- a/src/lib_context/context_dump.ml +++ b/src/lib_context/context_dump.ml @@ -96,7 +96,7 @@ let () = let rec read_string rbuf ~len = let open Lwt_result_syntax in - let (fd, buf, ofs, total) = !rbuf in + let fd, buf, ofs, total = !rbuf in if Bytes.length buf - ofs < len then ( let blen = Bytes.length buf - ofs in let neu = Bytes.create (blen + 1_000_000) in @@ -170,7 +170,7 @@ module Make_legacy (I : Dump_interface) = struct let open Lwt_result_syntax in let* l = get_int4 rbuf in let length = Int32.to_int l in - let (fd, buf, ofs, total) = !rbuf in + let fd, buf, ofs, total = !rbuf in rbuf := (fd, buf, ofs - 4, total) ; return (length + 4) @@ -195,8 +195,8 @@ module Make_legacy (I : Dump_interface) = struct let step i = if i >= total then return_none else - let* (length_name, name) = read_variable_length_string rbuf in - let* (length_hash, hash) = read_fixed_length_hash rbuf in + let* length_name, name = read_variable_length_string rbuf in + let* length_hash, hash = read_fixed_length_hash rbuf in let node = (name, hash) in let i = i + length_name + length_hash in return_some (node, i) @@ -232,7 +232,7 @@ module Make_legacy (I : Dump_interface) = struct let len = total - 1 in let b = Bytes.create len in let+ () = read_mbytes rbuf b in - let (info, parents) = + let info, parents = Data_encoding.Binary.of_bytes_exn eoc_encoding_raw b in Eoc {info; parents} diff --git a/src/lib_context/helpers/context.ml b/src/lib_context/helpers/context.ml index 634be779dc68..0726b1f00804 100644 --- a/src/lib_context/helpers/context.ml +++ b/src/lib_context/helpers/context.ml @@ -46,8 +46,8 @@ let binary_mask = 0b10 let decode_proof_version v = let extract_bit v mask = (v land mask <> 0, v land lnot mask) in - let (is_stream, v) = extract_bit v stream_mask in - let (is_binary, v) = extract_bit v binary_mask in + let is_stream, v = extract_bit v stream_mask in + let is_binary, v = extract_bit v binary_mask in if v <> 0 then Error `Invalid_proof_version else Ok {is_stream; is_binary} let encode_proof_version ~is_stream ~is_binary = @@ -362,7 +362,7 @@ struct let key = match key with `Node n -> `Node n | `Value v -> `Contents (v, ()) in - let+ (p, r) = Store.Tree.produce_proof repo key f in + let+ p, r = Store.Tree.produce_proof repo key f in (Proof.to_tree p, r) let verify_tree_proof proof f = @@ -374,7 +374,7 @@ struct let key = match key with `Node n -> `Node n | `Value v -> `Contents (v, ()) in - let+ (p, r) = Store.Tree.produce_stream repo key f in + let+ p, r = Store.Tree.produce_stream repo key f in (Proof.to_stream p, r) let verify_stream_proof proof f = diff --git a/src/lib_context/helpers/merkle_proof_encoding.ml b/src/lib_context/helpers/merkle_proof_encoding.ml index f178632ce38c..42bdc6d940e6 100644 --- a/src/lib_context/helpers/merkle_proof_encoding.ml +++ b/src/lib_context/helpers/merkle_proof_encoding.ml @@ -86,7 +86,7 @@ struct let rec f c bit = function | [] -> close c bit | i :: is -> - let (c, bit) = write c bit i in + let c, bit = write c bit i in f c bit is in f 0 0 is ; @@ -121,10 +121,10 @@ struct let rec read c rembit l s = if l = 0 then [] else - let (c, s, rembit) = + let c, s, rembit = if rembit >= 5 then (c, s, rembit) else - let (c', s) = head s in + let c', s = head s in ((c * 256) + c', s, rembit + 8) in let rembit = rembit - 5 in @@ -158,7 +158,7 @@ struct let rec f c bit = function | [] -> close c bit | i :: is -> - let (c, bit) = write c bit i in + let c, bit = write c bit i in f c bit is in f 0 0 is ; @@ -193,10 +193,10 @@ struct let rec read c rembit l s = if l = 0 then [] else - let (c, s, rembit) = + let c, s, rembit = if rembit >= 1 then (c, s, rembit) else - let (c', s) = head s in + let c', s = head s in ((c * 256) + c', s, rembit + 8) in let rembit = rembit - 1 in @@ -225,10 +225,10 @@ struct | [] -> invalid_arg "cannot encode ill-formed Merkle proof" | _ -> invalid_arg "cannot encode non binary proof tree") (function - | (Some x, Some y) -> Ok [(0, x); (1, y)] - | (Some x, None) -> Ok [(0, x)] - | (None, Some y) -> Ok [(1, y)] - | (None, None) -> Error "cannot decode ill-formed Merkle proof") + | Some x, Some y -> Ok [(0, x); (1, y)] + | Some x, None -> Ok [(0, x)] + | None, Some y -> Ok [(1, y)] + | None, None -> Error "cannot decode ill-formed Merkle proof") (tup2 a a) let inode_proofs_encoding_gen a = @@ -300,7 +300,7 @@ struct @@ obj3 length_field (req "segment" segment_encoding) (req "proof" a) (* data-encoding.0.4/test/mu.ml for building mutually recursive data_encodings *) - let (_inode_tree_encoding, tree_encoding) = + let _inode_tree_encoding, tree_encoding = let unoptionize enc = conv_with_guard (fun v -> Some v) @@ -554,10 +554,10 @@ struct | [] -> invalid_arg "cannot encode ill-formed Merkle proof" | _ -> invalid_arg "cannot encode non binary proof tree") (function - | (Some x, Some y) -> [(0, x); (1, y)] - | (Some x, None) -> [(0, x)] - | (None, Some y) -> [(1, y)] - | (None, None) -> invalid_arg "cannot decode ill-formed Merkle proof") + | Some x, Some y -> [(0, x); (1, y)] + | Some x, None -> [(0, x)] + | None, Some y -> [(1, y)] + | None, None -> invalid_arg "cannot decode ill-formed Merkle proof") (tup2 a a) let inode_proofs_encoding_32 a = @@ -650,7 +650,7 @@ struct assert false (* data-encoding.0.4/test/mu.ml for building mutually recursive data_encodings *) - let (_inode_tree_encoding, tree_encoding) = + let _inode_tree_encoding, tree_encoding = let unoptionize enc = conv_with_guard (fun v -> Some v) diff --git a/src/lib_context/sigs/config.ml b/src/lib_context/sigs/config.ml index 4df3a9542ee4..66e7798ba66c 100644 --- a/src/lib_context/sigs/config.ml +++ b/src/lib_context/sigs/config.ml @@ -28,9 +28,9 @@ type inode_child_order = let equal_inode_child_order x y = match (x, y) with - | (`Seeded_hash, `Seeded_hash) -> true - | (`Hash_bits, `Hash_bits) -> true - | (`Custom x, `Custom y) -> x == y + | `Seeded_hash, `Seeded_hash -> true + | `Hash_bits, `Hash_bits -> true + | `Custom x, `Custom y -> x == y | _ -> false type t = { diff --git a/src/lib_context/test/test_context.ml b/src/lib_context/test/test_context.ml index c552956c8868..92beb87756b6 100644 --- a/src/lib_context/test/test_context.ml +++ b/src/lib_context/test/test_context.ml @@ -323,7 +323,7 @@ let test_fold {idx; genesis; _} = let* ctxt = add ctxt ["foo"; "toto"] foo1 in let* ctxt = add ctxt ["foo"; "bar"; "toto"] foo2 in let fold depth ecs ens = - let* (cs, ns) = + let* cs, ns = fold ?depth ctxt @@ -382,7 +382,7 @@ let test_trees {idx; genesis; _} = let* v1 = Tree.add v1 ["foo"; "toto"] foo1 in let* v1 = Tree.add v1 ["foo"; "bar"; "toto"] foo2 in let fold depth ecs ens = - let* (cs, ns) = + let* cs, ns = Tree.fold v1 ?depth diff --git a/src/lib_context/test/test_merkle_proof.ml b/src/lib_context/test/test_merkle_proof.ml index 52924fb66321..cedc22194878 100644 --- a/src/lib_context/test/test_merkle_proof.ml +++ b/src/lib_context/test/test_merkle_proof.ml @@ -42,10 +42,10 @@ module Gen = struct let rec comb n xs = match (n, xs) with - | (0, _) -> Gen.return [] - | (_, []) -> assert false - | (1, [x]) -> Gen.return [x] - | (n, x :: xs) -> + | 0, _ -> Gen.return [] + | _, [] -> assert false + | 1, [x] -> Gen.return [x] + | n, x :: xs -> (* prob. n / length xs *) let* m = int_bound (List.length (x :: xs) - 1) in if m < n then diff --git a/src/lib_crypto/aggregate_signature.ml b/src/lib_crypto/aggregate_signature.ml index d79bfc3f2a56..3683bd79474c 100644 --- a/src/lib_crypto/aggregate_signature.ml +++ b/src/lib_crypto/aggregate_signature.ml @@ -134,7 +134,7 @@ module Public_key_hash = struct let compare a b = match (a, b) with - | (Bls12_381 x, Bls12_381 y) -> Bls.Public_key_hash.compare x y + | Bls12_381 x, Bls12_381 y -> Bls.Public_key_hash.compare x y end) include Helpers.MakeEncoder (struct @@ -197,8 +197,7 @@ module Public_key = struct type nonrec t = t let compare a b = - match (a, b) with - | (Bls12_381 x, Bls12_381 y) -> Bls.Public_key.compare x y + match (a, b) with Bls12_381 x, Bls12_381 y -> Bls.Public_key.compare x y end) type Base58.data += Data of t (* unused *) @@ -292,8 +291,7 @@ module Secret_key = struct type nonrec t = t let compare a b = - match (a, b) with - | (Bls12_381 x, Bls12_381 y) -> Bls.Secret_key.compare x y + match (a, b) with Bls12_381 x, Bls12_381 y -> Bls.Secret_key.compare x y end) type Base58.data += Data of t (* unused *) @@ -462,15 +460,15 @@ let sign (Secret_key.Bls12_381 sk) bytes = Bls12_381 (Bls.sign sk bytes) let check pk signature message = match (pk, signature) with - | (Public_key.Bls12_381 pk, Unknown signature) -> + | Public_key.Bls12_381 pk, Unknown signature -> Bls.of_bytes_opt signature |> Option.map (fun signature -> Bls.check pk signature message) |> Option.value ~default:false - | (Public_key.Bls12_381 pk, Bls12_381 signature) -> + | Public_key.Bls12_381 pk, Bls12_381 signature -> Bls.check pk signature message let generate_key ?seed () = - let (pkh, pk, sk) = Bls.generate_key ?seed () in + let pkh, pk, sk = Bls.generate_key ?seed () in ( Public_key_hash.Bls12_381 pkh, Public_key.Bls12_381 pk, Secret_key.Bls12_381 sk ) @@ -490,7 +488,7 @@ let aggregate_signature_opt signatures = let open Result_syntax in let aux acc s = match s with - | Bls12_381 s -> return @@ s :: acc + | Bls12_381 s -> return @@ (s :: acc) | Unknown s -> let* s = Bls.of_bytes s in return (s :: acc) diff --git a/src/lib_crypto/base58.ml b/src/lib_crypto/base58.ml index 718e7217b6b6..982d42b495e9 100644 --- a/src/lib_crypto/base58.ml +++ b/src/lib_crypto/base58.ml @@ -103,7 +103,7 @@ let raw_encode ?(alphabet = Alphabet.default) s = let rec loop s i = if s = Z.zero then i else - let (s, r) = Z.div_rem s zbase in + let s, r = Z.div_rem s zbase in Bytes.set res i (to_char ~alphabet (Z.to_int r)) ; loop s (i - 1) in @@ -222,7 +222,7 @@ struct assert (String.length s = length) ; of_raw s in - let (encoded_prefix, encoded_length) = make_encoded_prefix prefix length in + let encoded_prefix, encoded_length = make_encoded_prefix prefix length in check_ambiguous_prefix encoded_prefix encoded_length !encodings ; let encoding = {prefix; length; encoded_prefix; encoded_length; to_raw; of_raw; wrap} @@ -280,7 +280,7 @@ struct let min = raw_decode ~alphabet (request ^ String.make (len - n) zero) in let max = raw_decode ~alphabet (request ^ String.make (len - n) last) in match (min, max) with - | (Some min, Some max) -> + | Some min, Some max -> let prefix_len = TzString.common_prefix min max in Some (String.sub min 0 prefix_len) | _ -> None diff --git a/src/lib_crypto/blake2B.ml b/src/lib_crypto/blake2B.ml index 4022f5993b59..6ae5f3ee0669 100644 --- a/src/lib_crypto/blake2B.ml +++ b/src/lib_crypto/blake2B.ml @@ -143,14 +143,10 @@ module Make_minimal (K : Name) = struct except the last one which contains the rest. *) let to_path key l = let (`Hex key) = to_hex key in - String.sub key 0 2 - :: - String.sub key 2 2 - :: - String.sub key 4 2 - :: - String.sub key 6 2 - :: String.sub key 8 2 :: String.sub key 10 ((size * 2) - 10) :: l + String.sub key 0 2 :: String.sub key 2 2 :: String.sub key 4 2 + :: String.sub key 6 2 :: String.sub key 8 2 + :: String.sub key 10 ((size * 2) - 10) + :: l let of_path path = let path = String.concat "" path in @@ -305,14 +301,14 @@ struct match p with | Op -> (H.leaf h, 1, 0) | Left (p, r) -> - let (l, s, pos) = check_path p h in + let l, s, pos = check_path p h in (H.node l r, s * 2, pos) | Right (l, p) -> - let (r, s, pos) = check_path p h in + let r, s, pos = check_path p h in (H.node l r, s * 2, pos + s) let check_path p h = - let (h, _, pos) = check_path p h in + let h, _, pos = check_path p h in (h, pos) end diff --git a/src/lib_crypto/crypto_box.ml b/src/lib_crypto/crypto_box.ml index 323798a324b3..0794c4d9869c 100644 --- a/src/lib_crypto/crypto_box.ml +++ b/src/lib_crypto/crypto_box.ml @@ -74,7 +74,7 @@ let hash pk = Public_key_hash.hash_bytes [Box.unsafe_to_bytes pk] let tag_length = Box.tagbytes let random_keypair () = - let (pk, sk) = Box.keypair () in + let pk, sk = Box.keypair () in (sk, pk, hash pk) let zero_nonce = Bytes.make Nonce.size '\x00' @@ -93,7 +93,7 @@ let init_to_resp_seed = Bytes.of_string "Init -> Resp" let resp_to_init_seed = Bytes.of_string "Resp -> Init" let generate_nonces ~incoming ~sent_msg ~recv_msg = - let ((init_msg, resp_msg, false) | (resp_msg, init_msg, true)) = + let (init_msg, resp_msg, false | resp_msg, init_msg, true) = (sent_msg, recv_msg, incoming) in let nonce_init_to_resp = @@ -129,7 +129,7 @@ let compare_pow_target hash pow_target = let make_pow_target f = if f < 0. || 256. < f then invalid_arg "Cryptobox.target_of_float" ; - let (frac, shift) = modf f in + let frac, shift = modf f in let shift = int_of_float shift in let m = Z.of_int64 diff --git a/src/lib_crypto/ed25519.ml b/src/lib_crypto/ed25519.ml index cd2321891875..ec0615403ef8 100644 --- a/src/lib_crypto/ed25519.ml +++ b/src/lib_crypto/ed25519.ml @@ -343,7 +343,7 @@ let check ?watermark pk signature msg = let generate_key ?seed () = match seed with | None -> - let (pk, sk) = keypair () in + let pk, sk = keypair () in (Public_key.hash pk, pk, sk) | Some seed -> ( let seedlen = Bytes.length seed in diff --git a/src/lib_crypto/p256.ml b/src/lib_crypto/p256.ml index 28173d454bfb..e8ad4f79489f 100644 --- a/src/lib_crypto/p256.ml +++ b/src/lib_crypto/p256.ml @@ -306,7 +306,7 @@ let check ?watermark pk signature msg = let generate_key ?seed () = match seed with | None -> - let (pk, sk) = keypair () in + let pk, sk = keypair () in (Public_key.hash pk, pk, sk) | Some seed -> ( let seedlen = Bytes.length seed in diff --git a/src/lib_crypto/pvss.ml b/src/lib_crypto/pvss.ml index 736fcb2754f3..dc9c769afd22 100644 --- a/src/lib_crypto/pvss.ml +++ b/src/lib_crypto/pvss.ml @@ -134,7 +134,7 @@ module MakeDleq (G : CYCLIC_GROUP) : let fiat_shamir ?(exponents = []) elements = String.concat "||" - ("tezosftw" :: List.map G.to_bits elements + (("tezosftw" :: List.map G.to_bits elements) @ List.map G.Z_m.to_bits exponents) |> (fun x -> H.hash_string [x]) |> H.to_string |> G.Z_m.of_bits_exn @@ -197,8 +197,8 @@ module MakeDleq (G : CYCLIC_GROUP) : *) let rec map3 f xs ys zs = match (xs, ys, zs) with - | ([], [], []) -> [] - | (x :: xs, y :: ys, z :: zs) -> + | [], [], [] -> [] + | x :: xs, y :: ys, z :: zs -> let r = f x y z in r :: map3 f xs ys zs | _ -> invalid_arg "Pvss: List.map3" @@ -341,7 +341,7 @@ module MakePvss (G : CYCLIC_GROUP) : PVSS = struct commitments to the polynomial coefficients and n encrypted shares for the holders of the public keys *) let dealer_shares_and_proof ~secret ~threshold ~public_keys = - let (coefs, poly) = random_polynomial secret threshold in + let coefs, poly = random_polynomial secret threshold in let (* Cⱼ represents the commitment to the coefficients of the polynomial Cⱼ = g₁^(aⱼ) for j in 0 to t-1 *) @@ -360,8 +360,7 @@ module MakePvss (G : CYCLIC_GROUP) : PVSS = struct keys use the g₂ generator of G. Thus pkᵢ = g₂ˢᵏⁱ *) y_i = List.map2 G.pow public_keys p_i - and - (* xᵢ = g₁ᵖ⁽ⁱ⁾ for in in 1…n: commitment to polynomial points *) + and (* xᵢ = g₁ᵖ⁽ⁱ⁾ for in in 1…n: commitment to polynomial points *) x_i = List.map G.(pow g1) p_i in diff --git a/src/lib_crypto/signature.ml b/src/lib_crypto/signature.ml index 5cf4c8dd8466..adc607d9762b 100644 --- a/src/lib_crypto/signature.ml +++ b/src/lib_crypto/signature.ml @@ -195,9 +195,9 @@ module Public_key_hash = struct let compare a b = match (a, b) with - | (Ed25519 x, Ed25519 y) -> Ed25519.Public_key_hash.compare x y - | (Secp256k1 x, Secp256k1 y) -> Secp256k1.Public_key_hash.compare x y - | (P256 x, P256 y) -> P256.Public_key_hash.compare x y + | Ed25519 x, Ed25519 y -> Ed25519.Public_key_hash.compare x y + | Secp256k1 x, Secp256k1 y -> Secp256k1.Public_key_hash.compare x y + | P256 x, P256 y -> P256.Public_key_hash.compare x y | _ -> Stdlib.compare a b end) @@ -267,13 +267,13 @@ module Public_key = struct let compare a b = match (a, b) with - | (Ed25519 x, Ed25519 y) -> Ed25519.Public_key.compare x y - | (Secp256k1 x, Secp256k1 y) -> Secp256k1.Public_key.compare x y - | (P256 x, P256 y) -> P256.Public_key.compare x y - | (Ed25519 _, (Secp256k1 _ | P256 _)) -> -1 - | (Secp256k1 _, P256 _) -> -1 - | (P256 _, (Secp256k1 _ | Ed25519 _)) -> 1 - | (Secp256k1 _, Ed25519 _) -> 1 + | Ed25519 x, Ed25519 y -> Ed25519.Public_key.compare x y + | Secp256k1 x, Secp256k1 y -> Secp256k1.Public_key.compare x y + | P256 x, P256 y -> P256.Public_key.compare x y + | Ed25519 _, (Secp256k1 _ | P256 _) -> -1 + | Secp256k1 _, P256 _ -> -1 + | P256 _, (Secp256k1 _ | Ed25519 _) -> 1 + | Secp256k1 _, Ed25519 _ -> 1 end) type Base58.data += Data of t (* unused *) @@ -401,9 +401,9 @@ module Secret_key = struct let compare a b = match (a, b) with - | (Ed25519 x, Ed25519 y) -> Ed25519.Secret_key.compare x y - | (Secp256k1 x, Secp256k1 y) -> Secp256k1.Secret_key.compare x y - | (P256 x, P256 y) -> P256.Secret_key.compare x y + | Ed25519 x, Ed25519 y -> Ed25519.Secret_key.compare x y + | Secp256k1 x, Secp256k1 y -> Secp256k1.Secret_key.compare x y + | P256 x, P256 y -> P256.Secret_key.compare x y | _ -> Stdlib.compare a b end) @@ -644,23 +644,23 @@ let sign ?watermark secret_key message = let check ?watermark public_key signature message = let watermark = Option.map bytes_of_watermark watermark in match (public_key, signature) with - | (Public_key.Ed25519 pk, Unknown signature) -> ( + | Public_key.Ed25519 pk, Unknown signature -> ( match Ed25519.of_bytes_opt signature with | Some s -> Ed25519.check ?watermark pk s message | None -> false) - | (Public_key.Secp256k1 pk, Unknown signature) -> ( + | Public_key.Secp256k1 pk, Unknown signature -> ( match Secp256k1.of_bytes_opt signature with | Some s -> Secp256k1.check ?watermark pk s message | None -> false) - | (Public_key.P256 pk, Unknown signature) -> ( + | Public_key.P256 pk, Unknown signature -> ( match P256.of_bytes_opt signature with | Some s -> P256.check ?watermark pk s message | None -> false) - | (Public_key.Ed25519 pk, Ed25519 signature) -> + | Public_key.Ed25519 pk, Ed25519 signature -> Ed25519.check ?watermark pk signature message - | (Public_key.Secp256k1 pk, Secp256k1 signature) -> + | Public_key.Secp256k1 pk, Secp256k1 signature -> Secp256k1.check ?watermark pk signature message - | (Public_key.P256 pk, P256 signature) -> + | Public_key.P256 pk, P256 signature -> P256.check ?watermark pk signature message | _ -> false @@ -718,15 +718,15 @@ type algo = Ed25519 | Secp256k1 | P256 let generate_key ?(algo = Ed25519) ?seed () = match algo with | Ed25519 -> - let (pkh, pk, sk) = Ed25519.generate_key ?seed () in + let pkh, pk, sk = Ed25519.generate_key ?seed () in (Public_key_hash.Ed25519 pkh, Public_key.Ed25519 pk, Secret_key.Ed25519 sk) | Secp256k1 -> - let (pkh, pk, sk) = Secp256k1.generate_key ?seed () in + let pkh, pk, sk = Secp256k1.generate_key ?seed () in ( Public_key_hash.Secp256k1 pkh, Public_key.Secp256k1 pk, Secret_key.Secp256k1 sk ) | P256 -> - let (pkh, pk, sk) = P256.generate_key ?seed () in + let pkh, pk, sk = P256.generate_key ?seed () in (Public_key_hash.P256 pkh, Public_key.P256 pk, Secret_key.P256 sk) let deterministic_nonce sk msg = diff --git a/src/lib_crypto/test-unix/test_crypto_box.ml b/src/lib_crypto/test-unix/test_crypto_box.ml index 9984d60ae5a8..c75f955caa94 100644 --- a/src/lib_crypto/test-unix/test_crypto_box.ml +++ b/src/lib_crypto/test-unix/test_crypto_box.ml @@ -31,7 +31,7 @@ Subject: Roundtrips for functions built on the HACL* NaCl API. *) -let (_sk, pk, _pkh) = Crypto_box.random_keypair () +let _sk, pk, _pkh = Crypto_box.random_keypair () (** The test defines a proof-of-work target, generates a proof-of-work for that target, and then verifies it the proof of work is accepted diff --git a/src/lib_crypto/test/test_bls12_381.ml b/src/lib_crypto/test/test_bls12_381.ml index 6c5f5e374536..0ac9b38970b0 100644 --- a/src/lib_crypto/test/test_bls12_381.ml +++ b/src/lib_crypto/test/test_bls12_381.ml @@ -45,7 +45,7 @@ let test_b58check_roundtrip : input let test_b58check_roundtrips () = - let (pubkey_hash, pubkey, seckey) = Bls.generate_key () in + let pubkey_hash, pubkey, seckey = Bls.generate_key () in test_b58check_roundtrip (module Bls.Public_key_hash) "pubkey_hash" pubkey_hash ; test_b58check_roundtrip (module Bls.Public_key) "pubkey" pubkey ; test_b58check_roundtrip (module Bls.Secret_key) "seckey" seckey @@ -85,7 +85,7 @@ let test_pkh_encodings () = let test_key_encodings () = let test_encoded_key (seed, pkh_b58, pk_b58, sk_b58) = let seed = of_hex seed in - let (pkh_test, pk_test, sk_test) = Bls.generate_key ~seed () in + let pkh_test, pk_test, sk_test = Bls.generate_key ~seed () in let pkh_test = Base58.simple_encode Bls.Public_key_hash.b58check_encoding pkh_test in diff --git a/src/lib_crypto/test/test_crypto_box.ml b/src/lib_crypto/test/test_crypto_box.ml index 46d736cae9e9..05b6762fdfb6 100644 --- a/src/lib_crypto/test/test_crypto_box.ml +++ b/src/lib_crypto/test/test_crypto_box.ml @@ -31,7 +31,7 @@ Subject: Roundtrips for functions built on the HACL* NaCl API. *) -let (sk, pk, pkh) = Crypto_box.random_keypair () +let sk, pk, pkh = Crypto_box.random_keypair () let zero_nonce = Crypto_box.zero_nonce diff --git a/src/lib_crypto/test/test_deterministic_nonce.ml b/src/lib_crypto/test/test_deterministic_nonce.ml index a979ac3aaa2b..5c78ac3df265 100644 --- a/src/lib_crypto/test/test_deterministic_nonce.ml +++ b/src/lib_crypto/test/test_deterministic_nonce.ml @@ -33,7 +33,7 @@ (** Deterministic nonce generation using HMAC-SHA256 *) let test_hash_matches (module X : S.SIGNATURE) () = - let (_, _, sk) = X.generate_key () in + let _, _, sk = X.generate_key () in let data = Bytes.of_string "ce input sa pun eu aici oare?" in let nonce = X.deterministic_nonce sk data in let nonce_hash = X.deterministic_nonce_hash sk data in diff --git a/src/lib_crypto/test/test_ed25519.ml b/src/lib_crypto/test/test_ed25519.ml index 1a7721f4f372..4807fde38530 100644 --- a/src/lib_crypto/test/test_ed25519.ml +++ b/src/lib_crypto/test/test_ed25519.ml @@ -58,7 +58,7 @@ let test_b58check_roundtrip : for pkh, pk and sk in Ed25519 *) let test_b58check_roundtrips () = - let (pubkey_hash, pubkey, seckey) = Ed25519.generate_key () in + let pubkey_hash, pubkey, seckey = Ed25519.generate_key () in test_b58check_roundtrip (module Ed25519.Public_key_hash) "pubkey_hash" @@ -103,7 +103,7 @@ let test_pkh_encodings () = let test_key_encodings () = let test_encoded_key (seed, pkh_b58, pk_b58, sk_b58) = let seed = of_hex seed in - let (pkh_test, pk_test, sk_test) = Ed25519.generate_key ~seed () in + let pkh_test, pk_test, sk_test = Ed25519.generate_key ~seed () in let pkh_test = Base58.simple_encode Ed25519.Public_key_hash.b58check_encoding pkh_test in diff --git a/src/lib_crypto/test/test_merkle.ml b/src/lib_crypto/test/test_merkle.ml index 35a64e404287..caf77d82578c 100644 --- a/src/lib_crypto/test/test_merkle.ml +++ b/src/lib_crypto/test/test_merkle.ml @@ -46,7 +46,7 @@ let rec list_of_tree = function | Empty -> ([], 0) | Leaf x -> ([x], 1) | Node (x, y) -> - let (x, sx) = list_of_tree x and (y, sy) = list_of_tree y in + let x, sx = list_of_tree x and y, sy = list_of_tree y in assert (sx = sy) ; (x @ y, sx + sy) @@ -70,14 +70,14 @@ end) *) let rec compare_list xs ys = match (xs, ys) with - | ([], []) -> true - | ([x], y :: ys) when x = y -> ys = [] || compare_list xs ys - | (x :: xs, y :: ys) when x = y -> compare_list xs ys - | (_, _) -> false + | [], [] -> true + | [x], y :: ys when x = y -> ys = [] || compare_list xs ys + | x :: xs, y :: ys when x = y -> compare_list xs ys + | _, _ -> false let check_size i = let l = 0 -- i in - let (l2, _) = list_of_tree (Merkle.compute l) in + let l2, _ = list_of_tree (Merkle.compute l) in if compare_list l l2 then () else Format.kasprintf @@ -119,7 +119,7 @@ let check_path i = List.iter (fun j -> let path = Merkle.compute_path l j in - let (found, pos) = Merkle.check_path path j in + let found, pos = Merkle.check_path path j in if found = orig && j = pos then () else Format.kasprintf failwith "Failed for %d in %d." j i) l @@ -148,7 +148,7 @@ let test_path_examples _ = "path to 3rd element" (Merkle.compute_path [4; 5; 6; 7] 2) (Right (Node (Leaf 4, Leaf 5), Left (Op, Leaf 7))) ; - let (t, idx) = + let t, idx = Merkle.check_path (Right (Node (Leaf 4, Leaf 5), Left (Op, Leaf 7))) 6 in Alcotest.check diff --git a/src/lib_crypto/test/test_p256.ml b/src/lib_crypto/test/test_p256.ml index 5f26d25206b7..3c2ec5298fa9 100644 --- a/src/lib_crypto/test/test_p256.ml +++ b/src/lib_crypto/test/test_p256.ml @@ -45,7 +45,7 @@ let test_b58check_roundtrip : input let test_b58check_roundtrips () = - let (pubkey_hash, pubkey, seckey) = P256.generate_key () in + let pubkey_hash, pubkey, seckey = P256.generate_key () in test_b58check_roundtrip (module P256.Public_key_hash) "pubkey_hash" @@ -87,7 +87,7 @@ let test_pkh_encodings () = let test_key_encodings () = let test_encoded_key (seed, pkh_b58, pk_b58, sk_b58) = let seed = of_hex seed in - let (pkh_test, pk_test, sk_test) = P256.generate_key ~seed () in + let pkh_test, pk_test, sk_test = P256.generate_key ~seed () in let pkh_test = Base58.simple_encode P256.Public_key_hash.b58check_encoding pkh_test in diff --git a/src/lib_crypto/test/test_prop_signature.ml b/src/lib_crypto/test/test_prop_signature.ml index e1eefff04814..0c1d870fdea1 100644 --- a/src/lib_crypto/test/test_prop_signature.ml +++ b/src/lib_crypto/test/test_prop_signature.ml @@ -42,7 +42,7 @@ struct (** Tests that a signature of [s] by a generated key and [X.sign] is accepted by [X.check] with the same key. *) let test_prop_sign_check (s : string) = - let (_, pk, sk) = X.generate_key () in + let _, pk, sk = X.generate_key () in let data = Bytes.of_string s in let signed = X.sign sk data in X.check pk signed data @@ -67,9 +67,9 @@ struct aggregation of all these signatures obtained using [X.aggregate_signature_opt] is accepted by [X.aggregate_check]. *) let test_prop_sign_check ((seed1, msg1), (seed2, msg2), (seed3, msg3)) = - let (_, pk1, sk1) = X.generate_key ~seed:seed1 () in - let (_, pk2, sk2) = X.generate_key ~seed:seed2 () in - let (_, pk3, sk3) = X.generate_key ~seed:seed3 () in + let _, pk1, sk1 = X.generate_key ~seed:seed1 () in + let _, pk2, sk2 = X.generate_key ~seed:seed2 () in + let _, pk3, sk3 = X.generate_key ~seed:seed3 () in let signed1 = X.sign sk1 msg1 in let signed2 = X.sign sk2 msg2 in let signed3 = X.sign sk3 msg3 in diff --git a/src/lib_crypto/test/test_pvss.ml b/src/lib_crypto/test/test_pvss.ml index b61a437a09ad..e9fbb00551eb 100644 --- a/src/lib_crypto/test/test_pvss.ml +++ b/src/lib_crypto/test/test_pvss.ml @@ -259,7 +259,7 @@ let test_reconstruct () = Pvss.reconstruct (List.map (fun n -> - let (_, (r, _)) = List.nth Setup.reveals n in + let _, (r, _) = List.nth Setup.reveals n in r) indices) indices @@ -282,7 +282,7 @@ let test_invalid_reconstruct () = Pvss.reconstruct (List.map (fun n -> - let (_, (r, _)) = List.nth Setup.reveals n in + let _, (r, _) = List.nth Setup.reveals n in r) indices) indices @@ -314,13 +314,13 @@ let test_randomness_commitment_protocol () = endorsers in (* Client: A baker creates a randomness commitment *) - let (secret_nonce, public_nonce) = + let secret_nonce, public_nonce = Setup.random_keypairs 1 |> List.hd |> fun Setup.{secret_key; public_key} -> (secret_key, public_key) in (* Client: A baker creates shares for block endorsers, a list of commitments of length equal to the threshold and a proof *) - let (shares, commitments, proof) = + let shares, commitments, proof = Pvss.dealer_shares_and_proof ~secret:secret_nonce ~threshold @@ -349,7 +349,7 @@ let test_randomness_commitment_protocol () = let encrypted_share = List.nth shares index in let Setup.{secret_key; public_key} = List.nth bakers index in (* Client: Endorsers may reveal their shares *) - let (clear_share, proof) = + let clear_share, proof = Pvss.reveal_share encrypted_share ~secret_key ~public_key in (* Protocol: The revealed shares are verified with the proof *) diff --git a/src/lib_crypto/test/test_run.ml b/src/lib_crypto/test/test_run.ml index 9a4b91d665cf..7ea3778c837c 100644 --- a/src/lib_crypto/test/test_run.ml +++ b/src/lib_crypto/test/test_run.ml @@ -16,8 +16,8 @@ let runtest l = l) in () - ;; + runtest [ (module Test_base58); diff --git a/src/lib_crypto/test/test_signature.ml b/src/lib_crypto/test/test_signature.ml index ddf47009769d..0928a77296bd 100644 --- a/src/lib_crypto/test/test_signature.ml +++ b/src/lib_crypto/test/test_signature.ml @@ -26,7 +26,7 @@ let test_size () = let open Signature in let length = - let (_pkh, pk, _sk) = generate_key ~algo:Ed25519 () in + let _pkh, pk, _sk = generate_key ~algo:Ed25519 () in Public_key.size pk in let expected = @@ -37,7 +37,7 @@ let test_size () = in assert (Compare.Int.(expected = length)) ; let length = - let (_pkh, pk, _sk) = generate_key ~algo:P256 () in + let _pkh, pk, _sk = generate_key ~algo:P256 () in Public_key.size pk in let expected = @@ -48,7 +48,7 @@ let test_size () = in assert (Compare.Int.(expected = length)) ; let length = - let (_pkh, pk, _sk) = generate_key ~algo:Secp256k1 () in + let _pkh, pk, _sk = generate_key ~algo:Secp256k1 () in Public_key.size pk in let expected = @@ -62,7 +62,7 @@ let test_size () = let test_of_bytes_without_validation () = List.iter (fun algo -> - let (_pkh, pk, _sk) = Signature.generate_key ~algo () in + let _pkh, pk, _sk = Signature.generate_key ~algo () in let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding pk in diff --git a/src/lib_crypto/test/test_timelock.ml b/src/lib_crypto/test/test_timelock.ml index 29a2346bfd26..84fcb405c36a 100644 --- a/src/lib_crypto/test/test_timelock.ml +++ b/src/lib_crypto/test/test_timelock.ml @@ -33,12 +33,12 @@ *) let test_raw_scenario time () = - let (public, secret) = Timelock.gen_rsa_keys () in + let public, secret = Timelock.gen_rsa_keys () in let locked_value = Timelock.gen_locked_value public in - let (unlocked, proof_1) = + let unlocked, proof_1 = Timelock.unlock_and_prove_with_secret secret ~time locked_value in - let (same_unlocked, proof_2) = + let same_unlocked, proof_2 = Timelock.unlock_and_prove_without_secret public ~time locked_value in assert (proof_1 = proof_2) ; @@ -58,7 +58,7 @@ let test_raw_scenario time () = let bench () = let time = 10_000 in - let (public, secret) = Timelock.gen_rsa_keys () in + let public, secret = Timelock.gen_rsa_keys () in let locked_value = Timelock.gen_locked_value public in let unlocked_value = Timelock.unlock_with_secret secret ~time locked_value in let start = Unix.gettimeofday () in @@ -82,9 +82,7 @@ let bench () = let test_high_level_scenario () = let payload = Bytes.of_string "zrethgfdsq" and time = 3456 in - let (chest, chest_key_1) = - Timelock.create_chest_and_chest_key ~payload ~time - in + let chest, chest_key_1 = Timelock.create_chest_and_chest_key ~payload ~time in let chest_key_2 = Timelock.create_chest_key ~time chest in let opening_result_1 = Timelock.open_chest chest chest_key_1 ~time in let opening_result_2 = Timelock.open_chest chest chest_key_2 ~time in @@ -95,7 +93,7 @@ let test_high_level_scenario () = let test_negative () = let payload = Bytes.of_string "fdgfnhfd" and time = 10 in let wrong_time = 1000 in - let (rsa_public, rsa_secret) = Timelock.gen_rsa_keys () in + let rsa_public, rsa_secret = Timelock.gen_rsa_keys () in let locked_value = Timelock.gen_locked_value rsa_public in let sym_key = Timelock.locked_value_to_symmetric_key_with_secret @@ -106,7 +104,7 @@ let test_negative () = let ciphertext = Timelock.encrypt sym_key payload in let chest = Timelock.{locked_value; rsa_public; ciphertext} in (* the opener does garbage*) - let (unlocked_value_wrong, proof_wrong) = + let unlocked_value_wrong, proof_wrong = Timelock.unlock_and_prove_without_secret rsa_public ~time:wrong_time @@ -146,11 +144,11 @@ let test_sampler_and_get_plaintext_size () = (* used to check determinism*) let rng_state_same = Random.get_state () in let time = 1000 in - let (chest, chest_key) = + let chest, chest_key = Timelock.chest_sampler ~rng_state ~plaintext_size:100 ~time in assert (Timelock.get_plaintext_size chest = 100) ; - let (chest_same, chest_key_same) = + let chest_same, chest_key_same = Timelock.chest_sampler ~rng_state:rng_state_same ~plaintext_size:100 ~time in (* Check determinism*) diff --git a/src/lib_crypto/timelock.ml b/src/lib_crypto/timelock.ml index c6145ae7114d..3f0a3abd362d 100644 --- a/src/lib_crypto/timelock.ml +++ b/src/lib_crypto/timelock.ml @@ -103,7 +103,7 @@ let prove_with_secret secret ~time locked_value unlocked_value = which is equivalent to 2 ^ time = (((2 ^ time) / l) * l) + (2 ^ time mod l) mod phi see https://eprint.iacr.org/2018/712.pdf section 3.2 for this proof - *) +*) let verify_time_lock rsa_public ~time locked_value unlocked_value proof = let l = hash_to_prime rsa_public ~time locked_value unlocked_value in let r = Z.(powm (of_int 2) (Z.of_int time) l) in @@ -230,9 +230,9 @@ let open_chest chest chest_key ~time = | Some plaintext -> Correct plaintext) let create_chest_and_chest_key ~payload ~time = - let (rsa_public, rsa_secret) = gen_rsa_keys () in + let rsa_public, rsa_secret = gen_rsa_keys () in let locked_value = gen_locked_value rsa_public in - let (unlocked_value, proof) = + let unlocked_value, proof = unlock_and_prove_with_secret rsa_secret ~time locked_value in let sym_key = unlocked_value_to_symmetric_key unlocked_value in @@ -240,7 +240,7 @@ let create_chest_and_chest_key ~payload ~time = ({locked_value; rsa_public; ciphertext}, {unlocked_value; proof}) let create_chest_key chest ~time = - let (unlocked_value, proof) = + let unlocked_value, proof = unlock_and_prove_without_secret chest.rsa_public ~time chest.locked_value in {unlocked_value; proof} @@ -282,9 +282,9 @@ let encrypt_unsafe symmetric_key plaintext = let chest_sampler ~rng_state ~plaintext_size ~time = Random.set_state rng_state ; let plaintext = gen_random_bytes_unsafe plaintext_size in - let (rsa_public, rsa_secret) = gen_rsa_keys_unsafe () in + let rsa_public, rsa_secret = gen_rsa_keys_unsafe () in let locked_value = gen_locked_value_unsafe rsa_public in - let (unlocked_value, proof) = + let unlocked_value, proof = unlock_and_prove_with_secret rsa_secret ~time locked_value in let sym_key = unlocked_value_to_symmetric_key unlocked_value in diff --git a/src/lib_error_monad/error_classification.ml b/src/lib_error_monad/error_classification.ml index 5ef7e984b9da..c36e17dec668 100644 --- a/src/lib_error_monad/error_classification.ml +++ b/src/lib_error_monad/error_classification.ml @@ -29,7 +29,7 @@ let default = Temporary let combine c1 c2 = match (c1, c2) with - | (Permanent, _) | (_, Permanent) -> Permanent - | (Outdated, _) | (_, Outdated) -> Outdated - | (Branch, _) | (_, Branch) -> Branch - | (Temporary, Temporary) -> Temporary + | Permanent, _ | _, Permanent -> Permanent + | Outdated, _ | _, Outdated -> Outdated + | Branch, _ | _, Branch -> Branch + | Temporary, Temporary -> Temporary diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index efd15c8b4e1a..055c622f1a04 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -330,7 +330,7 @@ module All_sinks = struct in (* We want to filter the list in one Lwt-go (atomically), and only then call close on the ones that are being deleted. *) - let (next_active, to_close_list) = + let next_active, to_close_list = List.partition (fun act -> match act with Active {configuration; _} -> except configuration) diff --git a/src/lib_event_logging/test_helpers/mock_sink.ml b/src/lib_event_logging/test_helpers/mock_sink.ml index cd8c5b2360da..6616b050ea15 100644 --- a/src/lib_event_logging/test_helpers/mock_sink.ml +++ b/src/lib_event_logging/test_helpers/mock_sink.ml @@ -200,14 +200,14 @@ let assert_has_events msg ?filter ?(strict = true) (pats : Pattern.t list) = let events = get_events ?filter () in if strict then match List.combine_with_leftovers pats events with - | (pes, None) -> List.iter (fun (p, e) -> Pattern.assert_event p e) pes - | (_, Some (Either.Left pats)) -> + | pes, None -> List.iter (fun (p, e) -> Pattern.assert_event p e) pes + | _, Some (Either.Left pats) -> Alcotest.fail (Format.asprintf "Missing events in sink: %a" (Format.pp_print_list Pattern.pp) pats) - | (_, Some (Either.Right events)) -> + | _, Some (Either.Right events) -> Alcotest.fail (Format.asprintf "Excess events in sink: %a" diff --git a/src/lib_hacl/gen/api_json.ml b/src/lib_hacl/gen/api_json.ml index d2559daf73e1..bd08d07e59f4 100644 --- a/src/lib_hacl/gen/api_json.ml +++ b/src/lib_hacl/gen/api_json.ml @@ -50,10 +50,10 @@ let field_opt name l = List.assoc_opt name (Ezjsonm.get_dict l) let parse_size = function | `String name -> ( match (String.split_on_char '+' name, String.split_on_char '-' name) with - | ([name; plus], [_]) -> `Relative (name, int_of_string plus) - | ([_], [name; minus]) -> `Relative (name, int_of_string minus) - | ([_], [_]) -> `Relative (name, 0) - | ([], _) | (_, []) | ([_], _) | (_, [_]) -> assert false + | [name; plus], [_] -> `Relative (name, int_of_string plus) + | [_], [name; minus] -> `Relative (name, int_of_string minus) + | [_], [_] -> `Relative (name, 0) + | [], _ | _, [] | [_], _ | _, [_] -> assert false | _ -> assert false) | `Float f -> `Absolute (int_of_float f) | _ -> assert false diff --git a/src/lib_hacl/gen/gen.ml b/src/lib_hacl/gen/gen.ml index 2790873a3031..0d53a9e54580 100644 --- a/src/lib_hacl/gen/gen.ml +++ b/src/lib_hacl/gen/gen.ml @@ -63,11 +63,11 @@ end = struct let compare a b = match (a, b) with - | (Error {name = x; _}, Error {name = y; _}) -> compare x y - | (From_spec {name = x; _}, From_spec {name = y; _}) -> compare x y - | (Proxy {name = x; _}, Proxy {name = y; _}) -> compare x y - | (Unimplemented {name = x; _}, Unimplemented {name = y; _}) -> compare x y - | (a, b) -> compare a b + | Error {name = x; _}, Error {name = y; _} -> compare x y + | From_spec {name = x; _}, From_spec {name = y; _} -> compare x y + | Proxy {name = x; _}, Proxy {name = y; _} -> compare x y + | Unimplemented {name = x; _}, Unimplemented {name = y; _} -> compare x y + | a, b -> compare a b let size_to_js s args = match s with @@ -130,16 +130,16 @@ end = struct List.iter (fun (v : Api_json.arg) -> match (v.index, v.typ) with - | (None, _) -> () - | (Some _i, Buffer) -> + | None, _ -> () + | Some _i, Buffer -> f " var a_%s = hacl_create_buffer(%s,%s)@." v.name v.name (size_to_js v.size spec.args) - | (Some _i, Uint32) -> + | Some _i, Uint32 -> f " var i_%s = integers_int32_of_uint32(%s)@." v.name v.name - | (Some _, Uint8) -> () + | Some _, Uint8 -> () | _ -> assert false) spec.args ; (* Call the underlying api *) @@ -216,53 +216,53 @@ let rec compute_arity : 'a. 'a Ctypes_static.fn -> int = let unify_type (type a) (typ : a Ctypes_static.typ) (api : Api_json.typ) : Api_json.typ = match (typ, api) with - | (Void, Void) -> Void - | (Primitive Uint32_t, Int) -> Uint32 - | (Primitive Uint8_t, Int) -> Uint8 - | (Primitive Bool, Bool) -> Bool - | (OCaml Bytes, Buffer) -> Buffer - | (Void, _) -> assert false - | (Primitive Char, _) -> assert false - | (Primitive Schar, _) -> assert false - | (Primitive Uchar, _) -> assert false - | (Primitive Bool, _) -> assert false - | (Primitive Short, _) -> assert false - | (Primitive Int, _) -> assert false - | (Primitive Long, _) -> assert false - | (Primitive Llong, _) -> assert false - | (Primitive Ushort, _) -> assert false - | (Primitive Sint, _) -> assert false - | (Primitive Uint, _) -> assert false - | (Primitive Ulong, _) -> assert false - | (Primitive Ullong, _) -> assert false - | (Primitive Size_t, _) -> assert false - | (Primitive Int8_t, _) -> assert false - | (Primitive Int16_t, _) -> assert false - | (Primitive Int32_t, _) -> assert false - | (Primitive Int64_t, _) -> assert false - | (Primitive Uint8_t, _) -> assert false - | (Primitive Uint16_t, _) -> assert false - | (Primitive Uint32_t, _) -> assert false - | (Primitive Uint64_t, _) -> assert false - | (Primitive Camlint, _) -> assert false - | (Primitive Nativeint, _) -> assert false - | (Primitive Float, _) -> assert false - | (Primitive Double, _) -> assert false - | (Primitive LDouble, _) -> assert false - | (Primitive Complex32, _) -> assert false - | (Primitive Complex64, _) -> assert false - | (Primitive Complexld, _) -> assert false - | (Pointer _t, _) -> assert false - | (Funptr _fn, _) -> assert false - | (Struct _, _) -> assert false - | (Union _, _) -> assert false - | (Abstract _, _) -> assert false - | (View _, _) -> assert false - | (Array _, _) -> assert false - | (Bigarray _, _) -> assert false - | (OCaml String, _) -> assert false - | (OCaml Bytes, _) -> assert false - | (OCaml FloatArray, _) -> assert false + | Void, Void -> Void + | Primitive Uint32_t, Int -> Uint32 + | Primitive Uint8_t, Int -> Uint8 + | Primitive Bool, Bool -> Bool + | OCaml Bytes, Buffer -> Buffer + | Void, _ -> assert false + | Primitive Char, _ -> assert false + | Primitive Schar, _ -> assert false + | Primitive Uchar, _ -> assert false + | Primitive Bool, _ -> assert false + | Primitive Short, _ -> assert false + | Primitive Int, _ -> assert false + | Primitive Long, _ -> assert false + | Primitive Llong, _ -> assert false + | Primitive Ushort, _ -> assert false + | Primitive Sint, _ -> assert false + | Primitive Uint, _ -> assert false + | Primitive Ulong, _ -> assert false + | Primitive Ullong, _ -> assert false + | Primitive Size_t, _ -> assert false + | Primitive Int8_t, _ -> assert false + | Primitive Int16_t, _ -> assert false + | Primitive Int32_t, _ -> assert false + | Primitive Int64_t, _ -> assert false + | Primitive Uint8_t, _ -> assert false + | Primitive Uint16_t, _ -> assert false + | Primitive Uint32_t, _ -> assert false + | Primitive Uint64_t, _ -> assert false + | Primitive Camlint, _ -> assert false + | Primitive Nativeint, _ -> assert false + | Primitive Float, _ -> assert false + | Primitive Double, _ -> assert false + | Primitive LDouble, _ -> assert false + | Primitive Complex32, _ -> assert false + | Primitive Complex64, _ -> assert false + | Primitive Complexld, _ -> assert false + | Pointer _t, _ -> assert false + | Funptr _fn, _ -> assert false + | Struct _, _ -> assert false + | Union _, _ -> assert false + | Abstract _, _ -> assert false + | View _, _ -> assert false + | Array _, _ -> assert false + | Bigarray _, _ -> assert false + | OCaml String, _ -> assert false + | OCaml Bytes, _ -> assert false + | OCaml FloatArray, _ -> assert false let rec unify_types : 'a. @@ -273,12 +273,12 @@ let rec unify_types : Api_json.arg list * Api_json.typ = fun (type a) acc (t : a Ctypes_static.fn) args return -> match (t, args) with - | (Ctypes_static.Returns t, []) -> (List.rev acc, unify_type t return) - | (Ctypes_static.Returns _, _) -> assert false - | (Function (t, x), a :: args) -> + | Ctypes_static.Returns t, [] -> (List.rev acc, unify_type t return) + | Ctypes_static.Returns _, _ -> assert false + | Function (t, x), a :: args -> let typ = unify_type t a.Api_json.typ in unify_types ({a with typ} :: acc) x args return - | (Function _, []) -> assert false + | Function _, [] -> assert false let gen_fn ~api ~manually_implemented ~required ~name ~ctypes_name add fn : unit = @@ -371,9 +371,7 @@ let gen_fn ~api ~manually_implemented ~required ~name ~ctypes_name add fn : unit let api_spec = List.find (fun api -> name = api.Api_json.wasm_fun_name) api in - let (args, return) = - unify_types [] fn api_spec.args api_spec.return - in + let args, return = unify_types [] fn api_spec.args api_spec.return in let unprefixed_alias = String_set.mem name required in add (Entry.From_spec @@ -563,7 +561,7 @@ let entries = let api = Api_json.parse_file !api_json in - let (manually_implemented, required) = + let manually_implemented, required = let provides_r = Str.regexp "//Provides: *\\([a-zA-z0-9_]*\\)" in let requires_r = Str.regexp "//Requires: *\\([a-zA-z0-9_, ]*\\)" in let implemented = ref String_set.empty in diff --git a/src/lib_hacl/hacl.ml b/src/lib_hacl/hacl.ml index bb7f39e02ca6..89f25ce21fde 100644 --- a/src/lib_hacl/hacl.ml +++ b/src/lib_hacl/hacl.ml @@ -242,9 +242,9 @@ module Box = struct fun a b -> (* TODO re-group once coverage ppx is updated *) match (a, b) with - | (Pk a, Pk b) -> Bytes.equal a b - | (Sk a, Sk b) -> Bytes.equal a b - | (Ck a, Ck b) -> Bytes.equal a b + | Pk a, Pk b -> Bytes.equal a b + | Sk a, Sk b -> Bytes.equal a b + | Ck a, Ck b -> Bytes.equal a b let unsafe_sk_of_bytes buf = if Bytes.length buf <> skbytes then @@ -386,8 +386,8 @@ module Ed25519 : SIGNATURE = struct fun a b -> (* TODO re-group once coverage ppx is updated *) match (a, b) with - | (Pk a, Pk b) -> Bytes.compare a b - | (Sk a, Sk b) -> Bytes.compare a b + | Pk a, Pk b -> Bytes.compare a b + | Sk a, Sk b -> Bytes.compare a b let equal : type a. a key -> a key -> bool = fun a b -> compare a b = 0 @@ -448,8 +448,8 @@ module P256 : SIGNATURE = struct fun a b -> (* TODO re-group once coverage ppx is updated *) match (a, b) with - | (Pk a, Pk b) -> Bytes.compare a b - | (Sk a, Sk b) -> Bytes.compare a b + | Pk a, Pk b -> Bytes.compare a b + | Sk a, Sk b -> Bytes.compare a b let equal : type a. a key -> a key -> bool = fun a b -> compare a b = 0 diff --git a/src/lib_hacl/test/test.ml b/src/lib_hacl/test/test.ml index bf0c1e48e5ce..c385de397d87 100644 --- a/src/lib_hacl/test/test.ml +++ b/src/lib_hacl/test/test.ml @@ -260,8 +260,8 @@ let p256_tests = let test_ed25519 (v : Bytes.t ed25519_test) : unit = log_s "Testing Ed25519" ; - let (pk1, sk1) = Hacl.Ed25519.keypair () in - let (pk2, _) = Hacl.Ed25519.keypair () in + let pk1, sk1 = Hacl.Ed25519.keypair () in + let pk2, _ = Hacl.Ed25519.keypair () in assert (pk1 <> pk2) ; log_s "[Ed25519.keypair] Success" ; assert (pk1 = Hacl.Ed25519.neuterize sk1) ; @@ -280,8 +280,8 @@ let test_ed25519 (v : Bytes.t ed25519_test) : unit = let test_p256 (v : Bytes.t p256_test) : unit = log_s "Testing P256" ; - let (pk1, sk1) = Hacl.P256.keypair () in - let (pk2, _) = Hacl.P256.keypair () in + let pk1, sk1 = Hacl.P256.keypair () in + let pk2, _ = Hacl.P256.keypair () in assert (pk1 <> pk2) ; log_s "[P256.keypair] Success" ; assert (pk1 = Hacl.P256.neuterize sk1) ; diff --git a/src/lib_hacl/test/test_hacl.ml b/src/lib_hacl/test/test_hacl.ml index 99460126776d..5530c0bbbdda 100644 --- a/src/lib_hacl/test/test_hacl.ml +++ b/src/lib_hacl/test/test_hacl.ml @@ -270,7 +270,7 @@ let secretbox = [("secretbox", `Quick, test_secretbox)] *) let test_box () = let open Box in - let (pk, sk) = keypair () in + let pk, sk = keypair () in let k = dh pk sk in let nonce = Nonce.gen () in let msg_orig = msg in @@ -292,7 +292,7 @@ open Ed25519 let test_keypair_ed25519 () = let seed = Hacl.Rand.gen 32 in match (sk_of_bytes seed, sk_of_bytes seed) with - | (Some sk, Some sk') -> + | Some sk, Some sk' -> let pk = neuterize sk in let pk' = neuterize sk' in Alcotest.(check bool "of_seed" true (Ed25519.equal pk pk')) ; @@ -306,13 +306,13 @@ let test_keypair_ed25519 () = is accepted by [Sign.verify]. *) let test_sign_ed25519 () = - let (pk, sk) = keypair () in + let pk, sk = keypair () in let signature = sign ~sk ~msg in Alcotest.(check bool "verify" true (verify ~pk ~msg ~signature)) (** Checks the neuterize function for public key generation. *) let test_public_ed25519 () = - let (pk, sk) = keypair () in + let pk, sk = keypair () in let pk' = to_bytes pk in let ppk = to_bytes (neuterize pk) in let psk = to_bytes (neuterize sk) in @@ -343,13 +343,13 @@ let check_p256_bytes_public = let nb_iterations = 10 let test_export_p256 () = - let (pk, sk) = keypair () in + let pk, sk = keypair () in let sk_bytes = to_bytes sk in let pk_bytes = to_bytes pk in Alcotest.(check int __LOC__ sk_size (Bytes.length sk_bytes)) ; Alcotest.(check int __LOC__ pk_size (Bytes.length pk_bytes)) ; match (sk_of_bytes sk_bytes, pk_of_bytes pk_bytes) with - | (Some sk', Some pk') -> + | Some sk', Some pk' -> let pk'' = neuterize pk' in Alcotest.(check check_p256_bytes_secret "sk'" sk sk') ; Alcotest.(check check_p256_bytes_public "pk'" pk pk') ; @@ -363,7 +363,7 @@ let test_export_p256 () = done let test_write_key_p256 () = - let (pk, sk) = keypair () in + let pk, sk = keypair () in let sk_bytes = to_bytes sk in let pk_bytes = to_bytes pk in let sk_buf = Bytes.create sk_size in @@ -375,7 +375,7 @@ let test_write_key_p256 () = let test_write_key_pos_p256 () = let pos = 42 in - let (pk, sk) = keypair () in + let pk, sk = keypair () in let sk_bytes = to_bytes sk in let pk_bytes = to_bytes pk in let sk_buf = Bytes.create (sk_size + pos) in @@ -389,7 +389,7 @@ let test_write_key_pos_p256 () = let test_write_key_with_ledger () = (* This test simulates the code in Ledger_commands.public_key_returning_instruction *) - let (pk, _) = keypair () in + let pk, _ = keypair () in let pk_bytes = to_bytes pk in let buf = Bytes.create (pk_size + 1) in match pk_of_bytes pk_bytes with @@ -408,7 +408,7 @@ let test_write_key_p256 () = done let test_keypair_p256 () = - let (pk, sk) = keypair () in + let pk, sk = keypair () in let pk' = neuterize sk in Alcotest.(check bytes "keccak_256" (P256.to_bytes pk) (P256.to_bytes pk')) @@ -418,7 +418,7 @@ let test_keypair_p256 () = done let test_sign_p256 () = - let (pk, sk) = keypair () in + let pk, sk = keypair () in let signature = sign ~sk ~msg in Alcotest.(check bool "sign_p256" true (verify ~pk ~msg ~signature)) @@ -433,7 +433,7 @@ let test_vectors_p256 () = List.map (fun (sk, pk) -> match (sk_of_bytes (of_hex sk), pk_of_bytes (of_hex pk)) with - | (Some sk, Some pk) -> (sk, pk) + | Some sk, Some pk -> (sk, pk) | _ -> Alcotest.fail "invalid key") Vectors_p256.keys in diff --git a/src/lib_lwt_result_stdlib/bare/structs/list.ml b/src/lib_lwt_result_stdlib/bare/structs/list.ml index 0c618aab1a98..77153b0a6f4a 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/list.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/list.ml @@ -73,9 +73,9 @@ let nth xs n = else let rec aux xs n = match (xs, n) with - | ([], _) -> None - | (x :: _, 0) -> Some x - | (_ :: xs, n) -> (aux [@ocaml.tailcall]) xs (n - 1) + | [], _ -> None + | x :: _, 0 -> Some x + | _ :: xs, n -> (aux [@ocaml.tailcall]) xs (n - 1) in aux xs n @@ -98,18 +98,18 @@ let rec iter2 ~when_different_lengths f xs ys = The same remark applies to the other 2-list iterators. *) match (xs, ys) with - | ([], []) -> Result_syntax.return_unit - | ([], _ :: _) | (_ :: _, []) -> Error when_different_lengths - | (x :: xs, y :: ys) -> + | [], [] -> Result_syntax.return_unit + | [], _ :: _ | _ :: _, [] -> Error when_different_lengths + | x :: xs, y :: ys -> f x y ; (iter2 [@ocaml.tailcall]) ~when_different_lengths f xs ys let rev_map2 ~when_different_lengths f xs ys = let rec aux zs xs ys = match (xs, ys) with - | ([], []) -> Ok zs - | ([], _ :: _) | (_ :: _, []) -> Error when_different_lengths - | (x :: xs, y :: ys) -> + | [], [] -> Ok zs + | [], _ :: _ | _ :: _, [] -> Error when_different_lengths + | x :: xs, y :: ys -> let z = f x y in (aux [@ocaml.tailcall]) (z :: zs) xs ys in @@ -121,9 +121,9 @@ let map2 ~when_different_lengths f xs ys = let fold_left2 ~when_different_lengths f a xs ys = let rec aux acc xs ys = match (xs, ys) with - | ([], []) -> Ok acc - | ([], _ :: _) | (_ :: _, []) -> Error when_different_lengths - | (x :: xs, y :: ys) -> + | [], [] -> Ok acc + | [], _ :: _ | _ :: _, [] -> Error when_different_lengths + | x :: xs, y :: ys -> let acc = f acc x y in (aux [@ocaml.tailcall]) acc xs ys in @@ -132,9 +132,9 @@ let fold_left2 ~when_different_lengths f a xs ys = let fold_right2 ~when_different_lengths f xs ys a = let rec aux xs ys = match (xs, ys) with - | ([], []) -> Ok a - | ([], _ :: _) | (_ :: _, []) -> Error when_different_lengths - | (x :: xs, y :: ys) -> + | [], [] -> Ok a + | [], _ :: _ | _ :: _, [] -> Error when_different_lengths + | x :: xs, y :: ys -> let open Result_syntax in let* acc = aux xs ys in return (f x y acc) @@ -144,9 +144,9 @@ let fold_right2 ~when_different_lengths f xs ys a = let for_all2 ~when_different_lengths f xs ys = let rec aux xs ys = match (xs, ys) with - | ([], []) -> Ok true - | ([], _ :: _) | (_ :: _, []) -> Error when_different_lengths - | (x :: xs, y :: ys) -> ( + | [], [] -> Ok true + | [], _ :: _ | _ :: _, [] -> Error when_different_lengths + | x :: xs, y :: ys -> ( match f x y with | true -> (aux [@ocaml.tailcall]) xs ys | false -> Ok false) @@ -156,9 +156,9 @@ let for_all2 ~when_different_lengths f xs ys = let exists2 ~when_different_lengths f xs ys = let rec aux xs ys = match (xs, ys) with - | ([], []) -> Ok false - | ([], _ :: _) | (_ :: _, []) -> Error when_different_lengths - | (x :: xs, y :: ys) -> ( + | [], [] -> Ok false + | [], _ :: _ | _ :: _, [] -> Error when_different_lengths + | x :: xs, y :: ys -> ( match f x y with | true -> Ok true | false -> (aux [@ocaml.tailcall]) xs ys) @@ -169,7 +169,7 @@ let fold_left_map f accu l = let rec aux accu rev_list_accu = function | [] -> (accu, rev rev_list_accu) | x :: xs -> - let (accu, y) = f accu x in + let accu, y = f accu x in (aux [@ocaml.tailcall]) accu (y :: rev_list_accu) xs in aux accu [] l @@ -179,7 +179,7 @@ let fold_left_map_e f accu l = | [] -> Ok (accu, rev rev_list_accu) | x :: xs -> let open Result_syntax in - let* (accu, y) = f accu x in + let* accu, y = f accu x in (aux [@ocaml.tailcall]) accu (y :: rev_list_accu) xs in aux accu [] l @@ -189,13 +189,13 @@ let fold_left_map_s f accu l = let rec aux accu rev_list_accu = function | [] -> return (accu, rev rev_list_accu) | x :: xs -> - let* (accu, y) = f accu x in + let* accu, y = f accu x in (aux [@ocaml.tailcall]) accu (y :: rev_list_accu) xs in match l with | [] -> return (accu, []) | x :: xs -> - let* (accu, y) = lwt_apply2 f accu x in + let* accu, y = lwt_apply2 f accu x in (aux [@ocaml.tailcall]) accu [y] xs let fold_left_map_es f accu l = @@ -203,13 +203,13 @@ let fold_left_map_es f accu l = let rec aux accu rev_list_accu = function | [] -> return (accu, rev rev_list_accu) | x :: xs -> - let* (accu, y) = f accu x in + let* accu, y = f accu x in (aux [@ocaml.tailcall]) accu (y :: rev_list_accu) xs in match l with | [] -> return (accu, []) | x :: xs -> - let* (accu, y) = lwt_apply2 f accu x in + let* accu, y = lwt_apply2 f accu x in (aux [@ocaml.tailcall]) accu [y] xs let rec mem ~equal x = function @@ -802,7 +802,7 @@ let fold_left_i f init l = let fold_left_i_e f acc l = let open Result_syntax in - let* (_, acc) = + let* _, acc = fold_left_e (fun (i, acc) x -> let* acc = f i acc x in @@ -814,7 +814,7 @@ let fold_left_i_e f acc l = let fold_left_i_s f acc l = let open Lwt_syntax in - let* (_, acc) = + let* _, acc = fold_left_s (fun (i, acc) x -> let* acc = f i acc x in @@ -826,7 +826,7 @@ let fold_left_i_s f acc l = let fold_left_i_es f acc l = let open Lwt_result_syntax in - let* (_, acc) = + let* _, acc = fold_left_es (fun (i, acc) x -> let* acc = f i acc x in @@ -1016,11 +1016,11 @@ let rev_map2_e ~when_different_lengths f xs ys = let open Result_syntax in let rec aux zs xs ys = match (xs, ys) with - | ([], []) -> return zs - | (x :: xs, y :: ys) -> + | [], [] -> return zs + | x :: xs, y :: ys -> let* z = f x y in (aux [@ocaml.tailcall]) (z :: zs) xs ys - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths in aux [] xs ys @@ -1028,35 +1028,35 @@ let rev_map2_s ~when_different_lengths f xs ys = let open Lwt_syntax in let rec aux zs xs ys = match (xs, ys) with - | ([], []) -> return_ok zs - | (x :: xs, y :: ys) -> + | [], [] -> return_ok zs + | x :: xs, y :: ys -> let* z = f x y in (aux [@ocaml.tailcall]) (z :: zs) xs ys - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths in match (xs, ys) with - | ([], []) -> return_ok_nil - | (x :: xs, y :: ys) -> + | [], [] -> return_ok_nil + | x :: xs, y :: ys -> let* z = lwt_apply2 f x y in aux [z] xs ys - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths let rev_map2_es ~when_different_lengths f xs ys = let open Lwt_result_syntax in let rec aux zs xs ys = match (xs, ys) with - | ([], []) -> return zs - | (x :: xs, y :: ys) -> + | [], [] -> return zs + | x :: xs, y :: ys -> let* z = f x y in (aux [@ocaml.tailcall]) (z :: zs) xs ys - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths in match (xs, ys) with - | ([], []) -> return [] - | (x :: xs, y :: ys) -> + | [], [] -> return [] + | x :: xs, y :: ys -> let* z = lwt_apply2 f x y in aux [z] xs ys - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths let map2_e ~when_different_lengths f xs ys = rev_map2_e ~when_different_lengths f xs ys |> Result.map rev @@ -1071,11 +1071,11 @@ let iter2_e ~when_different_lengths f xs ys = let open Result_syntax in let rec aux xs ys = match (xs, ys) with - | ([], []) -> return_unit - | (x :: xs, y :: ys) -> + | [], [] -> return_unit + | x :: xs, y :: ys -> let* () = f x y in (aux [@ocaml.tailcall]) xs ys - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths in aux xs ys @@ -1083,45 +1083,45 @@ let iter2_s ~when_different_lengths f xs ys = let open Lwt_syntax in let rec aux xs ys = match (xs, ys) with - | ([], []) -> return_ok_unit - | (x :: xs, y :: ys) -> + | [], [] -> return_ok_unit + | x :: xs, y :: ys -> let* () = f x y in (aux [@ocaml.tailcall]) xs ys - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths in match (xs, ys) with - | ([], []) -> return_ok_unit - | (x :: xs, y :: ys) -> + | [], [] -> return_ok_unit + | x :: xs, y :: ys -> let* () = lwt_apply2 f x y in aux xs ys - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths let iter2_es ~when_different_lengths f xs ys = let open Lwt_result_syntax in let rec aux xs ys = match (xs, ys) with - | ([], []) -> return_unit - | (x :: xs, y :: ys) -> + | [], [] -> return_unit + | x :: xs, y :: ys -> let* () = f x y in (aux [@ocaml.tailcall]) xs ys - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths in match (xs, ys) with - | ([], []) -> return_unit - | (x :: xs, y :: ys) -> + | [], [] -> return_unit + | x :: xs, y :: ys -> let* () = lwt_apply2 f x y in aux xs ys - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths let fold_left2_e ~when_different_lengths f init xs ys = let open Result_syntax in let rec aux acc xs ys = match (xs, ys) with - | ([], []) -> return acc - | (x :: xs, y :: ys) -> + | [], [] -> return acc + | x :: xs, y :: ys -> let* acc = f acc x y in (aux [@ocaml.tailcall]) acc xs ys - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths in aux init xs ys @@ -1129,45 +1129,45 @@ let fold_left2_s ~when_different_lengths f init xs ys = let open Lwt_syntax in let rec aux acc xs ys = match (xs, ys) with - | ([], []) -> return_ok acc - | (x :: xs, y :: ys) -> + | [], [] -> return_ok acc + | x :: xs, y :: ys -> let* acc = f acc x y in (aux [@ocaml.tailcall]) acc xs ys - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths in match (xs, ys) with - | ([], []) -> return_ok init - | (x :: xs, y :: ys) -> + | [], [] -> return_ok init + | x :: xs, y :: ys -> let* acc = lwt_apply3 f init x y in aux acc xs ys - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths let fold_left2_es ~when_different_lengths f init xs ys = let open Lwt_result_syntax in let rec aux acc xs ys = match (xs, ys) with - | ([], []) -> return acc - | (x :: xs, y :: ys) -> + | [], [] -> return acc + | x :: xs, y :: ys -> let* acc = f acc x y in (aux [@ocaml.tailcall]) acc xs ys - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths in match (xs, ys) with - | ([], []) -> return init - | (x :: xs, y :: ys) -> + | [], [] -> return init + | x :: xs, y :: ys -> let* acc = lwt_apply3 f init x y in (aux [@ocaml.tailcall]) acc xs ys - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths let fold_right2_e ~when_different_lengths f xs ys init = let open Result_syntax in let rec aux xs ys = match (xs, ys) with - | ([], []) -> return init - | (x :: xs, y :: ys) -> + | [], [] -> return init + | x :: xs, y :: ys -> let* acc = aux xs ys in f x y acc - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths in aux xs ys @@ -1175,9 +1175,9 @@ let fold_right2_s ~when_different_lengths f xs ys init = let open Lwt_syntax in let rec aux xs ys = match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths - | ([], []) -> return_ok init - | (x :: xs, y :: ys) -> ( + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths + | [], [] -> return_ok init + | x :: xs, y :: ys -> ( let* acc = aux xs ys in match acc with | Error _ -> return acc @@ -1191,9 +1191,9 @@ let fold_right2_es ~when_different_lengths f xs ys init = let open Lwt_result_syntax in let rec aux xs ys = match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> return init - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths + | [], [] -> return init + | x :: xs, y :: ys -> let* acc = aux xs ys in f x y acc in @@ -1291,9 +1291,9 @@ let for_all2_e ~when_different_lengths f xs ys = let open Result_syntax in let rec aux xs ys = match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> return_true - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths + | [], [] -> return_true + | x :: xs, y :: ys -> let* b = f x y in if b then (aux [@ocaml.tailcall]) xs ys else return_false in @@ -1303,16 +1303,16 @@ let for_all2_s ~when_different_lengths f xs ys = let open Lwt_syntax in let rec aux xs ys = match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths - | ([], []) -> return_ok_true - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths + | [], [] -> return_ok_true + | x :: xs, y :: ys -> let* b = f x y in if b then (aux [@ocaml.tailcall]) xs ys else return_ok_false in match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths - | ([], []) -> return_ok_true - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths + | [], [] -> return_ok_true + | x :: xs, y :: ys -> let* b = lwt_apply2 f x y in if b then aux xs ys else return_ok_false @@ -1320,16 +1320,16 @@ let for_all2_es ~when_different_lengths f xs ys = let open Lwt_result_syntax in let rec aux xs ys = match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> return_true - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths + | [], [] -> return_true + | x :: xs, y :: ys -> let* b = f x y in if b then (aux [@ocaml.tailcall]) xs ys else return_false in match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> return_true - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths + | [], [] -> return_true + | x :: xs, y :: ys -> let* b = lwt_apply2 f x y in if b then aux xs ys else return_false @@ -1337,9 +1337,9 @@ let exists2_e ~when_different_lengths f xs ys = let open Result_syntax in let rec aux xs ys = match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> return_false - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths + | [], [] -> return_false + | x :: xs, y :: ys -> let* b = f x y in if b then return_true else (aux [@ocaml.tailcall]) xs ys in @@ -1349,16 +1349,16 @@ let exists2_s ~when_different_lengths f xs ys = let open Lwt_syntax in let rec aux xs ys = match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths - | ([], []) -> return_ok_false - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths + | [], [] -> return_ok_false + | x :: xs, y :: ys -> let* b = f x y in if b then return_ok_true else (aux [@ocaml.tailcall]) xs ys in match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> return_error when_different_lengths - | ([], []) -> return_ok_false - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> return_error when_different_lengths + | [], [] -> return_ok_false + | x :: xs, y :: ys -> let* b = lwt_apply2 f x y in if b then return_ok_true else aux xs ys @@ -1366,16 +1366,16 @@ let exists2_es ~when_different_lengths f xs ys = let open Lwt_result_syntax in let rec aux xs ys = match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> return_false - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths + | [], [] -> return_false + | x :: xs, y :: ys -> let* b = f x y in if b then return_true else (aux [@ocaml.tailcall]) xs ys in match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> return_false - | (x :: xs, y :: ys) -> + | [], _ :: _ | _ :: _, [] -> fail when_different_lengths + | [], [] -> return_false + | x :: xs, y :: ys -> let* b = lwt_apply2 f x y in if b then return_true else aux xs ys @@ -1400,7 +1400,7 @@ let rev_partition_result xs = aux [] [] xs let partition_result xs = - let (rev_oks, rev_errors) = rev_partition_result xs in + let rev_oks, rev_errors = rev_partition_result xs in (rev rev_oks, rev rev_errors) let rev_partition_either xs = @@ -1414,7 +1414,7 @@ let rev_partition_either xs = aux [] [] xs let partition_either xs = - let (rev_lefts, rev_rights) = rev_partition_either xs in + let rev_lefts, rev_rights = rev_partition_either xs in (rev rev_lefts, rev rev_rights) let rev_partition_e f l = @@ -1600,20 +1600,18 @@ let rev_combine ~when_different_lengths xs ys = let combine_with_leftovers xs ys = let rec aux rev_combined xs ys = match (xs, ys) with - | ([], []) -> (rev rev_combined, None) - | ((_ :: _ as left), []) -> (rev rev_combined, Some (Either.Left left)) - | ([], (_ :: _ as right)) -> (rev rev_combined, Some (Either.Right right)) - | (x :: xs, y :: ys) -> - (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys + | [], [] -> (rev rev_combined, None) + | (_ :: _ as left), [] -> (rev rev_combined, Some (Either.Left left)) + | [], (_ :: _ as right) -> (rev rev_combined, Some (Either.Right right)) + | x :: xs, y :: ys -> (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys in aux [] xs ys let combine_drop xs ys = let rec aux rev_combined xs ys = match (xs, ys) with - | (x :: xs, y :: ys) -> - (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys - | ([], []) | (_ :: _, []) | ([], _ :: _) -> rev rev_combined + | x :: xs, y :: ys -> (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys + | [], [] | _ :: _, [] | [], _ :: _ -> rev rev_combined in aux [] xs ys @@ -1636,15 +1634,15 @@ let shuffle ~rng l = let rec compare ecomp xs ys = match (xs, ys) with - | ([], []) -> 0 - | ([], _ :: _) -> -1 - | (_ :: _, []) -> 1 - | (x :: xs, y :: ys) -> + | [], [] -> 0 + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | x :: xs, y :: ys -> let ec = ecomp x y in if ec = 0 then compare ecomp xs ys else ec let rec equal eeq xs ys = match (xs, ys) with - | ([], []) -> true - | ([], _ :: _) | (_ :: _, []) -> false - | (x :: xs, y :: ys) -> eeq x y && equal eeq xs ys + | [], [] -> true + | [], _ :: _ | _ :: _, [] -> false + | x :: xs, y :: ys -> eeq x y && equal eeq xs ys diff --git a/src/lib_lwt_result_stdlib/bare/structs/monad.ml b/src/lib_lwt_result_stdlib/bare/structs/monad.ml index 90a2496121b9..8c2498d088cf 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/monad.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/monad.ml @@ -39,9 +39,9 @@ module Lwt_syntax = struct end module Option_syntax = struct - let (return[@ocaml.inline "always"]) = fun x -> Some x + let (return [@ocaml.inline "always"]) = fun x -> Some x - let (fail[@ocaml.inline "always"]) = None + let (fail [@ocaml.inline "always"]) = None let return_unit = return () @@ -55,7 +55,7 @@ module Option_syntax = struct let ( let+ ) o f = Stdlib.Option.map f o - let both a b = match (a, b) with (Some x, Some y) -> Some (x, y) | _ -> None + let both a b = match (a, b) with Some x, Some y -> Some (x, y) | _ -> None let ( and* ) = both @@ -63,9 +63,9 @@ module Option_syntax = struct end module Result_syntax = struct - let (return[@ocaml.inline "always"]) = fun x -> Ok x + let (return [@ocaml.inline "always"]) = fun x -> Ok x - let (fail[@ocaml.inline "always"]) = fun x -> Error x + let (fail [@ocaml.inline "always"]) = fun x -> Error x let return_unit = Ok () @@ -103,15 +103,15 @@ module Result_syntax = struct let both a b = match (a, b) with - | (Ok a, Ok b) -> Ok (a, b) - | (Error err, Ok _) | (Ok _, Error err) -> Error [err] - | (Error erra, Error errb) -> Error [erra; errb] + | Ok a, Ok b -> Ok (a, b) + | Error err, Ok _ | Ok _, Error err -> Error [err] + | Error erra, Error errb -> Error [erra; errb] end module Lwt_option_syntax = struct - let (return[@ocaml.iniline "always"]) = fun x -> Lwt.return (Some x) + let (return [@ocaml.iniline "always"]) = fun x -> Lwt.return (Some x) - let (fail[@ocaml.iniline "always"]) = Lwt.return None + let (fail [@ocaml.iniline "always"]) = Lwt.return None let return_unit = Lwt_syntax.return_some () @@ -123,7 +123,7 @@ module Lwt_option_syntax = struct let both a b = let open Lwt_syntax in - let+ (a, b) = both a b in + let+ a, b = both a b in Option_syntax.both a b let ( let* ) lo f = Lwt.bind lo (function None -> fail | Some x -> f x) @@ -140,9 +140,9 @@ module Lwt_option_syntax = struct end module Lwt_result_syntax = struct - let (return[@ocaml.iniline "always"]) = fun x -> Lwt.return (Ok x) + let (return [@ocaml.iniline "always"]) = fun x -> Lwt.return (Ok x) - let (fail[@ocaml.iniline "always"]) = fun x -> Lwt.return (Error x) + let (fail [@ocaml.iniline "always"]) = fun x -> Lwt.return (Error x) let return_unit = Lwt_syntax.return_ok_unit @@ -179,7 +179,7 @@ module Lwt_result_syntax = struct let both a b = let open Lwt_syntax in - let+ (a, b) = both a b in + let+ a, b = both a b in Result_syntax.both a b end @@ -188,8 +188,8 @@ end (* For internal use only, not advertised *) (* Like Lwt.apply but specialised for two-parameters functions *) -let (lwt_apply2[@ocaml.inline "always"]) = +let (lwt_apply2 [@ocaml.inline "always"]) = fun f x y -> try f x y with exn -> Lwt.fail exn -let (lwt_apply3[@ocaml.inline "always"]) = +let (lwt_apply3 [@ocaml.inline "always"]) = fun f a x y -> try f a x y with exn -> Lwt.fail exn diff --git a/src/lib_lwt_result_stdlib/bare/structs/option.ml b/src/lib_lwt_result_stdlib/bare/structs/option.ml index 81358fafae17..33c77824c170 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/option.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/option.ml @@ -82,34 +82,34 @@ let either_f oa ob = match oa with Some _ -> oa | None -> ob () let merge f oa ob = match (oa, ob) with - | (None, None) -> None - | (Some r, None) | (None, Some r) -> Some r - | (Some a, Some b) -> Some (f a b) + | None, None -> None + | Some r, None | None, Some r -> Some r + | Some a, Some b -> Some (f a b) let merge_e f oa ob = let open Result_syntax in match (oa, ob) with - | (None, None) -> return_none - | (Some r, None) | (None, Some r) -> return_some r - | (Some a, Some b) -> + | None, None -> return_none + | Some r, None | None, Some r -> return_some r + | Some a, Some b -> let* r = f a b in return_some r let merge_s f oa ob = let open Lwt_syntax in match (oa, ob) with - | (None, None) -> return_none - | (Some r, None) | (None, Some r) -> return_some r - | (Some a, Some b) -> + | None, None -> return_none + | Some r, None | None, Some r -> return_some r + | Some a, Some b -> let* r = f a b in return_some r let merge_es f oa ob = let open Lwt_result_syntax in match (oa, ob) with - | (None, None) -> return_none - | (Some r, None) | (None, Some r) -> return_some r - | (Some a, Some b) -> + | None, None -> return_none + | Some r, None | None, Some r -> return_some r + | Some a, Some b -> let* r = f a b in return_some r diff --git a/src/lib_lwt_result_stdlib/bare/structs/result.ml b/src/lib_lwt_result_stdlib/bare/structs/result.ml index a5f1e6329cdc..383a75bf0e7f 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/result.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/result.ml @@ -88,16 +88,16 @@ let is_error = function Ok _ -> false | Error _ -> true let equal ~ok ~error x y = match (x, y) with - | (Ok x, Ok y) -> ok x y - | (Error x, Error y) -> error x y - | (Ok _, Error _) | (Error _, Ok _) -> false + | Ok x, Ok y -> ok x y + | Error x, Error y -> error x y + | Ok _, Error _ | Error _, Ok _ -> false let compare ~ok ~error x y = match (x, y) with - | (Ok x, Ok y) -> ok x y - | (Error x, Error y) -> error x y - | (Ok _, Error _) -> -1 - | (Error _, Ok _) -> 1 + | Ok x, Ok y -> ok x y + | Error x, Error y -> error x y + | Ok _, Error _ -> -1 + | Error _, Ok _ -> 1 let to_option = function Ok v -> Some v | Error _ -> None diff --git a/src/lib_lwt_result_stdlib/bare/structs/withExceptions.ml b/src/lib_lwt_result_stdlib/bare/structs/withExceptions.ml index 3a4df18d3806..2f48bf274911 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/withExceptions.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/withExceptions.ml @@ -54,9 +54,9 @@ module List = struct let rev_combine ~loc xs ys = let rec aux acc xs ys = match (xs, ys) with - | ([], []) -> acc - | (x :: xs, y :: ys) -> aux ((x, y) :: acc) xs ys - | ([], _ :: _) | (_ :: _, []) -> + | [], [] -> acc + | x :: xs, y :: ys -> aux ((x, y) :: acc) xs ys + | [], _ :: _ | _ :: _, [] -> raise (invalid "Lwtreslib.WithExceptions.List.rev_combine" loc) in aux [] xs ys @@ -64,9 +64,9 @@ module List = struct let combine ~loc xs ys = let rec aux acc xs ys = match (xs, ys) with - | ([], []) -> acc - | (x :: xs, y :: ys) -> aux ((x, y) :: acc) xs ys - | ([], _ :: _) | (_ :: _, []) -> + | [], [] -> acc + | x :: xs, y :: ys -> aux ((x, y) :: acc) xs ys + | [], _ :: _ | _ :: _, [] -> raise (invalid "Lwtreslib.WithExceptions.List.combine" loc) in Stdlib.List.rev (aux [] xs ys) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml index af7790d8bae0..4f8734d79fe0 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml @@ -600,8 +600,8 @@ let eq_es_ep ?pp es ep = (let open Lwt_syntax in let+ es = es and+ ep = ep in match (es, ep) with - | (Ok ok_es, Ok ok_ep) -> eq ?pp ok_es ok_ep - | (Error error_es, Error trace_ep) -> + | Ok ok_es, Ok ok_ep -> eq ?pp ok_es ok_ep + | Error error_es, Error trace_ep -> let trace_ep_has_error_es = Support.Test_trace.fold (fun has error -> has || error = error_es) @@ -615,19 +615,19 @@ let eq_es_ep ?pp es ep = error_es (Support.Test_trace.pp Format.pp_print_int) trace_ep - | (Ok _, Error _) -> QCheck.Test.fail_report "Ok _ is not Error _" - | (Error _, Ok _) -> QCheck.Test.fail_report "Error _ is not Ok _") + | Ok _, Error _ -> QCheck.Test.fail_report "Ok _ is not Error _" + | Error _, Ok _ -> QCheck.Test.fail_report "Error _ is not Ok _") let eq_ep ?pp a b = Lwt_main.run (let open Lwt_syntax in let+ a = a and+ b = b in match (a, b) with - | (Ok ok_es, Ok ok_ep) -> eq ?pp ok_es ok_ep - | (Error _, Error _) -> + | Ok ok_es, Ok ok_ep -> eq ?pp ok_es ok_ep + | Error _, Error _ -> true (* Not as precise as we could be, but precise enough *) - | (Ok _, Error _) -> QCheck.Test.fail_report "Ok _ is not Error _" - | (Error _, Ok _) -> QCheck.Test.fail_report "Error _ is not Ok _") + | Ok _, Error _ -> QCheck.Test.fail_report "Ok _ is not Error _" + | Error _, Ok _ -> QCheck.Test.fail_report "Error _ is not Ok _") module PP = struct let int = Format.pp_print_int diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml index c0a4abdf4bff..ee8c631dc031 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml @@ -724,7 +724,7 @@ end) : Test = struct (Format.asprintf "%s.fold_left_map, Stdlib.List.fold_left_map" M.name) (triple accum one many) (fun (Fun (_, fn), init, input) -> - let (a, xs) = M.fold_left_map (FoldOf.fn fn) init (M.of_list input) in + let a, xs = M.fold_left_map (FoldOf.fn fn) init (M.of_list input) in eq (a, xs) (with_stdlib_fold_left_map (fn, init, input))) let fold_left_map_e = @@ -1793,7 +1793,7 @@ end) : Test = struct in !acc) (let acc = ref init in - let (leftright, leftovers) = + let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in M.iter (uncurry @@ Iter2Of.fn acc fn) leftright ; @@ -1816,7 +1816,7 @@ end) : Test = struct in !acc) (let acc = ref init in - let (leftright, leftovers) = + let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* () = M.iter_e (uncurry @@ Iter2EOf.fn_e acc fn) leftright in @@ -1839,7 +1839,7 @@ end) : Test = struct in !acc) (let acc = ref init in - let (leftright, leftovers) = + let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let*! () = M.iter_s (uncurry @@ Iter2SOf.fn_s acc fn) leftright in @@ -1862,7 +1862,7 @@ end) : Test = struct in !acc) (let acc = ref init in - let (leftright, leftovers) = + let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* () = M.iter_es (uncurry @@ Iter2ESOf.fn_e acc fn) leftright in @@ -1881,7 +1881,7 @@ end) : Test = struct (Map2Of.fn fn) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let t = M.map (uncurry @@ Map2Of.fn fn) leftright in @@ -1899,7 +1899,7 @@ end) : Test = struct (Map2EOf.fn_e fn) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.map_e (uncurry @@ Map2EOf.fn_e fn) leftright in @@ -1917,7 +1917,7 @@ end) : Test = struct (Map2SOf.fn fn) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.map_s (uncurry @@ Map2SOf.fn fn) leftright in @@ -1937,7 +1937,7 @@ end) : Test = struct (Map2ESOf.fn_e fn) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.map_es (uncurry @@ Map2ESOf.fn_e fn) leftright in @@ -1958,7 +1958,7 @@ end) : Test = struct (Map2Of.fn fn) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let t = M.rev_map (uncurry @@ Map2Of.fn fn) leftright in @@ -1976,7 +1976,7 @@ end) : Test = struct (Map2EOf.fn_e fn) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.rev_map_e (uncurry @@ Map2EOf.fn_e fn) leftright in @@ -1994,7 +1994,7 @@ end) : Test = struct (Map2SOf.fn fn) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.rev_map_s (uncurry @@ Map2SOf.fn fn) leftright in @@ -2014,7 +2014,7 @@ end) : Test = struct (Map2ESOf.fn_e fn) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.rev_map_es (uncurry @@ Map2ESOf.fn_e fn) leftright in @@ -2036,7 +2036,7 @@ end) : Test = struct init (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let t = M.fold_left (uncurry_l @@ Fold2Of.fn fn) init leftright in @@ -2055,7 +2055,7 @@ end) : Test = struct init (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = @@ -2076,7 +2076,7 @@ end) : Test = struct init (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = @@ -2099,7 +2099,7 @@ end) : Test = struct init (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = @@ -2212,14 +2212,14 @@ end) : Test = struct (Cond2Of.fn pred) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let t = M.for_all (uncurry @@ Cond2Of.fn pred) leftright in match (t, leftovers) with - | (false, _) -> Ok false - | (true, None) -> Ok true - | (true, Some _) -> Error 101)) + | false, _ -> Ok false + | true, None -> Ok true + | true, Some _ -> Error 101)) let for_all_e = Test.make @@ -2234,14 +2234,14 @@ end) : Test = struct (Cond2EOf.fn pred) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.for_all_e (uncurry @@ Cond2EOf.fn pred) leftright in match (t, leftovers) with - | (false, _) -> Ok false - | (true, None) -> Ok true - | (true, Some _) -> Error 101)) + | false, _ -> Ok false + | true, None -> Ok true + | true, Some _ -> Error 101)) let for_all_s = Test.make @@ -2256,14 +2256,14 @@ end) : Test = struct (Cond2SOf.fn pred) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let+ t = M.for_all_s (uncurry @@ Cond2SOf.fn pred) leftright in match (t, leftovers) with - | (false, _) -> Ok false - | (true, None) -> Ok true - | (true, Some _) -> Error 101)) + | false, _ -> Ok false + | true, None -> Ok true + | true, Some _ -> Error 101)) let for_all_es = Test.make @@ -2277,14 +2277,14 @@ end) : Test = struct (Cond2ESOf.fn pred) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.for_all_es (uncurry @@ Cond2ESOf.fn pred) leftright in match (t, leftovers) with - | (false, _) -> Lwt.return_ok false - | (true, None) -> Lwt.return_ok true - | (true, Some _) -> Lwt.return_error 101)) + | false, _ -> Lwt.return_ok false + | true, None -> Lwt.return_ok true + | true, Some _ -> Lwt.return_error 101)) let tests_for_all = [for_all; for_all_e; for_all_s; for_all_es] @@ -2300,14 +2300,14 @@ end) : Test = struct (Cond2Of.fn pred) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let t = M.exists (uncurry @@ Cond2Of.fn pred) leftright in match (t, leftovers) with - | (true, _) -> Ok true - | (false, None) -> Ok false - | (false, Some _) -> Error 101)) + | true, _ -> Ok true + | false, None -> Ok false + | false, Some _ -> Error 101)) let exists_e = Test.make @@ -2322,14 +2322,14 @@ end) : Test = struct (Cond2EOf.fn pred) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.exists_e (uncurry @@ Cond2EOf.fn pred) leftright in match (t, leftovers) with - | (true, _) -> Ok true - | (false, None) -> Ok false - | (false, Some _) -> Error 101)) + | true, _ -> Ok true + | false, None -> Ok false + | false, Some _ -> Error 101)) let exists_s = Test.make @@ -2344,14 +2344,14 @@ end) : Test = struct (Cond2SOf.fn pred) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let+ t = M.exists_s (uncurry @@ Cond2SOf.fn pred) leftright in match (t, leftovers) with - | (true, _) -> Ok true - | (false, None) -> Ok false - | (false, Some _) -> Error 101)) + | true, _ -> Ok true + | false, None -> Ok false + | false, Some _ -> Error 101)) let exists_es = Test.make @@ -2365,14 +2365,14 @@ end) : Test = struct (Cond2ESOf.fn pred) (M.of_list left) (M.of_list right)) - (let (leftright, leftovers) = + (let leftright, leftovers = M.combine_with_leftovers (M.of_list left) (M.of_list right) in let* t = M.exists_es (uncurry @@ Cond2ESOf.fn pred) leftright in match (t, leftovers) with - | (true, _) -> Lwt.return_ok true - | (false, None) -> Lwt.return_ok false - | (false, Some _) -> Lwt.return_error 101)) + | true, _ -> Lwt.return_ok true + | false, None -> Lwt.return_ok false + | false, Some _ -> Lwt.return_error 101)) let tests_exists = [exists; exists_e; exists_s; exists_es] diff --git a/src/lib_lwt_result_stdlib/test/test_hashtbl.ml b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml index 98ad7414b3bd..0db5f4380abf 100644 --- a/src/lib_lwt_result_stdlib/test/test_hashtbl.ml +++ b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml @@ -120,7 +120,7 @@ let test_self_clean _ _ = let test_order _ _ = let t = IntESHashtbl.create 2 in - let (wter, wker) = Lwt.task () in + let wter, wker = Lwt.task () in let world = ref [] in (* PROMISE A *) let p_a = diff --git a/src/lib_lwt_result_stdlib/traced/structs/monad.ml b/src/lib_lwt_result_stdlib/traced/structs/monad.ml index 839062ecb673..49cd677f44b7 100644 --- a/src/lib_lwt_result_stdlib/traced/structs/monad.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/monad.ml @@ -32,7 +32,7 @@ module Make (Trace : Traced_sigs.Trace.S) : module Traced_result_syntax = struct include Result_syntax - let (fail[@ocaml.inline "always"]) = fun e -> fail (Trace.make e) + let (fail [@ocaml.inline "always"]) = fun e -> fail (Trace.make e) let rec join_errors trace_acc = function | Ok _ :: ts -> join_errors trace_acc ts @@ -54,9 +54,9 @@ module Make (Trace : Traced_sigs.Trace.S) : let both a b = match (a, b) with - | (Ok a, Ok b) -> Ok (a, b) - | (Error err, Ok _) | (Ok _, Error err) -> Error err - | (Error erra, Error errb) -> Error (Trace.conp erra errb) + | Ok a, Ok b -> Ok (a, b) + | Error err, Ok _ | Ok _, Error err -> Error err + | Error erra, Error errb -> Error (Trace.conp erra errb) let ( and* ) = both @@ -66,7 +66,7 @@ module Make (Trace : Traced_sigs.Trace.S) : module Lwt_traced_result_syntax = struct include Lwt_result_syntax - let (fail[@ocaml.inline "always"]) = fun e -> fail (Trace.make e) + let (fail [@ocaml.inline "always"]) = fun e -> fail (Trace.make e) let join ts = let open Lwt_syntax in @@ -80,7 +80,7 @@ module Make (Trace : Traced_sigs.Trace.S) : let both a b = let open Lwt_syntax in - let+ (a, b) = both a b in + let+ a, b = both a b in Traced_result_syntax.both a b let ( and* ) = both diff --git a/src/lib_micheline/micheline_diff.ml b/src/lib_micheline/micheline_diff.ml index fc56f886e9e1..4837ba292b5d 100644 --- a/src/lib_micheline/micheline_diff.ml +++ b/src/lib_micheline/micheline_diff.ml @@ -109,10 +109,10 @@ let initial = } let rec zip_nodes = function - | ([], []) -> [] - | (p :: prevs, []) -> Left_only p :: zip_nodes (prevs, []) - | ([], c :: curs) -> Right_only c :: zip_nodes ([], curs) - | (p :: prevs, c :: curs) -> Both (p, c) :: zip_nodes (prevs, curs) + | [], [] -> [] + | p :: prevs, [] -> Left_only p :: zip_nodes (prevs, []) + | [], c :: curs -> Right_only c :: zip_nodes ([], curs) + | p :: prevs, c :: curs -> Both (p, c) :: zip_nodes (prevs, curs) let add_stack_level ~constr ~children ~diff state_stack = let Micheline_printer.{comment} = diff in @@ -150,16 +150,16 @@ let accumulate_child (is_different, node) = function let diff_simple prev cur state = match (prev, cur) with - | (Int (_, p), Int (_, c)) when Z.equal p c -> + | Int (_, p), Int (_, c) when Z.equal p c -> accumulate_child (false, Int (no_comment, p)) state - | (String (_, p), String (_, c)) when String.equal p c -> + | String (_, p), String (_, c) when String.equal p c -> accumulate_child (false, String (no_comment, p)) state - | (Bytes (_, p), Bytes (_, c)) when Bytes.equal p c -> + | Bytes (_, p), Bytes (_, c) when Bytes.equal p c -> accumulate_child (false, Bytes (no_comment, p)) state (* This function won't be called with pairs (Seq, Seq) or (Prim, Prim), so we don't care about looking inside those. This is taken care of elsewhere. *) - | (prev, cur) -> + | prev, cur -> accumulate_child (true, replace_location (replaced cur) prev) state let rec dequeue = function @@ -228,7 +228,5 @@ and diff_step state nodes = diff_simple prev cur state let diff ~prev ~current () = - let (is_different, diff) = - diff_step (Bottom initial) (Both (prev, current)) - in + let is_different, diff = diff_step (Bottom initial) (Both (prev, current)) in if is_different then Some diff else None diff --git a/src/lib_micheline/micheline_encoding.ml b/src/lib_micheline/micheline_encoding.ml index 4719503f0948..e11ea3a50010 100644 --- a/src/lib_micheline/micheline_encoding.ml +++ b/src/lib_micheline/micheline_encoding.ml @@ -180,7 +180,7 @@ let internal_canonical_encoding ~semantics ~variant prim_encoding = (req "annots" annots_encoding)) (function | Prim (_, v, [], annots) -> Some (v, annots) | _ -> None) - (function (prim, annots) -> Prim (0, prim, [], annots)); + (function prim, annots -> Prim (0, prim, [], annots)); (* Single arg, no annots *) case (Tag 5) @@ -189,7 +189,7 @@ let internal_canonical_encoding ~semantics ~variant prim_encoding = (obj2 (req "prim" prim_encoding) (req "arg" expr_encoding)) (function | Prim (_, v, [arg], []) -> Some (v, arg) | _ -> None) - (function (prim, arg) -> Prim (0, prim, [arg], [])); + (function prim, arg -> Prim (0, prim, [arg], [])); (* Single arg, with annots *) case (Tag 6) @@ -259,8 +259,8 @@ let table_encoding ~variant location_encoding prim_encoding = let open Data_encoding in conv (fun node -> - let (canon, assoc) = extract_locations node in - let (_, table) = List.split assoc in + let canon, assoc = extract_locations node in + let _, table = List.split assoc in (canon, table)) (fun (canon, table) -> let table = Array.of_list table in diff --git a/src/lib_micheline/micheline_parser.ml b/src/lib_micheline/micheline_parser.ml index d10059ecad6d..51c99d0221f0 100644 --- a/src/lib_micheline/micheline_parser.ml +++ b/src/lib_micheline/micheline_parser.ml @@ -104,7 +104,7 @@ let token_value_encoding = | Comment s -> Some (s, false) | Eol_comment s -> Some (s, true) | _ -> None) - (function (s, false) -> Comment s | (s, true) -> Eol_comment s); + (function s, false -> Comment s | s, true -> Eol_comment s); case (Tag 4) ~title:"Punctuation" @@ -201,8 +201,8 @@ let tokenize source = in let rec skip acc = match next () with - | (`End, _) -> List.rev acc - | (`Uchar c, start) -> ( + | `End, _ -> List.rev acc + | `Uchar c, start -> ( match uchar_to_char c with | Some ('a' .. 'z' | 'A' .. 'Z') -> ident acc start (fun s _ -> Ident s) | Some ('@' | ':' | '$' | '&' | '%' | '!' | '?') -> @@ -212,7 +212,7 @@ let tokenize source = Annot str) | Some '-' -> ( match next () with - | (`End, stop) -> + | `End, stop -> errors := Unterminated_integer {start; stop} :: !errors ; List.rev acc | (`Uchar c, stop) as first -> ( @@ -235,7 +235,7 @@ let tokenize source = | Some '#' -> eol_comment acc start | Some '/' -> ( match next () with - | (`Uchar c, _) when Uchar.equal c (Uchar.of_char '*') -> + | `Uchar c, _ when Uchar.equal c (Uchar.of_char '*') -> comment acc start 0 | ((`Uchar _ | `End), _) as charloc -> errors := Unexpected_character (start, "/") :: !errors ; @@ -309,10 +309,10 @@ let tokenize source = tok start (here ()) (String (String.concat "" (List.rev sacc))) in match next () with - | (`End, stop) -> + | `End, stop -> errors := Unterminated_string {start; stop} :: !errors ; skip (tok () :: acc) - | (`Uchar c, stop) -> ( + | `Uchar c, stop -> ( match uchar_to_char c with | Some '"' -> skip (tok () :: acc) | Some ('\n' | '\r') -> @@ -320,10 +320,10 @@ let tokenize source = skip (tok () :: acc) | Some '\\' -> ( match next () with - | (`End, stop) -> + | `End, stop -> errors := Unterminated_string {start; stop} :: !errors ; skip (tok () :: acc) - | (`Uchar c, loc) -> ( + | `Uchar c, loc -> ( match uchar_to_char c with | Some '"' -> string acc ("\"" :: sacc) start | Some 'r' -> string acc ("\r" :: sacc) start @@ -359,15 +359,15 @@ let tokenize source = and annot acc start ret = generic_ident allowed_annot_char acc start ret and comment acc start lvl = match next () with - | (`End, stop) -> + | `End, stop -> errors := Unterminated_comment {start; stop} :: !errors ; let text = String.sub source start.byte (stop.byte - start.byte) in skip (tok start stop (Comment text) :: acc) - | (`Uchar c, _) -> ( + | `Uchar c, _ -> ( match uchar_to_char c with | Some '*' -> ( match next () with - | (`Uchar c, _) when Uchar.equal c (Uchar.of_char '/') -> + | `Uchar c, _ when Uchar.equal c (Uchar.of_char '/') -> if lvl = 0 then let stop = here () in let text = @@ -380,7 +380,7 @@ let tokenize source = comment acc start lvl) | Some '/' -> ( match next () with - | (`Uchar c, _) when Uchar.equal c (Uchar.of_char '*') -> + | `Uchar c, _ when Uchar.equal c (Uchar.of_char '*') -> comment acc start (lvl + 1) | other -> back other ; @@ -392,7 +392,7 @@ let tokenize source = tok start stop (Eol_comment text) in match next () with - | (`Uchar c, stop) -> ( + | `Uchar c, stop -> ( match uchar_to_char c with | Some '\n' -> skip (tok stop :: acc) | Some _ | None -> eol_comment acc start) @@ -475,7 +475,7 @@ type error += Empty let rec annots = function | {token = Annot annot; _} :: rest -> - let (annots, rest) = annots rest in + let annots, rest = annots rest in (annot :: annots, rest) | rest -> ([], rest) @@ -487,29 +487,29 @@ let rec parse ?(check = true) errors tokens stack = (* Start by preventing all absurd cases, so now the pattern matching exhaustivity can tell us that we treater all possible tokens for all possible valid states. *) - | ([], _) - | ([Wrapped _], _) - | ([Unwrapped _], _) - | (Unwrapped _ :: Unwrapped _ :: _, _) - | (Unwrapped _ :: Wrapped _ :: _, _) - | (Toplevel _ :: _ :: _, _) - | (Expression _ :: _ :: _, _) -> + | [], _ + | [Wrapped _], _ + | [Unwrapped _], _ + | Unwrapped _ :: Unwrapped _ :: _, _ + | Unwrapped _ :: Wrapped _ :: _, _ + | Toplevel _ :: _ :: _, _ + | Expression _ :: _ :: _, _ -> assert false (* Return *) - | (Expression (Some result) :: _, []) -> ([result], List.rev errors) - | (Expression (Some _) :: _, token :: rem) -> + | Expression (Some result) :: _, [] -> ([result], List.rev errors) + | Expression (Some _) :: _, token :: rem -> let errors = Unexpected token :: errors in parse ~check errors rem (* skip *) stack - | (Expression None :: _, []) -> + | Expression None :: _, [] -> let errors = Empty :: errors in let ghost = {start = point_zero; stop = point_zero} in ([Seq (ghost, [])], List.rev errors) - | ([Toplevel [(Seq (_, exprs) as expr)]], []) -> + | [Toplevel [(Seq (_, exprs) as expr)]], [] -> let errors = if check then do_check ~toplevel:false errors expr else errors in (exprs, List.rev errors) - | ([Toplevel exprs], []) -> + | [Toplevel exprs], [] -> let exprs = List.rev exprs in let loc = {start = min_point exprs; stop = max_point exprs} in let expr = Seq (loc, exprs) in @@ -518,19 +518,22 @@ let rec parse ?(check = true) errors tokens stack = in (exprs, List.rev errors) (* Ignore comments *) - | (_, {token = Eol_comment _ | Comment _; _} :: rest) -> + | _, {token = Eol_comment _ | Comment _; _} :: rest -> parse ~check errors rest stack | ( (Expression None | Sequence _ | Toplevel _) :: _, ({token = Int _ | String _ | Bytes _; _} as token) - :: {token = Eol_comment _ | Comment _; _} :: rest ) + :: {token = Eol_comment _ | Comment _; _} + :: rest ) | ( (Wrapped _ | Unwrapped _) :: _, ({token = Open_paren; _} as token) - :: {token = Eol_comment _ | Comment _; _} :: rest ) -> + :: {token = Eol_comment _ | Comment _; _} + :: rest ) -> parse ~check errors (token :: rest) stack (* Erroneous states *) | ( (Wrapped _ | Unwrapped _) :: _, ({token = Open_paren; _} as token) - :: {token = Open_paren | Open_brace; _} :: rem ) + :: {token = Open_paren | Open_brace; _} + :: rem ) | ( Unwrapped _ :: Expression _ :: _, ({token = Semi | Close_brace | Close_paren; _} as token) :: rem ) | ( Expression None :: _, @@ -546,7 +549,7 @@ let rec parse ?(check = true) errors tokens stack = {token = Open_paren; _} :: ({token = Int _ | String _ | Bytes _ | Annot _ | Close_paren; _} as token) - :: rem ) + :: rem ) | ( (Expression None | Sequence _ | Toplevel _) :: _, {token = Int _ | String _ | Bytes _; _} :: ({ @@ -555,29 +558,28 @@ let rec parse ?(check = true) errors tokens stack = | Open_paren | Open_brace ); _; } as token) - :: rem ) + :: rem ) | ( Unwrapped (_, _, _, _) :: Toplevel _ :: _, ({token = Close_brace; _} as token) :: rem ) - | (Unwrapped (_, _, _, _) :: _, ({token = Close_paren; _} as token) :: rem) - | ([Toplevel _], ({token = Close_paren; _} as token) :: rem) - | ([Toplevel _], ({token = Open_paren; _} as token) :: rem) - | ([Toplevel _], ({token = Close_brace; _} as token) :: rem) - | (Sequence _ :: _, ({token = Open_paren; _} as token) :: rem) - | (Sequence _ :: _, ({token = Close_paren; _} as token) :: rem) + | Unwrapped (_, _, _, _) :: _, ({token = Close_paren; _} as token) :: rem + | [Toplevel _], ({token = Close_paren; _} as token) :: rem + | [Toplevel _], ({token = Open_paren; _} as token) :: rem + | [Toplevel _], ({token = Close_brace; _} as token) :: rem + | Sequence _ :: _, ({token = Open_paren; _} as token) :: rem + | Sequence _ :: _, ({token = Close_paren; _} as token) :: rem | ( (Wrapped _ | Unwrapped _) :: _, ({token = Open_paren; _} as token) :: (({token = Close_brace | Semi; _} :: _ | []) as rem) ) - | (_, ({token = Annot _; _} as token) :: rem) -> + | _, ({token = Annot _; _} as token) :: rem -> let errors = Unexpected token :: errors in parse ~check errors rem (* skip *) stack - | (Wrapped (token, _, _, _) :: _, ([] | {token = Close_brace | Semi; _} :: _)) + | Wrapped (token, _, _, _) :: _, ([] | {token = Close_brace | Semi; _} :: _) -> let errors = Unclosed token :: errors in let fake = {token with token = Close_paren} in let tokens = (* insert *) fake :: tokens in parse ~check errors tokens stack - | ((Sequence (token, _) :: _ | Unwrapped _ :: Sequence (token, _) :: _), []) - -> + | (Sequence (token, _) :: _ | Unwrapped _ :: Sequence (token, _) :: _), [] -> let errors = Unclosed token :: errors in let fake = {token with token = Close_brace} in let tokens = (* insert *) fake :: tokens in @@ -585,14 +587,14 @@ let rec parse ?(check = true) errors tokens stack = (* Valid states *) | ( (Toplevel _ | Sequence (_, _)) :: _, {token = Ident name; loc} :: ({token = Annot _; _} :: _ as rest) ) -> - let (annots, rest) = annots rest in + let annots, rest = annots rest in let mode = Unwrapped (loc, name, [], annots) in parse ~check errors rest (push_mode mode stack) | ( (Expression None | Toplevel _ | Sequence (_, _)) :: _, {token = Ident name; loc} :: rest ) -> let mode = Unwrapped (loc, name, [], []) in parse ~check errors rest (push_mode mode stack) - | ((Unwrapped _ | Wrapped _) :: _, {token = Int value; loc} :: rest) + | (Unwrapped _ | Wrapped _) :: _, {token = Int value; loc} :: rest | ( (Expression None | Sequence _ | Toplevel _) :: _, {token = Int value; loc} :: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) -> @@ -601,7 +603,7 @@ let rec parse ?(check = true) errors tokens stack = if check then do_check ~toplevel:false errors expr else errors in parse ~check errors rest (fill_mode expr stack) - | ((Unwrapped _ | Wrapped _) :: _, {token = String contents; loc} :: rest) + | (Unwrapped _ | Wrapped _) :: _, {token = String contents; loc} :: rest | ( (Expression None | Sequence _ | Toplevel _) :: _, {token = String contents; loc} :: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) -> @@ -610,11 +612,11 @@ let rec parse ?(check = true) errors tokens stack = if check then do_check ~toplevel:false errors expr else errors in parse ~check errors rest (fill_mode expr stack) - | ((Unwrapped _ | Wrapped _) :: _, {token = Bytes contents; loc} :: rest) + | (Unwrapped _ | Wrapped _) :: _, {token = Bytes contents; loc} :: rest | ( (Expression None | Sequence _ | Toplevel _) :: _, {token = Bytes contents; loc} :: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) -> - let (errors, bytes) = + let errors, bytes = match Hex.to_bytes (`Hex (String.sub contents 2 (String.length contents - 2))) @@ -635,7 +637,7 @@ let rec parse ?(check = true) errors tokens stack = if check then do_check ~toplevel:false errors expr else errors in parse ~check errors rest (fill_mode expr (pop_mode stack)) - | ((Sequence _ | Toplevel _) :: _, {token = Semi; _} :: rest) -> + | (Sequence _ | Toplevel _) :: _, {token = Semi; _} :: rest -> parse ~check errors rest stack | ( Unwrapped ({start; stop}, name, exprs, annot) :: Expression _ :: _, ([] as rest) ) @@ -654,15 +656,16 @@ let rec parse ?(check = true) errors tokens stack = parse ~check errors rest (fill_mode expr (pop_mode stack)) | ( (Wrapped _ | Unwrapped _) :: _, ({token = Open_paren; _} as token) - :: {token = Ident name; _} :: ({token = Annot _; _} :: _ as rest) ) -> - let (annots, rest) = annots rest in + :: {token = Ident name; _} + :: ({token = Annot _; _} :: _ as rest) ) -> + let annots, rest = annots rest in let mode = Wrapped (token, name, [], annots) in parse ~check errors rest (push_mode mode stack) | ( (Wrapped _ | Unwrapped _) :: _, ({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest ) -> let mode = Wrapped (token, name, [], []) in parse ~check errors rest (push_mode mode stack) - | ((Wrapped _ | Unwrapped _) :: _, {token = Ident name; loc} :: rest) -> + | (Wrapped _ | Unwrapped _) :: _, {token = Ident name; loc} :: rest -> let expr = Micheline.Prim (loc, name, [], []) in let errors = if check then do_check ~toplevel:false errors expr else errors @@ -706,8 +709,10 @@ let parse_expression ?check tokens = let result = match tokens with | ({token = Open_paren; _} as token) - :: {token = Ident name; _} :: {token = Annot annot; _} :: rest -> - let (annots, rest) = annots rest in + :: {token = Ident name; _} + :: {token = Annot annot; _} + :: rest -> + let annots, rest = annots rest in let mode = Wrapped (token, name, [], annot :: annots) in parse ?check [] rest [mode; Expression None] | ({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest -> @@ -715,7 +720,7 @@ let parse_expression ?check tokens = parse ?check [] rest [mode; Expression None] | _ -> parse ?check [] tokens [Expression None] in - match result with ([single], errors) -> (single, errors) | _ -> assert false + match result with [single], errors -> (single, errors) | _ -> assert false let parse_toplevel ?check tokens = parse ?check [] tokens [Toplevel []] @@ -960,5 +965,5 @@ let check_annot s = String.length s <= max_annot_length && match tokenize s with - | ([{token = Annot s'; _}], [] (* no errors *)) -> String.equal s s' + | [{token = Annot s'; _}], [] (* no errors *) -> String.equal s s' | _ -> false diff --git a/src/lib_micheline/micheline_printer.ml b/src/lib_micheline/micheline_printer.ml index 5fc601c49b4f..b8678c03b05e 100644 --- a/src/lib_micheline/micheline_printer.ml +++ b/src/lib_micheline/micheline_printer.ml @@ -65,34 +65,34 @@ let preformat root = in let rec preformat_expr = function | Int (loc, value) -> - let (cml, csz) = preformat_loc loc in + let cml, csz = preformat_loc loc in Int ((cml, String.length (Z.to_string value) + csz, loc), value) | String (loc, value) -> - let (cml, csz) = preformat_loc loc in + let cml, csz = preformat_loc loc in String ((cml, String.length value + csz, loc), value) | Bytes (loc, value) -> - let (cml, csz) = preformat_loc loc in + let cml, csz = preformat_loc loc in Bytes ((cml, (Bytes.length value * 2) + 2 + csz, loc), value) | Prim (loc, name, items, annots) -> - let (cml, csz) = preformat_loc loc in + let cml, csz = preformat_loc loc in let asz = preformat_annots annots in let items = List.map preformat_expr items in - let (ml, sz) = + let ml, sz = List.fold_left (fun (tml, tsz) e -> - let (ml, sz, _) = location e in + let ml, sz, _ = location e in (tml || ml, tsz + 1 + sz)) (cml, String.length name + csz + asz) items in Prim ((ml, sz, loc), name, items, annots) | Seq (loc, items) -> - let (cml, csz) = preformat_loc loc in + let cml, csz = preformat_loc loc in let items = List.map preformat_expr items in - let (ml, sz) = + let ml, sz = List.fold_left (fun (tml, tsz) e -> - let (ml, sz, _) = location e in + let ml, sz, _ = location e in (tml || ml, tsz + 3 + sz)) (cml, 4 + csz) items @@ -165,9 +165,9 @@ let rec print_expr_unwrapped ppf = function if (not ml) && s < 80 then Format.fprintf ppf "{ @[" else Format.fprintf ppf "{ @[" ; (match (comment, items) with - | (None, _) -> () - | (Some comment, []) -> Format.fprintf ppf "%a" print_comment comment - | (Some comment, _) -> Format.fprintf ppf "%a@ " print_comment comment) ; + | None, _ -> () + | Some comment, [] -> Format.fprintf ppf "%a" print_comment comment + | Some comment, _ -> Format.fprintf ppf "%a@ " print_comment comment) ; Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf " ;@ ") print_expr_unwrapped diff --git a/src/lib_micheline/test/assert.ml b/src/lib_micheline/test/assert.ml index 18247ef0b951..7d57686fb6e2 100644 --- a/src/lib_micheline/test/assert.ml +++ b/src/lib_micheline/test/assert.ml @@ -40,16 +40,16 @@ module Compat = struct let rec iter2_p f l1 l2 = match (l1, l2) with - | ([], []) -> return_unit - | ([], _) | (_, []) -> invalid_arg "Error_monad.iter2_p" - | (x1 :: l1, x2 :: l2) -> ( + | [], [] -> return_unit + | [], _ | _, [] -> invalid_arg "Error_monad.iter2_p" + | x1 :: l1, x2 :: l2 -> ( let tx = f x1 x2 and tl = iter2_p f l1 l2 in let tx_res = tx in let tl_res = tl in match (tx_res, tl_res) with - | (Ok (), Ok ()) -> Ok () - | (Error exn1, Error exn2) -> failwith "%s -- %s" exn1 exn2 - | (Ok (), Error exn) | (Error exn, Ok ()) -> Error exn) + | Ok (), Ok () -> Ok () + | Error exn1, Error exn2 -> failwith "%s -- %s" exn1 exn2 + | Ok (), Error exn | Error exn, Ok () -> Error exn) end open Compat diff --git a/src/lib_micheline/test/test_diff.ml b/src/lib_micheline/test/test_diff.ml index 86b89ee8d907..901a29f74d60 100644 --- a/src/lib_micheline/test/test_diff.ml +++ b/src/lib_micheline/test/test_diff.ml @@ -42,14 +42,14 @@ module Expr : TESTABLE with type t = Micheline_printer.node = struct let rec equal l r = match (l, r) with - | (Int (locl, il), Int (locr, ir)) -> locl = locr && il = ir - | (String (locl, sl), String (locr, sr)) -> locl = locr && sl = sr - | (Bytes (locl, bl), Bytes (locr, br)) -> locl = locr && bl = br - | (Prim (locl, pl, nodesl, annotl), Prim (locr, pr, nodesr, annotr)) -> + | Int (locl, il), Int (locr, ir) -> locl = locr && il = ir + | String (locl, sl), String (locr, sr) -> locl = locr && sl = sr + | Bytes (locl, bl), Bytes (locr, br) -> locl = locr && bl = br + | Prim (locl, pl, nodesl, annotl), Prim (locr, pr, nodesr, annotr) -> locl = locr && pl = pr && List.equal equal nodesl nodesr && annotl = annotr - | (Seq (locl, nodesl), Seq (locr, nodesr)) -> + | Seq (locl, nodesl), Seq (locr, nodesr) -> locl = locr && List.equal equal nodesl nodesr | _ -> false end diff --git a/src/lib_micheline/test/test_parser.ml b/src/lib_micheline/test/test_parser.ml index eac8db975a19..167c08597f6a 100644 --- a/src/lib_micheline/test/test_parser.ml +++ b/src/lib_micheline/test/test_parser.ml @@ -40,19 +40,19 @@ open Assert.Compat (** Asserts that an input [given] will generate some output [expected] *) let assert_tokenize ~loc given expected = match Micheline_parser.tokenize given with - | (tokens, []) -> + | tokens, [] -> let tokens_got = List.map (fun x -> x.Micheline_parser.token) tokens in Assert.equal_tokens ~loc tokens_got expected - | (_, _) -> failwith "%s - Cannot tokenize %s" loc given + | _, _ -> failwith "%s - Cannot tokenize %s" loc given (** Asserts that the token produced by the input [given] is not present in the [forbidden_tokens] list. *) let assert_tokenize_error ~loc given forbidden_tokens = match Micheline_parser.tokenize given with - | (tokens, []) -> + | tokens, [] -> let tokens_got = List.map (fun x -> x.Micheline_parser.token) tokens in Assert.not_equal_tokens ~loc tokens_got forbidden_tokens - | (_, _) -> return_unit + | _, _ -> return_unit (** Basic tokenizing of strings, bytes, integers, identifiers, annotations, comments. *) @@ -325,11 +325,11 @@ let test_condition_contract () = let assert_toplevel_parsing ~loc source expected = match Micheline_parser.tokenize source with - | (_, _ :: _) -> failwith "%s - Cannot tokenize %s" loc source - | (tokens, []) -> ( + | _, _ :: _ -> failwith "%s - Cannot tokenize %s" loc source + | tokens, [] -> ( match Micheline_parser.parse_toplevel tokens with - | (_, _ :: _) -> failwith "%s - Cannot parse_toplevel %s" loc source - | (ast, []) -> + | _, _ :: _ -> failwith "%s - Cannot parse_toplevel %s" loc source + | ast, [] -> let ast = List.map Micheline.strip_locations ast in let expected = List.map Micheline.strip_locations expected in let* () = @@ -340,11 +340,11 @@ let assert_toplevel_parsing ~loc source expected = let assert_toplevel_parsing_error ~loc source forbidden_tokens = match Micheline_parser.tokenize source with - | (_, _ :: _) -> return_unit - | (tokens, []) -> ( + | _, _ :: _ -> return_unit + | tokens, [] -> ( match Micheline_parser.parse_toplevel tokens with - | (_, _ :: _) -> return_unit - | (ast, []) -> + | _, _ :: _ -> return_unit + | ast, [] -> let ast = List.map Micheline.strip_locations ast in let forbidden_tokens = List.map Micheline.strip_locations forbidden_tokens @@ -661,11 +661,11 @@ let test_list_append_parsing () = let assert_expression_parsing ~loc source expected = match Micheline_parser.tokenize source with - | (_, _ :: _) -> failwith "%s - Cannot tokenize %s" loc source - | (tokens, []) -> ( + | _, _ :: _ -> failwith "%s - Cannot tokenize %s" loc source + | tokens, [] -> ( match Micheline_parser.parse_expression tokens with - | (_, _ :: _) -> failwith "%s - Cannot parse_expression %s" loc source - | (ast, []) -> + | _, _ :: _ -> failwith "%s - Cannot parse_expression %s" loc source + | ast, [] -> let ast = Micheline.strip_locations ast in let expected = Micheline.strip_locations expected in Assert.equal ~loc ast expected) diff --git a/src/lib_mockup/local_services.ml b/src/lib_mockup/local_services.ml index 9327f7e47f2a..10e6034650f4 100644 --- a/src/lib_mockup/local_services.ml +++ b/src/lib_mockup/local_services.ml @@ -461,13 +461,13 @@ module Make (E : MENV) = struct ~protocol_data () in - let* (validation_passes, validation_state, preapply_results) = + let* validation_passes, validation_state, preapply_results = List.fold_left_es (fun ( validation_passes, validation_state, validation_result ) operations -> - let* (state, result) = + let* state, result = List.fold_left_es simulate_operation (validation_state, Preapply_result.empty) @@ -485,7 +485,7 @@ module Make (E : MENV) = struct operations in let cache_nonce = Some E.rpc_context.block_header in - let* (validation_result, _metadata) = + let* validation_result, _metadata = E.Protocol.finalize_block validation_state cache_nonce in (* Similar to lib_shell.Prevalidation.preapply *) @@ -541,10 +541,10 @@ module Make (E : MENV) = struct with_chain ~caller_name:"preapply operations" chain (fun () -> let*! outcome = let* state = partial_construction ~cache:`Lazy () in - let* (state, acc) = + let* state, acc = List.fold_left_es (fun (state, acc) op -> - let* (state, result) = + let* state, result = E.Protocol.apply_operation state op in return (state, (op.protocol_data, result) :: acc)) @@ -585,7 +585,7 @@ module Make (E : MENV) = struct else let operations = op :: mempool_operations in let* validation_state = partial_construction ~cache:`Lazy () in - let* (validation_state, preapply_result) = + let* validation_state, preapply_result = List.fold_left_es (fun rstate (shell, protocol_data) -> simulate_operation rstate E.Protocol.{shell; protocol_data}) @@ -655,11 +655,11 @@ module Make (E : MENV) = struct in let*! result = let* state = partial_construction ~cache:`Lazy () in - let* (state, receipt) = E.Protocol.apply_operation state op in + let* state, receipt = E.Protocol.apply_operation state op in (* The following finalization does not have to update protocol caches because we are not interested in block creation here. Hence, [cache_nonce] is set to [None]. *) - let* (validation_result, _block_header_metadata) = + let* validation_result, _block_header_metadata = E.Protocol.finalize_block state None in return (validation_result, receipt) @@ -696,7 +696,7 @@ module Make (E : MENV) = struct {shell = block_header.shell; protocol_data} ~cache:`Lazy in - let* (validation_state, _) = + let* validation_state, _ = List.fold_left_es (List.fold_left_es (fun (validation_state, results) op -> match @@ -712,7 +712,7 @@ module Make (E : MENV) = struct protocol_data = operation_data; } in - let* (validation_state, receipt) = + let* validation_state, receipt = E.Protocol.apply_operation validation_state op in return (validation_state, receipt :: results))) @@ -733,7 +733,7 @@ module Make (E : MENV) = struct | None -> RPC_answer.fail [Cannot_parse_op] | Some block_header -> ( let*! r = - let* ({context; _}, _) = reconstruct operations block_header in + let* {context; _}, _ = reconstruct operations block_header in let rpc_context = Tezos_protocol_environment. { diff --git a/src/lib_mockup/migration.ml b/src/lib_mockup/migration.ml index 61f13ade3682..f599a19d3d11 100644 --- a/src/lib_mockup/migration.ml +++ b/src/lib_mockup/migration.ml @@ -55,7 +55,7 @@ let migrate_mockup ~(cctxt : Tezos_client_base.Client_context.full) Format.fprintf fmtr "is not a mockup base directory.") | Base_dir_is_mockup -> return_unit in - let* ((module Current_mockup_env), registration_data) = + let* (module Current_mockup_env), registration_data = get_mockup_context_from_disk ~base_dir ~protocol_hash cctxt in let* (module Next_mockup_env) = diff --git a/src/lib_mockup/mockup_wallet.ml b/src/lib_mockup/mockup_wallet.ml index 24a93902791a..7e8d1826dc43 100644 --- a/src/lib_mockup/mockup_wallet.ml +++ b/src/lib_mockup/mockup_wallet.ml @@ -64,7 +64,7 @@ let add_bootstrap_secret cctxt {name; sk_uri} = --force" name) in - let* (pkh, public_key) = + let* pkh, public_key = Client_keys.import_secret_key ~io:(cctxt :> Client_context.io_wallet) pk_uri in let*! () = diff --git a/src/lib_mockup/persistence.ml b/src/lib_mockup/persistence.ml index 9049d24adae5..8d0b7dde126d 100644 --- a/src/lib_mockup/persistence.ml +++ b/src/lib_mockup/persistence.ml @@ -327,7 +327,7 @@ module Make (Registration : Registration.S) = struct "%s is not empty, please specify a fresh base directory" base_dir in - let* (_mockup_env, {chain = chain_id; rpc_context; protocol_data}) = + let* _mockup_env, {chain = chain_id; rpc_context; protocol_data} = init_mockup_context_by_protocol_hash ~cctxt:(cctxt :> Tezos_client_base.Client_context.printer) ~protocol_hash diff --git a/src/lib_openapi/api.ml b/src/lib_openapi/api.ml index 986b40b42972..9b1f4b36d5ec 100644 --- a/src/lib_openapi/api.ml +++ b/src/lib_openapi/api.ml @@ -75,7 +75,7 @@ let parse_arg (json : Json.t) : arg = let rec parse_tree (json : Json.t) : Json.t tree = match Json.as_variant json with - | ("static", static) -> + | "static", static -> Json.as_record static @@ fun get -> Static { @@ -86,14 +86,14 @@ let rec parse_tree (json : Json.t) : Json.t tree = patch_service = get "patch_service"; subdirs = get "subdirs" |> Option.map parse_subdirs; } - | ("dynamic", dynamic) -> Dynamic dynamic - | (name, _) -> failwith ("parse_tree: don't know what to do with: " ^ name) + | "dynamic", dynamic -> Dynamic dynamic + | name, _ -> failwith ("parse_tree: don't know what to do with: " ^ name) and parse_subdirs (json : Json.t) : Json.t subdirs = match Json.as_variant json with - | ("suffixes", suffixes) -> + | "suffixes", suffixes -> Suffixes (suffixes |> Json.as_list |> List.map parse_suffix) - | ("dynamic_dispatch", dynamic_dispatch) -> + | "dynamic_dispatch", dynamic_dispatch -> Json.as_record dynamic_dispatch @@ fun get -> Dynamic_dispatch { @@ -106,7 +106,7 @@ and parse_subdirs (json : Json.t) : Json.t subdirs = |> opt_mandatory "dynamic_dispatch.tree" dynamic_dispatch |> parse_tree; } - | (name, _) -> failwith ("parse_subdir: don't know what to do with: " ^ name) + | name, _ -> failwith ("parse_subdir: don't know what to do with: " ^ name) and parse_suffix (json : Json.t) : Json.t suffix = Json.as_record json @@ fun get -> @@ -154,7 +154,7 @@ and flatten_static path acc static = static.delete_service, static.patch_service ) with - | (None, None, None, None, None) -> acc + | None, None, None, None, None -> acc | _ -> let endpoint = { @@ -231,7 +231,7 @@ let parse_query_parameter (json : Json.t) : query_parameter = let name = get "name" |> opt_mandatory "name" json |> Json.as_string in let description = get "description" |> Option.map Json.as_string in (* Then, fetch information which is in the "kind" field. *) - let (kind, id, descr) = + let kind, id, descr = (get "kind" |> opt_mandatory "kind" json |> Json.as_record) @@ fun get -> (* Function used for everything but kind "flag". *) let parse_kind_with_name make record = @@ -246,13 +246,13 @@ let parse_query_parameter (json : Json.t) : query_parameter = (* Field "kind" encodes a variant. There must be exactly one of either: "optional", "multi", "single" or "flag". *) match (get "optional", get "multi", get "single", get "flag") with - | (Some optional, None, None, None) -> + | Some optional, None, None, None -> parse_kind_with_name (fun name -> Optional {name}) optional - | (None, Some multi, None, None) -> + | None, Some multi, None, None -> parse_kind_with_name (fun name -> Multi {name}) multi - | (None, None, Some single, None) -> + | None, None, Some single, None -> parse_kind_with_name (fun name -> Single {name}) single - | (None, None, None, Some flag) -> + | None, None, None, Some flag -> let () = Json.as_record flag @@ fun _get -> (* Flags have no fields. *) @@ -264,9 +264,9 @@ let parse_query_parameter (json : Json.t) : query_parameter = (* Both the top level and the kind can contain a description. Merge them. *) let description = match (description, descr) with - | (None, None) -> None - | ((Some _ as x), None) | (None, (Some _ as x)) -> x - | (Some x, Some y) -> Some (y ^ " " ^ x) + | None, None -> None + | (Some _ as x), None | None, (Some _ as x) -> x + | Some x, Some y -> Some (y ^ " " ^ x) in {id; name; description; kind} diff --git a/src/lib_openapi/convert.ml b/src/lib_openapi/convert.ml index 4bb446004f15..d485f17514ba 100644 --- a/src/lib_openapi/convert.ml +++ b/src/lib_openapi/convert.ml @@ -121,7 +121,7 @@ let rec convert_element (element : Json_schema.element) : Openapi.Schema.t = in fun ?title ?description ?(nullable = false) () -> match (title, description, nullable) with - | (None, None, false) -> Openapi.Schema.reference name + | None, None, false -> Openapi.Schema.reference name | _ -> (* OpenAPI does not allow other fields next to "$ref" fields. So we have to cheat a little bit. *) @@ -158,13 +158,13 @@ let rec convert_element (element : Json_schema.element) : Openapi.Schema.t = let minimum = Option.map (function - | (f, `Exclusive) -> int_of_float (ceil f) | _ -> assert false) + | f, `Exclusive -> int_of_float (ceil f) | _ -> assert false) minimum in let maximum = Option.map (function - | (f, `Exclusive) -> int_of_float (floor f) | _ -> assert false) + | f, `Exclusive -> int_of_float (floor f) | _ -> assert false) maximum in Openapi.Schema.integer ?enum ?minimum ?maximum @@ -174,14 +174,10 @@ let rec convert_element (element : Json_schema.element) : Openapi.Schema.t = (* Note: there is currently a bug in Json_schema: `Exclusive and `Inclusive are inverted... *) let minimum = - Option.map - (function (f, `Exclusive) -> f | _ -> assert false) - minimum + Option.map (function f, `Exclusive -> f | _ -> assert false) minimum in let maximum = - Option.map - (function (f, `Exclusive) -> f | _ -> assert false) - maximum + Option.map (function f, `Exclusive -> f | _ -> assert false) maximum in Openapi.Schema.number ?minimum ?maximum | Boolean -> @@ -208,9 +204,9 @@ let empty_env = String_map.empty let merge_envs (a : env) (b : env) : env = let merge_key _name a b = match (a, b) with - | (None, None) -> None - | (None, (Some _ as x)) | ((Some _ as x), None) -> x - | (Some a, Some _b) -> + | None, None -> None + | None, (Some _ as x) | (Some _ as x), None -> x + | Some a, Some _b -> (* TODO: check that a and b are equivalent *) Some a in @@ -258,13 +254,13 @@ let convert_response ?code (schemas : Api.schemas option) : match schemas with | None -> (empty_env, []) | Some schemas -> - let (env, schema) = convert_schema schemas.json_schema in + let env, schema = convert_schema schemas.json_schema in (env, [Openapi.Response.make ?code ~description:"" schema]) let opt_map_with_env f = function | None -> (empty_env, None) | Some x -> - let (env, y) = f x in + let env, y = f x in (env, Some y) let convert_query_parameter {Api.id = _; name; description; kind} : @@ -293,12 +289,12 @@ let convert_service expected_path expected_method "expected path %s but found %s" (Api.show_path expected_path) (Api.show_path path) ; - let (env_1, request_body) = + let env_1, request_body = opt_map_with_env (fun x -> convert_schema x.Api.json_schema) input in (* 200 is the HTTP code for OK. *) - let (env_2, output) = convert_response ~code:200 output in - let (env_3, error) = convert_response error in + let env_2, output = convert_response ~code:200 output in + let env_3, error = convert_response error in let responses = List.flatten [output; error] in let query = List.map convert_query_parameter query in let service = @@ -322,15 +318,13 @@ let convert_path (path : Api.path) : Openapi.Path.t = let convert_endpoint (endpoint : Api.service Api.endpoint) : env * Openapi.Endpoint.t = let convert_service = convert_service endpoint.path in - let (env_1, get) = opt_map_with_env (convert_service GET) endpoint.get in - let (env_2, post) = opt_map_with_env (convert_service POST) endpoint.post in - let (env_3, put) = opt_map_with_env (convert_service PUT) endpoint.put in - let (env_4, delete) = + let env_1, get = opt_map_with_env (convert_service GET) endpoint.get in + let env_2, post = opt_map_with_env (convert_service POST) endpoint.post in + let env_3, put = opt_map_with_env (convert_service PUT) endpoint.put in + let env_4, delete = opt_map_with_env (convert_service DELETE) endpoint.delete in - let (env_5, patch) = - opt_map_with_env (convert_service PATCH) endpoint.patch - in + let env_5, patch = opt_map_with_env (convert_service PATCH) endpoint.patch in let endpoint = Openapi.Endpoint.make ?get @@ -345,7 +339,7 @@ let convert_endpoint (endpoint : Api.service Api.endpoint) : let convert_api version (endpoints : Api.service Api.endpoint list) : Openapi.t = - let (envs, endpoints) = List.map convert_endpoint endpoints |> List.split in + let envs, endpoints = List.map convert_endpoint endpoints |> List.split in Openapi.make ~title:"Tezos RPC" ~description:"Tezos client RPC API." diff --git a/src/lib_openapi/json.ml b/src/lib_openapi/json.ml index 24d2b40c0595..3d791875cf72 100644 --- a/src/lib_openapi/json.ml +++ b/src/lib_openapi/json.ml @@ -44,7 +44,7 @@ let as_variant json = let as_variant_named json name = match as_variant json with - | (name', value) when name' = name -> value + | name', value when name' = name -> value | _ -> error json "expected a variant named %s" name let ( |~> ) json name = as_variant_named json name diff --git a/src/lib_openapi/openapi.ml b/src/lib_openapi/openapi.ml index 416598378c62..ba30da6a670e 100644 --- a/src/lib_openapi/openapi.ml +++ b/src/lib_openapi/openapi.ml @@ -85,10 +85,8 @@ module Schema = struct | Ref name -> [field "$ref" (string ("#/components/schemas/" ^ name))] | Other {title; description; nullable; kind} -> field_opt "title" title string - :: - field_opt "description" description string - :: - (if nullable then field "nullable" (bool true) else []) + :: field_opt "description" description string + :: (if nullable then field "nullable" (bool true) else []) :: (match kind with | Boolean -> [typ "boolean"] @@ -403,7 +401,7 @@ module Service = struct let parameters_of_json in_ json = List.filter_map (fun query_json -> - let (required, parameter, in_result) = Parameter.of_json query_json in + let required, parameter, in_result = Parameter.of_json query_json in if String.equal in_result in_ then Some {required; parameter} else None) json @@ -484,8 +482,7 @@ module Endpoint = struct path; methods = List.filter_map - (function - | ((_ : Method.t), None) -> None | (m, Some s) -> Some (m, s)) + (function (_ : Method.t), None -> None | m, Some s -> Some (m, s)) [ (GET, get); (POST, post); @@ -514,13 +511,13 @@ module Endpoint = struct (Path.to_string endpoint.path, encode_parameters endpoint.methods parameters) let of_json (path, json) = - let (methods, p) = + let methods, p = let get_service method_ = let service = json |-> Method.to_openapi_string method_ in match unannotate service with | `Null -> [] | _ -> - let (service, parameters) = Service.of_json service in + let service, parameters = Service.of_json service in [((method_, service), parameters)] in get_service Method.GET @ get_service Method.POST @ get_service Method.PUT @@ -595,7 +592,7 @@ let to_json openapi = ] let of_json (json : Json.t) = - let (title, description, version) = + let title, description, version = let info = json |-> "info" in let title = info |-> "title" |> as_string in let description = info |-> "description" |> as_string_opt in diff --git a/src/lib_p2p/p2p.ml b/src/lib_p2p/p2p.ml index c4041b1e0791..a625f2d64553 100644 --- a/src/lib_p2p/p2p.ml +++ b/src/lib_p2p/p2p.ml @@ -130,7 +130,7 @@ let may_create_discovery_worker _limits config pool = match (config.listening_port, config.discovery_port, config.discovery_addr) with - | (Some listening_port, Some discovery_port, Some discovery_addr) -> + | Some listening_port, Some discovery_port, Some discovery_addr -> Some (P2p_discovery.create pool @@ -139,7 +139,7 @@ let may_create_discovery_worker _limits config pool = ~discovery_port ~discovery_addr ~trust_discovered_peers:config.trust_discovered_peers) - | (_, _, _) -> None + | _, _, _ -> None let create_maintenance_worker limits pool connect_handler config triggers log = let maintenance_config = diff --git a/src/lib_p2p/p2p_acl.ml b/src/lib_p2p/p2p_acl.ml index 4303ba00aa7e..af90b2b5773e 100644 --- a/src/lib_p2p/p2p_acl.ml +++ b/src/lib_p2p/p2p_acl.ml @@ -84,8 +84,8 @@ let create ~peer_id_size ~ip_size ~ip_cleanup_delay = Bloomer.create (* 512KiB *) ~hash:(fun x -> Blake2B.(to_bytes (hash_string [Ipaddr.V6.to_octets x]))) ~hashes:5 (* fixed, good for reasonable values of [ip_size] *) - ~countdown_bits: - 4 (* 16 steps to 0, fixed discrete split of the cleanup delay *) + ~countdown_bits:4 + (* 16 steps to 0, fixed discrete split of the cleanup delay *) ~index_bits:(Bits.numbits (ip_size * 8 * 1024 (* to bits *) / 4)) in let delay = Time.System.Span.multiply_exn (1. /. 16.) ip_cleanup_delay in diff --git a/src/lib_p2p/p2p_conn.ml b/src/lib_p2p/p2p_conn.ml index f56414c50bd9..e97a1d814630 100644 --- a/src/lib_p2p/p2p_conn.ml +++ b/src/lib_p2p/p2p_conn.ml @@ -145,7 +145,7 @@ let read t = let open Lwt_syntax in Lwt.catch (fun () -> - let* (s, msg) = Lwt_pipe.Maybe_bounded.pop t.messages in + let* s, msg = Lwt_pipe.Maybe_bounded.pop t.messages in let* () = Events.(emit bytes_popped_from_queue) (s, (P2p_socket.info t.conn).peer_id) diff --git a/src/lib_p2p/p2p_connect_handler.ml b/src/lib_p2p/p2p_connect_handler.ml index f7bba0b5cc20..b2a95c823597 100644 --- a/src/lib_p2p/p2p_connect_handler.ml +++ b/src/lib_p2p/p2p_connect_handler.ml @@ -292,7 +292,7 @@ let raw_authenticate t ?point_info canceler scheduled_conn point = let incoming = point_info = None in let incoming_str = if incoming then "incoming" else "outgoing" in let*! () = Events.(emit authenticate_start) (point, incoming_str) in - let* (info, auth_conn) = + let* info, auth_conn = protect ~canceler (fun () -> @@ -350,7 +350,7 @@ let raw_authenticate t ?point_info canceler scheduled_conn point = in let remote_point_info = match info.id_point with - | (addr, Some port) -> P2p_pool.register_new_point t.pool (addr, port) + | addr, Some port -> P2p_pool.register_new_point t.pool (addr, port) | _ -> None in let connection_point_info = Option.either point_info remote_point_info in @@ -511,8 +511,8 @@ let raw_authenticate t ?point_info canceler scheduled_conn point = match (info.id_point, Option.map P2p_point_state.Info.point point_info) with - | ((addr, _), Some (_, port)) -> (addr, Some port) - | (id_point, None) -> id_point + | (addr, _), Some (_, port) -> (addr, Some port) + | id_point, None -> id_point in let conn = create_connection diff --git a/src/lib_p2p/p2p_directory.ml b/src/lib_p2p/p2p_directory.ml index 8c3aced34f30..2ab85e1ab5bc 100644 --- a/src/lib_p2p/p2p_directory.ml +++ b/src/lib_p2p/p2p_directory.ml @@ -51,7 +51,7 @@ let info_of_point_info i = let info_of_peer_info pool i = let open P2p_peer.Info in let open P2p_peer.State in - let (state, id_point) = + let state, id_point = match P2p_peer_state.get i with | Accepted {current_point; _} -> (Accepted, Some current_point) | Running {current_point; _} -> (Running, Some current_point) @@ -113,7 +113,7 @@ let build_rpc_directory net = in let dir = RPC_directory.gen_register0 dir P2p_services.S.events (fun () () -> - let (stream, stopper) = P2p.watcher net in + let stream, stopper = P2p.watcher net in let shutdown () = Lwt_watcher.shutdown stopper in let next () = Lwt_stream.get stream in RPC_answer.return_stream {next; shutdown}) @@ -207,7 +207,7 @@ let build_rpc_directory net = let evts = P2p_peer_state.Info.events gi in if not q#monitor then RPC_answer.return evts else - let (stream, stopper) = P2p_peer_state.Info.watch gi in + let stream, stopper = P2p_peer_state.Info.watch gi in let shutdown () = Lwt_watcher.shutdown stopper in let first_request = ref true in let next () = @@ -391,7 +391,7 @@ let build_rpc_directory net = let evts = P2p_point_state.Info.events gi in if not q#monitor then RPC_answer.return evts else - let (stream, stopper) = P2p_point_state.Info.watch gi in + let stream, stopper = P2p_point_state.Info.watch gi in let shutdown () = Lwt_watcher.shutdown stopper in let first_request = ref true in let next () = diff --git a/src/lib_p2p/p2p_discovery.ml b/src/lib_p2p/p2p_discovery.ml index 11fa188a3944..4fc1deaeffd4 100644 --- a/src/lib_p2p/p2p_discovery.ml +++ b/src/lib_p2p/p2p_discovery.ml @@ -89,7 +89,7 @@ module Answer = struct return content) in match rd with - | (len, Lwt_unix.ADDR_INET (remote_addr, _)) + | len, Lwt_unix.ADDR_INET (remote_addr, _) when Compare.Int.equal len Message.length -> ( match Data_encoding.Binary.of_bytes_opt Message.encoding buf with | Some (key, remote_peer_id, remote_port) diff --git a/src/lib_p2p/p2p_fd.ml b/src/lib_p2p/p2p_fd.ml index 0f5463b91237..9ddf468e2dd6 100644 --- a/src/lib_p2p/p2p_fd.ml +++ b/src/lib_p2p/p2p_fd.ml @@ -95,7 +95,7 @@ let connect t saddr = let accept sock = let open Lwt_syntax in - let* (fd, saddr) = Lwt_unix.accept sock in + let* fd, saddr = Lwt_unix.accept sock in let* t = create fd in let* () = Events.(emit accept_fd) (t.id, string_of_sockaddr saddr) in Lwt.return (t, saddr) diff --git a/src/lib_p2p/p2p_io_scheduler.ml b/src/lib_p2p/p2p_io_scheduler.ml index 458ab8c51a4b..bd225b69f520 100644 --- a/src/lib_p2p/p2p_io_scheduler.ml +++ b/src/lib_p2p/p2p_io_scheduler.ml @@ -204,7 +204,7 @@ module Scheduler (IO : IO) = struct in if Lwt_canceler.canceled st.canceler then Lwt.return_unit else - let (prio, (conn, msg)) = + let prio, (conn, msg) = if not (Queue.is_empty st.readys_high) then (true, Queue.pop st.readys_high) else (false, Queue.pop st.readys_low) @@ -467,7 +467,7 @@ type t = { Each connection's quota is the average bandwidth consumption divided by the number of connections minus the over consumption of - the previous round. *) + the previous round. *) let reset_quota st = Events.(emit__dont_wait__use_with_care reset_quota ()) ; let {Moving_average.average = current_inflow; _} = @@ -491,8 +491,7 @@ let reset_quota st = connections and starting the associated moving average worker. The worker will call [reset_quota] at each update. - - *) +*) let create ?max_upload_speed ?max_download_speed ?read_queue_size ?write_queue_size ~read_buffer_size () = Events.(emit__dont_wait__use_with_care create ()) ; diff --git a/src/lib_p2p/p2p_maintenance.ml b/src/lib_p2p/p2p_maintenance.ml index ce38335e3e7c..ad4a1a2d5c9a 100644 --- a/src/lib_p2p/p2p_maintenance.ml +++ b/src/lib_p2p/p2p_maintenance.ml @@ -117,10 +117,10 @@ let connectable t start_time expected seen_points = let compare (t1, _) (t2, _) = match (t1, t2) with - | (None, None) -> 0 - | (None, Some _) -> 1 - | (Some _, None) -> -1 - | (Some t1, Some t2) -> Time.System.compare t2 t1 + | None, None -> 0 + | None, Some _ -> 1 + | Some _, None -> -1 + | Some t1, Some t2 -> Time.System.compare t2 t1 end) in let acc = Bounded_point_info.create expected in let f point pi seen_points = @@ -152,7 +152,7 @@ let rec try_to_contact_loop t start_time ~seen_points min_to_contact let open Lwt_syntax in if min_to_contact <= 0 then Lwt.return_true else - let (candidates, seen_points) = + let candidates, seen_points = connectable t start_time max_to_contact seen_points in if candidates = [] then diff --git a/src/lib_p2p/p2p_peer_state.ml b/src/lib_p2p/p2p_peer_state.ml index 61ee148431d0..1467ae77101f 100644 --- a/src/lib_p2p/p2p_peer_state.ml +++ b/src/lib_p2p/p2p_peer_state.ml @@ -248,7 +248,7 @@ let set_running ~timestamp peer_info point data conn_metadata = Info.log peer_info ~timestamp point Connection_established let set_disconnected ~timestamp ?(requested = false) peer_info = - let (current_point, (event : Pool_event.kind)) = + let current_point, (event : Pool_event.kind) = match peer_info.Info.state with | Accepted {current_point; _} -> peer_info.last_rejected_connection <- Some (current_point, timestamp) ; diff --git a/src/lib_p2p/p2p_pool.ml b/src/lib_p2p/p2p_pool.ml index e79ca3409147..ad543b259d8c 100644 --- a/src/lib_p2p/p2p_pool.ml +++ b/src/lib_p2p/p2p_pool.ml @@ -421,8 +421,8 @@ module Connection = struct | Some _ | None -> ( let ci = P2p_conn.info conn in match ci.id_point with - | (_, None) -> acc - | (addr, Some port) -> ((addr, port), ci.peer_id) :: acc)) + | _, None -> acc + | addr, Some port -> ((addr, port), ci.peer_id) :: acc)) in random_elt candidates @@ -447,7 +447,7 @@ module Connection = struct let propose_swap_request pool = let open Option_syntax in let* recipient = random_connection ~no_private:true pool in - let* (proposed_point, proposed_peer_id) = + let* proposed_point, proposed_peer_id = random_addr ~different_than:recipient ~no_private:true pool in Some (proposed_point, proposed_peer_id, recipient) @@ -579,7 +579,7 @@ let add_to_id_points t point = close to the end of the list is picked multiple times. @raise Invalid_argument if either [best] or [other] is strictly negative. - *) +*) let sample best other points = if best < 0 || other < 0 then raise (Invalid_argument "P2p_pool.sample") ; let l = List.length points in @@ -622,19 +622,19 @@ let compare_known_point_info p1 p2 = match (P2p_point_state.Info.last_seen p1, P2p_point_state.Info.last_seen p2) with - | (None, None) -> (Random.int 2 * 2) - 1 (* HACK... *) - | (Some _, None) -> 1 - | (None, Some _) -> -1 - | (Some (_, time1), Some (_, time2)) -> ( + | None, None -> (Random.int 2 * 2) - 1 (* HACK... *) + | Some _, None -> 1 + | None, Some _ -> -1 + | Some (_, time1), Some (_, time2) -> ( match compare time1 time2 with | 0 -> (Random.int 2 * 2) - 1 (* HACK... *) | x -> x) in match (disconnected1, disconnected2) with - | (false, false) -> compare_last_seen p1 p2 - | (false, true) -> -1 - | (true, false) -> 1 - | (true, true) -> compare_last_seen p2 p1 + | false, false -> compare_last_seen p1 p2 + | false, true -> -1 + | true, false -> 1 + | true, true -> compare_last_seen p2 p1 let list_known_points ~ignore_private ?(size = 50) pool = if size < 0 then Lwt.fail (Invalid_argument "P2p_pool.list_known_points") diff --git a/src/lib_p2p/p2p_socket.ml b/src/lib_p2p/p2p_socket.ml index dc93f69be688..952ee52ea0b4 100644 --- a/src/lib_p2p/p2p_socket.ml +++ b/src/lib_p2p/p2p_socket.ml @@ -377,7 +377,7 @@ let authenticate ~canceler ~proof_of_work_target ~incoming scheduled_conn version = announced_version; } in - let* (msg, recv_msg) = + let* msg, recv_msg = Connection_message.read ~canceler (P2p_io_scheduler.to_readable scheduled_conn) @@ -407,7 +407,7 @@ let authenticate ~canceler ~proof_of_work_target ~incoming scheduled_conn let channel_key = Crypto_box.precompute identity.P2p_identity.secret_key msg.public_key in - let (local_nonce, remote_nonce) = + let local_nonce, remote_nonce = Crypto_box.generate_nonces ~incoming ~sent_msg ~recv_msg in let cryptobox_data = {Crypto.channel_key; local_nonce; remote_nonce} in @@ -478,7 +478,7 @@ module Reader = struct let open Lwt_syntax in let* r = let open Lwt_result_syntax in - let* (msg, size, stream) = read_message st stream in + let* msg, size, stream = read_message st stream in protect ~canceler:st.canceler (fun () -> let*! () = Lwt_pipe.Maybe_bounded.push st.messages (Ok (size, msg)) in return_some stream) @@ -622,10 +622,10 @@ module Writer = struct 0 in function - | (buf_l, None) -> + | buf_l, None -> Sys.word_size + buf_list_size buf_l + Lwt_pipe.Maybe_bounded.push_overhead - | (buf_l, Some _) -> + | buf_l, Some _ -> (2 * Sys.word_size) + buf_list_size buf_l + Lwt_pipe.Maybe_bounded.push_overhead in @@ -761,7 +761,7 @@ let write {writer; _} msg = let write_sync {writer; _} msg = let open Lwt_result_syntax in catch_closed_pipe (fun () -> - let (waiter, wakener) = Lwt.wait () in + let waiter, wakener = Lwt.wait () in let*? buf = Writer.encode_message writer msg in let*! () = Lwt_pipe.Maybe_bounded.push writer.messages (buf, Some wakener) @@ -784,7 +784,7 @@ let raw_write_sync {writer; _} bytes = let open Lwt_syntax in let bytes = split_bytes writer.binary_chunks_size bytes in catch_closed_pipe (fun () -> - let (waiter, wakener) = Lwt.wait () in + let waiter, wakener = Lwt.wait () in let* () = Lwt_pipe.Maybe_bounded.push writer.messages (bytes, Some wakener) in @@ -816,7 +816,7 @@ let close ?(wait = false) st = module Internal_for_tests = struct let mock_authenticated_connection default_metadata = - let (secret_key, public_key, _pkh) = Crypto_box.random_keypair () in + let secret_key, public_key, _pkh = Crypto_box.random_keypair () in let cryptobox_data = Crypto. { diff --git a/src/lib_p2p/test/node.ml b/src/lib_p2p/test/node.ml index a6b05628b3b2..d69615a7956b 100644 --- a/src/lib_p2p/test/node.ml +++ b/src/lib_p2p/test/node.ml @@ -304,7 +304,7 @@ let detach_nodes ?timeout ?prefix ?min_connections ?max_connections let max_incoming_connections = Option.map (fun f -> f n) max_incoming_connections in - let ((addr, port), other_points) = select_nth_point n points in + let (addr, port), other_points = select_nth_point n points in detach_node ?prefix ?p2p_versions diff --git a/src/lib_p2p/test/p2p_test_utils.ml b/src/lib_p2p/test/p2p_test_utils.ml index 21cd70fa85fe..28963876d603 100644 --- a/src/lib_p2p/test/p2p_test_utils.ml +++ b/src/lib_p2p/test/p2p_test_utils.ml @@ -168,7 +168,7 @@ let sync_nodes nodes = let run_nodes client server = let open Lwt_result_syntax in - let*! (main_socket, port) = listen !addr in + let*! main_socket, port = listen !addr in let* server_node = Process.detach ~prefix:"server: " (fun channel -> let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in @@ -197,7 +197,7 @@ let run_nodes client server = let raw_accept sched main_socket = let open Lwt_syntax in - let* (fd, sockaddr) = P2p_fd.accept main_socket in + let* fd, sockaddr = P2p_fd.accept main_socket in let fd = P2p_io_scheduler.register sched fd in let point = match sockaddr with @@ -213,7 +213,7 @@ let raw_accept sched main_socket = let accept ?(id = id1) ?(proof_of_work_target = proof_of_work_target) sched main_socket = let open Lwt_syntax in - let* (fd, point) = raw_accept sched main_socket in + let* fd, point = raw_accept sched main_socket in let* id1 = id in P2p_socket.authenticate ~canceler diff --git a/src/lib_p2p/test/process.ml b/src/lib_p2p/test/process.ml index a083d1eea4f7..e3ff33308257 100644 --- a/src/lib_p2p/test/process.ml +++ b/src/lib_p2p/test/process.ml @@ -176,7 +176,7 @@ end let terminate pid = let open Lwt_syntax in (try Unix.kill pid Sys.sigterm with _ -> ()) ; - let* (_pid, _status) = Lwt_unix.waitpid [] pid in + let* _pid, _status = Lwt_unix.waitpid [] pid in Lwt.return_unit let wait ~value_encoding ~flags pid result_ch = @@ -185,11 +185,11 @@ let wait ~value_encoding ~flags pid result_ch = (fun () -> let*! s = Lwt_unix.waitpid [] pid in match s with - | (_, Lwt_unix.WEXITED 0) -> + | _, Lwt_unix.WEXITED 0 -> received_result ~value_encoding ~flags result_ch - | (_, Lwt_unix.WEXITED n) -> fail_with_exn (Exited n) - | (_, Lwt_unix.WSIGNALED n) -> fail_with_exn (Signaled n) - | (_, Lwt_unix.WSTOPPED n) -> fail_with_exn (Stopped n)) + | _, Lwt_unix.WEXITED n -> fail_with_exn (Exited n) + | _, Lwt_unix.WSIGNALED n -> fail_with_exn (Signaled n) + | _, Lwt_unix.WSTOPPED n -> fail_with_exn (Stopped n)) (function | Lwt.Canceled -> let*! () = terminate pid in @@ -217,9 +217,9 @@ let detach ?(prefix = "") ?canceler ?input_encoding ?output_encoding protect ~canceler (fun () -> - let (main_in, child_out) = Lwt_io.pipe () in - let (child_in, main_out) = Lwt_io.pipe () in - let (main_result, child_exit) = Lwt_io.pipe () in + let main_in, child_out = Lwt_io.pipe () in + let child_in, main_out = Lwt_io.pipe () in + let main_result, child_exit = Lwt_io.pipe () in match Lwt_unix.fork () with | 0 -> Lwt_log.default := @@ -327,7 +327,7 @@ module Assoc = struct end (* [group_by f h l] for all elements [e] of [l] groups all [g e] that have the same value - for [f e] *) + for [f e] *) let group_by ~equal f g l = let rec aux l res = match l with @@ -386,7 +386,7 @@ let pp_grouped ppf plist pp_trace = (* Print the status of a list of detached process. Grouped by final result. TODO: either print the OK result, or ignore the result - value when Ok. *) + value when Ok. *) let pp_results ppf plist = let pp_res plural ppf res = match res with @@ -422,7 +422,7 @@ let wait_all_results (processes : ('a, 'b, 'c) t list) = match processes with | [] -> return_none | processes -> - let* (finished, remaining) = Lwt.nchoose_split processes in + let* finished, remaining = Lwt.nchoose_split processes in let rec handle = function | [] -> loop remaining | Ok _ :: finished -> handle finished @@ -445,8 +445,8 @@ let wait_all_results (processes : ('a, 'b, 'c) t list) = let* () = lwt_log_info "All done!" in let* terminated = all terminations in match List.partition_result terminated with - | (_, _ :: _) -> assert false - | (terminated, []) -> return_ok terminated) + | _, _ :: _ -> assert false + | terminated, [] -> return_ok terminated) | Some (_err, remaining) -> ( let* () = lwt_log_error "Early error! Canceling remaining process." in List.iter Lwt.cancel remaining ; @@ -457,8 +457,8 @@ let wait_all_results (processes : ('a, 'b, 'c) t list) = let errors = List.filter_map (function - | (_, _, Ok _) -> None - | (i, prefix, Error []) -> + | _, _, Ok _ -> None + | i, prefix, Error [] -> Some (TzTrace.make (Exn @@ -467,7 +467,7 @@ let wait_all_results (processes : ('a, 'b, 'c) t list) = "process %d(%s) returned an empty error trace" i (String.trim prefix))))) - | (i, prefix, Error trace) -> + | i, prefix, Error trace -> Some (TzTrace.cons (Exn diff --git a/src/lib_p2p/test/test_p2p_banned_peers.ml b/src/lib_p2p/test/test_p2p_banned_peers.ml index ddd19b4ca7ca..1ecf090bc8d2 100644 --- a/src/lib_p2p/test/test_p2p_banned_peers.ml +++ b/src/lib_p2p/test/test_p2p_banned_peers.ml @@ -148,10 +148,10 @@ let () = [ ("empty", test_empty); ("ban", test_ban); - ("clear", test_clear); + ("clear", test_clear) (* FIXME flaky test: ("test_gc", test_gc) - *) + *); ] ); ] |> Lwt_main.run diff --git a/src/lib_p2p/test/test_p2p_buffer_reader.ml b/src/lib_p2p/test/test_p2p_buffer_reader.ml index d431bdb1736d..d8f714fdc3a6 100644 --- a/src/lib_p2p/test/test_p2p_buffer_reader.ml +++ b/src/lib_p2p/test/test_p2p_buffer_reader.ml @@ -84,7 +84,7 @@ let test_mk_buffer_safe = let safe_buffer = Bytes.create buf_len |> P2p_buffer_reader.mk_buffer_safe in - let (pos, length_to_copy, buf) = + let pos, length_to_copy, buf = P2p_buffer_reader.Internal_for_tests.destruct_buffer safe_buffer in Alcotest.(check int "pos is always 0") 0 pos ; diff --git a/src/lib_p2p/test/test_p2p_io_scheduler.ml b/src/lib_p2p/test/test_p2p_io_scheduler.ml index 2df29236d590..afb4fd44cb16 100644 --- a/src/lib_p2p/test/test_p2p_io_scheduler.ml +++ b/src/lib_p2p/test/test_p2p_io_scheduler.ml @@ -59,7 +59,7 @@ let rec listen ?port addr = let accept main_socket = let open Lwt_syntax in - let* (fd, _sockaddr) = P2p_fd.accept main_socket in + let* fd, _sockaddr = P2p_fd.accept main_socket in return_ok fd let rec accept_n main_socket n = @@ -188,7 +188,7 @@ let run ?display_client_stat ?max_download_speed ?max_upload_speed ~read_buffer_size ?read_queue_size ?write_queue_size addr port time n = let open Lwt_result_syntax in let*! () = Tezos_base_unix.Internal_event_unix.init () in - let*! (main_socket, port) = listen ?port addr in + let*! main_socket, port = listen ?port addr in let* server_node = Process.detach ~prefix:"server: " diff --git a/src/lib_p2p/test/test_p2p_logging.ml b/src/lib_p2p/test/test_p2p_logging.ml index fe78f1442f93..f8b1b86e23df 100644 --- a/src/lib_p2p/test/test_p2p_logging.ml +++ b/src/lib_p2p/test/test_p2p_logging.ml @@ -38,7 +38,7 @@ module Authentication = struct let server _ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let* conn = P2p_socket.accept ~canceler auth_fd encoding in let*! () = P2p_socket.close conn in Mock_sink.assert_has_event @@ -54,7 +54,7 @@ module Authentication = struct let client _ch sched addr port = let open Lwt_result_syntax in let*! id2 = id2 in - let* (_, auth_fd) = connect sched addr port id2 in + let* _, auth_fd = connect sched addr port id2 in let* conn = P2p_socket.accept ~canceler auth_fd encoding in let*! () = P2p_socket.close conn in Mock_sink.assert_has_event @@ -89,7 +89,7 @@ module Nack = struct let server ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let*! () = P2p_socket.nack auth_fd P2p_rejection.No_motive [] in Mock_sink.assert_has_event ~strict:false @@ -100,7 +100,7 @@ module Nack = struct let client ch sched addr port = let open Lwt_result_syntax in let*! id2 = id2 in - let* (_, auth_fd) = connect sched addr port id2 in + let* _, auth_fd = connect sched addr port id2 in let*! _conn = P2p_socket.accept ~canceler auth_fd Data_encoding.bytes in sync ch @@ -140,12 +140,12 @@ module Read_and_write = struct let server ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let* conn = P2p_socket.accept ~canceler auth_fd Data_encoding.bytes in let* () = P2p_socket.write_sync conn @@ Bytes.of_string "a polite greeting" in - let* (_msg_size, _msg) = P2p_socket.read conn in + let* _msg_size, _msg = P2p_socket.read conn in let* () = sync ch in let*! () = P2p_socket.close conn in Mock_sink.assert_has_event @@ -165,12 +165,12 @@ module Read_and_write = struct let client ch sched addr port = let open Lwt_result_syntax in let*! id2 = id2 in - let* (_, auth_fd) = connect sched addr port id2 in + let* _, auth_fd = connect sched addr port id2 in let* conn = P2p_socket.accept ~canceler auth_fd Data_encoding.bytes in let* () = P2p_socket.write_sync conn @@ Bytes.of_string "a polite request" in - let* (_msg_size, _msg) = P2p_socket.read conn in + let* _msg_size, _msg = P2p_socket.read conn in let* () = sync ch in let*! _stat = P2p_socket.close conn in Mock_sink.assert_has_event diff --git a/src/lib_p2p/test/test_p2p_node.ml b/src/lib_p2p/test/test_p2p_node.ml index 23e7d41d8709..57150df60ff5 100644 --- a/src/lib_p2p/test/test_p2p_node.ml +++ b/src/lib_p2p/test/test_p2p_node.ml @@ -95,8 +95,8 @@ let wrap n f = let* r = f () in match r with | Ok () -> Lwt.return_unit - | Error - (Exn (Unix.Unix_error ((EADDRINUSE | EADDRNOTAVAIL), _, _)) :: _) -> + | Error (Exn (Unix.Unix_error ((EADDRINUSE | EADDRNOTAVAIL), _, _)) :: _) + -> let* () = Event.(emit port_conflicts) () in gen_points () ; aux n f diff --git a/src/lib_p2p/test/test_p2p_pool.ml b/src/lib_p2p/test/test_p2p_pool.ml index c55fe2934d5d..5704b6f5f5a4 100644 --- a/src/lib_p2p/test/test_p2p_pool.ml +++ b/src/lib_p2p/test/test_p2p_pool.ml @@ -392,7 +392,7 @@ module Overcrowded = struct | Error _ as res -> Lwt.return res let client_knowledge pool all_points = - let (unknowns, known) = + let unknowns, known = P2p_pool.Points.fold_known pool ~init:(all_points, []) @@ -407,7 +407,7 @@ module Overcrowded = struct (unknowns, known) let client_check pool all_points legacy = - let (unknowns, _known) = client_knowledge pool all_points in + let unknowns, _known = client_knowledge pool all_points in let advert_succeed = unknowns = [] in if legacy || advert_succeed then log_info @@ -476,8 +476,8 @@ module Overcrowded = struct in (unknown_points, id :: knowns)) in - let (unknowns, knowns) = unknowns_knowns () in - let (log, stopper) = Lwt_watcher.create_stream node.watcher in + let unknowns, knowns = unknowns_knowns () in + let log, stopper = Lwt_watcher.create_stream node.watcher in let*! () = lwt_debug "trusted : %a" P2p_point.Id.pp_list node.trusted_points in @@ -796,8 +796,8 @@ let wrap n f = let* r = f () in match r with | Ok () -> Lwt.return_unit - | Error - (Exn (Unix.Unix_error ((EADDRINUSE | EADDRNOTAVAIL), _, _)) :: _) -> + | Error (Exn (Unix.Unix_error ((EADDRINUSE | EADDRNOTAVAIL), _, _)) :: _) + -> warn "Conflict on ports, retry the test." ; gen_points () ; aux n f diff --git a/src/lib_p2p/test/test_p2p_socket.ml b/src/lib_p2p/test/test_p2p_socket.ml index e14830c38a33..c4256272d1d7 100644 --- a/src/lib_p2p/test/test_p2p_socket.ml +++ b/src/lib_p2p/test/test_p2p_socket.ml @@ -57,7 +57,7 @@ let sync ch = expected [target_id]). *) let connect ?proof_of_work_target ?(target_id = id1) sched addr port id = let open Lwt_result_syntax in - let* (info, auth_fd) = + let* info, auth_fd = P2p_test_utils.connect ?proof_of_work_target sched addr port id in let*! id1 = target_id in @@ -158,13 +158,13 @@ module Crypto_test = struct in return msg - let (sk, pk, _pkh) = Crypto_box.random_keypair () + let sk, pk, _pkh = Crypto_box.random_keypair () let zero_nonce = Crypto_box.zero_nonce let channel_key = Crypto_box.precompute sk pk - let (in_fd, out_fd) = Unix.pipe () + let in_fd, out_fd = Unix.pipe () let data = {channel_key; local_nonce = zero_nonce; remote_nonce = zero_nonce} @@ -231,7 +231,7 @@ module Low_level = struct let server ch sched socket = let open Lwt_result_syntax in - let*! (fd, _point) = raw_accept sched socket in + let*! fd, _point = raw_accept sched socket in let* () = P2p_io_scheduler.write fd simple_msg in let* () = sync ch in let* _ = P2p_io_scheduler.close fd in @@ -257,7 +257,7 @@ module Nack = struct let server ch sched socket = let open Lwt_result_syntax in - let* (info, auth_fd) = accept sched socket in + let* info, auth_fd = accept sched socket in let* () = tzassert info.incoming __POS__ in let*! id2 = id2 in let* () = @@ -286,7 +286,7 @@ module Nacked = struct let server ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let*! conn = P2p_socket.accept ~canceler auth_fd encoding in let* () = tzassert (Nack.is_rejected conn) __POS__ in sync ch @@ -315,10 +315,10 @@ module Simple_message = struct let server ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let* conn = P2p_socket.accept ~canceler auth_fd encoding in let* () = P2p_socket.write_sync conn simple_msg in - let* (_msg_size, msg) = P2p_socket.read conn in + let* _msg_size, msg = P2p_socket.read conn in let* () = tzassert (Bytes.compare simple_msg2 msg = 0) __POS__ in let* () = sync ch in let*! _stat = P2p_socket.close conn in @@ -330,7 +330,7 @@ module Simple_message = struct let* auth_fd = connect sched addr port id2 in let* conn = P2p_socket.accept ~canceler auth_fd encoding in let* () = P2p_socket.write_sync conn simple_msg2 in - let* (_msg_size, msg) = P2p_socket.read conn in + let* _msg_size, msg = P2p_socket.read conn in let* () = tzassert (Bytes.compare simple_msg msg = 0) __POS__ in let* () = sync ch in let*! _stat = P2p_socket.close conn in @@ -353,12 +353,12 @@ module Chunked_message = struct let server ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let* conn = P2p_socket.accept ~canceler ~binary_chunks_size:21 auth_fd encoding in let* () = P2p_socket.write_sync conn simple_msg in - let* (_msg_size, msg) = P2p_socket.read conn in + let* _msg_size, msg = P2p_socket.read conn in let* () = tzassert (Bytes.compare simple_msg2 msg = 0) __POS__ in let* () = sync ch in let*! _stat = P2p_socket.close conn in @@ -372,7 +372,7 @@ module Chunked_message = struct P2p_socket.accept ~canceler ~binary_chunks_size:21 auth_fd encoding in let* () = P2p_socket.write_sync conn simple_msg2 in - let* (_msg_size, msg) = P2p_socket.read conn in + let* _msg_size, msg = P2p_socket.read conn in let* () = tzassert (Bytes.compare simple_msg msg = 0) __POS__ in let* () = sync ch in let*! _stat = P2p_socket.close conn in @@ -399,10 +399,10 @@ module Oversized_message = struct let server ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let* conn = P2p_socket.accept ~canceler auth_fd encoding in let* () = P2p_socket.write_sync conn simple_msg in - let* (_msg_size, msg) = P2p_socket.read conn in + let* _msg_size, msg = P2p_socket.read conn in let* () = tzassert (Bytes.compare simple_msg2 msg = 0) __POS__ in let* () = sync ch in let*! _stat = P2p_socket.close conn in @@ -414,7 +414,7 @@ module Oversized_message = struct let* auth_fd = connect sched addr port id2 in let* conn = P2p_socket.accept ~canceler auth_fd encoding in let* () = P2p_socket.write_sync conn simple_msg2 in - let* (_msg_size, msg) = P2p_socket.read conn in + let* _msg_size, msg = P2p_socket.read conn in let* () = tzassert (Bytes.compare simple_msg msg = 0) __POS__ in let* () = sync ch in let*! _stat = P2p_socket.close conn in @@ -432,7 +432,7 @@ module Close_on_read = struct let server ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let* conn = P2p_socket.accept ~canceler auth_fd encoding in let* () = sync ch in let*! _stat = P2p_socket.close conn in @@ -463,7 +463,7 @@ module Close_on_write = struct let server ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let* conn = P2p_socket.accept ~canceler auth_fd encoding in let*! _stat = P2p_socket.close conn in let* () = sync ch in @@ -507,7 +507,7 @@ module Garbled_data = struct let server _ch sched socket = let open Lwt_result_syntax in - let* (_info, auth_fd) = accept sched socket in + let* _info, auth_fd = accept sched socket in let* conn = P2p_socket.accept ~canceler auth_fd encoding in let* () = P2p_socket.raw_write_sync conn garbled_msg in let*! err = P2p_socket.read conn in diff --git a/src/lib_protocol_compiler/bin/main_embedded_packer.ml b/src/lib_protocol_compiler/bin/main_embedded_packer.ml index e9ebda888bcb..07fc19c44a1b 100644 --- a/src/lib_protocol_compiler/bin/main_embedded_packer.ml +++ b/src/lib_protocol_compiler/bin/main_embedded_packer.ml @@ -31,7 +31,7 @@ let srcdir = if Filename.basename srcdir = "TEZOS_PROTOCOL" then Filename.dirname srcdir else srcdir -let (hash, sources) = +let hash, sources = match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir srcdir) with | Ok (None, proto) -> (Protocol.hash proto, proto) | Ok (Some hash, proto) -> (hash, proto) diff --git a/src/lib_protocol_compiler/bin/main_packer.ml b/src/lib_protocol_compiler/bin/main_packer.ml index f95e1bb7943c..37b5bf77f18f 100644 --- a/src/lib_protocol_compiler/bin/main_packer.ml +++ b/src/lib_protocol_compiler/bin/main_packer.ml @@ -40,7 +40,7 @@ let () = Arg.usage args_spec usage_msg ; Stdlib.exit 1 in - let (hash, protocol) = + let hash, protocol = match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with | Ok (None, proto) -> (Protocol.hash proto, proto) | Ok (Some hash, proto) -> (hash, proto) diff --git a/src/lib_protocol_compiler/bin/replace.ml b/src/lib_protocol_compiler/bin/replace.ml index 69864227283b..d7a9aa49617e 100644 --- a/src/lib_protocol_compiler/bin/replace.ml +++ b/src/lib_protocol_compiler/bin/replace.ml @@ -153,7 +153,7 @@ let main () = let version = try Sys.argv.(4) with Invalid_argument _ -> guess_version () in - let (hash, proto, check_hash) = read_proto destination final_protocol_file in + let hash, proto, check_hash = read_proto destination final_protocol_file in process ~template ~destination proto version hash check_hash let () = main () diff --git a/src/lib_protocol_compiler/compiler.ml b/src/lib_protocol_compiler/compiler.ml index abc7f1ec328e..35952cd49fe3 100644 --- a/src/lib_protocol_compiler/compiler.ml +++ b/src/lib_protocol_compiler/compiler.ml @@ -58,7 +58,7 @@ let load_embedded_cmi (unit_name, content) = assert (magic = Bytes.of_string Config.cmi_magic_number) ; (* Read cmi_name and cmi_sign *) let pos = magic_len in - let (cmi_name, cmi_sign) = Marshal.from_bytes content pos in + let cmi_name, cmi_sign = Marshal.from_bytes content pos in let pos = pos + Marshal.total_size content pos in (* Read cmi_crcs *) let cmi_crcs = Marshal.from_bytes content pos in @@ -212,7 +212,7 @@ let main {compile_ml; pack_objects; link_shared} = Arg.usage args_spec usage_msg ; Stdlib.exit 1 in - let (announced_hash, protocol) = + let announced_hash, protocol = match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with | Ok (hash, proto) -> (hash, proto) | Error err -> diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index e3b0a3992f23..34aab02710df 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -70,7 +70,7 @@ module type V0 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_error = Error_monad.error type error += Ecoproto_error of Error_monad.error diff --git a/src/lib_protocol_environment/environment_V0.mli b/src/lib_protocol_environment/environment_V0.mli index 0bdbf3b87670..4568fb14a256 100644 --- a/src/lib_protocol_environment/environment_V0.mli +++ b/src/lib_protocol_environment/environment_V0.mli @@ -70,7 +70,7 @@ module type V0 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_error = Error_monad.error type error += Ecoproto_error of Error_monad.error diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index 27fe11804bfa..770161ec76a6 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -65,7 +65,7 @@ module type V1 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -76,7 +76,7 @@ module type V1 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_error = Error_monad.error and module Sapling = Tezos_sapling.Core.Validator_legacy diff --git a/src/lib_protocol_environment/environment_V1.mli b/src/lib_protocol_environment/environment_V1.mli index 73900db4b910..c31167f24bc0 100644 --- a/src/lib_protocol_environment/environment_V1.mli +++ b/src/lib_protocol_environment/environment_V1.mli @@ -64,7 +64,7 @@ module type V1 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -75,7 +75,7 @@ module type V1 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_error = Error_monad.error and module Sapling = Tezos_sapling.Core.Validator_legacy diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index 3e9d2f4ff3a0..301d20edc587 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -65,7 +65,7 @@ module type V2 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -76,7 +76,7 @@ module type V2 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and module Sapling = Tezos_sapling.Core.Validator_legacy diff --git a/src/lib_protocol_environment/environment_V2.mli b/src/lib_protocol_environment/environment_V2.mli index 8e970975c7a2..c1ef411cd6d8 100644 --- a/src/lib_protocol_environment/environment_V2.mli +++ b/src/lib_protocol_environment/environment_V2.mli @@ -64,7 +64,7 @@ module type V2 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -75,7 +75,7 @@ module type V2 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and module Sapling = Tezos_sapling.Core.Validator_legacy diff --git a/src/lib_protocol_environment/environment_V3.ml b/src/lib_protocol_environment/environment_V3.ml index 59a0966c8731..2445b8dd2a73 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -68,7 +68,7 @@ module type V3 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -79,7 +79,7 @@ module type V3 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and type Timelock.chest = Timelock.chest diff --git a/src/lib_protocol_environment/environment_V3.mli b/src/lib_protocol_environment/environment_V3.mli index dec0ffb4429b..05a3503338db 100644 --- a/src/lib_protocol_environment/environment_V3.mli +++ b/src/lib_protocol_environment/environment_V3.mli @@ -67,7 +67,7 @@ module type V3 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -78,7 +78,7 @@ module type V3 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and type Timelock.chest = Timelock.chest diff --git a/src/lib_protocol_environment/environment_V4.ml b/src/lib_protocol_environment/environment_V4.ml index f170ce1e77d4..347c6e0259c7 100644 --- a/src/lib_protocol_environment/environment_V4.ml +++ b/src/lib_protocol_environment/environment_V4.ml @@ -72,7 +72,7 @@ module type V4 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -84,7 +84,7 @@ module type V4 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and type Timelock.chest = Timelock.chest diff --git a/src/lib_protocol_environment/environment_V4.mli b/src/lib_protocol_environment/environment_V4.mli index a987b1764025..03c4847ebc24 100644 --- a/src/lib_protocol_environment/environment_V4.mli +++ b/src/lib_protocol_environment/environment_V4.mli @@ -67,7 +67,7 @@ module type V4 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -79,7 +79,7 @@ module type V4 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and type Timelock.chest = Timelock.chest diff --git a/src/lib_protocol_environment/environment_V5.ml b/src/lib_protocol_environment/environment_V5.ml index 6cb3e277ebd3..173496f32020 100644 --- a/src/lib_protocol_environment/environment_V5.ml +++ b/src/lib_protocol_environment/environment_V5.ml @@ -77,7 +77,7 @@ module type V5 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -89,7 +89,7 @@ module type V5 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and type Timelock.chest = Timelock.chest diff --git a/src/lib_protocol_environment/environment_V5.mli b/src/lib_protocol_environment/environment_V5.mli index a744f565a28e..c304902004b9 100644 --- a/src/lib_protocol_environment/environment_V5.mli +++ b/src/lib_protocol_environment/environment_V5.mli @@ -78,7 +78,7 @@ module type V5 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -90,7 +90,7 @@ module type V5 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and type Timelock.chest = Timelock.chest diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index ab446775349c..8d5aa897345b 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -77,7 +77,7 @@ module type V6 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -89,7 +89,7 @@ module type V6 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and type Timelock.chest = Timelock.chest diff --git a/src/lib_protocol_environment/environment_V6.mli b/src/lib_protocol_environment/environment_V6.mli index 3e10e82d0a7e..b47aae1c9ba5 100644 --- a/src/lib_protocol_environment/environment_V6.mli +++ b/src/lib_protocol_environment/environment_V6.mli @@ -78,7 +78,7 @@ module type V6 = sig and type Signature.watermark = Signature.watermark and type Pvss_secp256k1.Commitment.t = Pvss_secp256k1.Commitment.t and type Pvss_secp256k1.Encrypted_share.t = - Pvss_secp256k1.Encrypted_share.t + Pvss_secp256k1.Encrypted_share.t and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t @@ -90,7 +90,7 @@ module type V6 = sig and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t = - ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t + ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t and type Error_monad.shell_tztrace = Error_monad.tztrace and type 'a Error_monad.shell_tzresult = ('a, Error_monad.tztrace) result and type Timelock.chest = Timelock.chest diff --git a/src/lib_protocol_environment/environment_cache.ml b/src/lib_protocol_environment/environment_cache.ml index 99937d8f2064..9f44883e6441 100644 --- a/src/lib_protocol_environment/environment_cache.ml +++ b/src/lib_protocol_environment/environment_cache.ml @@ -352,7 +352,7 @@ type domain = subcache_domain list let sync_cache cache ~cache_nonce = let cache = enforce_size_limit cache in let cache = record_entries_removals cache in - let (cache, new_entries) = finalize_cache cache cache_nonce in + let cache, new_entries = finalize_cache cache cache_nonce in (cache, {keys = new_entries; counter = cache.counter}) let subcache_keys_encoding : value_metadata KeyMap.t Data_encoding.t = @@ -381,7 +381,7 @@ let sync t ~cache_nonce = with_caches t @@ fun caches -> FunctionalArray.fold_map (fun acc cache -> - let (cache, domain) = sync_cache cache ~cache_nonce in + let cache, domain = sync_cache cache ~cache_nonce in (domain :: acc, cache)) caches [] diff --git a/src/lib_protocol_environment/environment_context.ml b/src/lib_protocol_environment/environment_context.ml index f7772ef49446..ba652bfff981 100644 --- a/src/lib_protocol_environment/environment_context.ml +++ b/src/lib_protocol_environment/environment_context.ml @@ -148,7 +148,7 @@ module Context = struct let add_tree (Context ({ops = (module Ops); ctxt; _} as c)) key (Tree t) = let open Lwt_syntax in match equiv c.equality_witness t.equality_witness with - | (Some Refl, Some Refl) -> + | Some Refl, Some Refl -> let+ ctxt = Ops.add_tree ctxt key t.tree in Context {c with ctxt} | _ -> err_implementation_mismatch ~expected:c.impl_name ~got:t.impl_name @@ -202,7 +202,7 @@ module Context = struct let equal (Tree {ops = (module Ops); tree; equality_witness; _}) (Tree t) = match equiv equality_witness t.equality_witness with - | (Some Refl, Some Refl) -> Ops.Tree.equal tree t.tree + | Some Refl, Some Refl -> Ops.Tree.equal tree t.tree | _ -> false let empty @@ -228,7 +228,7 @@ module Context = struct let add_tree (Tree ({ops = (module Ops); _} as c)) key (Tree t) = let open Lwt_syntax in match equiv c.equality_witness t.equality_witness with - | (Some Refl, Some Refl) -> + | Some Refl, Some Refl -> let+ tree = Ops.Tree.add_tree c.tree key t.tree in Tree {c with tree} | _ -> err_implementation_mismatch ~expected:c.impl_name ~got:t.impl_name @@ -299,7 +299,7 @@ module Context = struct let project : tree -> M.tree = fun (Tree t) -> match equiv t.equality_witness equality_witness with - | (Some Refl, Some Refl) -> t.tree + | Some Refl, Some Refl -> t.tree | _ -> err_implementation_mismatch ~expected:impl_name ~got:t.impl_name end @@ -326,7 +326,7 @@ module Context = struct let project : tree -> M.tree = fun (Tree t) -> match equiv t.equality_witness equality_witness with - | (Some Refl, Some Refl) -> t.tree + | Some Refl, Some Refl -> t.tree | _ -> err_implementation_mismatch ~expected:impl_name ~got:t.impl_name end @@ -364,10 +364,10 @@ module Context = struct let verify_tree_proof proof (f : tree -> (tree * 'a) Lwt.t) = let open Lwt_result_syntax in let* (module Proof_context) = proof_context ~kind:`Tree proof in - let* (tree, r) = + let* tree, r = Proof_context.M.verify_tree_proof proof (fun tree -> let tree = Proof_context.inject tree in - let*! (tree, r) = f tree in + let*! tree, r = f tree in Lwt.return (Proof_context.project tree, r)) in return (Proof_context.inject tree, r) @@ -375,10 +375,10 @@ module Context = struct let verify_stream_proof proof (f : tree -> (tree * 'a) Lwt.t) = let open Lwt_result_syntax in let* (module Proof_context) = proof_context ~kind:`Stream proof in - let* (tree, r) = + let* tree, r = Proof_context.M.verify_stream_proof proof (fun tree -> let tree = Proof_context.inject tree in - let*! (tree, r) = f tree in + let*! tree, r = f tree in Lwt.return (Proof_context.project tree, r)) in return (Proof_context.inject tree, r) @@ -531,7 +531,7 @@ module Context = struct let sync (Context ctxt) ~cache_nonce = let open Environment_cache in let open Data_encoding in - let (cache, domain) = sync ctxt.cache ~cache_nonce in + let cache, domain = sync ctxt.cache ~cache_nonce in let bytes = Binary.to_bytes_exn domain_encoding domain in let ctxt = Context {ctxt with cache} in add ctxt cache_domain_path bytes diff --git a/src/lib_protocol_environment/environment_protocol_T.ml b/src/lib_protocol_environment/environment_protocol_T.ml index f134741bf74f..70d93baebf08 100644 --- a/src/lib_protocol_environment/environment_protocol_T.ml +++ b/src/lib_protocol_environment/environment_protocol_T.ml @@ -107,7 +107,6 @@ end A module of this signature is typically obtained through an adapter (see Lift functors in environment definitions) of the Main module (which complies with the [Updater] signature). - *) module type PROTOCOL = sig include diff --git a/src/lib_protocol_environment/proxy_context.ml b/src/lib_protocol_environment/proxy_context.ml index 664bc85b379a..62f102732a0f 100644 --- a/src/lib_protocol_environment/proxy_context.ml +++ b/src/lib_protocol_environment/proxy_context.ml @@ -378,7 +378,7 @@ module C = struct let map_f f tree = let open Lwt_syntax in - let+ (t, r) = f (of_local tree) in + let+ t, r = f (of_local tree) in (t.tree, r) let verify verifier proof f = diff --git a/src/lib_protocol_environment/sigs/v0/int32.mli b/src/lib_protocol_environment/sigs/v0/int32.mli index ee99d0edff2f..3f6690963529 100644 --- a/src/lib_protocol_environment/sigs/v0/int32.mli +++ b/src/lib_protocol_environment/sigs/v0/int32.mli @@ -17,7 +17,6 @@ * Import version 4.06.1 * Remove deprecated functions - *) (** 32-bit integers. diff --git a/src/lib_protocol_environment/sigs/v0/int64.mli b/src/lib_protocol_environment/sigs/v0/int64.mli index bdfa7854b101..3ff2be8c7e37 100644 --- a/src/lib_protocol_environment/sigs/v0/int64.mli +++ b/src/lib_protocol_environment/sigs/v0/int64.mli @@ -17,7 +17,6 @@ * Import version 4.06.1 * Remove deprecated functions - *) (** 64-bit integers. diff --git a/src/lib_protocol_environment/sigs/v0/pervasives.mli b/src/lib_protocol_environment/sigs/v0/pervasives.mli index d5c078cbd821..a91bc67ab3b4 100644 --- a/src/lib_protocol_environment/sigs/v0/pervasives.mli +++ b/src/lib_protocol_environment/sigs/v0/pervasives.mli @@ -21,7 +21,6 @@ * Remove floating-point arithmetic * Remove string conversion functions for float * Remove deprecated functions - *) (** The initially opened module. diff --git a/src/lib_protocol_environment/sigs/v0/string.mli b/src/lib_protocol_environment/sigs/v0/string.mli index 19dfb121f8b8..8d3c52e6a52f 100644 --- a/src/lib_protocol_environment/sigs/v0/string.mli +++ b/src/lib_protocol_environment/sigs/v0/string.mli @@ -19,7 +19,6 @@ * Remove unsafe functions * Remove deprecated functions (enforcing string immutability) * Add binary data extraction functions - *) (** String operations. diff --git a/src/lib_protocol_environment/structs/v0/error_monad_traversors.ml b/src/lib_protocol_environment/structs/v0/error_monad_traversors.ml index b31ad2ecd188..d4766691e7c7 100644 --- a/src/lib_protocol_environment/structs/v0/error_monad_traversors.ml +++ b/src/lib_protocol_environment/structs/v0/error_monad_traversors.ml @@ -88,9 +88,9 @@ let rec map_p f l = tx >>= fun x -> tl >>= fun l -> match (x, l) with - | (Ok x, Ok l) -> Lwt.return_ok (x :: l) - | (Error trace1, Error trace2) -> Lwt.return_error (trace1 @ trace2) - | (Ok _, Error trace) | (Error trace, Ok _) -> Lwt.return_error trace) + | Ok x, Ok l -> Lwt.return_ok (x :: l) + | Error trace1, Error trace2 -> Lwt.return_error (trace1 @ trace2) + | Ok _, Error trace | Error trace, Ok _ -> Lwt.return_error trace) let mapi_p f l = let rec mapi_p f i l = @@ -101,26 +101,26 @@ let mapi_p f l = tx >>= fun x -> tl >>= fun l -> match (x, l) with - | (Ok x, Ok l) -> Lwt.return_ok (x :: l) - | (Error trace1, Error trace2) -> Lwt.return_error (trace1 @ trace2) - | (Ok _, Error trace) | (Error trace, Ok _) -> Lwt.return_error trace) + | Ok x, Ok l -> Lwt.return_ok (x :: l) + | Error trace1, Error trace2 -> Lwt.return_error (trace1 @ trace2) + | Ok _, Error trace | Error trace, Ok _ -> Lwt.return_error trace) in mapi_p f 0 l let rec map2_s f l1 l2 = match (l1, l2) with - | ([], []) -> return_nil - | (_ :: _, []) | ([], _ :: _) -> invalid_arg "Error_monad.map2_s" - | (h1 :: t1, h2 :: t2) -> + | [], [] -> return_nil + | _ :: _, [] | [], _ :: _ -> invalid_arg "Error_monad.map2_s" + | h1 :: t1, h2 :: t2 -> f h1 h2 >>=? fun rh -> map2_s f t1 t2 >>=? fun rt -> return (rh :: rt) let mapi2_s f l1 l2 = let rec mapi2_s i f l1 l2 = match (l1, l2) with - | ([], []) -> return_nil - | (_ :: _, []) | ([], _ :: _) -> invalid_arg "Error_monad.mapi2_s" - | (h1 :: t1, h2 :: t2) -> + | [], [] -> return_nil + | _ :: _, [] | [], _ :: _ -> invalid_arg "Error_monad.mapi2_s" + | h1 :: t1, h2 :: t2 -> f i h1 h2 >>=? fun rh -> mapi2_s (i + 1) f t1 t2 >>=? fun rt -> return (rh :: rt) in @@ -128,18 +128,18 @@ let mapi2_s f l1 l2 = let rec map2 f l1 l2 = match (l1, l2) with - | ([], []) -> ok_nil - | (_ :: _, []) | ([], _ :: _) -> invalid_arg "Error_monad.map2" - | (h1 :: t1, h2 :: t2) -> + | [], [] -> ok_nil + | _ :: _, [] | [], _ :: _ -> invalid_arg "Error_monad.map2" + | h1 :: t1, h2 :: t2 -> f h1 h2 >>? fun rh -> map2 f t1 t2 >>? fun rt -> Ok (rh :: rt) let mapi2 f l1 l2 = let rec mapi2 i f l1 l2 = match (l1, l2) with - | ([], []) -> ok_nil - | (_ :: _, []) | ([], _ :: _) -> invalid_arg "Error_monad.mapi2" - | (h1 :: t1, h2 :: t2) -> + | [], [] -> ok_nil + | _ :: _, [] | [], _ :: _ -> invalid_arg "Error_monad.mapi2" + | h1 :: t1, h2 :: t2 -> f i h1 h2 >>? fun rh -> mapi2 (i + 1) f t1 t2 >>? fun rt -> Ok (rh :: rt) in @@ -199,9 +199,9 @@ let rec iter_p f l = tx >>= fun tx_res -> tl >>= fun tl_res -> match (tx_res, tl_res) with - | (Ok (), Ok ()) -> Lwt.return_ok () - | (Error trace1, Error trace2) -> Lwt.return_error (trace1 @ trace2) - | (Ok (), Error trace) | (Error trace, Ok ()) -> Lwt.return_error trace) + | Ok (), Ok () -> Lwt.return_ok () + | Error trace1, Error trace2 -> Lwt.return_error (trace1 @ trace2) + | Ok (), Error trace | Error trace, Ok () -> Lwt.return_error trace) let iteri_p f l = let rec iteri_p i f l = @@ -212,38 +212,38 @@ let iteri_p f l = tx >>= fun tx_res -> tl >>= fun tl_res -> match (tx_res, tl_res) with - | (Ok (), Ok ()) -> Lwt.return ok_unit - | (Error trace1, Error trace2) -> Lwt.return_error (trace1 @ trace2) - | (Ok (), Error trace) | (Error trace, Ok ()) -> Lwt.return_error trace) + | Ok (), Ok () -> Lwt.return ok_unit + | Error trace1, Error trace2 -> Lwt.return_error (trace1 @ trace2) + | Ok (), Error trace | Error trace, Ok () -> Lwt.return_error trace) in iteri_p 0 f l let rec iter2_p f l1 l2 = match (l1, l2) with - | ([], []) -> return_unit - | ([], _) | (_, []) -> invalid_arg "Error_monad.iter2_p" - | (x1 :: l1, x2 :: l2) -> ( + | [], [] -> return_unit + | [], _ | _, [] -> invalid_arg "Error_monad.iter2_p" + | x1 :: l1, x2 :: l2 -> ( let tx = f x1 x2 and tl = iter2_p f l1 l2 in tx >>= fun tx_res -> tl >>= fun tl_res -> match (tx_res, tl_res) with - | (Ok (), Ok ()) -> Lwt.return_ok () - | (Error trace1, Error trace2) -> Lwt.return_error (trace1 @ trace2) - | (Ok (), Error trace) | (Error trace, Ok ()) -> Lwt.return_error trace) + | Ok (), Ok () -> Lwt.return_ok () + | Error trace1, Error trace2 -> Lwt.return_error (trace1 @ trace2) + | Ok (), Error trace | Error trace, Ok () -> Lwt.return_error trace) let iteri2_p f l1 l2 = let rec iteri2_p i f l1 l2 = match (l1, l2) with - | ([], []) -> return_unit - | ([], _) | (_, []) -> invalid_arg "Error_monad.iteri2_p" - | (x1 :: l1, x2 :: l2) -> ( + | [], [] -> return_unit + | [], _ | _, [] -> invalid_arg "Error_monad.iteri2_p" + | x1 :: l1, x2 :: l2 -> ( let tx = f i x1 x2 and tl = iteri2_p (i + 1) f l1 l2 in tx >>= fun tx_res -> tl >>= fun tl_res -> match (tx_res, tl_res) with - | (Ok (), Ok ()) -> Lwt.return_ok () - | (Error trace1, Error trace2) -> Lwt.return_error (trace1 @ trace2) - | (Ok (), Error trace) | (Error trace, Ok ()) -> Lwt.return_error trace) + | Ok (), Ok () -> Lwt.return_ok () + | Error trace1, Error trace2 -> Lwt.return_error (trace1 @ trace2) + | Ok (), Error trace | Error trace, Ok () -> Lwt.return_error trace) in iteri2_p 0 f l1 l2 diff --git a/src/lib_protocol_environment/structs/v3/lwtreslib_list_combine.ml b/src/lib_protocol_environment/structs/v3/lwtreslib_list_combine.ml index 4229ce5c9619..3449891bc424 100644 --- a/src/lib_protocol_environment/structs/v3/lwtreslib_list_combine.ml +++ b/src/lib_protocol_environment/structs/v3/lwtreslib_list_combine.ml @@ -29,6 +29,6 @@ let combine_with_leftovers xs ys = match Tezos_lwt_result_stdlib.Lwtreslib.Bare.List.combine_with_leftovers xs ys with - | (c, None) -> (c, None) - | (c, Some (Either.Left l)) -> (c, Some (`Left l)) - | (c, Some (Either.Right r)) -> (c, Some (`Right r)) + | c, None -> (c, None) + | c, Some (Either.Left l) -> (c, Some (`Left l)) + | c, Some (Either.Right r) -> (c, Some (`Right r)) diff --git a/src/lib_protocol_environment/test/test_cache.ml b/src/lib_protocol_environment/test/test_cache.ml index ed99d53e7e6a..41a032c615a1 100644 --- a/src/lib_protocol_environment/test/test_cache.ml +++ b/src/lib_protocol_environment/test/test_cache.ml @@ -64,8 +64,8 @@ let almost_full_cache cache ~cache_index = match (cache_size cache ~cache_index, cache_size_limit cache ~cache_index) with - | (Some size, Some limit) -> size + entry_size >= limit - | (_, _) -> assert false + | Some size, Some limit -> size + entry_size >= limit + | _, _ -> assert false let equal_identifiers k1 k2 = identifier_of_key k1 = identifier_of_key k2 @@ -142,7 +142,7 @@ let pp_entries = Format.pp_print_list pp_entry let pp_cache fmt cache = - let (layout, entries, cache) = cache in + let layout, entries, cache = cache in Format.fprintf fmt "(layout: %a, entries: [%a], cache: %a)" @@ -340,7 +340,7 @@ let check_key_of_identifier_assigns_given_identifier = *) let inserted_entries_are_in get (_, entries, cache) = - let (cache, _) = sync cache ~cache_nonce:Bytes.empty in + let cache, _ = sync cache ~cache_nonce:Bytes.empty in let full_flags = Array.make (number_of_caches cache) false in let rec process cache' = function | [] -> true @@ -442,15 +442,15 @@ let update_removes_cached_value (_, entries, cache) = List.for_all (fun (_, i, k, _) -> match (find cache' k, find cache k) with - | (None, None) -> true - | (Some v, _) -> + | None, None -> true + | Some v, _ -> if selected_for_removal v then QCheck.Test.fail_reportf "For key %s, got %d, expecting absence\n" i v else true - | (None, Some v) -> + | None, Some v -> if not (selected_for_removal v) then QCheck.Test.fail_reportf "For key %s, expecting %d, got absence\n" @@ -493,12 +493,12 @@ let future_cache_expectation_repeats_the_past if number_of_caches cache > 1 then true else let lr_entries = List.rev entries in - let (cache, _) = sync cache ~cache_nonce:Bytes.empty in + let cache, _ = sync cache ~cache_nonce:Bytes.empty in let remove_some_entries n (cache, lr_entries) = Utils.fold_n_times n (fun (cache, lr_entries) -> - let (least_recent_entries, lr_entries) = + let least_recent_entries, lr_entries = List.split_n nb_removals lr_entries in let cache = @@ -510,10 +510,10 @@ let future_cache_expectation_repeats_the_past (fst (sync cache ~cache_nonce:Bytes.empty), lr_entries)) (cache, lr_entries) in - let (cache, lr_entries) = remove_some_entries 10 (cache, lr_entries) in + let cache, lr_entries = remove_some_entries 10 (cache, lr_entries) in let predicted_cache = future_cache_expectation ~time_in_blocks cache in let predicted_size = number_of_keys predicted_cache in - let (cache', _) = remove_some_entries time_in_blocks (cache, lr_entries) in + let cache', _ = remove_some_entries time_in_blocks (cache, lr_entries) in let actual_size = number_of_keys cache' in if predicted_size - actual_size > actual_size / 3 then QCheck.Test.fail_reportf @@ -545,11 +545,11 @@ let after_sync_cache_nonce_are_set (entries, cache, fresh_entries) = in let nonce1 = Bytes.of_string "init" in let nonce2 = Bytes.of_string "new" in - let (cache, _) = sync cache ~cache_nonce:nonce1 in + let cache, _ = sync cache ~cache_nonce:nonce1 in if_in_then_has_cache_nonce cache entries nonce1 && let cache = insert_entries cache fresh_entries in - let (cache, _) = sync cache ~cache_nonce:nonce2 in + let cache, _ = sync cache ~cache_nonce:nonce2 in if_in_then_has_cache_nonce cache fresh_entries nonce2 let check_after_sync_cache_nonce_are_set = @@ -559,7 +559,7 @@ let check_after_sync_cache_nonce_are_set = QCheck.( make Gen.( - let* (_, entries, cache) = gen_cache () in + let* _, entries, cache = gen_cache () in let* fresh_entries = gen_entries (number_of_caches cache) in return (entries, cache, fresh_entries))) after_sync_cache_nonce_are_set @@ -609,7 +609,7 @@ let check_list_keys_returns_entries = *) let key_rank_returns_valid_rank (_, entries, cache) = - let (cache, _) = sync cache ~cache_nonce:Bytes.empty in + let cache, _ = sync cache ~cache_nonce:Bytes.empty in List.for_all (fun cache_index -> match list_keys cache ~cache_index with @@ -624,9 +624,9 @@ let key_rank_returns_valid_rank (_, entries, cache) = ( key_rank cache k, position_of_assoc ~equal:equal_identifiers k ks ) with - | (None, None) -> true - | (Some rank, Some pos) -> rank = pos - | (_, _) -> false) + | None, None -> true + | Some rank, Some pos -> rank = pos + | _, _ -> false) entries) (0 -- (number_of_caches cache - 1)) @@ -651,7 +651,7 @@ let same_cache_keys cache cache' = let from_cache_with_same_domain_copies (_, _, cache) = let open Lwt_result_syntax in - let (cache, domain) = sync cache ~cache_nonce:Bytes.empty in + let cache, domain = sync cache ~cache_nonce:Bytes.empty in let* cache' = from_cache cache domain ~value_of_key:(fun _ -> assert false) in return (same_cache_keys cache cache') diff --git a/src/lib_protocol_environment/test/test_mem_context.ml b/src/lib_protocol_environment/test/test_mem_context.ml index 99f90a0d6e7e..faab68d1859f 100644 --- a/src/lib_protocol_environment/test/test_mem_context.ml +++ b/src/lib_protocol_environment/test/test_mem_context.ml @@ -218,7 +218,7 @@ let test_fold {genesis = ctxt; _} = let* ctxt = Context.add ctxt ["foo"; "toto"] foo1 in let* ctxt = Context.add ctxt ["foo"; "bar"; "toto"] foo2 in let fold depth ecs ens = - let* (cs, ns) = + let* cs, ns = Context.fold ?depth ctxt @@ -314,7 +314,7 @@ let test_trees {genesis = ctxt; _} = let* v1 = Context.Tree.add v1 ["foo"; "toto"] foo1 in let* v1 = Context.Tree.add v1 ["foo"; "bar"; "toto"] foo2 in let fold depth ecs ens = - let* (cs, ns) = + let* cs, ns = Context.Tree.fold v1 ?depth diff --git a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml index 376e1319cf20..a4459f6c368b 100644 --- a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml +++ b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml @@ -66,7 +66,7 @@ let value_arb = QCheck.map ~rev:Bytes.to_string Bytes.of_string QCheck.string let key_value_arb = QCheck.pair key_arb value_arb (* We generate contexts by starting from a fresh one and - doing a sequence of calls to [Context.add]. *) + doing a sequence of calls to [Context.add]. *) let context_arb : Context.t QCheck.arbitrary = let set_all key_value_list = Lwt_main.run diff --git a/src/lib_proxy/light_internal.ml b/src/lib_proxy/light_internal.ml index 1b2fd916a4c9..f88bd9de1a17 100644 --- a/src/lib_proxy/light_internal.ml +++ b/src/lib_proxy/light_internal.ml @@ -262,12 +262,12 @@ module Merkle = struct (right : Tezos_shell_services.Block_services.merkle_node) = let open Tezos_shell_services.Block_services in match (left, right, path_to_ignore) with - | (Hash _, Hash _, _) | (Data _, Data _, _) -> None - | (Continue left_tree, Continue right_tree, _) -> ( + | Hash _, Hash _, _ | Data _, Data _, _ -> None + | Continue left_tree, Continue right_tree, _ -> ( trees_shape_match path_to_ignore left_tree right_tree |> function | [] -> None | errors -> Some errors) - | (_, _, ThisPath _) -> + | _, _, ThisPath _ -> (* Shapes are different but this is the path to ignore. *) None | _ -> @@ -287,16 +287,16 @@ module Merkle = struct String.Map.merge (fun key left_val_opt right_val_opt -> match (left_val_opt, right_val_opt, path_to_ignore) with - | (Some _, None, _) | (None, Some _, _) -> + | Some _, None, _ | None, Some _, _ -> Some [Format.asprintf "Key \"%s\" is missing in one of the trees." key] - | (None, None, _) -> + | None, None, _ -> (* Unreachable, at least one of the maps has the key *) assert false - | (Some left_value, Some right_value, ThisPath (hd_key :: tl_key)) + | Some left_value, Some right_value, ThisPath (hd_key :: tl_key) when String.equal hd_key key -> nodes_shape_match (ThisPath tl_key) left_value right_value - | (Some left_value, Some right_value, _) -> + | Some left_value, Some right_value, _ -> nodes_shape_match NotThisPath left_value right_value) left right diff --git a/src/lib_proxy/proxy_getter.ml b/src/lib_proxy/proxy_getter.ml index d75adfd7d26e..21498686e3b7 100644 --- a/src/lib_proxy/proxy_getter.ml +++ b/src/lib_proxy/proxy_getter.ml @@ -198,8 +198,8 @@ module RequestsTree : REQUESTS_TREE = struct let rec add (t : tree) (k : string list) : tree = match (t, k) with - | (_, []) | (All, _) -> All - | (Partial map, k_hd :: k_tail) -> ( + | _, [] | All, _ -> All + | Partial map, k_hd :: k_tail -> ( let sub_t_opt = StringMap.find_opt k_hd map in match sub_t_opt with | None -> Partial (StringMap.add k_hd (add empty k_tail) map) @@ -209,9 +209,9 @@ module RequestsTree : REQUESTS_TREE = struct let rec find_opt (t : tree) (k : string list) : tree option = match (t, k) with - | (All, _) -> Some All - | (Partial _, []) -> None - | (Partial map, k_hd :: k_tail) -> ( + | All, _ -> Some All + | Partial _, [] -> None + | Partial map, k_hd :: k_tail -> ( let sub_t_opt = StringMap.find_opt k_hd map in match sub_t_opt with | None -> None @@ -260,7 +260,7 @@ module Make (C : Proxy.CORE) (X : Proxy_proto.PROTO_RPC) : M = struct let do_rpc (pgi : Proxy.proxy_getter_input) (kind : kind) (requested_key : Local.key) : unit tzresult Lwt.t = let open Lwt_result_syntax in - let (key_to_get, split) = + let key_to_get, split = match kind with | Mem -> (* If the value is not going to be used, don't request a parent *) diff --git a/src/lib_proxy/proxy_services.ml b/src/lib_proxy/proxy_services.ml index 00e4fcdc6f9c..5064f23e82f7 100644 --- a/src/lib_proxy/proxy_services.ml +++ b/src/lib_proxy/proxy_services.ml @@ -175,7 +175,7 @@ let schedule_clearing (printer : Tezos_client_base.Client_context.printer) chain block = let open Lwt_syntax in match (mode, raw_hash_of_block block) with - | (Light_client _, _) | (Proxy_client, _) | (_, Some _) -> + | Light_client _, _ | Proxy_client, _ | _, Some _ -> (* - If tezos-client executes: don't clear anything, because the client is short-lived and should not observe chain reorganization - If raw_hash_of_blocks returns [Some]: don't clear anything, because @@ -183,8 +183,8 @@ let schedule_clearing (printer : Tezos_client_base.Client_context.printer) Remember that contexts are kept in an LRU cache though, so clearing will eventually happen; but we don't schedule it. *) Lwt.return_unit - | (Proxy_server {sleep; sym_block_caching_time; _}, _) -> - let (chain_string, block_string) = + | Proxy_server {sleep; sym_block_caching_time; _}, _ -> + let chain_string, block_string = Tezos_shell_services.Block_services. (chain_to_string chain, to_string block) in @@ -276,7 +276,7 @@ let build_directory (printer : Tezos_client_base.Client_context.printer) let (module C) = Light_core.get_core (module Proxy_environment) printer sources in - let (chain_string, block_string) = + let chain_string, block_string = Tezos_shell_services.Block_services. (chain_to_string chain, to_string block) in @@ -309,7 +309,7 @@ let build_directory (printer : Tezos_client_base.Client_context.printer) let get_env_rpc_context chain block = let open Lwt_result_syntax in let* block_hash_opt = B2H.hash_of_block rpc_context chain block in - let (block_key, (fill_b2h : Block_hash.t -> unit)) = + let block_key, (fill_b2h : Block_hash.t -> unit) = match block_hash_opt with | None -> (block, fun block_hash -> B2H.add chain block block_hash) | Some block_hash -> (`Hash (block_hash, 0), ignore) diff --git a/src/lib_proxy/test/light_lib.ml b/src/lib_proxy/test/light_lib.ml index ebf5470119a1..3d5ee669184d 100644 --- a/src/lib_proxy/test/light_lib.ml +++ b/src/lib_proxy/test/light_lib.ml @@ -95,8 +95,8 @@ let is_empty = function SLeaf -> true | SDir dir -> StringMap.is_empty dir let rec simple_tree_eq t1 t2 = match (t1, t2) with - | (SLeaf, SLeaf) -> true - | (SDir dir1, SDir dir2) -> + | SLeaf, SLeaf -> true + | SDir dir1, SDir dir2 -> let b1 = StringMap.bindings dir1 in let b2 = StringMap.bindings dir2 in if List.length b1 != List.length b2 then false @@ -104,7 +104,7 @@ let rec simple_tree_eq t1 t2 = List.for_all (fun ((k1, t1), (k2, t2)) -> k1 = k2 && simple_tree_eq t1 t2) @@ List.combine_drop b1 b2 - | (SLeaf, d) | (d, SLeaf) -> is_empty d + | SLeaf, d | d, SLeaf -> is_empty d let rec irmin_tree_to_simple_tree tree = let open Lwt_syntax in diff --git a/src/lib_proxy/test/test_fuzzing_light.ml b/src/lib_proxy/test/test_fuzzing_light.ml index 20a83f2e2d83..a9a0ed402e59 100644 --- a/src/lib_proxy/test/test_fuzzing_light.ml +++ b/src/lib_proxy/test/test_fuzzing_light.ml @@ -187,10 +187,10 @@ let test_union_translation = let rec union_merkle_node n1 n2 = let open Tezos_shell_services.Block_services in match (n1, n2) with - | (Hash h1, Hash h2) when h1 = h2 -> Some n1 - | (Data raw_context1, Data raw_context2) when raw_context1 = raw_context2 -> + | Hash h1, Hash h2 when h1 = h2 -> Some n1 + | Data raw_context1, Data raw_context2 when raw_context1 = raw_context2 -> Some n1 - | (Continue mtree1, Continue mtree2) -> ( + | Continue mtree1, Continue mtree2 -> ( match union_merkle_tree mtree1 mtree2 with | None -> None | Some u -> Some (Continue u)) @@ -460,7 +460,7 @@ module AddTree = struct end module Consensus = struct - let (chain, block) = (`Main, `Head 0) + let chain, block = (`Main, `Head 0) class mock_rpc_context : RPC_context.simple = object diff --git a/src/lib_proxy_server_config/proxy_server_config.ml b/src/lib_proxy_server_config/proxy_server_config.ml index a574c8b3c6ca..1355c4e52543 100644 --- a/src/lib_proxy_server_config/proxy_server_config.ml +++ b/src/lib_proxy_server_config/proxy_server_config.ml @@ -132,9 +132,9 @@ let address_and_port_for_runtime rpc_addr = looked_for in match (Uri.host rpc_addr, Uri.port rpc_addr) with - | (None, _) -> wrong_rpc_addr "Hostname" - | (_, None) -> wrong_rpc_addr "Port" - | (Some rpc_server_address, Some rpc_server_port) -> ( + | None, _ -> wrong_rpc_addr "Hostname" + | _, None -> wrong_rpc_addr "Port" + | Some rpc_server_address, Some rpc_server_port -> ( match P2p_addr.of_string_opt rpc_server_address with | Some rpc_server_address -> Ok (rpc_server_address, rpc_server_port) | None -> @@ -181,15 +181,15 @@ let to_runtime match (endpoint, rpc_addr, sym_block_caching_time_error sym_block_caching_time) with - | (None, _, _) -> + | None, _, _ -> fail {|Endpoint not specified: pass argument --endpoint or specify "endpoint" field in CONFIG file|} - | (_, None, _) -> + | _, None, _ -> fail {|RPC address not specified: pass argument --rpc-addr or specify "rpc_addr" field in CONFIG file|} - | (_, _, Some err) -> fail err - | (Some endpoint, Some rpc_addr, None) -> - let* (rpc_server_address, rpc_server_port) = + | _, _, Some err -> fail err + | Some endpoint, Some rpc_addr, None -> + let* rpc_server_address, rpc_server_port = address_and_port_for_runtime rpc_addr in let* rpc_server_tls = diff --git a/src/lib_proxy_server_config/test/test_proxy_server_config.ml b/src/lib_proxy_server_config/test/test_proxy_server_config.ml index 7147a2033586..1bae143dd891 100644 --- a/src/lib_proxy_server_config/test/test_proxy_server_config.ml +++ b/src/lib_proxy_server_config/test/test_proxy_server_config.ml @@ -62,7 +62,7 @@ let path_gen = (** A generator that generates valid values for the [rpc_tls] field *) let rpc_tls_gen = QCheck.Gen.( - let+ (cert, key) = pair path_gen path_gen in + let+ cert, key = pair path_gen path_gen in cert ^ "," ^ key) (** A generator that generates valid values for the @@ -120,7 +120,7 @@ module UnionRightBias = struct @@ fun (config1, config2) -> let union = Proxy_server_config.union_right_bias config1 config2 in let right opt1 opt2 = - match (opt1, opt2) with (_, Some _) -> opt2 | _ -> opt1 + match (opt1, opt2) with _, Some _ -> opt2 | _ -> opt1 in let endpoint ({endpoint = x; _} : Proxy_server_config.t) = x in let rpc_addr ({rpc_addr = x; _} : Proxy_server_config.t) = x in diff --git a/src/lib_requester/requester.ml b/src/lib_requester/requester.ml index b6321d7487f8..d06cf477d522 100644 --- a/src/lib_requester/requester.ml +++ b/src/lib_requester/requester.ml @@ -371,10 +371,9 @@ end = struct Table.replace state.pending key next ; let requests = key - :: - Option.value - ~default:[] - (P2p_peer.Map.find requested_peer acc) + :: Option.value + ~default:[] + (P2p_peer.Map.find requested_peer acc) in P2p_peer.Map.add requested_peer requests acc) state.pending @@ -556,7 +555,7 @@ module Make disk-table query. *) match Memory_table.find s.memory k with | None -> - let (waiter, wakener) = Lwt.wait () in + let waiter, wakener = Lwt.wait () in Memory_table.add s.memory k diff --git a/src/lib_requester/test/test_fuzzing_requester.ml b/src/lib_requester/test/test_fuzzing_requester.ml index f86ed198fec3..11ec6fa77345 100644 --- a/src/lib_requester/test/test_fuzzing_requester.ml +++ b/src/lib_requester/test/test_fuzzing_requester.ml @@ -66,13 +66,13 @@ let domain_and_requester_gen : (string list * Test_Requester.t) Gen.t = *) let requester_and_keys_gen : (Test_Requester.t * string * string) Gen.t = let open Gen in - let* (domain, requester) = domain_and_requester_gen in + let* domain, requester = domain_and_requester_gen in let key_gen = let in_domain_gen = if domain = [] then [] else [oneofl domain] in (* Either a random key or a key in the domain *) oneof (key_gen :: in_domain_gen) in - let* (key1, key2) = pair key_gen key_gen in + let* key1, key2 = pair key_gen key_gen in pure (requester, key1, key2) let print = Print.(triple (Fun.const "requester") string string) @@ -142,7 +142,7 @@ let test_inject_read_opt_other = qcheck_eq_true ~actual:(read_opt_before = read_opt_after) let leq_opt opt1 opt2 = - match (opt1, opt2) with (None, _) | (Some _, Some _) -> true | _ -> false + match (opt1, opt2) with None, _ | Some _, Some _ -> true | _ -> false let test_inject_growth = Test.make diff --git a/src/lib_requester/test/test_requester.ml b/src/lib_requester/test/test_requester.ml index 797d16a974d6..40fd85b58c7c 100644 --- a/src/lib_requester/test/test_requester.ml +++ b/src/lib_requester/test/test_requester.ml @@ -93,7 +93,7 @@ let test_full_requester_create_with_global_input _ () = let (global_input : (Parameters.key * Parameters.value) Lwt_watcher.input) = Lwt_watcher.create_input () in - let (stream, stopper) = Lwt_watcher.create_stream global_input in + let stream, stopper = Lwt_watcher.create_stream global_input in let requester = init_full_requester ~global_input () in (* Fetch two values *) let f1 = Test_Requester.fetch requester "foo" precheck_pass in @@ -148,7 +148,7 @@ let test_read_known_read_opt _ () = *) let test_full_requester_disk_found_value _ () = let open Lwt_syntax in - let (requester, store) = init_full_requester_disk () in + let requester, store = init_full_requester_disk () in let* b = Test_Requester.known requester "boo" in let* () = lwt_assert_false "empty requester has no values" b in (* add initial value 'boo' to disk requester *) @@ -367,7 +367,7 @@ let test_pending_timeout _ () = let test_full_requester_test_simple_watch _ () = let open Lwt_syntax in let requester = init_full_requester () in - let (stream, stopper) = Test_Requester.watch requester in + let stream, stopper = Test_Requester.watch requester in (* Fetch two values *) let f1 = Test_Requester.fetch requester "foo" precheck_pass in let f2 = Test_Requester.fetch requester "bar" precheck_pass in @@ -392,7 +392,7 @@ let test_full_requester_test_simple_watch _ () = let test_full_requester_test_notify_non_fetched_watch _ () = let open Lwt_syntax in let requester = init_full_requester () in - let (stream, stopper) = Test_Requester.watch requester in + let stream, stopper = Test_Requester.watch requester in (* Notify the a value that not been requested, should be ignored and hence not visible to the watcher. *) let* () = Test_Requester.notify requester P2p_peer.Id.zero "foo" 1 in @@ -406,8 +406,8 @@ let test_full_requester_test_notify_non_fetched_watch _ () = let test_full_requester_test_double_watcher _ () = let open Lwt_syntax in let requester = init_full_requester () in - let (stream1, stopper1) = Test_Requester.watch requester in - let (stream2, stopper2) = Test_Requester.watch requester in + let stream1, stopper1 = Test_Requester.watch requester in + let stream2, stopper2 = Test_Requester.watch requester in (* Fetch a values *) let f1 = Test_Requester.fetch requester "foo" precheck_pass in (* Notify the value *) @@ -457,7 +457,7 @@ let test_full_requester_test_inject_memory _ () = (** Injects a value present on disk: false should be returned. *) let test_full_requester_test_inject_disk _ () = let open Lwt_syntax in - let (req, store) = init_full_requester_disk () in + let req, store = init_full_requester_disk () in Test_disk_table_hash.add store "foo" 1 ; let* b = Test_Requester.inject req "foo" 1 in lwt_assert_false "Inject is false when present on disk" b @@ -533,7 +533,7 @@ let test_full_requester_test_notify_unfetched _ () = be ignored (not sure how to test this, but this code runs through that code path). *) let test_full_requester_test_notify_disk_duplicate _ () = - let (req, store) = init_full_requester_disk () in + let req, store = init_full_requester_disk () in (* Put value on disk *) Test_disk_table_hash.add store "foo" 1 ; (* Fetch valid value *) diff --git a/src/lib_rpc/RPC_context.ml b/src/lib_rpc/RPC_context.ml index 4f933027eb7d..e9d1f268f513 100644 --- a/src/lib_rpc/RPC_context.ml +++ b/src/lib_rpc/RPC_context.ml @@ -227,7 +227,7 @@ type stopper = unit -> unit let make_streamed_call s (ctxt : #streamed) p q i = let open Lwt_result_syntax in - let (stream, push) = Lwt_stream.create () in + let stream, push = Lwt_stream.create () in let on_chunk v = push (Some v) and on_close () = push None in let* spill_all = ctxt#call_streamed_service s ~on_chunk ~on_close p q i in let close () = diff --git a/src/lib_rpc/RPC_encoding.ml b/src/lib_rpc/RPC_encoding.ml index 33e611acfac0..9d52de0578fd 100644 --- a/src/lib_rpc/RPC_encoding.ml +++ b/src/lib_rpc/RPC_encoding.ml @@ -216,12 +216,8 @@ let directory_descr_encoding = | Some s -> Resto.MethMap.add meth s services in let services = - Resto.MethMap.empty - |> add `GET get - |> add `POST post - |> add `DELETE delete - |> add `PUT put - |> add `PATCH patch + Resto.MethMap.empty |> add `GET get |> add `POST post + |> add `DELETE delete |> add `PUT put |> add `PATCH patch in {services; subdirs}) (obj6 diff --git a/src/lib_rpc/RPC_service.ml b/src/lib_rpc/RPC_service.ml index 1a9f33bc1e8c..41416083b954 100644 --- a/src/lib_rpc/RPC_service.ml +++ b/src/lib_rpc/RPC_service.ml @@ -62,9 +62,9 @@ include ( include Resto.MakeService (RPC_encoding) end with type (+'m, 'pr, 'p, 'q, 'i, 'o, 'e) t := - ('m, 'pr, 'p, 'q, 'i, 'o, 'e) raw + ('m, 'pr, 'p, 'q, 'i, 'o, 'e) raw and type (+'m, 'pr, 'p, 'q, 'i, 'o, 'e) service := - ('m, 'pr, 'p, 'q, 'i, 'o, 'e) raw) + ('m, 'pr, 'p, 'q, 'i, 'o, 'e) raw) let error_path = ref None diff --git a/src/lib_rpc/RPC_service.mli b/src/lib_rpc/RPC_service.mli index 3857ee7069ba..f5780c36f419 100644 --- a/src/lib_rpc/RPC_service.mli +++ b/src/lib_rpc/RPC_service.mli @@ -51,9 +51,9 @@ include module type of struct include Resto.MakeService (RPC_encoding) end with type (+'m, 'pr, 'p, 'q, 'i, 'o, 'e) t := - ('m, 'pr, 'p, 'q, 'i, 'o, 'e) raw + ('m, 'pr, 'p, 'q, 'i, 'o, 'e) raw and type (+'m, 'pr, 'p, 'q, 'i, 'o, 'e) service := - ('m, 'pr, 'p, 'q, 'i, 'o, 'e) raw + ('m, 'pr, 'p, 'q, 'i, 'o, 'e) raw val get_service : ?description:string -> diff --git a/src/lib_rpc_http/RPC_client.ml b/src/lib_rpc_http/RPC_client.ml index 4cace450c09f..d31316bc63bb 100644 --- a/src/lib_rpc_http/RPC_client.ml +++ b/src/lib_rpc_http/RPC_client.ml @@ -331,7 +331,7 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct let* body = post_process_bson_response ~body meth uri in return (`Json (`Ok body)) | _ -> ( - let* (content_type, other_resp) = + let* content_type, other_resp = post_process_error_responses response meth uri accept in (* We attempt to decode in JSON. It might diff --git a/src/lib_rpc_http/RPC_client_errors.ml b/src/lib_rpc_http/RPC_client_errors.ml index 0f1328f34469..d6cd9024ae27 100644 --- a/src/lib_rpc_http/RPC_client_errors.ml +++ b/src/lib_rpc_http/RPC_client_errors.ml @@ -70,13 +70,13 @@ let rpc_error_encoding = (req "kind" (constant "connection_failed")) (req "message" string)) (function Connection_failed msg -> Some ((), msg) | _ -> None) - (function ((), msg) -> Connection_failed msg); + (function (), msg -> Connection_failed msg); case (Tag 2) ~title:"Bad_request" (obj2 (req "kind" (constant "bad_request")) (req "message" string)) (function Bad_request msg -> Some ((), msg) | _ -> None) - (function ((), msg) -> Bad_request msg); + (function (), msg -> Bad_request msg); case (Tag 3) ~title:"Method_not_allowed" @@ -84,7 +84,7 @@ let rpc_error_encoding = (req "kind" (constant "method_not_allowed")) (req "allowed" (list RPC_service.meth_encoding))) (function Method_not_allowed meths -> Some ((), meths) | _ -> None) - (function ((), meths) -> Method_not_allowed meths); + (function (), meths -> Method_not_allowed meths); case (Tag 4) ~title:"Unsupported_media_type" @@ -92,7 +92,7 @@ let rpc_error_encoding = (req "kind" (constant "unsupported_media_type")) (opt "content_type" string)) (function Unsupported_media_type m -> Some ((), m) | _ -> None) - (function ((), m) -> Unsupported_media_type m); + (function (), m -> Unsupported_media_type m); case (Tag 5) ~title:"Not_acceptable" @@ -105,7 +105,7 @@ let rpc_error_encoding = Some ((), proposed, acceptable) | _ -> None) (function - | ((), proposed, acceptable) -> Not_acceptable {proposed; acceptable}); + | (), proposed, acceptable -> Not_acceptable {proposed; acceptable}); case (Tag 6) ~title:"Unexpected_status_code" @@ -119,7 +119,7 @@ let rpc_error_encoding = Some ((), Cohttp.Code.code_of_status code, content, media_type) | _ -> None) (function - | ((), code, content, media_type) -> + | (), code, content, media_type -> let code = Cohttp.Code.status_of_code code in Unexpected_status_code {code; content; media_type}); case @@ -135,7 +135,7 @@ let rpc_error_encoding = Some ((), received, acceptable, body) | _ -> None) (function - | ((), received, acceptable, body) -> + | (), received, acceptable, body -> Unexpected_content_type {received; acceptable; body}); case (Tag 8) @@ -150,14 +150,14 @@ let rpc_error_encoding = Some ((), content, media_type, error) | _ -> None) (function - | ((), content, media_type, error) -> + | (), content, media_type, error -> Unexpected_content {content; media_type; error}); case (Tag 9) ~title:"OCaml_exception" (obj2 (req "kind" (constant "ocaml_exception")) (req "content" string)) (function OCaml_exception msg -> Some ((), msg) | _ -> None) - (function ((), msg) -> OCaml_exception msg); + (function (), msg -> OCaml_exception msg); case (Tag 10) ~title:"Unauthorized URI" diff --git a/src/lib_rpc_http/RPC_client_unix.ml b/src/lib_rpc_http/RPC_client_unix.ml index ebc99fca6ee2..c1060a4939c2 100644 --- a/src/lib_rpc_http/RPC_client_unix.ml +++ b/src/lib_rpc_http/RPC_client_unix.ml @@ -62,7 +62,7 @@ module RetryClient : Cohttp_lwt.S.Client = struct let call ?ctx ?headers ?body ?chunked meth uri = let rec call_and_retry_on_502 attempt delay = let open Lwt_syntax in - let* (response, ansbody) = call ?ctx ?headers ?body ?chunked meth uri in + let* response, ansbody = call ?ctx ?headers ?body ?chunked meth uri in let status = Cohttp.Response.status response in match status with | `Bad_gateway -> diff --git a/src/lib_rpc_http/RPC_server.ml b/src/lib_rpc_http/RPC_server.ml index 1e77cbf1e578..e1713020c53b 100644 --- a/src/lib_rpc_http/RPC_server.ml +++ b/src/lib_rpc_http/RPC_server.ml @@ -181,7 +181,7 @@ module Acl = struct (req "address" endpoint_encoding) (req "whitelist" @@ list matcher_encoding)) (function - | (addr, Deny_all {except}) -> Some (addr, except) | _ -> None) + | addr, Deny_all {except} -> Some (addr, except) | _ -> None) (fun (addr, except) -> (addr, Deny_all {except})); case ~title:"Blacklist" @@ -190,7 +190,7 @@ module Acl = struct (req "address" endpoint_encoding) (req "blacklist" @@ list matcher_encoding)) (function - | (addr, Allow_all {except}) -> Some (addr, except) | _ -> None) + | addr, Allow_all {except} -> Some (addr, except) | _ -> None) (fun (addr, except) -> (addr, Allow_all {except})); ] @@ -202,8 +202,8 @@ module Acl = struct let match_addr searched_port searched_addr (endpoint, acl) = let open P2p_point.Id in match (endpoint.addr = searched_addr, endpoint.port, searched_port) with - | (true, None, _) -> Some acl - | (true, Some port, Some searched_port) when port = searched_port -> + | true, None, _ -> Some acl + | true, Some port, Some searched_port when port = searched_port -> Some acl | _ -> None in diff --git a/src/lib_rpc_http/test/test_rpc_http.ml b/src/lib_rpc_http/test/test_rpc_http.ml index b825cf80c6f5..e0c6bbbe51b7 100644 --- a/src/lib_rpc_http/test/test_rpc_http.ml +++ b/src/lib_rpc_http/test/test_rpc_http.ml @@ -117,7 +117,7 @@ module Arbitrary = struct let generate = let open Gen in let* p = gen policy - and* (searched_for, searched_acl) = generate_entry + and* searched_for, searched_acl = generate_entry and* added_entry = generate_entry in let* policy = oneofl [p; RPC_server.Acl.put_policy (searched_for, searched_acl) p] @@ -193,8 +193,8 @@ let acl_testable = in Alcotest.testable pp @@ fun left right -> match (left, right) with - | (Allow_all {except = l}, Allow_all {except = r}) - | (Deny_all {except = l}, Deny_all {except = r}) -> + | Allow_all {except = l}, Allow_all {except = r} + | Deny_all {except = l}, Deny_all {except = r} -> l = r | _ -> false @@ -227,9 +227,7 @@ let test_codec_identity = let check_find_policy = let open QCheck in let assert_results_satisfactory before_put after_put = - match (before_put, after_put) with - | (Some _, None) -> false - | (_, _) -> true + match (before_put, after_put) with Some _, None -> false | _, _ -> true in Test.make ~name:"put_policy preserves existing entries." diff --git a/src/lib_sapling/bindings/rustzcash_ctypes_gen.ml b/src/lib_sapling/bindings/rustzcash_ctypes_gen.ml index 7d21a055ea1d..5278e0398b8a 100644 --- a/src/lib_sapling/bindings/rustzcash_ctypes_gen.ml +++ b/src/lib_sapling/bindings/rustzcash_ctypes_gen.ml @@ -8,7 +8,7 @@ let c_headers = #endif\n" let () = - let (ml_filename, c_filename) = (Sys.argv.(1), Sys.argv.(2)) in + let ml_filename, c_filename = (Sys.argv.(1), Sys.argv.(2)) in let c_out = open_out_bin c_filename in let ml_out = open_out_bin ml_filename in let c_formatter = Format.formatter_of_out_channel c_out in diff --git a/src/lib_sapling/core.ml b/src/lib_sapling/core.ml index 212eb2d93f3b..d0e067927fab 100644 --- a/src/lib_sapling/core.ml +++ b/src/lib_sapling/core.ml @@ -590,7 +590,7 @@ module Raw = struct ciphertext.payload_out ciphertext.nonce_out >?? fun plaintext -> - let (pkd, esk) = decompose_plaintext_out plaintext in + let pkd, esk = decompose_plaintext_out plaintext in (* symkey for payload_enc *) let symkey = DH.symkey_sender esk pkd in Crypto_box.Secretbox.secretbox_open diff --git a/src/lib_sapling/forge.ml b/src/lib_sapling/forge.ml index 6c32ab62f7de..12a07c28a4e4 100644 --- a/src/lib_sapling/forge.ml +++ b/src/lib_sapling/forge.ml @@ -47,7 +47,7 @@ module Input = struct S.mem_nullifier state nf let get state pos vk = - let (existing_cm, cipher) = S.get state pos in + let existing_cm, cipher = S.get state pos in match of_ciphertext ~pos cipher vk with | None -> None | Some (memo, forge_input) -> @@ -55,7 +55,7 @@ module Input = struct else None let get_out state pos ovk = - let (existing_cm, cipher) = S.get state pos in + let existing_cm, cipher = S.get state pos in match of_ciphertext_out ~pos cipher ovk existing_cm with | None -> None | Some (memo, forge_input) -> @@ -79,7 +79,7 @@ let dummy_input anti_replay ctx dummy_witness root = let ar = Core.Proving.ar_random () in (* The proof is considered valid even with a dummy witness if the amount given is 0. *) - let (cv, rk, proof_i) = + let cv, rk, proof_i = Core.Proving.spend_proof ctx vk @@ -115,8 +115,8 @@ let dummy_output pctx ~memo_size = let o = make_output addr amount (Hacl.Rand.gen memo_size) in let rcm = Core.Rcm.random () in let esk = Core.DH.esk_random () in - let (cv_o, proof_o) = Core.Proving.output_proof pctx esk addr rcm ~amount in - let (ciphertext, cm) = + let cv_o, proof_o = Core.Proving.output_proof pctx esk addr rcm ~amount in + let ciphertext, cm = Core.Forge.Output.to_ciphertext_without_ovk o rcm esk cv_o in Core.UTXO.{cm; proof_o; ciphertext} @@ -150,7 +150,7 @@ let forge_transaction ?(number_dummy_inputs = 0) ?(number_dummy_outputs = 0) let open Input in let ar = Core.Proving.ar_random () in let witness = S.get_witness state i.pos in - let (cv, rk, proof_i) = + let cv, rk, proof_i = Core.Proving.spend_proof ctx vk @@ -187,7 +187,7 @@ let forge_transaction ?(number_dummy_inputs = 0) ?(number_dummy_outputs = 0) which is enough to hold 2^64 *) let open Core.Forge.Output in let esk = Core.DH.esk_random () in - let (cv_o, proof_o) = + let cv_o, proof_o = Core.Proving.output_proof ctx esk @@ -195,7 +195,7 @@ let forge_transaction ?(number_dummy_inputs = 0) ?(number_dummy_outputs = 0) rcm ~amount:forge_output.amount in - let (ciphertext, cm) = to_ciphertext forge_output cv_o vk rcm esk in + let ciphertext, cm = to_ciphertext forge_output cv_o vk rcm esk in Core.UTXO.{cm; proof_o; ciphertext}) forge_outputs in @@ -270,7 +270,7 @@ let forge_shield_transaction ?(number_dummy_inputs = 0) which is enough to hold 2^64 *) let open Core.Forge.Output in let esk = Core.DH.esk_random () in - let (cv_o, proof_o) = + let cv_o, proof_o = Core.Proving.output_proof ctx esk @@ -278,7 +278,7 @@ let forge_shield_transaction ?(number_dummy_inputs = 0) rcm ~amount:forge_output.amount in - let (ciphertext, cm) = + let ciphertext, cm = to_ciphertext_without_ovk forge_output rcm esk cv_o in Core.UTXO.{cm; proof_o; ciphertext}) diff --git a/src/lib_sapling/rustzcash.ml b/src/lib_sapling/rustzcash.ml index 595243b0529d..84945c332d73 100644 --- a/src/lib_sapling/rustzcash.ml +++ b/src/lib_sapling/rustzcash.ml @@ -33,7 +33,7 @@ and return [true] otherwise (in which case result buffer contains the result). Because we lean on the OCaml type system to enforce that arguments are well-formed, we simply [assert] on the return value of the rust bindings. - *) +*) (* Ctypes binding. We encapsulate the binding in a specific module *) module RS = Rustzcash_ctypes_bindings.Bindings (Rustzcash_ctypes_stubs) diff --git a/src/lib_sapling/storage.ml b/src/lib_sapling/storage.ml index ab8b279574c4..fe4f5e55944b 100644 --- a/src/lib_sapling/storage.ml +++ b/src/lib_sapling/storage.ml @@ -118,7 +118,7 @@ module Make_Storage (C : Core_sig.Validator) = struct match l with | [] -> ([], l) | x :: xs -> - let (l1, l2) = split_at Int64.(pred n) xs in + let l1, l2 = split_at Int64.(pred n) xs in (x :: l1, l2) let hash ~height t1 t2 = @@ -140,23 +140,23 @@ module Make_Storage (C : Core_sig.Validator) = struct assert (Compare.Int64.(pos >= 0L && pos <= pow2 height)) ; assert (Compare.Int.(height >= 0 && height <= 32)) ; match (tree, height, cms) with - | (_, _, []) -> tree - | (Empty, 0, [cm]) -> Leaf cm - | (Leaf _, _, _) + | _, _, [] -> tree + | Empty, 0, [cm] -> Leaf cm + | Leaf _, _, _ (* The second conjuntion of the precondition is violated by a Leaf (which is already full) and a non empty cms. *) - | (_, 0, _) -> + | _, 0, _ -> (* Only leaves can be at height 0. *) assert false - | (Empty, height, _) -> insert_node Empty Empty (height - 1) pos cms - | (Node (_, t1, t2), height, _) -> insert_node t1 t2 (height - 1) pos cms + | Empty, height, _ -> insert_node Empty Empty (height - 1) pos cms + | Node (_, t1, t2), height, _ -> insert_node t1 t2 (height - 1) pos cms and insert_node t1 t2 height pos cms = - let (t1, t2) = + let t1, t2 = if Compare.Int64.(pos < pow2 height) then ( assert (t2 = Empty) ; let at = Int64.(sub (pow2 height) pos) in - let (cml, cmr) = split_at at cms in + let cml, cmr = split_at at cms in let t1 = insert t1 height pos cml in let t2 = insert t2 height 0L cmr in (t1, t2)) @@ -321,7 +321,7 @@ module Make_Storage (C : Core_sig.Validator) = struct (list C.Nullifier.encoding) let get_from t pos = - let (es, _) = + let es, _ = fold (fun e (acc, cnt) -> if Compare.Int64.(cnt >= pos) then (e :: acc, Int64.succ cnt) @@ -432,7 +432,7 @@ module Make_Storage (C : Core_sig.Validator) = struct } let add state cm_cipher_list = - let (cm_list, cipher_list) = List.split cm_cipher_list in + let cm_list, cipher_list = List.split cm_cipher_list in assert ( List.for_all (fun cipher -> C.Ciphertext.get_memo_size cipher = state.memo_size) diff --git a/src/lib_sapling/test/example.ml b/src/lib_sapling/test/example.ml index 1b6ca4007780..05823717a438 100644 --- a/src/lib_sapling/test/example.ml +++ b/src/lib_sapling/test/example.ml @@ -55,7 +55,7 @@ module Client = struct } let new_address wallet = - let (idx, address) = Core.Viewing_key.new_address wallet.vk wallet.idx in + let idx, address = Core.Viewing_key.new_address wallet.vk wallet.idx in wallet.idx <- idx ; address @@ -80,7 +80,7 @@ module Client = struct Int64.(equal pos 0L) then (pos, set, balance) else (Int64.pred pos, set, balance) in - let (scanned, unspent_inputs, balance) = + let scanned, unspent_inputs, balance = aux w.scanned w.unspent_inputs w.balance in {w with unspent_inputs; balance; scanned} @@ -119,13 +119,13 @@ module Client = struct (InputSet.remove input_to_add unspent_inputs) else (inputs, balance, unspent_inputs, Int64.abs to_pay) in - let (inputs, balance, unspent_inputs, change) = + let inputs, balance, unspent_inputs, change = gather_input (Int64.sub 0L tez) wallet.balance [] wallet.unspent_inputs in let payment_output = Forge.make_output (Core.Viewing_key.dummy_address ()) 0L memo in - let (new_index, address) = + let new_index, address = Core.Viewing_key.new_address wallet.vk wallet.idx in wallet.idx <- new_index ; @@ -172,7 +172,7 @@ module Client = struct (InputSet.remove input_to_add unspent_input) else (inputs, balance, unspent_input, Int64.abs to_pay) in - let (inputs, balance, unspent_inputs, change) = + let inputs, balance, unspent_inputs, change = gather_input (Int64.sub amount tez) wallet.balance diff --git a/src/lib_sapling/test/test_keys.ml b/src/lib_sapling/test/test_keys.ml index 39825ab3ac01..80a41529c699 100644 --- a/src/lib_sapling/test/test_keys.ml +++ b/src/lib_sapling/test/test_keys.ml @@ -49,19 +49,19 @@ let test_vectors_zip32 () = let j1 = index_succ j0 in let j2 = index_succ j1 in let jmax = R.to_diversifier_index (Bytes.make 11 '\xff') in - let (res_j0, address0) = new_address v.xfvk j0 in + let res_j0, address0 = new_address v.xfvk j0 in (match v.d0 with | Some d -> assert (res_j0 = j0) ; assert (address0.diversifier = d) | None -> ()) ; - let (res_j1, address1) = new_address v.xfvk j1 in + let res_j1, address1 = new_address v.xfvk j1 in (match v.d1 with | Some d -> assert (res_j1 = j1) ; assert (address1.diversifier = d) | None -> assert (res_j1 <> j1)) ; - let (res_j2, address2) = new_address v.xfvk j2 in + let res_j2, address2 = new_address v.xfvk j2 in (match v.d2 with | Some d -> assert (res_j2 = j2) ; @@ -69,7 +69,7 @@ let test_vectors_zip32 () = | None -> assert (res_j2 <> j2)) ; match v.dmax with | Some d -> - let (res_jmax, address_max) = new_address v.xfvk jmax in + let res_jmax, address_max = new_address v.xfvk jmax in assert (res_jmax = jmax) ; assert (address_max.diversifier = d) | None -> ()) @@ -93,7 +93,7 @@ let test_zip32 () = assert (xsk.dk = v.dk) ; let xfvk = of_sk xsk in assert (xfvk = v.xfvk) ; - let (_j, address) = new_address xfvk default_index in + let _j, address = new_address xfvk default_index in assert (address.diversifier = Stdlib.Option.get v.d0) ; (* TODO continue test with derivation once implemented *) () diff --git a/src/lib_sapling/test/test_merkle.ml b/src/lib_sapling/test/test_merkle.ml index b0e3d07d88b8..0af890b6eaa6 100644 --- a/src/lib_sapling/test/test_merkle.ml +++ b/src/lib_sapling/test/test_merkle.ml @@ -255,10 +255,10 @@ let test_merkle2 () = "87a086ae7d2252d58729b30263fb7b66308bf94ef59a76c9c86e7ea016536505" in (* compute the root *) - let (_, root) = + let _, root = Array.fold_left (fun a b -> - let (i, hash) = a in + let i, hash = a in (i + 1, Core.Hash.merkle_hash ~height:i hash b)) (0, h) witness_unflat diff --git a/src/lib_sapling/test/test_sapling.ml b/src/lib_sapling/test/test_sapling.ml index a486f4a1216c..07f7fb3c587a 100644 --- a/src/lib_sapling/test/test_sapling.ml +++ b/src/lib_sapling/test/test_sapling.ml @@ -24,7 +24,7 @@ let test_proof_raw () = let pos = 0L in let rcm = Rcm.random () in let xfvk = Viewing_key.of_sk xsk in - let (_, address) = Viewing_key.(new_address xfvk default_index) in + let _, address = Viewing_key.(new_address xfvk default_index) in let nf = Nullifier.compute address xfvk ~amount:vlue rcm ~position:pos in let cm = Commitment.compute address ~amount:vlue rcm in let esk = DH.esk_random () in @@ -44,7 +44,7 @@ let test_proof_raw () = R.init_params () ; let ctx_prove = R.proving_ctx_init () in let ctx_verif = R.verification_ctx_init () in - let (cv_spend, rk, zkproof_spend) = + let cv_spend, rk, zkproof_spend = R.spend_proof ctx_prove xfvk.fvk.ak @@ -60,7 +60,7 @@ let test_proof_raw () = R.check_spend ctx_verif cv_spend root nf rk zkproof_spend signature sighash in assert check_spend ; - let (cv_output, zkproof_output) = + let cv_output, zkproof_output = R.output_proof ctx_prove esk @@ -94,9 +94,9 @@ let test_full_transaction () = let xfvk1 = Viewing_key.of_sk xsk1 in let xfvk2 = Viewing_key.of_sk xsk2 in let xfvk3 = Viewing_key.of_sk xsk3 in - let (_, addr1) = Viewing_key.(new_address xfvk1 default_index) in - let (_, addr2) = Viewing_key.(new_address xfvk2 default_index) in - let (_, addr3) = Viewing_key.(new_address xfvk3 default_index) in + let _, addr1 = Viewing_key.(new_address xfvk1 default_index) in + let _, addr2 = Viewing_key.(new_address xfvk2 default_index) in + let _, addr3 = Viewing_key.(new_address xfvk3 default_index) in (* creation of the first note *) let rcm_1 = Rcm.random () in let cm_1 = Commitment.compute addr1 ~amount:10L rcm_1 in @@ -129,7 +129,7 @@ let test_full_transaction () = let ctx_prove_1 = R.proving_ctx_init () in (* Commitment value, randomised signature key, ZK proof that cm_1 is in the blockchain and has correct stuff *) - let (cv_spend_1, rk_1, zkproof_spend_1) = + let cv_spend_1, rk_1, zkproof_spend_1 = Proving.spend_proof ctx_prove_1 xfvk1 @@ -142,7 +142,7 @@ let test_full_transaction () = ~witness:witness_1 in (* Commitment value of the created note, ZK proof that everything is correct *) - let (cv_output_1, zkproof_output_1) = + let cv_output_1, zkproof_output_1 = Proving.output_proof ctx_prove_1 esk_1 addr2 rcm_2 ~amount:10L in (* Hash of the spend description *) @@ -251,7 +251,7 @@ let test_full_transaction () = let cm_3 = Commitment.compute addr3 ~amount:5L rcm_3 in (* the shared secret is here unnecessary since in our example 3 won't spend money It has to be done in real though *) - let (cv_spend_2, rk_2, zkproof_spend_2) = + let cv_spend_2, rk_2, zkproof_spend_2 = R.spend_proof ctx_prove_2 xfvk2.fvk.ak @@ -263,7 +263,7 @@ let test_full_transaction () = ~root:root_2 ~witness:witness_2 in - let (cv_output_2, zkproof_output_2) = + let cv_output_2, zkproof_output_2 = R.output_proof ctx_prove_2 esk_2 @@ -310,16 +310,16 @@ let test_forge () = let sk2 = List.nth Keys.xsks 1 in let vk1 = Core.Viewing_key.of_sk sk1 in let vk2 = Core.Viewing_key.of_sk sk2 in - let (_, addr1) = Core.Viewing_key.(new_address vk1 default_index) in - let (_, addr2) = Core.Viewing_key.(new_address vk2 default_index) in + let _, addr1 = Core.Viewing_key.(new_address vk1 default_index) in + let _, addr2 = Core.Viewing_key.(new_address vk2 default_index) in let output = Forge.make_output addr1 10L Bytes.empty in let state = Storage.empty ~memo_size:0 in let t1 = Forge.forge_transaction [] [output] sk1 key ~bound_data:"pkh" state in - let* (_, state) = Example.Validator.verify_update t1 state key in + let* _, state = Example.Validator.verify_update t1 state key in let forge_input_opt = Forge.Input.get state 0L vk1 in - let (_msg, forge_input) = Stdlib.Option.get @@ forge_input_opt in + let _msg, forge_input = Stdlib.Option.get @@ forge_input_opt in let forge_output = Forge.make_output addr2 10L Bytes.empty in let transaction = Forge.forge_transaction @@ -369,8 +369,8 @@ let test_simple_client () = let state = Storage.empty ~memo_size:2 in let addr_b = new_address wb in (*a gives 2 to b and 1 (of change) to himself with 3 transparent money*) - let (t1, wa) = pay wa addr_b 2L ~memo:"t1" 3L state key in - let* (balance, state) = Example.Validator.verify_update t1 state key in + let t1, wa = pay wa addr_b 2L ~memo:"t1" 3L state key in + let* balance, state = Example.Validator.verify_update t1 state key in assert (balance = -3L) ; let wb = scan wb state in assert (wb.balance = 2L) ; @@ -378,8 +378,8 @@ let test_simple_client () = assert (wa.balance = 1L) ; let addr_a = new_address wa in (* b gives 1 to a and 1 (of change) to himself with 2 transparent money*) - let (t2, wb) = pay wb addr_a 1L ~memo:"t2" 2L state key in - let* (balance, state) = Example.Validator.verify_update t2 state key in + let t2, wb = pay wb addr_a 1L ~memo:"t2" 2L state key in + let* balance, state = Example.Validator.verify_update t2 state key in assert (balance = -2L) ; (* before scanning b still has 2*) assert (wb.balance = 2L) ; @@ -389,8 +389,8 @@ let test_simple_client () = assert (wa.balance = 2L) ; (* b gives 1 to a with shielded money *) let addr_a = new_address wa in - let (t3, wb) = pay wb addr_a 1L ~memo:"t3" 0L state key in - let* (balance, state) = Example.Validator.verify_update t3 state key in + let t3, wb = pay wb addr_a 1L ~memo:"t3" 0L state key in + let* balance, state = Example.Validator.verify_update t3 state key in assert (balance = 0L) ; let wb = scan wb state in assert (wb.balance = 2L) ; @@ -398,16 +398,16 @@ let test_simple_client () = assert (wa.balance = 3L) ; (* a burns 1 shielded money *) let addr_a = new_address wa in - let (t4, wa) = pay wa addr_a 0L ~memo:"t4" Int64.minus_one state key in + let t4, wa = pay wa addr_a 0L ~memo:"t4" Int64.minus_one state key in assert (wa.balance = 2L) ; - let* (balance, state) = Example.Validator.verify_update t4 state key in + let* balance, state = Example.Validator.verify_update t4 state key in assert (balance = 1L) ; let l_a = scan_ovk (Obj.magic (Core.Viewing_key.ovk_of_xfvk wa.vk) : Core.Spending_key.ovk) state in - let (l_a_mess, _l_a_forge_input) = List.split l_a in + let l_a_mess, _l_a_forge_input = List.split l_a in List.iter (fun x -> assert (List.mem (Bytes.of_string x) l_a_mess)) ["t1"; "t4"] ; @@ -416,7 +416,7 @@ let test_simple_client () = (Obj.magic (Core.Viewing_key.ovk_of_xfvk wb.vk) : Core.Spending_key.ovk) state in - let (l_b_mess, _l_b_forge_input) = List.split l_b in + let l_b_mess, _l_b_forge_input = List.split l_b in List.iter (fun x -> assert (List.mem (Bytes.of_string x) l_b_mess)) ["t2"; "t3"] ; @@ -431,7 +431,7 @@ let test_replay () = let wa = new_wallet (List.nth Keys.xsks 0) in let state = Storage.empty ~memo_size:2 in let addr = new_address wa in - let (t1, _) = pay wa addr 2L ~memo:"t1" 3L state right_string in + let t1, _ = pay wa addr 2L ~memo:"t1" 3L state right_string in let*! r = Example.Validator.verify_update t1 state wrong_string in match r with Error _ -> return_unit | _ -> assert false @@ -446,7 +446,7 @@ let test_wrong_bound_data () = let wa = new_wallet (List.nth Keys.xsks 0) in let state = Storage.empty ~memo_size:2 in let addr = new_address wa in - let (t1, _) = pay wa addr 2L ~memo:"t1" ~bound_data:"right" 3L state key in + let t1, _ = pay wa addr 2L ~memo:"t1" ~bound_data:"right" 3L state key in let t1_wrong = {t1 with bound_data = "wrong"} in let*! r = Example.Validator.verify_update t1_wrong state key in match r with diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml index b925dc028bb6..b6da3186a1a5 100644 --- a/src/lib_shell/block_directory.ml +++ b/src/lib_shell/block_directory.ml @@ -166,7 +166,7 @@ let build_raw_rpc_directory (module Proto : Block_services.PROTO) let module Block_services = Block_services.Make (Proto) (Next_proto) in let module S = Block_services.S in register0 S.live_blocks (fun (chain_store, block) () () -> - let* (live_blocks, _) = + let* live_blocks, _ = Store.Chain.compute_live_blocks chain_store ~block in return live_blocks) ; @@ -178,7 +178,7 @@ let build_raw_rpc_directory (module Proto : Block_services.PROTO) Proto.block_header_metadata_encoding (Store.Block.block_metadata metadata) in - let* (test_chain_status, _) = + let* test_chain_status, _ = Store.Block.testchain_status chain_store block in let max_operations_ttl = Store.Block.max_operations_ttl metadata in @@ -282,7 +282,7 @@ let build_raw_rpc_directory (module Proto : Block_services.PROTO) let predecessor_ops_metadata_hash = Store.Block.all_operations_metadata_hash predecessor_block in - let* (_block_metadata, ops_metadata) = + let* _block_metadata, ops_metadata = Block_validation.recompute_metadata ~chain_id ~predecessor_block_header:predecessor_header @@ -430,7 +430,7 @@ let build_raw_rpc_directory (module Proto : Block_services.PROTO) register2 S.Operation_hashes.operation_hash (fun (_, block) i j () () -> Lwt.catch (fun () -> - let (ops, _) = Store.Block.operations_hashes_path block i in + let ops, _ = Store.Block.operations_hashes_path block i in return (List.nth ops j |> WithExceptions.Option.to_exn ~none:Not_found)) (fun _ -> Lwt.fail Not_found)) ; (* operation_metadata_hashes *) @@ -597,10 +597,10 @@ let build_raw_rpc_directory (module Proto : Block_services.PROTO) ~cache:`Lazy () in - let* (state, acc) = + let* state, acc = List.fold_left_es (fun (state, acc) op -> - let* (state, result) = Next_proto.apply_operation state op in + let* state, result = Next_proto.apply_operation state op in return (state, (op.protocol_data, result) :: acc)) (state, []) ops @@ -713,7 +713,7 @@ let get_directory chain_store block = current protocol *) Lwt.return (module Next_proto : Registered_protocol.T) | Some pred -> - let* (_, savepoint_level) = Store.Chain.savepoint chain_store in + let* _, savepoint_level = Store.Chain.savepoint chain_store in let* protocol_hash = if Compare.Int32.(Store.Block.level pred < savepoint_level) then let* predecessor_protocol = diff --git a/src/lib_shell/block_validator.ml b/src/lib_shell/block_validator.ml index 0f4ce272137b..ee55437bc465 100644 --- a/src/lib_shell/block_validator.ml +++ b/src/lib_shell/block_validator.ml @@ -240,8 +240,8 @@ let on_validation_request w | Ok x -> return x (* [Unavailable_protocol] is expected to be the first error in the trace *) - | Error - (Unavailable_protocol {protocol; _} :: _) -> + | Error (Unavailable_protocol {protocol; _} :: _) + -> let* _ = Protocol_validator .fetch_and_compile_protocol @@ -360,15 +360,15 @@ let on_completion : fun w request v st -> let open Lwt_syntax in match (request, v) with - | (Request.Request_validation {hash; _}, Already_commited) -> + | Request.Request_validation {hash; _}, Already_commited -> Prometheus.Counter.inc_one metrics.already_commited_blocks_count ; let* () = Worker.log_event w (Previously_validated hash) in Lwt.return_unit - | (Request.Request_validation {hash; _}, Outdated_block) -> + | Request.Request_validation {hash; _}, Outdated_block -> Prometheus.Counter.inc_one metrics.outdated_blocks_count ; let* () = Worker.log_event w (Previously_validated hash) in Lwt.return_unit - | (Request.Request_validation _, Validated) -> ( + | Request.Request_validation _, Validated -> ( let () = Shell_metrics.Worker.update metrics.validation_worker_metrics st in @@ -376,7 +376,7 @@ let on_completion : match Request.view request with | Validation v -> Worker.log_event w (Validation_success (v, st)) | _ -> (* assert false *) Lwt.return_unit) - | (Request.Request_validation _, Validation_error errs) -> ( + | Request.Request_validation _, Validation_error errs -> ( let () = Shell_metrics.Worker.update metrics.validation_worker_metrics st in @@ -385,19 +385,19 @@ let on_completion : | Validation v -> Worker.log_event w (Event.Validation_failure (v, st, errs)) | _ -> (* assert false *) Lwt.return_unit) - | (Request.Request_preapplication _, Preapplied _) -> ( + | Request.Request_preapplication _, Preapplied _ -> ( Prometheus.Counter.inc_one metrics.preapplied_blocks_count ; match Request.view request with | Preapplication v -> Worker.log_event w (Event.Preapplication_success (v, st)) | _ -> (* assert false *) Lwt.return_unit) - | (Request.Request_preapplication _, Preapplication_error errs) -> ( + | Request.Request_preapplication _, Preapplication_error errs -> ( Prometheus.Counter.inc_one metrics.preapplication_errors_count ; match Request.view request with | Preapplication v -> Worker.log_event w (Event.Preapplication_failure (v, st, errs)) | _ -> (* assert false *) Lwt.return_unit) - | (Request.Request_validation _, Validation_error_after_precheck errs) -> ( + | Request.Request_validation _, Validation_error_after_precheck errs -> ( let () = Shell_metrics.Worker.update metrics.validation_worker_metrics st in @@ -408,7 +408,7 @@ let on_completion : w (Event.Validation_failure_after_precheck (v, st, errs)) | _ -> (* assert false *) Lwt.return_unit) - | (Request.Request_validation _, Precheck_failed errs) -> ( + | Request.Request_validation _, Precheck_failed errs -> ( let () = Shell_metrics.Worker.update metrics.validation_worker_metrics st in diff --git a/src/lib_shell/block_validator.mli b/src/lib_shell/block_validator.mli index 589b1d7166c9..60f39f858b97 100644 --- a/src/lib_shell/block_validator.mli +++ b/src/lib_shell/block_validator.mli @@ -59,7 +59,8 @@ val create : type block_validity = | Valid - | Invalid_after_precheck of error trace (* precheck succeeded but validation failed *) + | Invalid_after_precheck of + error trace (* precheck succeeded but validation failed *) | Invalid of error trace (* Invalid (precheck failed) *) diff --git a/src/lib_shell/block_validator_process.ml b/src/lib_shell/block_validator_process.ml index fdb73f57990f..eb3addbf89e3 100644 --- a/src/lib_shell/block_validator_process.ml +++ b/src/lib_shell/block_validator_process.ml @@ -278,7 +278,7 @@ module Internal_validator_process = struct let operation_metadata_size_limit = validator.operation_metadata_size_limit in - let* (result, apply_result) = + let* result, apply_result = Block_validation.preapply ~chain_id ~user_activated_upgrades @@ -561,7 +561,7 @@ module External_validator_process = struct Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> clean_process_fd socket_path) in - let* (process_socket, _) = + let* process_socket, _ = Lwt.finalize (fun () -> let* process_socket = @@ -637,7 +637,7 @@ module External_validator_process = struct let send_request vp request result_encoding = let open Lwt_result_syntax in - let* (process, process_stdin, process_stdout) = + let* process, process_stdin, process_stdout = match vp.validator_process with | Running { @@ -911,7 +911,7 @@ let apply_block (E {validator_process = (module VP); validator}) chain_store let open Lwt_result_syntax in let* metadata = Store.Block.get_block_metadata chain_store predecessor in let max_operations_ttl = Store.Block.max_operations_ttl metadata in - let* (live_blocks, live_operations) = + let* live_blocks, live_operations = Store.Chain.compute_live_blocks chain_store ~block:predecessor in let block_hash = Block_header.hash header in @@ -945,7 +945,7 @@ let preapply_block (E {validator_process = (module VP); validator} : t) chain_store ~predecessor ~protocol_data ~timestamp operations = let open Lwt_result_syntax in let chain_id = Store.Chain.chain_id chain_store in - let* (live_blocks, live_operations) = + let* live_blocks, live_operations = Store.Chain.compute_live_blocks chain_store ~block:predecessor in let predecessor_shell_header = Store.Block.shell_header predecessor in diff --git a/src/lib_shell/bootstrap_pipeline.ml b/src/lib_shell/bootstrap_pipeline.ml index a7ae3c7bfb24..a66edb9e65bc 100644 --- a/src/lib_shell/bootstrap_pipeline.ml +++ b/src/lib_shell/bootstrap_pipeline.ml @@ -96,7 +96,7 @@ open Validation_errors [Block_locator] from the network. A large step is defined by [big_step_size]. In that case an event is made every [big_step_size_announced]. *) -let (big_step_size, big_step_size_announce) = (2000, 1000) +let big_step_size, big_step_size_announce = (2000, 1000) (** The promises which fetches headers and operations communicate through a [Lwt_pipe.Bounded]. This pipe stores headers by batch. The size @@ -161,7 +161,7 @@ let assert_acceptable_header pipeline hash (header : Block_header.t) = (Future_block_header {block = hash; time = time_now; block_time = header.shell.timestamp}) in - let*! (checkpoint_hash, checkpoint_level) = + let*! checkpoint_hash, checkpoint_level = Store.Chain.checkpoint chain_store in let* () = @@ -319,7 +319,7 @@ let headers_fetch_worker_loop pipeline = If the queue is full, the [Lwt_pipe.Bounded.push] promise is pending until some headers are popped from the queue. *) let rec process_headers headers = - let (batch, remaining_headers) = + let batch, remaining_headers = List.split_n header_batch_size headers in let* () = @@ -477,7 +477,7 @@ let rec validation_worker_loop pipeline = let open Lwt_result_syntax in let*! r = let*! () = Lwt.pause () in - let* (hash, header, operations) = + let* hash, header, operations = protect ~canceler:pipeline.canceler (fun () -> let*! v = Lwt_pipe.Bounded.pop pipeline.fetched_blocks in return v) diff --git a/src/lib_shell/chain_directory.ml b/src/lib_shell/chain_directory.ml index 760a7c301ca0..9d39f47c5143 100644 --- a/src/lib_shell/chain_directory.ml +++ b/src/lib_shell/chain_directory.ml @@ -51,7 +51,7 @@ let get_chain_store_exn store chain = let get_checkpoint store (chain : Chain_services.chain) = let open Lwt_syntax in let* chain_store = get_chain_store_exn store chain in - let* (checkpoint_hash, _) = Store.Chain.checkpoint chain_store in + let* checkpoint_hash, _ = Store.Chain.checkpoint chain_store in Lwt.return checkpoint_hash let predecessors chain_store ignored length head = @@ -102,7 +102,7 @@ let list_blocks chain_store ?(length = 1) ?min_date heads = | _ :: _ as heads -> List.map_p (Store.Block.read_block_opt chain_store) heads in - let* (_, blocks) = + let* _, blocks = List.fold_left_es (fun (ignored, acc) head -> match head with @@ -145,11 +145,11 @@ let rpc_directory validator = register0 S.chain_id (fun chain_store () () -> return (Store.Chain.chain_id chain_store)) ; register0 S.checkpoint (fun chain_store () () -> - let*! (checkpoint_hash, _) = Store.Chain.checkpoint chain_store in + let*! checkpoint_hash, _ = Store.Chain.checkpoint chain_store in let* block = Store.Block.read_block chain_store checkpoint_hash in let checkpoint_header = Store.Block.header block in - let*! (_, savepoint_level) = Store.Chain.savepoint chain_store in - let*! (_, caboose_level) = Store.Chain.caboose chain_store in + let*! _, savepoint_level = Store.Chain.savepoint chain_store in + let*! _, caboose_level = Store.Chain.caboose chain_store in let history_mode = Store.Chain.history_mode chain_store in return (checkpoint_header, savepoint_level, caboose_level, history_mode)) ; register0 S.Levels.checkpoint (fun chain_store () () -> diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 9deb12dc9e81..ebe7a7fe3ec3 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -319,10 +319,10 @@ let may_switch_test_chain w active_chains spawn_child block = let*! r = let* v = Store.Block.testchain_status nv.parameters.chain_store block in match v with - | (Not_running, _) -> + | Not_running, _ -> let*! () = shutdown_child nv active_chains in return_unit - | ((Forking _ | Running _), None) -> return_unit (* only for snapshots *) + | (Forking _ | Running _), None -> return_unit (* only for snapshots *) | ( (Forking {protocol; expiration; _} | Running {protocol; expiration; _}), Some forking_block_hash ) -> may_create_child block protocol expiration forking_block_hash @@ -414,7 +414,7 @@ let may_flush_or_update_prevalidator parameters event prevalidator chain_db let* () = Prevalidator.shutdown old_prevalidator in return_ok_unit else - let* (live_blocks, live_operations) = + let* live_blocks, live_operations = Store.Chain.live_blocks parameters.chain_store in Prevalidator.flush @@ -627,7 +627,8 @@ let on_close w = in Lwt.join (Option.iter_s Prevalidator.shutdown !(nv.prevalidator) - :: Option.iter_s (fun (_, shutdown) -> shutdown ()) nv.child :: pvs) + :: Option.iter_s (fun (_, shutdown) -> shutdown ()) nv.child + :: pvs) let may_load_protocols parameters = let open Lwt_result_syntax in diff --git a/src/lib_shell/distributed_db_requester.ml b/src/lib_shell/distributed_db_requester.ml index b243b2fc4cef..2b683d0f865b 100644 --- a/src/lib_shell/distributed_db_requester.ml +++ b/src/lib_shell/distributed_db_requester.ml @@ -81,7 +81,7 @@ module Make_raw let initial_delay = Request_message.initial_delay let rec send state gid keys = - let (first_keys, keys) = List.split_n Request_message.max_length keys in + let first_keys, keys = List.split_n Request_message.max_length keys in let msg = Request_message.forge state.data first_keys in state.send gid msg ; let open Peer_metadata in @@ -319,7 +319,7 @@ module Raw_operations = struct type notified_value = Operation.t list * Operation_list_list_hash.path let probe (_block, expected_ofs) expected_hash (ops, path) = - let (received_hash, received_ofs) = + let received_hash, received_ofs = Operation_list_list_hash.check_path path (Operation_list_hash.compute (List.map Operation.hash ops)) diff --git a/src/lib_shell/injection_directory.ml b/src/lib_shell/injection_directory.ml index 63e9bea205d9..d4c00af8412c 100644 --- a/src/lib_shell/injection_directory.ml +++ b/src/lib_shell/injection_directory.ml @@ -37,7 +37,7 @@ let read_chain_id validator chain = let inject_block validator ?force ?chain bytes operations = let open Lwt_result_syntax in let*! chain_id = read_chain_id validator chain in - let* (hash, block) = + let* hash, block = Validator.validate_block validator ?force ?chain_id bytes operations in return @@ -85,14 +85,14 @@ let build_rpc_directory validator = dir := RPC_directory.register !dir s (fun () p q -> f p q) in let inject_operation ~force q contents = - let*! (hash, wait) = + let*! hash, wait = inject_operation validator ~force ?chain:q#chain contents in let* () = if q#async then return_unit else wait in return hash in register0 Injection_services.S.block (fun q (raw, operations) -> - let* (hash, wait) = + let* hash, wait = inject_block validator ?chain:q#chain ~force:q#force raw operations in let* () = if q#async then return_unit else wait in @@ -102,7 +102,7 @@ let build_rpc_directory validator = Injection_services.S.private_operation (inject_operation ~force:true) ; register0 Injection_services.S.protocol (fun q protocol -> - let*! (hash, wait) = inject_protocol state protocol in + let*! hash, wait = inject_protocol state protocol in let* () = if q#async then return_unit else wait in return hash) ; !dir diff --git a/src/lib_shell/monitor_directory.ml b/src/lib_shell/monitor_directory.ml index 57501d56d87a..997071f461d1 100644 --- a/src/lib_shell/monitor_directory.ml +++ b/src/lib_shell/monitor_directory.ml @@ -36,7 +36,7 @@ let build_rpc_directory validator mainchain_validator = dir := RPC_directory.gen_register !dir s (fun ((), a) p q -> f a p q) in gen_register0 Monitor_services.S.bootstrapped (fun () () -> - let (block_stream, stopper) = + let block_stream, stopper = Chain_validator.new_head_watcher mainchain_validator in let first_run = ref true in @@ -62,7 +62,7 @@ let build_rpc_directory validator mainchain_validator = let shutdown () = Lwt_watcher.shutdown stopper in RPC_answer.return_stream {next; shutdown}) ; gen_register0 Monitor_services.S.valid_blocks (fun q () -> - let (block_stream, stopper) = Store.global_block_watcher store in + let block_stream, stopper = Store.global_block_watcher store in let shutdown () = Lwt_watcher.shutdown stopper in let in_chains (chain_store, _block) = match q#chains with @@ -122,7 +122,7 @@ let build_rpc_directory validator mainchain_validator = match Validator.get validator (Store.Chain.chain_id chain_store) with | Error _ -> Lwt.fail Not_found | Ok chain_validator -> - let (block_stream, stopper) = + let block_stream, stopper = Chain_validator.new_head_watcher chain_validator in let* head = Store.Chain.current_head chain_store in @@ -159,14 +159,14 @@ let build_rpc_directory validator mainchain_validator = in RPC_answer.return_stream {next; shutdown}) ; gen_register0 Monitor_services.S.protocols (fun () () -> - let (stream, stopper) = Store.Protocol.protocol_watcher store in + let stream, stopper = Store.Protocol.protocol_watcher store in let shutdown () = Lwt_watcher.shutdown stopper in let next () = Lwt_stream.get stream in RPC_answer.return_stream {next; shutdown}) ; gen_register0 Monitor_services.S.commit_hash (fun () () -> RPC_answer.return Tezos_version.Current_git_info.commit_hash) ; gen_register0 Monitor_services.S.active_chains (fun () () -> - let (stream, stopper) = Validator.chains_watcher validator in + let stream, stopper = Validator.chains_watcher validator in let shutdown () = Lwt_watcher.shutdown stopper in let first_call = (* Only notify the newly created chains if this is false *) diff --git a/src/lib_shell/node.ml b/src/lib_shell/node.ml index ecd280db49b9..791bdb48deeb 100644 --- a/src/lib_shell/node.ml +++ b/src/lib_shell/node.ml @@ -235,7 +235,7 @@ let create ?(sandboxed = false) ?sandbox_parameters ~singleprocess } peer_validator_limits block_validator_limits prevalidator_limits chain_validator_limits history_mode = let open Lwt_result_syntax in - let (start_prevalidator, start_testchain) = + let start_prevalidator, start_testchain = match p2p_params with | Some _ -> (not disable_mempool, enable_testchain) | None -> (true, true) @@ -247,7 +247,7 @@ let create ?(sandboxed = false) ?sandbox_parameters ~singleprocess disable_mempool in Shell_metrics.Version.init p2p ; - let* (validator_process, store) = + let* validator_process, store = let open Block_validator_process in let validator_environment = { diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index a782978b14de..0672630940f2 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -368,7 +368,7 @@ let handle_msg state msg = match o with | None -> Lwt.return_unit | Some (_, block) -> - let (ops, path) = Store.Block.operations_path block ofs in + let ops, path = Store.Block.operations_path block ofs in Peer_metadata.update_responses meta Operations_for_block @@ P2p.try_send state.p2p state.conn @@ Operations_for_block (hash, ofs, ops, path) ; @@ -392,7 +392,7 @@ let handle_msg state msg = | Get_checkpoint chain_id -> ( Peer_metadata.incr meta @@ Received_request Checkpoint ; may_handle_global state chain_id @@ fun chain_db -> - let* (checkpoint_hash, _) = Store.Chain.checkpoint chain_db.chain_store in + let* checkpoint_hash, _ = Store.Chain.checkpoint chain_db.chain_store in let* o = Store.Block.read_block_opt chain_db.chain_store checkpoint_hash in diff --git a/src/lib_shell/peer_validator.ml b/src/lib_shell/peer_validator.ml index e680ececef25..d2eb57f488cf 100644 --- a/src/lib_shell/peer_validator.ml +++ b/src/lib_shell/peer_validator.ml @@ -317,11 +317,11 @@ let may_validate_new_branch w locator = locator in match v with - | (Known_valid, prefix_locator) -> + | Known_valid, prefix_locator -> if prefix_locator.Block_locator.history <> [] then bootstrap_new_branch w prefix_locator else return_unit - | (Unknown, _) -> + | Unknown, _ -> (* May happen when: - A locator from another chain is received; - A rolling peer is too far ahead; @@ -332,7 +332,7 @@ let may_validate_new_branch w locator = (Ignoring_branch_without_common_ancestor block_received) in tzfail Validation_errors.Unknown_ancestor - | (Known_invalid, _) -> + | Known_invalid, _ -> let*! () = Worker.log_event w diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index 2b5a1244be0f..97b1b4b5fa1a 100644 --- a/src/lib_shell/prevalidator.ml +++ b/src/lib_shell/prevalidator.ml @@ -321,10 +321,10 @@ module Make_s (Filter : Prevalidator_filters.FILTER) (Prevalidation_t : Prevalidation.T with type validation_state = - Filter.Proto.validation_state + Filter.Proto.validation_state and type protocol_operation = Filter.Proto.operation and type operation_receipt = - Filter.Proto.operation_receipt) : + Filter.Proto.operation_receipt) : S with type filter_state = Filter.Mempool.state and type filter_config = Filter.Mempool.config @@ -622,7 +622,7 @@ module Make_s (acc_filter_state, acc_validation_state, acc_mempool) else ( shell.pending <- Pending_ops.remove oph shell.pending ; - let+ (new_filter_state, new_validation_state, new_mempool, to_handle) + let+ new_filter_state, new_validation_state, new_mempool, to_handle = classify_operation shell @@ -694,7 +694,7 @@ module Make_s if Pending_ops.is_empty pv.shell.pending then Lwt.return_unit else let* () = Event.(emit processing_operations) () in - let* (filter_state, validation_state, delta_mempool) = + let* filter_state, validation_state, delta_mempool = classify_pending_operations ~notifier pv.shell @@ -852,7 +852,7 @@ module Make_s else let*? validation_state = pv.validation_state in let notifier = mk_notifier pv.operation_stream in - let*! (filter_state, validation_state, delta_mempool, to_handle) = + let*! filter_state, validation_state, delta_mempool, to_handle = classify_operation pv.shell ~filter_config:pv.filter_config @@ -868,7 +868,7 @@ module Make_s retrieve the classification of our operation. *) List.find_opt (function - | (({hash; _} : protocol_operation operation), _) -> + | ({hash; _} : protocol_operation operation), _ -> Operation_hash.equal hash oph) to_handle in @@ -969,7 +969,7 @@ module Make_s in (* Could be implemented as Operation_hash.Map.filter_s which does not exist for the moment. *) - let*! (new_pending_operations, nb_pending) = + let*! new_pending_operations, nb_pending = Operation_hash.Map.fold_s (fun _oph op (pending, nb_pending) -> let*! v = @@ -1027,7 +1027,7 @@ module Make_s return_unit | Some (_op, classification) -> ( match (classification, flush_if_prechecked) with - | (`Prechecked, true) | (`Applied, _) -> + | `Prechecked, true | `Applied, _ -> (* Modifying the list of operations classified as [Applied] might change the classification of all the operations in the mempool. Hence if the removed operation has been @@ -1043,11 +1043,11 @@ module Make_s pv.shell.live_operations in pv.shell.pending <- Pending_ops.remove oph pv.shell.pending - | (`Branch_delayed _, _) - | (`Branch_refused _, _) - | (`Refused _, _) - | (`Outdated _, _) - | (`Prechecked, false) -> + | `Branch_delayed _, _ + | `Branch_refused _, _ + | `Refused _, _ + | `Outdated _, _ + | `Prechecked, false -> pv.filter_state <- Filter.Mempool.remove ~filter_state:pv.filter_state oph ; return_unit) @@ -1081,10 +1081,10 @@ module Make (Arg : ARG) (Prevalidation_t : Prevalidation.T with type validation_state = - Filter.Proto.validation_state + Filter.Proto.validation_state and type protocol_operation = Filter.Proto.operation and type operation_receipt = - Filter.Proto.operation_receipt + Filter.Proto.operation_receipt and type chain_store = Store.chain_store) : T with type prevalidation_t = Prevalidation_t.t = struct include Make_s (Filter) (Prevalidation_t) @@ -1282,7 +1282,7 @@ module Make (Proto_services.S.Mempool.monitor_operations RPC_path.open_root) (fun pv params () -> Lwt_mutex.with_lock pv.lock @@ fun () -> - let (op_stream, stopper) = + let op_stream, stopper = Lwt_watcher.create_stream pv.operation_stream in (* Convert ops *) @@ -1345,8 +1345,8 @@ module Make let current_mempool = List.concat_map (List.map (function - | (hash, op, []) -> ((hash, op), None) - | (hash, op, errors) -> ((hash, op), Some errors))) + | hash, op, [] -> ((hash, op), None) + | hash, op, errors -> ((hash, op), Some errors))) [ applied; prechecked; @@ -1494,7 +1494,7 @@ module Make let*! predecessor = Store.Chain.current_head chain_store in let predecessor_header = Store.Block.header predecessor in let*! mempool = Store.Chain.mempool chain_store in - let*! (live_blocks, live_operations) = + let*! live_blocks, live_operations = Store.Chain.live_blocks chain_store in let timestamp_system = Tezos_base.Time.System.now () in @@ -1814,10 +1814,10 @@ module Internal_for_tests = struct (Filter : Prevalidator_filters.FILTER) (Prevalidation_t : Prevalidation.T with type validation_state = - Filter.Proto.validation_state + Filter.Proto.validation_state and type protocol_operation = Filter.Proto.operation and type operation_receipt = - Filter.Proto.operation_receipt) = + Filter.Proto.operation_receipt) = struct module Internal = Make_s (Filter) (Prevalidation_t) diff --git a/src/lib_shell/prevalidator.mli b/src/lib_shell/prevalidator.mli index 70575df75961..81c4b36ae19c 100644 --- a/src/lib_shell/prevalidator.mli +++ b/src/lib_shell/prevalidator.mli @@ -170,10 +170,10 @@ module Internal_for_tests : sig (Filter : Prevalidator_filters.FILTER) (Prevalidation_t : Prevalidation.T with type validation_state = - Filter.Proto.validation_state + Filter.Proto.validation_state and type protocol_operation = Filter.Proto.operation and type operation_receipt = - Filter.Proto.operation_receipt) : sig + Filter.Proto.operation_receipt) : sig (** The corresponding internal type of the mempool (see {!Prevalidator.S}), that depends on the protocol *) type types_state diff --git a/src/lib_shell/prevalidator_classification.ml b/src/lib_shell/prevalidator_classification.ml index 8d51fd1ad6e5..edc00559476c 100644 --- a/src/lib_shell/prevalidator_classification.ml +++ b/src/lib_shell/prevalidator_classification.ml @@ -225,7 +225,7 @@ let handle_prechecked oph op classes = 4. Add the operation to the [in_mempool] set. *) let handle_error oph op classification classes = - let (bounded_map, tztrace) = + let bounded_map, tztrace = match classification with | `Branch_refused tztrace -> (classes.branch_refused, tztrace) | `Branch_delayed tztrace -> (classes.branch_delayed, tztrace) @@ -262,9 +262,9 @@ let to_map ~applied ~prechecked ~branch_delayed ~branch_refused ~refused let ( +> ) accum to_add = let merge_fun _k accum_v_opt to_add_v_opt = match (accum_v_opt, to_add_v_opt) with - | (Some accum_v, None) -> Some accum_v - | (None, Some (to_add_v, _err)) -> Some to_add_v - | (Some _accum_v, Some (to_add_v, _err)) -> + | Some accum_v, None -> Some accum_v + | None, Some (to_add_v, _err) -> Some to_add_v + | Some _accum_v, Some (to_add_v, _err) -> (* This case should not happen, because the different classes should be disjoint. However, if this invariant is broken, it is not critical, hence we do not raise an error. @@ -272,7 +272,7 @@ let to_map ~applied ~prechecked ~branch_delayed ~branch_refused ~refused the invariant is not critical, we don't advertise the node administrator either (no log). *) Some to_add_v - | (None, None) -> None + | None, None -> None in Map.merge merge_fun accum to_add in @@ -373,14 +373,14 @@ let handle_live_operations ~classes ~(block_store : 'block block_tools) mempool operations in - let* (ancestor, path) = + let* ancestor, path = chain.new_blocks ~from_block:from_branch ~to_block:to_branch in let+ mempool = pop_block (block_store.hash ancestor) from_branch old_mempool in let new_mempool = List.fold_left push_block mempool path in - let (new_mempool, outdated) = + let new_mempool, outdated = Map.partition (fun _oph op -> is_branch_alive op.Prevalidation.raw.Operation.shell.branch) diff --git a/src/lib_shell/prevalidator_pending_operations.ml b/src/lib_shell/prevalidator_pending_operations.ml index ddd66e3eb028..bf3dc5827f90 100644 --- a/src/lib_shell/prevalidator_pending_operations.ml +++ b/src/lib_shell/prevalidator_pending_operations.ml @@ -41,12 +41,12 @@ module Priority_map : Map.S with type key = priority = Map.Make (struct (* - Explicit comparison, `High is smaller, - Avoid fragile patterns in case the type is extended in the future *) match (p1, p2) with - | (`High, `High) | (`Medium, `Medium) -> 0 - | (`Low p1, `Low p2) -> compare_low_prio p1 p2 - | (`High, (`Low _ | `Medium)) -> -1 - | ((`Low _ | `Medium), `High) -> 1 - | (`Low _, `Medium) -> 1 - | (`Medium, `Low _) -> -1 + | `High, `High | `Medium, `Medium -> 0 + | `Low p1, `Low p2 -> compare_low_prio p1 p2 + | `High, (`Low _ | `Medium) -> -1 + | (`Low _ | `Medium), `High -> 1 + | `Low _, `Medium -> 1 + | `Medium, `Low _ -> -1 end) module Map = Operation_hash.Map diff --git a/src/lib_shell/protocol_validator.ml b/src/lib_shell/protocol_validator.ml index d72adcfdacfb..b31e728bc966 100644 --- a/src/lib_shell/protocol_validator.ml +++ b/src/lib_shell/protocol_validator.ml @@ -113,7 +113,7 @@ let validate state hash protocol = in match Protocol_hash.Map.find hash state.pending with | None -> - let (res, wakener) = Lwt.task () in + let res, wakener = Lwt.task () in let broadcast = Protocol_hash.Map.cardinal state.pending = 0 in state.pending <- Protocol_hash.Map.add hash (protocol, res, wakener) state.pending ; diff --git a/src/lib_shell/synchronisation_heuristic.ml b/src/lib_shell/synchronisation_heuristic.ml index 135083c4b0c3..063ba53ced2a 100644 --- a/src/lib_shell/synchronisation_heuristic.ml +++ b/src/lib_shell/synchronisation_heuristic.ml @@ -41,10 +41,10 @@ type candidate = Time.Protocol.t * P2p_peer.Id.t let earlier_o l r = match (l, r) with - | (None, None) -> false - | (None, Some _) -> true - | (Some (i, _), Some (j, _)) -> Time.Protocol.(i < j) - | (Some _, None) -> false + | None, None -> false + | None, Some _ -> true + | Some (i, _), Some (j, _) -> Time.Protocol.(i < j) + | Some _, None -> false let earlier_ro (i, _) r = match r with Some (j, _) -> Time.Protocol.(i < j) | None -> false @@ -54,8 +54,8 @@ let earlier l (j, _) = let coincident_o l r = match (l, r) with - | (None, None) -> true - | (Some (i, _), Some (j, _)) -> Time.Protocol.(i = j) + | None, None -> true + | Some (i, _), Some (j, _) -> Time.Protocol.(i = j) | _ -> false let earlier_or_coincident_o l r = earlier_o l r || coincident_o l r @@ -138,10 +138,10 @@ module Core = struct ( state.candidates.(state.index_of_youngest_candidate), state.candidates.(state.index_of_oldest_candidate) ) with - | (None, _) | (_, None) -> + | None, _ | _, None -> (* The threshold is not reached *) Not_synchronised - | (Some (best, _), Some (least, _)) -> + | Some (best, _), Some (least, _) -> let least_timestamp_drifted = Time.Protocol.add least (Int64.of_int state.latency) in diff --git a/src/lib_shell/test/generators.ml b/src/lib_shell/test/generators.ml index 17c80538413b..cc0ccc3fdf32 100644 --- a/src/lib_shell/test/generators.ml +++ b/src/lib_shell/test/generators.ml @@ -111,7 +111,7 @@ let priority_gen () : Prevalidator_pending_operations.priority QCheck2.Gen.t = let operation_with_hash_gen ?proto_gen ?block_hash_t () : unit Prevalidation.operation QCheck2.Gen.t = let open QCheck2.Gen in - let+ (oph, op) = raw_operation_with_hash_gen ?proto_gen ?block_hash_t () in + let+ oph, op = raw_operation_with_hash_gen ?proto_gen ?block_hash_t () in Prevalidation.Internal_for_tests.make_operation op oph () let operation_with_hash_and_priority_gen ?proto_gen ?block_hash_t () : diff --git a/src/lib_shell/test/generators_tree.ml b/src/lib_shell/test/generators_tree.ml index d9a1f94627f2..6f7aeab2c34e 100644 --- a/src/lib_shell/test/generators_tree.ml +++ b/src/lib_shell/test/generators_tree.ml @@ -40,8 +40,8 @@ module List_extra = struct let rec common_elem ~(equal : 'a -> 'a -> bool) (l1 : 'a list) (l2 : 'a list) = match (l1, l2) with - | ([], _) -> None - | (e1 :: rest1, _) -> + | [], _ -> None + | e1 :: rest1, _ -> if List.exists (equal e1) l2 then Some e1 else common_elem ~equal rest1 l2 @@ -114,7 +114,7 @@ module Tree = struct let rec values : 'a tree -> 'a list = function | Leaf a -> [a] | Node1 (a, t1) -> a :: values t1 - | Node2 (a, t1, t2) -> a :: values t1 @ values t2 + | Node2 (a, t1, t2) -> (a :: values t1) @ values t2 (** Predicate to check that all values are different. We want this property for trees of blocks. If generation of block @@ -150,7 +150,7 @@ module Tree = struct | Node2 (e, subtree1, subtree2) -> let child1 = value subtree1 in let child2 = value subtree2 in - (child1, e) :: (child2, e) :: predecessor_pairs subtree1 + ((child1, e) :: (child2, e) :: predecessor_pairs subtree1) @ predecessor_pairs subtree2 (** Returns the predecessors of a tree node. I.e., given @@ -374,12 +374,12 @@ let tree_gen ?blocks () = | Some sub -> ret (Tree.Node1 (x, sub)) else let* n = QCheck2.Gen.int_bound (List.length xs - 1) in - let (left, right) = List.split_n n xs in + let left, right = List.split_n n xs in let* left = go left and* right = go right in match (left, right) with - | (None, None) -> ret (Tree.Leaf x) - | (None, Some sub) | (Some sub, None) -> ret (Tree.Node1 (x, sub)) - | (Some left, Some right) -> ret (Tree.Node2 (x, left, right))) + | None, None -> ret (Tree.Leaf x) + | None, Some sub | Some sub, None -> ret (Tree.Node1 (x, sub)) + | Some left, Some right -> ret (Tree.Node2 (x, left, right))) in (* The assertion cannot break, because we made sure that [blocks] is not empty. *) @@ -420,7 +420,7 @@ let new_blocks (type a) ~(equal : a -> a -> bool) (tree : a Tree.tree) ( to_parents, List_extra.take_until_if_found ~pred:(( = ) ancestor) to_parents ) with - | ([], _) -> + | [], _ -> (* This case is not supported, because the production implementation of new_blocks doesn't support it either (since it MUST return an ancestor, acccording to its return @@ -430,11 +430,11 @@ let new_blocks (type a) ~(equal : a -> a -> bool) (tree : a Tree.tree) of new_blocks should allow this case, hereby allowing a more general test. *) assert false - | (_, None) -> + | _, None -> (* Should not happen, because [ancestor] is a member of [to_parents] *) assert false - | (_, Some path) -> + | _, Some path -> (* Because [to_block] must be included in new_blocks' returned value. *) let path = to_block :: path in diff --git a/src/lib_shell/test/test_consensus_heuristic.ml b/src/lib_shell/test/test_consensus_heuristic.ml index c4db54e3909b..c1c8bf6b1cb4 100644 --- a/src/lib_shell/test/test_consensus_heuristic.ml +++ b/src/lib_shell/test/test_consensus_heuristic.ml @@ -29,7 +29,7 @@ Invocation: dune exec src/lib_shell/test/test_shell.exe \ -- test '^consensus heuristic' Subject: Test the consensus heuristic - *) +*) module Assert = Lib_test.Assert open Consensus_heuristic @@ -138,7 +138,7 @@ let job_sleep () = Assert.equal ~pp (Lwt.state p) Lwt.Sleep let job_protected () = - let (t, u) = Lwt.task () in + let t, u = Lwt.task () in let worker = Worker.create ~expire_time:Ptime.Span.zero @@ -153,7 +153,7 @@ let job_protected () = Assert.equal ~pp (Lwt.state p') (Lwt.state (Lwt.return Block_hash.zero)) let worker_canceled () = - let (t, _) = Lwt.task () in + let t, _ = Lwt.task () in let worker = Worker.create ~expire_time:Ptime.Span.zero @@ -254,7 +254,7 @@ let job_on_next_consensus_1 () = let job_on_next_consensus_2 () = let open Lwt_syntax in let cpt = ref 0 in - let (t, u) = Lwt.task () in + let t, u = Lwt.task () in let worker = Worker.create ~expire_time:Ptime.Span.zero @@ -288,7 +288,7 @@ let job_on_all_consensus_1 () = let job_on_all_consensus_2 () = let open Lwt_syntax in let cpt = ref 0 in - let (t, u) = Lwt.task () in + let t, u = Lwt.task () in let worker = Worker.create ~expire_time:Ptime.Span.zero @@ -308,7 +308,7 @@ let job_on_all_consensus_2 () = let job_on_all_consensus_3 () = let open Lwt_syntax in let cpt = ref 0 in - let (t, u) = Lwt.task () in + let t, u = Lwt.task () in let worker = Worker.create ~expire_time:Ptime.Span.zero @@ -331,7 +331,7 @@ let job_on_all_consensus_3 () = let job_on_next_consensus_3 () = let open Lwt_syntax in let cpt = ref 0 in - let (t, u) = Lwt.task () in + let t, u = Lwt.task () in let worker = Worker.create ~expire_time:Ptime.Span.zero diff --git a/src/lib_shell/test/test_locator.ml b/src/lib_shell/test/test_locator.ml index ae65d95426a6..2df1cbf8abd4 100644 --- a/src/lib_shell/test/test_locator.ml +++ b/src/lib_shell/test/test_locator.ml @@ -128,7 +128,7 @@ let make_multiple_protocol_chain (chain_store : Store.Chain.t) let rec loop remaining_fork_points lvl (pred_header : Block_header.t) = if lvl > chain_length then return pred_header else - let (proto_level, remaining_fork_points) = + let proto_level, remaining_fork_points = match remaining_fork_points with | h :: t when h = lvl -> (pred_header.shell.proto_level + 1, t) | remaining_fork_points -> @@ -208,10 +208,10 @@ let time ?(runs = 1) f = let rec loop cnt sum = if cnt = runs then sum else - let (_, t) = time1 f in + let _, t = time1 f in loop (cnt + 1) (sum +. t) in - let (res, t) = time1 f in + let res, t = time1 f in let sum = loop 1 t in (res, sum /. float runs) @@ -272,10 +272,10 @@ let test_pred (base_dir : string) : unit tzresult Lwt.t = ~distance in match (lin_res, exp_res) with - | (None, None) -> return_unit - | (None, Some _) | (Some _, None) -> + | None, None -> return_unit + | None, Some _ | Some _, None -> Assert.fail_msg "mismatch between exponential and linear predecessor_n" - | (Some lin_res, Some exp_res) -> + | Some lin_res, Some exp_res -> (* check that the two results are the same *) assert (lin_res = exp_res) ; let*! pred = Store.Block.read_block_opt chain_store lin_res in @@ -361,7 +361,7 @@ let bench_locator base_dir = in let*! head = res in let check_locator max_size : unit tzresult Lwt.t = - let*! (caboose, _) = Store.Chain.caboose chain_store in + let*! caboose, _ = Store.Chain.caboose chain_store in let* block = Store.Block.read_block chain_store head in time ~runs (fun () -> Store.Chain.compute_locator chain_store ~max_size block seed) @@ -500,7 +500,7 @@ let test_protocol_locator base_dir = in let*! store = Shell_test_helpers.init_chain ~history_mode base_dir in let chain_store = Store.main_chain_store store in - let*! (caboose_hash, _) = Store.Chain.caboose chain_store in + let*! caboose_hash, _ = Store.Chain.caboose chain_store in let* () = List.iter_es (fun i -> diff --git a/src/lib_shell/test/test_prevalidation_t.ml b/src/lib_shell/test/test_prevalidation_t.ml index e324c2fdbdc6..f9cf2e749126 100644 --- a/src/lib_shell/test/test_prevalidation_t.ml +++ b/src/lib_shell/test/test_prevalidation_t.ml @@ -255,7 +255,7 @@ let test_apply_operation_live_operations ctxt = in let apply_op pv (op : _ Prevalidation.operation) = let*! application_result = P.apply_operation pv op in - let (next_pv, result_is_outdated) = + let next_pv, result_is_outdated = match application_result with | Applied (next_pv, _receipt) -> (next_pv, false) | Outdated _ -> (pv, true) @@ -301,7 +301,7 @@ let test_apply_operation_applied ctxt = let apply_op pv (op : _ Prevalidation.operation) = let applied_before = to_applied pv in let*! application_result = P.apply_operation pv op in - let (next_pv, result_is_applied) = + let next_pv, result_is_applied = match application_result with | Applied (next_pv, _receipt) -> (next_pv, true) | Branch_delayed _ -> diff --git a/src/lib_shell/test/test_prevalidator_classification.ml b/src/lib_shell/test/test_prevalidator_classification.ml index 5395cbb176bf..5b0dd97cbda1 100644 --- a/src/lib_shell/test/test_prevalidator_classification.ml +++ b/src/lib_shell/test/test_prevalidator_classification.ml @@ -103,7 +103,7 @@ module Extra_generators = struct let event_gen t = let open QCheck2.Gen in let add_gen = - let+ (classification, op) = + let+ classification, op = pair Generators.classification_gen (Generators.operation_with_hash_gen ()) @@ -593,12 +593,12 @@ module To_map = struct let eq_mod_op m1 (k, v_opt) m2 = let diff = remove_all m2 m1 in match (Operation_hash.Map.bindings diff, v_opt) with - | ([], _) -> true - | ([(kdiff, vdiff)], Some v) + | [], _ -> true + | [(kdiff, vdiff)], Some v when Operation_hash.equal kdiff k && Operation.equal v.Prevalidation.raw vdiff.Prevalidation.raw -> true - | ([(kdiff, _)], None) when Operation_hash.equal kdiff k -> true + | [(kdiff, _)], None when Operation_hash.equal kdiff k -> true | _ -> false (** [to_map_all] calls [Classification.to_map] with all named diff --git a/src/lib_shell/test/test_prevalidator_classification_operations.ml b/src/lib_shell/test/test_prevalidator_classification_operations.ml index f5b0ac4979cd..7056c3a618a4 100644 --- a/src/lib_shell/test/test_prevalidator_classification_operations.ml +++ b/src/lib_shell/test/test_prevalidator_classification_operations.ml @@ -138,7 +138,7 @@ module Handle_operations = struct it would be overkill. *) let gen = let open QCheck2.Gen in - let* (tree, pair_blocks_opt, old_mempool) = + let* tree, pair_blocks_opt, old_mempool = Generators_tree.tree_gen ?blocks:None () in let* live_blocks = sublist (Tree.values tree) in @@ -153,7 +153,7 @@ module Handle_operations = struct gen @@ fun (tree, pair_blocks_opt, old_mempool, live_blocks) -> QCheck2.assume @@ Option.is_some pair_blocks_opt ; - let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in let chain = Generators_tree.classification_chain_tools tree in let expected_superset : unit Prevalidation.operation Op_map.t = (* Take all blocks *) @@ -193,7 +193,7 @@ module Handle_operations = struct (Generators_tree.tree_gen ()) @@ fun (tree, pair_blocks_opt, _) -> QCheck2.assume @@ Option.is_some pair_blocks_opt ; - let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in let chain = Generators_tree.classification_chain_tools tree in let equal = Block.equal in let ancestor : Block.t = @@ -239,7 +239,7 @@ module Handle_operations = struct Generators_tree.(tree_gen ()) @@ fun (tree, pair_blocks_opt, old_mempool) -> QCheck2.assume @@ Option.is_some pair_blocks_opt ; - let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in let chain = Generators_tree.classification_chain_tools tree in let cleared = ref Operation_hash.Set.empty in let clearer oph = cleared := Operation_hash.Set.add oph !cleared in @@ -280,7 +280,7 @@ module Handle_operations = struct (Generators_tree.tree_gen ()) @@ fun (tree, pair_blocks_opt, old_mempool) -> QCheck2.assume @@ Option.is_some pair_blocks_opt ; - let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in let chain = Generators_tree.classification_chain_tools tree in let injected = ref Operation_hash.Set.empty in let inject_operation oph _op = @@ -392,13 +392,13 @@ module Recyle_operations = struct (fun oph _ -> not (Op_map.mem oph blocks_ops)) classification_pendings_ops in - let* (classification_ops, pending_ops) = + let* classification_ops, pending_ops = Op_map.bindings classification_pendings_ops |> Generators_tree.split_in_two in let classification_ops = oph_op_list_to_map classification_ops in let pending_ops = oph_op_list_to_map pending_ops in - let* (tree, from_to, _) = Generators_tree.tree_gen ~blocks () in + let* tree, from_to, _ = Generators_tree.tree_gen ~blocks () in let+ classification = classification_of_ops_gen classification_ops in (tree, from_to, classification, pending_ops) @@ -421,7 +421,7 @@ module Recyle_operations = struct Gen.(pair gen bool) @@ fun ((tree, pair_blocks_opt, classes, pending), handle_branch_refused) -> assume @@ Option.is_some pair_blocks_opt ; - let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in let chain = Generators_tree.classification_chain_tools tree in let parse raw hash = Some (Prevalidation.Internal_for_tests.make_operation hash raw ()) @@ -452,7 +452,7 @@ module Recyle_operations = struct QCheck2.Gen.(pair gen bool) @@ fun ((tree, pair_blocks_opt, classes, pending), handle_branch_refused) -> QCheck2.assume @@ Option.is_some pair_blocks_opt ; - let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in let chain = Generators_tree.classification_chain_tools tree in let equal = Block.equal in let ancestor : Block.t = @@ -537,7 +537,7 @@ module Recyle_operations = struct ~outdated:true classes in - let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in let chain = Generators_tree.classification_chain_tools tree in let parse raw hash = Some (Prevalidation.Internal_for_tests.make_operation hash raw ()) diff --git a/src/lib_shell/test/test_prevalidator_pending_operations.ml b/src/lib_shell/test/test_prevalidator_pending_operations.ml index 76e9cef1caa6..fa06932abc26 100644 --- a/src/lib_shell/test/test_prevalidator_pending_operations.ml +++ b/src/lib_shell/test/test_prevalidator_pending_operations.ml @@ -60,11 +60,11 @@ let test_iterators_ordering ~name ~iterator return_value = let previous_priority = ref `High in let previous_prio_ok ~priority ~previous_priority = match (previous_priority, priority) with - | (`High, `High) -> true - | ((`High | `Medium), `Medium) -> true - | ((`High | `Medium), `Low _) -> true - | (`Low q_prev, `Low q_new) -> CompareListQ.(q_new <= q_prev) - | (_, _) -> false + | `High, `High -> true + | (`High | `Medium), `Medium -> true + | (`High | `Medium), `Low _ -> true + | `Low q_prev, `Low q_new -> CompareListQ.(q_new <= q_prev) + | _, _ -> false in iterator (fun priority _hash _op () -> diff --git a/src/lib_shell/test/test_synchronisation_heuristic.ml b/src/lib_shell/test/test_synchronisation_heuristic.ml index 8d77f32b2a1f..04924ff9e138 100644 --- a/src/lib_shell/test/test_synchronisation_heuristic.ml +++ b/src/lib_shell/test/test_synchronisation_heuristic.ml @@ -240,8 +240,7 @@ let test_threshold_is_one_always_takes_best_timestamp () = 4. After adding more values (including in the past, from other peers), the status still is `Sync` - - *) +*) let test_threshold_is_two () = let latency = 120 in let heuristic = create ~threshold:2 ~latency in @@ -320,7 +319,7 @@ let test_threshold_is_two_one_in_the_past_and_one_more () = the status is `Stuck`. 4. After a more recent value, the status is `Unsync`. - *) +*) let test_threshold_is_two_two_in_the_past () = let latency = 120 in let heuristic = create ~threshold:2 ~latency in diff --git a/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml b/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml index 1b22d5161af2..843919da120c 100644 --- a/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml +++ b/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml @@ -109,7 +109,7 @@ module Reference : S = struct if Compare.List_length_with.(candidates < threshold) then Not_synchronised else match (best_of candidates, least_of candidates) with - | ((best, _), (least, _)) -> + | (best, _), (least, _) -> let least_timestamp_drifted = Time.Protocol.add least (Int64.of_int latency) in diff --git a/src/lib_shell/validator.ml b/src/lib_shell/validator.ml index 84978c94ab03..9b5ebe256f8a 100644 --- a/src/lib_shell/validator.ml +++ b/src/lib_shell/validator.ml @@ -109,7 +109,7 @@ let read_block store h = let read_block_header db h = let open Lwt_option_syntax in - let* (chain_id, block) = read_block (Distributed_db.store db) h in + let* chain_id, block = read_block (Distributed_db.store db) h in let header = Store.Block.header block in return (chain_id, header) diff --git a/src/lib_shell/worker_directory.ml b/src/lib_shell/worker_directory.ml index 55c676a309ec..c57f915799a5 100644 --- a/src/lib_shell/worker_directory.ml +++ b/src/lib_shell/worker_directory.ml @@ -52,7 +52,7 @@ let build_rpc_directory state = register1 Worker_services.Prevalidators.S.state (fun chain () () -> let* chain_id = Chain_directory.get_chain_id state chain in let workers = Prevalidator.running_workers () in - let (_, _, t) = + let _, _, t = (* NOTE: it is technically possible to use the Prevalidator interface to * register multiple Prevalidator for a single chain (using distinct * protocols). However, this is never done. *) diff --git a/src/lib_shell_benchmarks/bloomer_benchmarks.ml b/src/lib_shell_benchmarks/bloomer_benchmarks.ml index 994c25cf4a3b..5cea368c9b8b 100644 --- a/src/lib_shell_benchmarks/bloomer_benchmarks.ml +++ b/src/lib_shell_benchmarks/bloomer_benchmarks.ml @@ -78,7 +78,7 @@ let () = Bloomer.add bloomer string ; (bloomer, string)) (fun generator () -> - let (bloomer, string) = generator () in + let bloomer, string = generator () in let closure () = ignore (Bloomer.mem bloomer string) in Generator.Plain {workload = (); closure}) diff --git a/src/lib_shell_benchmarks/encoding_benchmarks_helpers.ml b/src/lib_shell_benchmarks/encoding_benchmarks_helpers.ml index f2fbcef1b84e..0a480164c8a1 100644 --- a/src/lib_shell_benchmarks/encoding_benchmarks_helpers.ml +++ b/src/lib_shell_benchmarks/encoding_benchmarks_helpers.ml @@ -157,7 +157,7 @@ let make_encode_variable_size : Benchmark.t = fun ~name ~encoding ~generator -> linear_shared ~name ~generator ~make_bench:(fun generator () -> - let (generated, workload) = generator () in + let generated, workload = generator () in let closure () = ignore (Data_encoding.Binary.to_bytes_exn encoding generated) in @@ -186,7 +186,7 @@ let make_decode_variable_size : Benchmark.t = fun ~name ~encoding ~generator -> linear_shared ~name ~generator ~make_bench:(fun generator () -> - let (generated, workload) = generator () in + let generated, workload = generator () in let encoded = Data_encoding.Binary.to_bytes_exn encoding generated in let closure () = ignore (Data_encoding.Binary.of_bytes_exn encoding encoded) @@ -228,7 +228,7 @@ let make_encode_variable_size_to_string : Benchmark.t = fun ~name ~to_string ~generator -> linear_shared ~name ~generator ~make_bench:(fun generator () -> - let (generated, workload) = generator () in + let generated, workload = generator () in let closure () = ignore (to_string generated) in Generator.Plain {workload; closure}) @@ -269,7 +269,7 @@ let make_decode_variable_size_from_string : Benchmark.t = fun ~name ~to_string ~from_string ~generator -> linear_shared ~name ~generator ~make_bench:(fun generator () -> - let (generated, workload) = generator () in + let generated, workload = generator () in let string = to_string generated in let closure () = ignore (from_string string) in Generator.Plain {workload; closure}) @@ -283,7 +283,7 @@ let make_decode_variable_size_from_bytes : Benchmark.t = fun ~name ~to_bytes ~from_bytes ~generator -> linear_shared ~name ~generator ~make_bench:(fun generator () -> - let (generated, workload) = generator () in + let generated, workload = generator () in let string = to_bytes generated in let closure () = ignore (from_bytes string) in Generator.Plain {workload; closure}) diff --git a/src/lib_shell_benchmarks/io_benchmarks.ml b/src/lib_shell_benchmarks/io_benchmarks.ml index 8ff2c02dc502..57e69c6cb71b 100644 --- a/src/lib_shell_benchmarks/io_benchmarks.ml +++ b/src/lib_shell_benchmarks/io_benchmarks.ml @@ -56,7 +56,7 @@ module Helpers = struct let random_contents rng_state base_dir index context key_set commit_batch_size = let open Lwt_syntax in - let* (index, context, _) = + let* index, context, _ = Key_map.fold_lwt (fun path size (index, context, current_commit_batch_size) -> let* context = @@ -66,7 +66,7 @@ module Helpers = struct Lwt.return (index, context, current_commit_batch_size + 1) else (* save and proceed with fresh diff *) - let* (context, index) = + let* context, index = Io_helpers.commit_and_reload base_dir index context in Lwt.return (index, context, 0)) @@ -99,12 +99,12 @@ module Helpers = struct Io_helpers.assert_ok ~msg:"Io_helpers.prepare_empty_context" @@ Lwt_main.run (Io_helpers.prepare_empty_context base_dir) in - let (context, index) = + let context, index = Io_helpers.load_context_from_disk base_dir context_hash in Lwt_main.run (let open Lwt_syntax in - let* (context, index) = + let* context, index = random_contents rng_state base_dir index context keys commit_batch_size in Io_helpers.commit_and_reload base_dir index context) @@ -264,7 +264,7 @@ module Context_size_dependent_read_bench : Benchmark.S = struct ~key_card:cfg.key_card ~insertions in - let (random_key, value_size) = sample_accessed_key rng_state cfg keys in + let random_key, value_size = sample_accessed_key rng_state cfg keys in let keys = Key_map.insert random_key value_size keys in Format.eprintf "preparing bench: insertions = %d@." insertions ; let closure context = @@ -291,7 +291,7 @@ module Context_size_dependent_read_bench : Benchmark.S = struct let with_context f = let base_dir = Filename.temp_file ?temp_dir:cfg.temp_dir name "" in Io_helpers.prepare_base_dir base_dir ; - let (context, index) = + let context, index = Helpers.prepare_random_context rng_state base_dir @@ -350,7 +350,7 @@ module Context_size_dependent_write_bench : Benchmark.S = struct ~key_card:cfg.key_card ~insertions in - let (random_key, value_size) = sample_accessed_key rng_state cfg keys in + let random_key, value_size = sample_accessed_key rng_state cfg keys in Format.eprintf "preparing bench: insertions = %d@." insertions ; let closure context = Lwt_main.run @@ -371,7 +371,7 @@ module Context_size_dependent_write_bench : Benchmark.S = struct let with_context f = let base_dir = Filename.temp_file ?temp_dir:cfg.temp_dir name "" in Io_helpers.prepare_base_dir base_dir ; - let (context, index) = + let context, index = Helpers.prepare_random_context rng_state base_dir @@ -525,7 +525,7 @@ module Irmin_pack_read_bench : Benchmark.S = struct "Irmin_pack_read_bench: irmin_pack_max_width < 256, invalid \ configuration" else - let (_prefix, directories) = + let _prefix, directories = sample_irmin_directory rng_state ~cfg ~key_set in let dir_width = Array.length directories in @@ -605,7 +605,7 @@ module Irmin_pack_read_bench : Benchmark.S = struct ~key_card:cfg.key_card ~insertions in - let (target_key, value_size, keys, irmin_pack_paths) = + let target_key, value_size, keys, irmin_pack_paths = prepare_irmin_directory rng_state ~cfg ~key_set:keys in let irmin_width = Array.length irmin_pack_paths in @@ -635,7 +635,7 @@ module Irmin_pack_read_bench : Benchmark.S = struct let with_context f = let base_dir = Filename.temp_file ?temp_dir:cfg.temp_dir name "" in Io_helpers.prepare_base_dir base_dir ; - let (context, index) = + let context, index = Helpers.prepare_random_context rng_state base_dir @@ -675,12 +675,12 @@ module Irmin_pack_write_bench : Benchmark.S = struct "Irmin_pack_read_bench: irmin_pack_max_width < 256, invalid \ configuration" else - let (_prefix, directories) = + let _prefix, directories = sample_irmin_directory rng_state ~cfg ~key_set in let total_keys_in_pack = Array.length directories in let number_of_keys_written = Random.int total_keys_in_pack in - let (keys_written_to, keys_not_written_to) = + let keys_written_to, keys_not_written_to = Io_helpers.sample_without_replacement number_of_keys_written (Array.to_list directories) @@ -798,7 +798,7 @@ module Irmin_pack_write_bench : Benchmark.S = struct in let with_context f = Io_helpers.prepare_base_dir base_dir ; - let (context, index) = + let context, index = Helpers.prepare_random_context rng_state base_dir @@ -916,10 +916,10 @@ module Read_random_key_bench : Benchmark.S = struct let make_bench rng_state config keys () = let card = Array.length keys in assert (card > 0) ; - let (key, value_size) = keys.(Random.State.int rng_state card) in + let key, value_size = keys.(Random.State.int rng_state card) in let with_context f = - let (context, index) = - let (base_dir, context_hash) = config.existing_context in + let context, index = + let base_dir, context_hash = config.existing_context in Io_helpers.load_context_from_disk base_dir context_hash in let finalizer () = @@ -949,7 +949,7 @@ module Read_random_key_bench : Benchmark.S = struct Generator.With_context {workload; closure; with_context} let create_benchmarks ~rng_state ~bench_num config = - let (base_dir, context_hash) = config.existing_context in + let base_dir, context_hash = config.existing_context in let tree = Io_helpers.with_context ~base_dir ~context_hash (fun context -> Io_stats.load_tree context config.subdirectory) @@ -1076,10 +1076,10 @@ module Write_random_keys_bench : Benchmark.S = struct total_keys_in_directory (Random.State.int rng_state cfg.max_written_keys) in - let (keys_written_to, _keys_not_written_to) = + let keys_written_to, _keys_not_written_to = Io_helpers.sample_without_replacement number_of_keys_written keys in - let (source_base_dir, context_hash) = cfg.existing_context in + let source_base_dir, context_hash = cfg.existing_context in let value_size = Base_samplers.sample_in_interval rng_state ~range:cfg.storage_chunks * cfg.storage_chunk_bytes @@ -1091,7 +1091,7 @@ module Write_random_keys_bench : Benchmark.S = struct in Io_helpers.copy_rec source_base_dir target_base_dir ; Format.eprintf "Finished copying original context to %s@." target_base_dir ; - let (context, index) = + let context, index = Io_helpers.load_context_from_disk target_base_dir context_hash in let context = @@ -1133,7 +1133,7 @@ module Write_random_keys_bench : Benchmark.S = struct Generator.With_context {workload; closure; with_context} let create_benchmarks ~rng_state ~bench_num config = - let (base_dir, context_hash) = config.existing_context in + let base_dir, context_hash = config.existing_context in let tree = Io_helpers.with_context ~base_dir ~context_hash (fun context -> Io_stats.load_tree context config.subdirectory) diff --git a/src/lib_shell_benchmarks/io_helpers.ml b/src/lib_shell_benchmarks/io_helpers.ml index 4dd72bb35afb..eeee5e19925a 100644 --- a/src/lib_shell_benchmarks/io_helpers.ml +++ b/src/lib_shell_benchmarks/io_helpers.ml @@ -66,7 +66,7 @@ let commit context = let prepare_empty_context base_dir = let open Lwt_result_syntax in - let* (index, context, _context_hash) = prepare_genesis base_dir in + let* index, context, _context_hash = prepare_genesis base_dir in let*! context_hash = commit context in let*! () = Tezos_context.Context.close index in return context_hash @@ -85,7 +85,7 @@ let load_context_from_disk base_dir context_hash = Lwt_main.run (load_context_from_disk_lwt base_dir context_hash) let with_context ~base_dir ~context_hash f = - let (context, index) = load_context_from_disk base_dir context_hash in + let context, index = load_context_from_disk base_dir context_hash in Lwt_main.run (let open Lwt_syntax in let* res = f context in @@ -151,30 +151,30 @@ module Key_map = struct if is_empty tree then `Key_does_not_collide else match (key, tree) with - | ([], Leaf _) -> `Key_exists - | (_, Leaf _) -> `Key_has_prefix - | ([], Node _) -> `Key_has_suffix - | (seg :: tl, Node map) -> ( + | [], Leaf _ -> `Key_exists + | _, Leaf _ -> `Key_has_prefix + | [], Node _ -> `Key_has_suffix + | seg :: tl, Node map -> ( match String_map.find_opt seg map with | None -> `Key_does_not_collide | Some subtree -> does_not_collide tl subtree) let rec mem key tree = match (key, tree) with - | ([], Leaf _) -> true - | (_, Leaf _) -> false - | ([], Node _) -> false - | (seg :: tl, Node map) -> ( + | [], Leaf _ -> true + | _, Leaf _ -> false + | [], Node _ -> false + | seg :: tl, Node map -> ( match String_map.find_opt seg map with | None -> false | Some subtree -> mem tl subtree) let rec find_opt key tree = match (key, tree) with - | ([], Leaf v) -> Some v - | (_ :: _, Leaf _) -> None - | ([], Node _) -> None - | (seg :: tl, Node map) -> ( + | [], Leaf v -> Some v + | _ :: _, Leaf _ -> None + | [], Node _ -> None + | seg :: tl, Node map -> ( match String_map.find_opt seg map with | None -> None | Some subtree -> find_opt tl subtree) @@ -220,7 +220,7 @@ let rec take_n n list acc = | x :: tl -> take_n (n - 1) tl (x :: acc) let sample_without_replacement n list = - let (first_n, rest) = take_n n list [] in + let first_n, rest = take_n n list [] in let reservoir = Array.of_list first_n in let reject = ref [] in List.iteri diff --git a/src/lib_shell_benchmarks/io_stats.ml b/src/lib_shell_benchmarks/io_stats.ml index 9f4e8d6b4927..9460852d924c 100644 --- a/src/lib_shell_benchmarks/io_stats.ml +++ b/src/lib_shell_benchmarks/io_stats.ml @@ -46,7 +46,7 @@ let min_max (l : int list) = loop l max_int ~-1 let pp fmtr {total; keys; dirs; degrees = _; depths = _; sizes} = - let (min_size, max_size) = min_max sizes in + let min_size, max_size = min_max sizes in Format.fprintf fmtr "{ total = %d; keys = %d ; dirs = %d; sizes in [%d; %d] degrees = ...; \ @@ -82,7 +82,7 @@ let tree_statistics key_map = map (degrees, depths, sizes) in - let (degrees, depths, sizes) = loop key_map 0 [] [] [] in + let degrees, depths, sizes = loop key_map 0 [] [] [] in {total = !nodes; keys = !keys; dirs = !dirs; degrees; depths; sizes} let load_tree context key = @@ -102,7 +102,7 @@ let load_tree context key = let context_statistics base_dir context_hash = let open Lwt_syntax in - let (context, index) = + let context, index = Io_helpers.load_context_from_disk base_dir context_hash in let* tree = load_tree context [] in diff --git a/src/lib_shell_services/block_services.ml b/src/lib_shell_services/block_services.ml index 59c6236eba0b..29cf8a99416e 100644 --- a/src/lib_shell_services/block_services.ml +++ b/src/lib_shell_services/block_services.ml @@ -94,33 +94,33 @@ let parse_block s = in try match split_on_delim (count_delims s) with - | (["genesis"], _) -> Ok `Genesis - | (["genesis"; n], '+') -> Ok (`Level (Int32.of_string n)) - | (["head"], _) -> Ok (`Head 0) - | (["head"; n], '~') | (["head"; n], '-') -> Ok (`Head (int_of_string n)) - | (["checkpoint"], _) -> Ok (`Alias (`Checkpoint, 0)) - | (["checkpoint"; n], '~') | (["checkpoint"; n], '-') -> + | ["genesis"], _ -> Ok `Genesis + | ["genesis"; n], '+' -> Ok (`Level (Int32.of_string n)) + | ["head"], _ -> Ok (`Head 0) + | ["head"; n], '~' | ["head"; n], '-' -> Ok (`Head (int_of_string n)) + | ["checkpoint"], _ -> Ok (`Alias (`Checkpoint, 0)) + | ["checkpoint"; n], '~' | ["checkpoint"; n], '-' -> Ok (`Alias (`Checkpoint, int_of_string n)) - | (["checkpoint"; n], '+') -> Ok (`Alias (`Checkpoint, -int_of_string n)) - | (["savepoint"], _) -> Ok (`Alias (`Savepoint, 0)) - | (["savepoint"; n], '~') | (["savepoint"; n], '-') -> + | ["checkpoint"; n], '+' -> Ok (`Alias (`Checkpoint, -int_of_string n)) + | ["savepoint"], _ -> Ok (`Alias (`Savepoint, 0)) + | ["savepoint"; n], '~' | ["savepoint"; n], '-' -> Ok (`Alias (`Savepoint, int_of_string n)) - | (["savepoint"; n], '+') -> Ok (`Alias (`Savepoint, -int_of_string n)) - | (["caboose"], _) -> Ok (`Alias (`Caboose, 0)) - | (["caboose"; n], '~') | (["caboose"; n], '-') -> + | ["savepoint"; n], '+' -> Ok (`Alias (`Savepoint, -int_of_string n)) + | ["caboose"], _ -> Ok (`Alias (`Caboose, 0)) + | ["caboose"; n], '~' | ["caboose"; n], '-' -> Ok (`Alias (`Caboose, int_of_string n)) - | (["caboose"; n], '+') -> Ok (`Alias (`Caboose, -int_of_string n)) - | ([hol], _) -> ( + | ["caboose"; n], '+' -> Ok (`Alias (`Caboose, -int_of_string n)) + | [hol], _ -> ( match Block_hash.of_b58check_opt hol with | Some h -> Ok (`Hash (h, 0)) | None -> to_level (to_valid_level_id s)) - | ([hol; n], '~') | ([hol; n], '-') -> ( + | [hol; n], '~' | [hol; n], '-' -> ( match Block_hash.of_b58check_opt hol with | Some h -> Ok (`Hash (h, int_of_string n)) | None -> let offset = to_valid_level_id n in to_level ~offset (to_valid_level_id hol)) - | ([hol; n], '+') -> ( + | [hol; n], '+' -> ( match Block_hash.of_b58check_opt hol with | Some h -> Ok (`Hash (h, -int_of_string n)) | None -> @@ -188,9 +188,9 @@ type raw_context = Key of Bytes.t | Dir of raw_context String.Map.t | Cut let rec raw_context_eq rc1 rc2 = match (rc1, rc2) with - | (Key bytes1, Key bytes2) -> Bytes.equal bytes1 bytes2 - | (Dir dir1, Dir dir2) -> String.Map.(equal raw_context_eq dir1 dir2) - | (Cut, Cut) -> true + | Key bytes1, Key bytes2 -> Bytes.equal bytes1 bytes2 + | Dir dir1, Dir dir2 -> String.Map.(equal raw_context_eq dir1 dir2) + | Cut, Cut -> true | _ -> false let rec pp_raw_context ppf = function @@ -263,9 +263,9 @@ and merkle_tree = merkle_node String.Map.t let rec merkle_node_eq n1 n2 = match (n1, n2) with - | (Hash (mhk1, s1), Hash (mhk2, s2)) -> mhk1 = mhk2 && String.equal s1 s2 - | (Data rc1, Data rc2) -> raw_context_eq rc1 rc2 - | (Continue mtree1, Continue mtree2) -> merkle_tree_eq mtree1 mtree2 + | Hash (mhk1, s1), Hash (mhk2, s2) -> mhk1 = mhk2 && String.equal s1 s2 + | Data rc1, Data rc2 -> raw_context_eq rc1 rc2 + | Continue mtree1, Continue mtree2 -> merkle_tree_eq mtree1 mtree2 | _ -> false and merkle_tree_eq mtree1 mtree2 = String.Map.equal merkle_node_eq mtree1 mtree2 @@ -516,25 +516,23 @@ module Make (Proto : PROTO) (Next_proto : PROTO) = struct Proto.operation_data_encoding (obj1 (req "metadata" (constant "too large")))) (function - | (operation_data, Too_large) -> Some (operation_data, ()) - | _ -> None) + | operation_data, Too_large -> Some (operation_data, ()) | _ -> None) (fun (operation_data, ()) -> (operation_data, Too_large)); case ~title:"Operation without metadata" (Tag 1) Proto.operation_data_encoding - (function - | (operation_data, Empty) -> Some operation_data | _ -> None) + (function operation_data, Empty -> Some operation_data | _ -> None) (fun operation_data -> (operation_data, Empty)); case ~title:"Operation with metadata" (Tag 2) Proto.operation_data_and_receipt_encoding (function - | (operation_data, Receipt receipt) -> Some (operation_data, receipt) + | operation_data, Receipt receipt -> Some (operation_data, receipt) | _ -> None) (function - | (operation_data, receipt) -> (operation_data, Receipt receipt)); + | operation_data, receipt -> (operation_data, Receipt receipt)); ] let operation_encoding = diff --git a/src/lib_shell_services/history_mode.ml b/src/lib_shell_services/history_mode.ml index bff8d4b3aeb7..5f08b22a5468 100644 --- a/src/lib_shell_services/history_mode.ml +++ b/src/lib_shell_services/history_mode.ml @@ -156,16 +156,14 @@ let encoding = let equal hm1 hm2 = match (hm1, hm2) with - | (Archive, Archive) | (Full None, Full None) | (Rolling None, Rolling None) - -> - true - | (Full (Some {offset}), Full (Some {offset = offset'})) - | (Rolling (Some {offset}), Rolling (Some {offset = offset'})) -> + | Archive, Archive | Full None, Full None | Rolling None, Rolling None -> true + | Full (Some {offset}), Full (Some {offset = offset'}) + | Rolling (Some {offset}), Rolling (Some {offset = offset'}) -> Compare.Int.(offset = offset') - | ((full, Full (Some {offset})) | (Full (Some {offset}), full)) + | (full, Full (Some {offset}) | Full (Some {offset}), full) when offset = default_offset && full = default_full -> true - | ((rolling, Rolling (Some {offset})) | (Rolling (Some {offset}), rolling)) + | (rolling, Rolling (Some {offset}) | Rolling (Some {offset}), rolling) when offset = default_offset && rolling = default_rolling -> true | _ -> false diff --git a/src/lib_shell_services/peer_validator_worker_state.ml b/src/lib_shell_services/peer_validator_worker_state.ml index bcade1b3cc82..39ad35d83a59 100644 --- a/src/lib_shell_services/peer_validator_worker_state.ml +++ b/src/lib_shell_services/peer_validator_worker_state.ml @@ -409,6 +409,6 @@ let pipeline_length_encoding = | {fetched_header_length; fetched_block_length} -> (fetched_header_length, fetched_block_length)) (function - | (fetched_header_length, fetched_block_length) -> + | fetched_header_length, fetched_block_length -> {fetched_header_length; fetched_block_length}) (obj2 (req "fetched_headers" int31) (req "fetched_blocks" int31)) diff --git a/src/lib_shell_services/prevalidator_worker_state.ml b/src/lib_shell_services/prevalidator_worker_state.ml index 53e7092176fc..05097d0d83fc 100644 --- a/src/lib_shell_services/prevalidator_worker_state.ml +++ b/src/lib_shell_services/prevalidator_worker_state.ml @@ -165,7 +165,7 @@ module Operation_encountered = struct (obj2 (req "situation" (constant "injected")) (req "operation" Operation_hash.encoding)) - (function (Injected, oph) -> Some ((), oph) | _ -> None) + (function Injected, oph -> Some ((), oph) | _ -> None) (fun ((), oph) -> (Injected, oph)); case (Tag 1) @@ -173,7 +173,7 @@ module Operation_encountered = struct (obj2 (req "situation" (constant "arrived")) (req "operation" Operation_hash.encoding)) - (function (Arrived, oph) -> Some ((), oph) | _ -> None) + (function Arrived, oph -> Some ((), oph) | _ -> None) (fun ((), oph) -> (Arrived, oph)); case (Tag 2) @@ -182,7 +182,7 @@ module Operation_encountered = struct (req "situation" (constant "notified")) (req "operation" Operation_hash.encoding) (req "peer" (option P2p_peer_id.encoding))) - (function (Notified peer, oph) -> Some ((), oph, peer) | _ -> None) + (function Notified peer, oph -> Some ((), oph, peer) | _ -> None) (fun ((), oph, peer) -> (Notified peer, oph)); case (Tag 3) @@ -190,7 +190,7 @@ module Operation_encountered = struct (obj2 (req "situation" (constant "other")) (req "operation" Operation_hash.encoding)) - (function (Other, hash) -> Some ((), hash) | _ -> None) + (function Other, hash -> Some ((), hash) | _ -> None) (fun ((), oph) -> (Other, oph)); ] diff --git a/src/lib_shell_services/store_errors.ml b/src/lib_shell_services/store_errors.ml index c5d39fbfd12a..ab03160ed76e 100644 --- a/src/lib_shell_services/store_errors.ml +++ b/src/lib_shell_services/store_errors.ml @@ -1105,8 +1105,8 @@ let () = ppf "Invariant '%ld (genesis) ≤ %ld (caboose) ≤ %ld (savepoint) ≤ %a \ [cementing_highwatermark] ≤\n\ - \ %ld (checkpoint) ≤ all(alternate_heads ∪ (%ld) current_head)' \ - does not hold" + \ %ld (checkpoint) ≤ all(alternate_heads ∪ (%ld) current_head)' does \ + not hold" genesis caboose savepoint diff --git a/src/lib_signer_backends/encrypted.ml b/src/lib_signer_backends/encrypted.ml index bc0ab30ea68d..591c21f989cf 100644 --- a/src/lib_signer_backends/encrypted.ml +++ b/src/lib_signer_backends/encrypted.ml @@ -91,8 +91,8 @@ module Raw = struct match (Crypto_box.Secretbox.secretbox_open key encrypted_sk nonce, algo) with - | (None, _) -> return_none - | (Some bytes, Encrypted_sk Signature.Ed25519) -> ( + | None, _ -> return_none + | Some bytes, Encrypted_sk Signature.Ed25519 -> ( match Data_encoding.Binary.of_bytes_opt Ed25519.Secret_key.encoding bytes with @@ -102,7 +102,7 @@ module Raw = struct failwith "Corrupted wallet, deciphered key is not a valid Ed25519 secret \ key") - | (Some bytes, Encrypted_sk Signature.Secp256k1) -> ( + | Some bytes, Encrypted_sk Signature.Secp256k1 -> ( match Data_encoding.Binary.of_bytes_opt Secp256k1.Secret_key.encoding bytes with @@ -112,7 +112,7 @@ module Raw = struct failwith "Corrupted wallet, deciphered key is not a valid Secp256k1 \ secret key") - | (Some bytes, Encrypted_sk Signature.P256) -> ( + | Some bytes, Encrypted_sk Signature.P256 -> ( match Data_encoding.Binary.of_bytes_opt P256.Secret_key.encoding bytes with @@ -121,7 +121,7 @@ module Raw = struct | None -> failwith "Corrupted wallet, deciphered key is not a valid P256 secret key") - | (Some bytes, Encrypted_aggregate_sk) -> ( + | Some bytes, Encrypted_aggregate_sk -> ( match Data_encoding.Binary.of_bytes_opt Bls.Secret_key.encoding bytes with @@ -270,7 +270,7 @@ let rec noninteractive_decrypt_loop algo ~encrypted_sk = let decrypt_payload cctxt ?name encrypted_sk = let open Lwt_result_syntax in - let* (algo, encrypted_sk) = + let* algo, encrypted_sk = match Base58.decode encrypted_sk with | Some (Encrypted_ed25519 encrypted_sk) -> return (Encrypted_sk Signature.Ed25519, encrypted_sk) diff --git a/src/lib_signer_backends/http_gen.ml b/src/lib_signer_backends/http_gen.ml index 6bad86381904..250fc27fb248 100644 --- a/src/lib_signer_backends/http_gen.ml +++ b/src/lib_signer_backends/http_gen.ml @@ -95,7 +95,7 @@ struct let open Lwt_result_syntax in assert (Uri.scheme uri = Some scheme) ; let path = Uri.path uri in - let* (base, pkh) = + let* base, pkh = match String.rindex_opt path '/' with | None -> failwith "Invalid locator %a" Uri.pp_hum uri | Some i -> @@ -111,7 +111,7 @@ struct let public_key uri = let open Lwt_result_syntax in - let* (base, pkh) = parse (uri : pk_uri :> Uri.t) in + let* base, pkh = parse (uri : pk_uri :> Uri.t) in RPC_client.call_service ~logger:P.logger ?headers @@ -159,7 +159,7 @@ struct let sign ?watermark uri msg = let open Lwt_result_syntax in - let* (base, pkh) = parse (uri : sk_uri :> Uri.t) in + let* base, pkh = parse (uri : sk_uri :> Uri.t) in let msg = match watermark with | None -> msg @@ -179,7 +179,7 @@ struct let deterministic_nonce uri msg = let open Lwt_result_syntax in - let* (base, pkh) = parse (uri : sk_uri :> Uri.t) in + let* base, pkh = parse (uri : sk_uri :> Uri.t) in let* signature = get_signature base pkh msg in RPC_client.call_service ~logger:P.logger @@ -193,7 +193,7 @@ struct let deterministic_nonce_hash uri msg = let open Lwt_result_syntax in - let* (base, pkh) = parse (uri : sk_uri :> Uri.t) in + let* base, pkh = parse (uri : sk_uri :> Uri.t) in let* signature = get_signature base pkh msg in RPC_client.call_service ~logger:P.logger @@ -207,7 +207,7 @@ struct let supports_deterministic_nonces uri = let open Lwt_result_syntax in - let* (base, pkh) = parse (uri : sk_uri :> Uri.t) in + let* base, pkh = parse (uri : sk_uri :> Uri.t) in let*! r = RPC_client.call_service ~logger:P.logger diff --git a/src/lib_signer_backends/test/test_encrypted.ml b/src/lib_signer_backends/test/test_encrypted.ml index ba15c25c616e..a75323e5ec33 100644 --- a/src/lib_signer_backends/test/test_encrypted.ml +++ b/src/lib_signer_backends/test/test_encrypted.ml @@ -223,7 +223,7 @@ let test_random algo = let open Lwt_result_syntax in if i >= loops then return_unit else - let (_, _, sk) = Signature.generate_key ~algo () in + let _, _, sk = Signature.generate_key ~algo () in let* sk_uri = Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt ctx sk in @@ -241,7 +241,7 @@ let test_random_aggregate () = let open Lwt_result_syntax in if i >= loops then return_unit else - let (_, _, sk) = Aggregate_signature.generate_key () in + let _, _, sk = Aggregate_signature.generate_key () in let* sk_uri = Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt_aggregate ctx diff --git a/src/lib_signer_backends/unix/ledger.available.ml b/src/lib_signer_backends/unix/ledger.available.ml index f496efa7f8c5..2bf526f9229b 100644 --- a/src/lib_signer_backends/unix/ledger.available.ml +++ b/src/lib_signer_backends/unix/ledger.available.ml @@ -292,7 +292,7 @@ module Ledger_commands = struct Bytes.cat (Signature.bytes_of_watermark watermark) base_msg) in let path = Bip32_path.tezos_root @ path in - let* (hash_opt, signature) = + let* hash_opt, signature = wrap_ledger_cmd (fun pp -> let {Ledgerwallet_tezos.Version.major; minor; patch; _} = version in let open Result_syntax in @@ -302,7 +302,7 @@ module Ledger_commands = struct in Ok (None, s) else - let* (h, s) = + let* h, s = Ledgerwallet_tezos.sign_and_hash ~pp hid @@ -453,7 +453,7 @@ module Ledger_uri = struct let components = String.split_no_empty '/' (Uri.path uri) in match components with | s :: tl -> - let (curve, more_path) = + let curve, more_path = match Ledgerwallet_tezos.curve_of_string s with | Some curve -> (curve, tl) | None -> (Ledger_id.curve, s :: tl) @@ -669,7 +669,7 @@ let use_ledger_or_fail ~ledger_uri ?filter ?msg f = pp_curve curve Version.pp - (let (a, b, c) = min_version_of_derivation_scheme curve in + (let a, b, c = min_version_of_derivation_scheme curve in {version with major = a; minor = b; patch = c}) Version.pp version) @@ -933,7 +933,7 @@ let generic_commands group = "; " (List.map (Printf.sprintf "0x%lX") full_path)) in - let* (pkh, pk) = + let* pkh, pk = Ledger_commands.public_key_hash hidapi curve path in let*! () = @@ -949,7 +949,7 @@ let generic_commands group = pkh in match (test_sign, version.app_class) with - | (true, Tezos) -> ( + | true, Tezos -> ( let pkh_bytes = Signature.Public_key_hash.to_bytes pkh in @@ -990,11 +990,11 @@ let generic_commands group = signature in return_unit) - | (true, TezBake) -> + | true, TezBake -> failwith "Option --test-sign only works for the Tezos Wallet \ app." - | (false, _) -> return_unit) + | false, _ -> return_unit) | `Ledger _ when test_sign -> failwith "Option --test-sign only works with a full ledger \ @@ -1320,7 +1320,7 @@ let high_water_mark_commands group watermark_spelling = "Fatal: this operation is only valid with the Tezos Baking \ application" | TezBake when (not no_legacy_apdu) && version.major < 2 -> - let* (hwm, hwm_round_opt) = + let* hwm, hwm_round_opt = Ledger_commands.wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_high_watermark ~pp hidapi) in @@ -1341,7 +1341,7 @@ let high_water_mark_commands group watermark_spelling = Ledgerwallet_tezos.Version.pp version | TezBake -> - let* (`Main_hwm (mh, mr), `Test_hwm (th, tr), `Chain_id ci) = + let* `Main_hwm (mh, mr), `Test_hwm (th, tr), `Chain_id ci = Ledger_commands.wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_all_high_watermarks ~pp hidapi) in @@ -1387,7 +1387,7 @@ let high_water_mark_commands group watermark_spelling = Ledger_commands.wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.set_high_watermark ~pp hidapi hwm) in - let* (new_hwm, new_hwm_round_opt) = + let* new_hwm, new_hwm_round_opt = Ledger_commands.wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_high_watermark ~pp hidapi) in diff --git a/src/lib_signer_backends/unix/remote.ml b/src/lib_signer_backends/unix/remote.ml index a3c092be4f86..79d9a4b898c9 100644 --- a/src/lib_signer_backends/unix/remote.ml +++ b/src/lib_signer_backends/unix/remote.ml @@ -141,9 +141,9 @@ let read_base_uri_from_env () = Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST", Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" ) with - | (None, None, None, None) -> return_none - | (Some path, None, None, None) -> return_some (Socket.make_unix_base path) - | (None, Some host, None, None) -> ( + | None, None, None, None -> return_none + | Some path, None, None, None -> return_some (Socket.make_unix_base path) + | None, Some host, None, None -> ( try let port = match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" with @@ -153,7 +153,7 @@ let read_base_uri_from_env () = return_some (Socket.make_tcp_base host port) with Invalid_argument _ -> failwith "Failed to parse TEZOS_SIGNER_TCP_PORT.@.") - | (None, None, Some host, None) -> ( + | None, None, Some host, None -> ( try let port = match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" with @@ -163,7 +163,7 @@ let read_base_uri_from_env () = return_some (Http.make_base host port) with Invalid_argument _ -> failwith "Failed to parse TEZOS_SIGNER_HTTP_PORT.@.") - | (None, None, None, Some host) -> ( + | None, None, None, Some host -> ( try let port = match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" with @@ -173,7 +173,7 @@ let read_base_uri_from_env () = return_some (Https.make_base host port) with Invalid_argument _ -> failwith "Failed to parse TEZOS_SIGNER_HTTPS_PORT.@.") - | (_, _, _, _) -> + | _, _, _, _ -> failwith "Only one the following environment variable must be defined: \ TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, \ diff --git a/src/lib_signer_backends/unix/socket.ml b/src/lib_signer_backends/unix/socket.ml index f96dd29cd5ae..072d4773e90d 100644 --- a/src/lib_signer_backends/unix/socket.ml +++ b/src/lib_signer_backends/unix/socket.ml @@ -173,7 +173,7 @@ struct let public_key uri = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : pk_uri :> Uri.t) in + let* path, pkh = parse (uri : pk_uri :> Uri.t) in public_key path pkh let neuterize uri = @@ -190,22 +190,22 @@ struct let sign ?watermark uri msg = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : sk_uri :> Uri.t) in + let* path, pkh = parse (uri : sk_uri :> Uri.t) in sign ?watermark path pkh msg let deterministic_nonce uri msg = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : sk_uri :> Uri.t) in + let* path, pkh = parse (uri : sk_uri :> Uri.t) in deterministic_nonce path pkh msg let deterministic_nonce_hash uri msg = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : sk_uri :> Uri.t) in + let* path, pkh = parse (uri : sk_uri :> Uri.t) in deterministic_nonce_hash path pkh msg let supports_deterministic_nonces uri = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : sk_uri :> Uri.t) in + let* path, pkh = parse (uri : sk_uri :> Uri.t) in supports_deterministic_nonces path pkh end @@ -224,9 +224,9 @@ struct let open Result_syntax in assert (Uri.scheme uri = Some scheme) ; match (Uri.host uri, Uri.port uri) with - | (None, _) -> error_with "Missing host address" - | (_, None) -> error_with "Missing host port" - | (Some path, Some port) -> + | None, _ -> error_with "Missing host address" + | _, None -> error_with "Missing host port" + | Some path, Some port -> let pkh = Uri.path uri in let pkh = try String.(sub pkh 1 (length pkh - 1)) with _ -> "" in let+ pkh = Signature.Public_key_hash.of_b58check pkh in @@ -240,7 +240,7 @@ struct let public_key uri = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : pk_uri :> Uri.t) in + let* path, pkh = parse (uri : pk_uri :> Uri.t) in public_key path pkh let neuterize uri = @@ -257,22 +257,22 @@ struct let sign ?watermark uri msg = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : sk_uri :> Uri.t) in + let* path, pkh = parse (uri : sk_uri :> Uri.t) in sign ?watermark path pkh msg let deterministic_nonce uri msg = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : sk_uri :> Uri.t) in + let* path, pkh = parse (uri : sk_uri :> Uri.t) in deterministic_nonce path pkh msg let deterministic_nonce_hash uri msg = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : sk_uri :> Uri.t) in + let* path, pkh = parse (uri : sk_uri :> Uri.t) in deterministic_nonce_hash path pkh msg let supports_deterministic_nonces uri = let open Lwt_result_syntax in - let* (path, pkh) = parse (uri : sk_uri :> Uri.t) in + let* path, pkh = parse (uri : sk_uri :> Uri.t) in supports_deterministic_nonces path pkh end end diff --git a/src/lib_stdlib/bloomer.ml b/src/lib_stdlib/bloomer.ml index 41132ce2c90f..99065cbc5644 100644 --- a/src/lib_stdlib/bloomer.ml +++ b/src/lib_stdlib/bloomer.ml @@ -59,7 +59,7 @@ let check_peek_poke_args fname bytes ofs bits = The function proceeds by iteratively blitting the bytes overlapping the sought bit interval into [v]. The superfluous bits at the beginning and at the end are then removed from [v], yielding the returned value. - *) +*) let peek_unsafe bytes ofs bits = let first = ofs / 8 in let last = first + (((ofs mod 8) + bits + 7) / 8) in @@ -407,7 +407,7 @@ let%test_unit "false_positive_rate" = (fun i -> Char.chr (Hashtbl.hash (v, i) mod 256)) in let bloomer = create ~hash ~index_bits ~hashes ~countdown_bits in - let (add, cur) = + let add, cur = let cur = ref 0 in ( (fun n -> for _ = 1 to n do @@ -454,7 +454,7 @@ let%test_unit "false_positive_rate" = match Sys.getenv_opt "BLOOMER_TEST_GNUPLOT_PATH" with | Some path -> for run = 0 to Array.length runs - 1 do - let (kb, index_bits, hashes, values) = data.(run) in + let kb, index_bits, hashes, values = data.(run) in (let fp = open_out (Format.asprintf "%s/run_%02d.plot" path run) in Printf.fprintf fp diff --git a/src/lib_stdlib/circular_buffer.ml b/src/lib_stdlib/circular_buffer.ml index 5353af601e68..adc5e685f08d 100644 --- a/src/lib_stdlib/circular_buffer.ml +++ b/src/lib_stdlib/circular_buffer.ml @@ -49,7 +49,7 @@ let create ?(maxlength = 1 lsl 15) ?(fresh_buf_size = 2000) () = (* Invariant: - There is no two concurrent write at the same time - read should be called in the same order than write - *) +*) (* [get_buf_with_offset t write_len] Find a place where [write_len] data can be written onto the buffer [t]. @@ -178,7 +178,7 @@ let write ~maxlen ~fill_using t = Lwt.return {offset = t.data_end; length = 0; buf = t.buffer} else let open Lwt.Syntax in - let (buf, offset) = get_buf_with_offset t maxlen in + let buf, offset = get_buf_with_offset t maxlen in let maxlen = if buf == t.buffer then maxlen else min t.fresh_buf_size maxlen in diff --git a/src/lib_stdlib/compare.ml b/src/lib_stdlib/compare.ml index fb88fc245bdb..78b288bcacc9 100644 --- a/src/lib_stdlib/compare.ml +++ b/src/lib_stdlib/compare.ml @@ -83,10 +83,10 @@ module List (P : COMPARABLE) = Make (struct let rec compare xs ys = match (xs, ys) with - | ([], []) -> 0 - | ([], _) -> -1 - | (_, []) -> 1 - | (x :: xs, y :: ys) -> + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | x :: xs, y :: ys -> let hd = P.compare x y in if hd <> 0 then hd else compare xs ys end) @@ -96,10 +96,10 @@ module Option (P : COMPARABLE) = Make (struct let compare xs ys = match (xs, ys) with - | (None, None) -> 0 - | (None, _) -> -1 - | (_, None) -> 1 - | (Some x, Some y) -> P.compare x y + | None, None -> 0 + | None, _ -> -1 + | _, None -> 1 + | Some x, Some y -> P.compare x y end) module Result (Ok : COMPARABLE) (Error : COMPARABLE) = Make (struct @@ -109,10 +109,10 @@ module Result (Ok : COMPARABLE) (Error : COMPARABLE) = Make (struct comparison. *) let compare ra rb = match (ra, rb) with - | (Ok a, Ok b) -> Ok.compare a b - | (Error a, Error b) -> Error.compare a b - | (Ok _, Error _) -> -1 - | (Error _, Ok _) -> 1 + | Ok a, Ok b -> Ok.compare a b + | Error a, Error b -> Error.compare a b + | Ok _, Error _ -> -1 + | Error _, Ok _ -> 1 end) module Char = Make (Char) diff --git a/src/lib_stdlib/hash_queue.ml b/src/lib_stdlib/hash_queue.ml index 040e8887ed73..eec88c7cc0d0 100644 --- a/src/lib_stdlib/hash_queue.ml +++ b/src/lib_stdlib/hash_queue.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module RingoMaker : Ringo.MAP_MAKER = -(val Ringo.(map_maker ~replacement:FIFO ~overflow:Strong ~accounting:Precise)) + (val Ringo.(map_maker ~replacement:FIFO ~overflow:Strong ~accounting:Precise)) module Make (K : Hashtbl.HashedType) (V : sig diff --git a/src/lib_stdlib/lwt_dropbox.ml b/src/lib_stdlib/lwt_dropbox.ml index 907233205032..e26d1106e3a0 100644 --- a/src/lib_stdlib/lwt_dropbox.ml +++ b/src/lib_stdlib/lwt_dropbox.ml @@ -59,7 +59,7 @@ let wait_put_with_timeout ~timeout dropbox = match dropbox.put_waiter with | Some (waiter, _wakener) -> Lwt.pick [timeout; Lwt.protected waiter] | None -> - let (waiter, wakener) = Lwt.wait () in + let waiter, wakener = Lwt.wait () in dropbox.put_waiter <- Some (waiter, wakener) ; Lwt.pick [timeout; Lwt.protected waiter] @@ -67,7 +67,7 @@ let wait_put_no_timeout dropbox = match dropbox.put_waiter with | Some (waiter, _wakener) -> Lwt.protected waiter | None -> - let (waiter, wakener) = Lwt.wait () in + let waiter, wakener = Lwt.wait () in dropbox.put_waiter <- Some (waiter, wakener) ; Lwt.protected waiter diff --git a/src/lib_stdlib/lwt_idle_waiter.ml b/src/lib_stdlib/lwt_idle_waiter.ml index 0eda60eea1a1..ad3839404ee6 100644 --- a/src/lib_stdlib/lwt_idle_waiter.ml +++ b/src/lib_stdlib/lwt_idle_waiter.ml @@ -73,7 +73,7 @@ let wakeup_error u = function let rec task w f = if w.running_idle || w.prevent_tasks then ( - let (t, u) = Lwt.task () in + let t, u = Lwt.task () in w.pending_tasks <- u :: w.pending_tasks ; let* () = t in task w f) @@ -85,7 +85,7 @@ let rec task w f = unwrap_error res) let when_idle w f = - let (t, u) = Lwt.task () in + let t, u = Lwt.task () in let canceled = ref false in Lwt.on_cancel t (fun () -> canceled := true) ; let f () = diff --git a/src/lib_stdlib/lwt_pipe.ml b/src/lib_stdlib/lwt_pipe.ml index 15b0b1d8b96d..91e7918079d7 100644 --- a/src/lib_stdlib/lwt_pipe.ml +++ b/src/lib_stdlib/lwt_pipe.ml @@ -74,7 +74,7 @@ module Bounded = struct match q.push_waiter with | Some (t, _) -> Lwt.protected t | None -> - let (waiter, wakener) = Lwt.wait () in + let waiter, wakener = Lwt.wait () in q.push_waiter <- Some (waiter, wakener) ; Lwt.protected waiter @@ -82,7 +82,7 @@ module Bounded = struct match q.pop_waiter with | Some (t, _) -> Lwt.protected t | None -> - let (waiter, wakener) = Lwt.wait () in + let waiter, wakener = Lwt.wait () in q.pop_waiter <- Some (waiter, wakener) ; Lwt.protected waiter @@ -117,7 +117,7 @@ module Bounded = struct let rec pop ({closed; queue; current_size; _} as q) = if not (Queue.is_empty queue) then ( - let (elt_size, elt) = Queue.pop queue in + let elt_size, elt = Queue.pop queue in notify_pop q ; q.current_size <- current_size - elt_size ; Lwt.return elt) @@ -143,7 +143,7 @@ module Bounded = struct let rec peek ({closed; queue; _} as q) = if not (Queue.is_empty queue) then - let (_elt_size, elt) = Queue.peek queue in + let _elt_size, elt = Queue.peek queue in Lwt.return elt else if closed then Lwt.fail Closed else @@ -184,7 +184,7 @@ module Bounded = struct else if q.closed then Lwt.fail Closed else let* () = wait_push q in - let (_, element) = Queue.pop q.queue in + let _, element = Queue.pop q.queue in q.current_size <- 0 ; notify_pop q ; Lwt.return [element] @@ -227,7 +227,7 @@ module Unbounded = struct match q.push_waiter with | Some (t, _) -> Lwt.protected t | None -> - let (waiter, wakener) = Lwt.wait () in + let waiter, wakener = Lwt.wait () in q.push_waiter <- Some (waiter, wakener) ; Lwt.protected waiter diff --git a/src/lib_stdlib/lwt_utils.ml b/src/lib_stdlib/lwt_utils.ml index 9237051cd95d..29ef81def343 100644 --- a/src/lib_stdlib/lwt_utils.ml +++ b/src/lib_stdlib/lwt_utils.ml @@ -30,7 +30,7 @@ let never_ending () = fst (Lwt.wait ()) (* A worker launcher, takes a cancel callback to call upon *) let worker name ~on_event ~run ~cancel = - let (stop, stopper) = Lwt.wait () in + let stop, stopper = Lwt.wait () in let fail e = Lwt.finalize (fun () -> diff --git a/src/lib_stdlib/readOnlyArray.ml b/src/lib_stdlib/readOnlyArray.ml index e2103584b242..df2724b5018d 100644 --- a/src/lib_stdlib/readOnlyArray.ml +++ b/src/lib_stdlib/readOnlyArray.ml @@ -97,7 +97,7 @@ let fold_map f array init fallback = let rec aux accu idx = if idx > length array - 1 then accu else - let (accu, y) = f accu (Array.unsafe_get array idx) in + let accu, y = f accu (Array.unsafe_get array idx) in Array.unsafe_set output idx y ; aux accu (idx + 1) in diff --git a/src/lib_stdlib/tag.ml b/src/lib_stdlib/tag.ml index 8f630efc2e9e..a1e95499e0f5 100644 --- a/src/lib_stdlib/tag.ml +++ b/src/lib_stdlib/tag.ml @@ -172,9 +172,9 @@ let union f = merger = (fun tag a b -> match (a, b) with - | (Some aa, Some bb) -> Some (f.unioner tag aa bb) - | (Some _, None) -> a - | (None, _) -> b); + | Some aa, Some bb -> Some (f.unioner tag aa bb) + | Some _, None -> a + | None, _ -> b); } (* no compare and equal, compare especially makes little sense *) diff --git a/src/lib_stdlib/test-unix/test_circular_buffer_fuzzy.ml b/src/lib_stdlib/test-unix/test_circular_buffer_fuzzy.ml index b99db03fd43c..3bfb9f61d3c6 100644 --- a/src/lib_stdlib/test-unix/test_circular_buffer_fuzzy.ml +++ b/src/lib_stdlib/test-unix/test_circular_buffer_fuzzy.ml @@ -126,7 +126,7 @@ let rec ops_gen acc i = let open QCheck in let open Gen in ops_gen - (let* (nb_writes, ops) = acc in + (let* nb_writes, ops = acc in let gen = if nb_writes > 0 then op else write_op in map (fun op -> @@ -242,10 +242,10 @@ let () = Lwt.return_false | Read read_len -> ( try - let (left_has_raised, left_buf) = + let left_has_raised, left_buf = read_data ~without_invalid_argument read_len left_state in - let (right_has_raised, right_buf) = + let right_has_raised, right_buf = read_data ~without_invalid_argument read_len right_state in if left_has_raised then diff --git a/src/lib_stdlib/test-unix/test_hash_queue_lwt.ml b/src/lib_stdlib/test-unix/test_hash_queue_lwt.ml index cbdbb51eb2f9..94cb8ad70ccc 100644 --- a/src/lib_stdlib/test-unix/test_hash_queue_lwt.ml +++ b/src/lib_stdlib/test-unix/test_hash_queue_lwt.ml @@ -42,11 +42,11 @@ let gen_values n = let add_multiple_values q vs = List.iter (fun (k, v) -> Queue.replace q k v) vs (* Invariants: - - (key, value) are ("val", i) for i in [0, n-1] - - keys are added in increasing order, hence ("val<0>", 0) is always the oldest - value if `capacity` >= `n`. - - there is no capacity check. If n > capacity, the oldest values are replaced - *) + - (key, value) are ("val", i) for i in [0, n-1] + - keys are added in increasing order, hence ("val<0>", 0) is always the oldest + value if `capacity` >= `n`. + - there is no capacity check. If n > capacity, the oldest values are replaced +*) let init_queue capacity n = let q = Queue.create capacity in let vs = gen_values n in diff --git a/src/lib_stdlib/test/test_arrays.ml b/src/lib_stdlib/test/test_arrays.ml index 3675ffb27d63..9b393ff48bd8 100644 --- a/src/lib_stdlib/test/test_arrays.ml +++ b/src/lib_stdlib/test/test_arrays.ml @@ -30,9 +30,9 @@ {!FunctionalArray}. *) -(* TODO: https://gitlab.com/tezos/tezos/-/issues/1586 - Use monolith to improve these tests. - *) +(* TODO: https://gitlab.com/tezos/tezos/-/issues/1586 + Use monolith to improve these tests. +*) open Alcotest @@ -89,7 +89,7 @@ struct let check_out_of_bounds (s, d, _) = let a = make s d in - let (a, _) = + let a, _ = Utils.fold_n_times s (fun (a, i) -> (set a i "tezos", i + 1)) (a, 0) in if not (get a (-1) = d) then fail "get a (-1) = d" ; @@ -97,18 +97,14 @@ struct let check_iter (s, _, _) = let a = make s 0 in - let (a, _) = - Utils.fold_n_times s (fun (a, i) -> (set a i 1, i + 1)) (a, 0) - in + let a, _ = Utils.fold_n_times s (fun (a, i) -> (set a i 1, i + 1)) (a, 0) in let r = ref 0 in iter (fun x -> r := !r + x) a ; if not (!r = s) then fail "iter f a should iterate over a." let check_map (s, _, _) = let a = make s 0 in - let (a, _) = - Utils.fold_n_times s (fun (a, i) -> (set a i 1, i + 1)) (a, 0) - in + let a, _ = Utils.fold_n_times s (fun (a, i) -> (set a i 1, i + 1)) (a, 0) in let b = map succ a in let r = ref 0 in iter (fun x -> r := !r + x) b ; @@ -116,9 +112,7 @@ struct let check_fold (s, _, _) = let a = make s 100 in - let (a, _) = - Utils.fold_n_times s (fun (a, i) -> (set a i 1, i + 1)) (a, 0) - in + let a, _ = Utils.fold_n_times s (fun (a, i) -> (set a i 1, i + 1)) (a, 0) in let r' = fold ( + ) a 0 in let r = ref 0 in iter (fun x -> r := !r + x) a ; @@ -129,10 +123,8 @@ struct let check_fold_map (s, _, _) = let a = make s 100 in - let (a, _) = - Utils.fold_n_times s (fun (a, i) -> (set a i 1, i + 1)) (a, 0) - in - let (r', a') = fold_map (fun accu x -> (accu + x, x)) a 0 0 in + let a, _ = Utils.fold_n_times s (fun (a, i) -> (set a i 1, i + 1)) (a, 0) in + let r', a' = fold_map (fun accu x -> (accu + x, x)) a 0 0 in let r = ref 0 in iter (fun x -> r := !r + x) a' ; if not (!r = r') then diff --git a/src/lib_stdlib/test/test_hash_queue.ml b/src/lib_stdlib/test/test_hash_queue.ml index 12ce5e023e0c..9e4d274a2abc 100644 --- a/src/lib_stdlib/test/test_hash_queue.ml +++ b/src/lib_stdlib/test/test_hash_queue.ml @@ -50,11 +50,11 @@ let gen_values n = let add_multiple_values q vs = List.iter (fun (k, v) -> Queue.replace q k v) vs (* Invariants: - - (key, value) are ("val", i) for i in [0, n-1] - - keys are added in increasing order, hence ("val<0>", 0) is always the oldest - value if `capacity` >= `n`. - - there is no capacity check. If n > capacity, the oldest values are replaced - *) + - (key, value) are ("val", i) for i in [0, n-1] + - keys are added in increasing order, hence ("val<0>", 0) is always the oldest + value if `capacity` >= `n`. + - there is no capacity check. If n > capacity, the oldest values are replaced +*) let init_queue capacity n = let q = Queue.create capacity in let vs = gen_values n in @@ -178,7 +178,7 @@ let test_fold () = let test_elements () = let q = init_queue 10 10 in - let (_, vs) = gen_values 10 |> List.split in + let _, vs = gen_values 10 |> List.split in let elts = Queue.elements q in Assert.Int.List.equal ~loc:__LOC__ vs elts diff --git a/src/lib_stdlib/test/test_tzList.ml b/src/lib_stdlib/test/test_tzList.ml index 237f75c9d8f4..ffc37b6a1722 100644 --- a/src/lib_stdlib/test/test_tzList.ml +++ b/src/lib_stdlib/test/test_tzList.ml @@ -43,7 +43,7 @@ let test_repeat _ = let test_drop_take_split _ = let t loc n l = - let (a, b) = split_n n l in + let a, b = split_n n l in let aa = take_n n l in Assert.equal ~msg:(string_of_int __LINE__ ^ "/" ^ loc) a aa ; let bb = drop_n n l in @@ -73,7 +73,7 @@ let test_drop_take_split _ = let test_drop_take_split_rev _ = let t loc n l = - let (a, b) = rev_split_n n l in + let a, b = rev_split_n n l in let aa = rev_take_n n l in Assert.equal ~msg:(string_of_int __LINE__ ^ "/" ^ loc) a aa ; let bb = drop_n n l in diff --git a/src/lib_stdlib/test/test_tzString.ml b/src/lib_stdlib/test/test_tzString.ml index fd811a49f9d1..a18ed992f15b 100644 --- a/src/lib_stdlib/test/test_tzString.ml +++ b/src/lib_stdlib/test/test_tzString.ml @@ -1,6 +1,6 @@ (* Verify the default behavior of split is handling multiple instances of the separator in a row - *) +*) let test_split_duplicated_separator () = let inputs = [ diff --git a/src/lib_stdlib/tzList.ml b/src/lib_stdlib/tzList.ml index 27d0dd7e59b6..8939148abd88 100644 --- a/src/lib_stdlib/tzList.ml +++ b/src/lib_stdlib/tzList.ml @@ -35,7 +35,7 @@ let rev_split_n n l = loop [] n l let split_n n l = - let (rev_taken, dropped) = rev_split_n n l in + let rev_taken, dropped = rev_split_n n l in (List.rev rev_taken, dropped) let rev_take_n n l = fst (rev_split_n n l) diff --git a/src/lib_stdlib/tzString.ml b/src/lib_stdlib/tzString.ml index 4eebd094d4e7..d48ab1fac955 100644 --- a/src/lib_stdlib/tzString.ml +++ b/src/lib_stdlib/tzString.ml @@ -47,13 +47,11 @@ let split_no_empty delim ?(limit = max_int) path = else do_split acc limit i and do_split acc limit i = if limit <= 0 then - if i = l then List.rev acc - else List.rev (String.sub path i (l - i) :: acc) + if i = l then List.rev acc else List.rev (String.sub path i (l - i) :: acc) else do_component acc (pred limit) i i and do_component acc limit i j = if j >= l then - if i = j then List.rev acc - else List.rev (String.sub path i (j - i) :: acc) + if i = j then List.rev acc else List.rev (String.sub path i (j - i) :: acc) else if path.[j] = delim then do_slashes (String.sub path i (j - i) :: acc) limit j else do_component acc limit i (j + 1) diff --git a/src/lib_stdlib_unix/animation.ml b/src/lib_stdlib_unix/animation.ml index feae1f06666b..fda780a2fd04 100644 --- a/src/lib_stdlib_unix/animation.ml +++ b/src/lib_stdlib_unix/animation.ml @@ -89,7 +89,7 @@ let display_progress ?(every = 1) ?(out = Lwt_unix.stdout) if not print_progress then f (fun () -> Lwt.return_unit) else let clear_line fmt = Format.fprintf fmt "\027[2K\r" in - let (stream, notifier) = Lwt_stream.create () in + let stream, notifier = Lwt_stream.create () in let wrapped_notifier () = notifier (Some ()) ; Lwt.pause () diff --git a/src/lib_stdlib_unix/file_descriptor_sink.ml b/src/lib_stdlib_unix/file_descriptor_sink.ml index d86f8bf5a283..1cbeabb40105 100644 --- a/src/lib_stdlib_unix/file_descriptor_sink.ml +++ b/src/lib_stdlib_unix/file_descriptor_sink.ml @@ -84,19 +84,19 @@ end) : Internal_event.SINK with type t = t = struct let section_prefixes = let all = List.filter_map - (function ("section-prefix", l) -> Some l | _ -> None) + (function "section-prefix", l -> Some l | _ -> None) (Uri.query uri) in match all with [] -> None | more -> Some (List.concat more) in let* filter = match (Uri.get_query_param uri "level-at-least", section_prefixes) with - | (None, None) -> return (`Level_at_least Internal_event.Level.default) - | (Some l, None) -> ( + | None, None -> return (`Level_at_least Internal_event.Level.default) + | Some l, None -> ( match Internal_event.Level.of_string l with | Some l -> return (`Level_at_least l) | None -> fail_parsing "Wrong level: %S" l) - | (base_level, Some l) -> ( + | base_level, Some l -> ( try let sections = let parse_section s = diff --git a/src/lib_stdlib_unix/file_event_sink.ml b/src/lib_stdlib_unix/file_event_sink.ml index 49f798abe295..341c67d6a8a4 100644 --- a/src/lib_stdlib_unix/file_event_sink.ml +++ b/src/lib_stdlib_unix/file_event_sink.ml @@ -284,7 +284,7 @@ module Sink_implementation : Internal_event.SINK with type t = t = struct let open Lwt_result_syntax in let module M = (val m : Internal_event.EVENT_DEFINITION with type t = a) in let now = Micro_seconds.now () in - let (date, time) = Micro_seconds.date_string now in + let date, time = Micro_seconds.date_string now in let forced = v () in let level = M.level forced in match Event_filter.run ~section ~level ~name:M.name event_filter with diff --git a/src/lib_stdlib_unix/lwt_log_sink_unix.ml b/src/lib_stdlib_unix/lwt_log_sink_unix.ml index f558a5454d94..231554b7ae91 100644 --- a/src/lib_stdlib_unix/lwt_log_sink_unix.ml +++ b/src/lib_stdlib_unix/lwt_log_sink_unix.ml @@ -184,10 +184,10 @@ let init ?(template = default_template) output = let find_log_rules default = match Sys.(getenv_opt "TEZOS_LOG", getenv_opt "LWT_LOG") with - | (Some rules, None) -> ("environment variable TEZOS_LOG", Some rules) - | (None, Some rules) -> ("environment variable LWT_LOG", Some rules) - | (None, None) -> ("configuration file", default) - | (Some rules, Some _) -> + | Some rules, None -> ("environment variable TEZOS_LOG", Some rules) + | None, Some rules -> ("environment variable LWT_LOG", Some rules) + | None, None -> ("configuration file", default) + | Some rules, Some _ -> Format.eprintf "@[@{@{Warning@}@} Both environment variables \ TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG.@]@\n\ @@ -196,7 +196,7 @@ let find_log_rules default = let initialize ?(cfg = default_cfg) () = Lwt_log_core.add_rule "*" (Internal_event.Level.to_lwt_log cfg.default_level) ; - let (origin, rules) = find_log_rules cfg.rules in + let origin, rules = find_log_rules cfg.rules in let* () = match rules with | None -> Lwt.return_unit diff --git a/src/lib_stdlib_unix/utils.ml b/src/lib_stdlib_unix/utils.ml index 4e6feeb6dff8..f5b20c671b78 100644 --- a/src/lib_stdlib_unix/utils.ml +++ b/src/lib_stdlib_unix/utils.ml @@ -29,7 +29,7 @@ let hide_progress_line s = let display_progress ?(refresh_rate = (1, 1)) msgf = if Unix.isatty Unix.stderr then - let (index, rate) = refresh_rate in + let index, rate = refresh_rate in if index mod rate == 0 then msgf (Format.kasprintf (fun msg -> diff --git a/src/lib_store/block_store.ml b/src/lib_store/block_store.ml index 11aa2a5a3f34..de6706e09b77 100644 --- a/src/lib_store/block_store.ml +++ b/src/lib_store/block_store.ml @@ -114,7 +114,7 @@ let global_predecessor_lookup block_store hash pow_nth = | None -> Lwt.return_none | Some predecessors -> Lwt.return (List.nth_opt predecessors pow_nth)) (block_store.rw_floating_block_store - :: block_store.ro_floating_block_stores) + :: block_store.ro_floating_block_stores) in match o with | Some hash -> Lwt.return_some hash @@ -231,7 +231,7 @@ let mem block_store key = List.exists_s (fun store -> Floating_block_store.mem store predecessor_hash) (block_store.rw_floating_block_store - :: block_store.ro_floating_block_stores) + :: block_store.ro_floating_block_stores) in return (is_known_in_floating @@ -257,7 +257,7 @@ let read_block ~read_metadata block_store key_kind = (fun store -> Floating_block_store.read_block store adjusted_hash) (block_store.rw_floating_block_store - :: block_store.ro_floating_block_stores) + :: block_store.ro_floating_block_stores) in match o with | Some block -> Lwt.return_some block @@ -298,7 +298,7 @@ let read_block_metadata block_store key_kind = (fun store -> Floating_block_store.read_block store adjusted_hash) (block_store.rw_floating_block_store - :: block_store.ro_floating_block_stores) + :: block_store.ro_floating_block_stores) in match o with | Some block -> return block.metadata @@ -517,7 +517,7 @@ let infer_savepoint block_store current_head ~target_offset = (* [expected_caboose block_store ~target_offset] computes the expected caboose based on the [target_offset]). None is returned if - the cemented store cannot satisfy the targeted offset. *) + the cemented store cannot satisfy the targeted offset. *) let expected_caboose block_store ~target_offset = let cemented_store = cemented_block_store block_store in match Cemented_block_store.cemented_blocks_files cemented_store with @@ -593,7 +593,7 @@ let switch_history_mode block_store ~current_head ~previous_history_mode let open Lwt_result_syntax in let open History_mode in match (previous_history_mode, new_history_mode) with - | (Full _, Rolling m) | (Rolling _, Rolling m) -> + | Full _, Rolling m | Rolling _, Rolling m -> let m = (Option.value m ~default:History_mode.default_additional_cycles).offset in @@ -617,7 +617,7 @@ let switch_history_mode block_store ~current_head ~previous_history_mode let* () = write_savepoint block_store new_savepoint in let* () = write_caboose block_store new_caboose in return_unit - | (Full _, Full m) -> + | Full _, Full m -> let m = (Option.value m ~default:History_mode.default_additional_cycles).offset in @@ -632,7 +632,7 @@ let switch_history_mode block_store ~current_head ~previous_history_mode in let* () = write_savepoint block_store new_savepoint in return_unit - | (Archive, Full m) | (Archive, Rolling m) -> + | Archive, Full m | Archive, Rolling m -> let m = (Option.value m ~default:History_mode.default_additional_cycles).offset in @@ -728,7 +728,7 @@ let compute_new_savepoint block_store history_mode ~new_store store. We drag the savepoint only if it is not in the new floating store nor in the cycles to cements U cemented cycles. *) - let (savepoint_hash, savepoint_level) = savepoint in + let savepoint_hash, savepoint_level = savepoint in let is_savepoint_in_cemented = List.exists (fun (l, h) -> l <= savepoint_level && savepoint_level <= h) @@ -824,7 +824,7 @@ let update_floating_stores block_store ~history_mode ~ro_store ~rw_store let* lafl_block = read_predecessor_block_by_level block_store ~head:new_head new_head_lafl in - let (final_hash, final_level) = Block_repr.descriptor lafl_block in + let final_hash, final_level = Block_repr.descriptor lafl_block in (* 1. Append to the new RO [new_store] blocks between [lowest_bound_to_preserve_in_floating] and [lafl_block]. N.B. size in memory proportional to max_op_ttl of the lafl block @@ -989,7 +989,7 @@ let move_all_floating_stores block_store ~new_ro_store = List.iter_s Floating_block_store.close (block_store.rw_floating_block_store - :: block_store.ro_floating_block_stores) + :: block_store.ro_floating_block_stores) in let*! r = protect (fun () -> @@ -1108,10 +1108,10 @@ let create_merging_thread block_store ~history_mode ~old_ro_store ~old_rw_store let*! new_ro_store = Floating_block_store.init block_store.chain_dir ~readonly:false RO_TMP in - let* (new_savepoint, new_caboose) = + let* new_savepoint, new_caboose = Lwt.catch (fun () -> - let* (cycles_interval_to_cement, new_savepoint, new_caboose) = + let* cycles_interval_to_cement, new_savepoint, new_caboose = update_floating_stores block_store ~history_mode @@ -1244,7 +1244,7 @@ let merge_stores block_store ~(on_error : tztrace -> unit tzresult Lwt.t) let* () = Lwt_idle_waiter.force_idle block_store.merge_scheduler (fun () -> (* Move the rw in the ro stores and create a new tmp *) - let* (old_ro_store, old_rw_store, _new_rw_store) = + let* old_ro_store, old_rw_store, _new_rw_store = instanciate_temporary_floating_store block_store in (* Important: do not clean-up the temporary stores on @@ -1266,7 +1266,7 @@ let merge_stores block_store ~(on_error : tztrace -> unit tzresult Lwt.t) in on_error (Merge_error :: err)) (fun () -> - let* (new_ro_store, new_savepoint, new_caboose) = + let* new_ro_store, new_savepoint, new_caboose = create_merging_thread block_store ~history_mode @@ -1337,7 +1337,7 @@ let merge_temporary_floating block_store = List.iter_s Floating_block_store.close (block_store.rw_floating_block_store - :: block_store.ro_floating_block_stores) + :: block_store.ro_floating_block_stores) in (* Remove RO_TMP if it still exists *) let ro_tmp_floating_store_dir_path = @@ -1434,14 +1434,14 @@ let load ?block_cache_limit chain_dir ~genesis_block ~readonly = (Naming.savepoint_file chain_dir) ~initial_data:genesis_descr in - let*! (_, savepoint_level) = Stored_data.get savepoint in + let*! _, savepoint_level = Stored_data.get savepoint in Prometheus.Gauge.set Store_metrics.metrics.savepoint_level (Int32.to_float savepoint_level) ; let* caboose = Stored_data.init (Naming.caboose_file chain_dir) ~initial_data:genesis_descr in - let*! (_, caboose_level) = Stored_data.get caboose in + let*! _, caboose_level = Stored_data.get caboose in Prometheus.Gauge.set Store_metrics.metrics.caboose_level (Int32.to_float caboose_level) ; diff --git a/src/lib_store/cemented_block_store.ml b/src/lib_store/cemented_block_store.ml index e54cec8589c2..7f870a0242ea 100644 --- a/src/lib_store/cemented_block_store.ml +++ b/src/lib_store/cemented_block_store.ml @@ -158,7 +158,7 @@ let load_table cemented_blocks_dir = let start_level_opt = Int32.of_string_opt start_level in let end_level_opt = Int32.of_string_opt end_level in match (start_level_opt, end_level_opt) with - | (Some start_level, Some end_level) -> + | Some start_level, Some end_level -> let file = Naming.cemented_blocks_file cemented_blocks_dir @@ -210,7 +210,7 @@ let load_metadata_table cemented_blocks_dir = let start_level_opt = Int32.of_string_opt start_level in let end_level_opt = Int32.of_string_opt end_level in match (start_level_opt, end_level_opt) with - | (Some start_level, Some end_level) -> + | Some start_level, Some end_level -> let file = Naming.cemented_blocks_file cemented_blocks_dir @@ -486,7 +486,7 @@ let read_block fd block_number = in let* _ofs = Lwt_unix.lseek fd offset Unix.SEEK_SET in (* We move the cursor to the element's position *) - let* (block, _len) = Block_repr.read_next_block_exn fd in + let* block, _len = Block_repr.read_next_block_exn fd in Lwt.return block let get_lowest_cemented_level cemented_store = @@ -674,7 +674,7 @@ let trigger_full_gc cemented_store cemented_blocks_files offset = if nb_files <= offset then Lwt.return_unit else let cemented_files = Array.to_list cemented_blocks_files in - let (files_to_remove, _files_to_keep) = + let files_to_remove, _files_to_keep = List.split_n (nb_files - offset) cemented_files in (* Remove the rest of the files to prune *) @@ -707,7 +707,7 @@ let trigger_rolling_gc cemented_store cemented_blocks_files offset = Cemented_block_level_index.filter cemented_store.cemented_block_level_index (fun (_, level) -> Compare.Int32.(level > last_level_to_purge)) ; - let (files_to_remove, _files_to_keep) = + let files_to_remove, _files_to_keep = List.split_n (nb_files - offset) cemented_files in (* Remove the rest of the files to prune *) @@ -854,7 +854,7 @@ let check_indexes_consistency ?(post_step = fun () -> Lwt.return_unit) (Bad_offset {level = n; cycle = Naming.file_path file})) in - let*! (block, _) = Block_repr.read_next_block_exn fd in + let*! block, _ = Block_repr.read_next_block_exn fd in let* () = fail_unless Compare.Int32.( diff --git a/src/lib_store/consistency.ml b/src/lib_store/consistency.ml index 6498cb0e68c4..e52cdc1a620d 100644 --- a/src/lib_store/consistency.ml +++ b/src/lib_store/consistency.ml @@ -41,7 +41,7 @@ open Store_errors - We suppose that the stores have not been modified outside of the store. - *) +*) (* [check_cementing_highwatermark ~chain_dir block_store] checks that the cementing_highwatermark is consistent with the cemented @@ -53,18 +53,18 @@ let check_cementing_highwatermark ~cementing_highwatermark block_store = Cemented_block_store.get_highest_cemented_level cemented_store in match (highest_cemented_level, cementing_highwatermark) with - | (Some highest_cemented_level, Some cementing_highwatermark) -> + | Some highest_cemented_level, Some cementing_highwatermark -> fail_unless (Int32.equal highest_cemented_level cementing_highwatermark) (Inconsistent_cementing_highwatermark {highest_cemented_level; cementing_highwatermark}) - | (Some _, None) -> + | Some _, None -> (* Can be the case after a snapshot import *) return_unit - | (None, Some _) -> + | None, Some _ -> (* Can be the case in Rolling 0 *) return_unit - | (None, None) -> return_unit + | None, None -> return_unit let is_block_stored block_store (descriptor, expected_metadata, block_name) = let open Lwt_result_syntax in @@ -94,7 +94,7 @@ let check_protocol_levels block_store ~caboose protocol_levels = let open Lwt_result_syntax in Protocol_levels.iter_es (fun proto_level - {Protocol_levels.block = (hash, activation_level); protocol; _} -> + {Protocol_levels.block = hash, activation_level; protocol; _} -> if Compare.Int32.(activation_level < snd caboose) then (* Cannot say anything *) return_unit @@ -238,7 +238,7 @@ let check_consistency chain_dir genesis = let fix_floating_stores chain_dir = let open Lwt_result_syntax in let store_kinds = [Floating_block_store.RO; RW; RW_TMP; RO_TMP] in - let*! (existing_floating_stores, incomplete_floating_stores) = + let*! existing_floating_stores, incomplete_floating_stores = List.partition_s (fun kind -> Floating_block_store.all_files_exists chain_dir kind) store_kinds @@ -441,19 +441,18 @@ let lowest_floating_blocks floating_stores = in let lowest_block_with_metadata = match (last_min_with_metadata, Block_repr.metadata block) with - | (Some last_min_with_metadata, Some _) -> + | Some last_min_with_metadata, Some _ -> Some (min last_min_with_metadata (Block_repr.level block)) - | (Some last_min_with_metadata, None) -> - Some last_min_with_metadata - | (None, Some _) -> Some (Block_repr.level block) - | (None, None) -> None + | Some last_min_with_metadata, None -> Some last_min_with_metadata + | None, Some _ -> Some (Block_repr.level block) + | None, None -> None in return (lowest_block, lowest_block_with_metadata)) (None, None)) floating_stores in let min l = List.fold_left (Option.merge min) None l in - let (lw, lwm) = List.split l in + let lw, lwm = List.split l in (* If we have failed getting a block with metadata from both the RO and RW floating stores, then it is not possible to determine a savepoint. The store is broken. *) @@ -532,13 +531,13 @@ let infer_savepoint_and_caboose chain_dir block_store = let cemented_caboose_candidate = lowest_cemented_block cemented_block_files in let floating_stores = Block_store.floating_block_stores block_store in match (cemented_savepoint_candidate, cemented_caboose_candidate) with - | (Some cemented_savepoint, Some caboose) -> + | Some cemented_savepoint, Some caboose -> (* Cemented candidates are available. However, we must check that the lowest block with metadata from the floating store is not lower than the cemented candidate and thus, a better candidate. It can be the case when [checkpoint_level - max_op_ttl < lowest_cemented_level_with_metadata]. *) - let* (_, lowest_floating_with_metadata) = + let* _, lowest_floating_with_metadata = lowest_floating_blocks floating_stores in let sp = @@ -551,10 +550,10 @@ let infer_savepoint_and_caboose chain_dir block_store = | None -> cemented_savepoint in return (sp, caboose) - | (None, Some caboose_level) -> + | None, Some caboose_level -> (* No cemented cycle with metadata but some cycles. Search for the savepoint in the floating blocks. *) - let* (_, lowest_floating_with_metadata) = + let* _, lowest_floating_with_metadata = lowest_floating_blocks floating_stores in let* savepoint_level = @@ -563,10 +562,10 @@ let infer_savepoint_and_caboose chain_dir block_store = | None -> tzfail (Corrupted_store Cannot_find_floating_savepoint) in return (savepoint_level, caboose_level) - | (None, None) -> + | None, None -> (* No cycle found. Searching for savepoint and caboose in the floating block store.*) - let* (lowest_floating, lowest_floating_with_metadata) = + let* lowest_floating, lowest_floating_with_metadata = lowest_floating_blocks floating_stores in let* savepoint_level = @@ -580,7 +579,7 @@ let infer_savepoint_and_caboose chain_dir block_store = | None -> tzfail (Corrupted_store Cannot_find_floating_caboose) in return (savepoint_level, caboose_level) - | (Some _, None) -> + | Some _, None -> (* Inconsistent as a cemented cycle with metadata implies that the caboose candidate is known. *) assert false @@ -618,7 +617,7 @@ let fix_savepoint_and_caboose ?history_mode chain_dir block_store head genesis = let genesis_descr = Block_repr.descriptor genesis_block in return (genesis_descr, genesis_descr) | None | Some (Full _) | Some (Rolling _) -> - let* (savepoint_level, caboose_level) = + let* savepoint_level, caboose_level = infer_savepoint_and_caboose chain_dir block_store in let* savepoint = @@ -860,7 +859,7 @@ let fix_protocol_levels context_index block_store genesis genesis_header ~head let* highest_cemented_proto_level = match cemented_protocol_levels with | [] -> return 0 - | (_, {block = (_, block_level); _}) :: _ -> + | (_, {block = _, block_level; _}) :: _ -> let* block_o = Cemented_block_store.get_cemented_block_by_level ~read_metadata:false @@ -1070,7 +1069,7 @@ let fix_chain_state chain_dir block_store ~head ~cementing_highwatermark (* For archive mode, do not update the savepoint/caboose to the inferred ones if they are breaking the invariants (savepoint = caboose = genesis). *) - let* (savepoint, caboose) = + let* savepoint, caboose = match chain_config.history_mode with | History_mode.Archive -> if snd tmp_savepoint = 0l && snd tmp_caboose = 0l then @@ -1231,7 +1230,7 @@ let fix_consistency ?history_mode chain_dir context_index genesis = let*! cementing_highwatermark = fix_cementing_highwatermark chain_dir block_store in - let* (savepoint, caboose) = + let* savepoint, caboose = fix_savepoint_and_caboose chain_dir block_store head genesis in let* checkpoint = fix_checkpoint chain_dir block_store head in diff --git a/src/lib_store/floating_block_store.ml b/src/lib_store/floating_block_store.ml index a6b5a424b400..915a60f5b463 100644 --- a/src/lib_store/floating_block_store.ml +++ b/src/lib_store/floating_block_store.ml @@ -174,7 +174,7 @@ let folder f floating_store = let open Lwt_syntax in Lwt_idle_waiter.task floating_store.scheduler (fun () -> (* We open a new fd *) - let (flags, perms) = ([Unix.O_CREAT; O_RDONLY; O_CLOEXEC], 0o444) in + let flags, perms = ([Unix.O_CREAT; O_RDONLY; O_CLOEXEC], 0o444) in let path = Naming.floating_blocks_file floating_store.floating_blocks_dir |> Naming.file_path @@ -227,7 +227,7 @@ let iter_with_pred_s f floating_store = let init chain_dir ~readonly kind = let open Lwt_syntax in - let (flag, perms) = + let flag, perms = (* Only RO is readonly: when we open RO_TMP, we actually write in it. *) if kind = Naming.RO && readonly then (Unix.O_RDONLY, 0o444) else (Unix.O_RDWR, 0o644) @@ -324,7 +324,7 @@ let full_integrity_check chain_dir kind = loop index fd (nb_bytes_left - length) (succ count) else Lwt.return_false in - let (flag, perms) = (Unix.O_RDWR, 0o644) in + let flag, perms = (Unix.O_RDWR, 0o644) in let floating_blocks_dir = Naming.floating_blocks_dir chain_dir kind in let floating_blocks_file_path = Naming.floating_blocks_file floating_blocks_dir |> Naming.file_path diff --git a/src/lib_store/reconstruction.ml b/src/lib_store/reconstruction.ml index c29b82763fb0..59c7939decdd 100644 --- a/src/lib_store/reconstruction.ml +++ b/src/lib_store/reconstruction.ml @@ -171,10 +171,10 @@ let compute_block_metadata_hash block_metadata = let split_operations_metadata = function | Block_validation.No_metadata_hash metadata -> (metadata, None) | Metadata_hash l -> - let (metadata, hashes) = + let metadata, hashes = List.fold_left (fun (metadata_acc, hashes_acc) l -> - let (metadata, hashes) = List.split l in + let metadata, hashes = List.split l in (metadata :: metadata_acc, hashes :: hashes_acc)) ([], []) l @@ -268,7 +268,7 @@ let protocol_env_of_protocol_level chain_store protocol_level block_hash = let restore_block_contents chain_store block_protocol_env ~block_metadata ~operations_metadata message max_operations_ttl last_allowed_fork_level block = - let (operations_metadata, operations_metadata_hashes) = + let operations_metadata, operations_metadata_hashes = split_operations_metadata operations_metadata in let contents = @@ -414,12 +414,12 @@ let reconstruct_chunk chain_store context_index ~user_activated_upgrades let store_chunk cemented_store chunk = let open Lwt_result_syntax in - let* (lower_block, lower_env_version) = + let* lower_block, lower_env_version = match List.hd chunk with | None -> failwith "Cannot read chunk to cement." | Some e -> return e in - let* (_, higher_env_version) = + let* _, higher_env_version = match List.hd (List.rev chunk) with | None -> failwith "Cannot read chunk to cement." | Some e -> return e @@ -448,7 +448,7 @@ let store_chunk cemented_store chunk = ( Block_repr.block_metadata_hash b, Block_repr.operations_metadata_hashes b ) with - | (Some _, Some _) -> return_true + | Some _, Some _ -> return_true | _ -> return_false) in let* valid_lower_block = is_valid (Block_repr.level lower_block) in @@ -496,7 +496,7 @@ let reconstruct_cemented chain_store context_index ~user_activated_upgrades let cemented_block_store = Block_store.cemented_block_store block_store in let chain_dir = Store.Chain.chain_dir chain_store in let cemented_blocks_dir = Naming.cemented_blocks_dir chain_dir in - let* (cemented_cycles, start_cycle_index) = + let* cemented_cycles, start_cycle_index = let* o = Cemented_block_store.load_table cemented_blocks_dir (* Filter the cemented cycles to get the ones to reconstruct *) diff --git a/src/lib_store/snapshots.ml b/src/lib_store/snapshots.ml index 12a845c1aff3..f54a3b67d101 100644 --- a/src/lib_store/snapshots.ml +++ b/src/lib_store/snapshots.ml @@ -1857,7 +1857,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct let open Cemented_block_store in let nb_cycles = List.length files in (* Rebuild fresh indexes: cannot cp because of concurrent accesses *) - let (fresh_level_index, fresh_hash_index) = + let fresh_level_index, fresh_hash_index = Exporter.create_cemented_block_indexes snapshot_exporter in protect (fun () -> @@ -1922,7 +1922,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct let ((limit_hash, limit_level) as export_block_descr) = Store.Block.descriptor export_block in - let (stream, bpush) = Lwt_stream.create_bounded 1000 in + let stream, bpush = Lwt_stream.create_bounded 1000 in (* Retrieve first floating block *) let* first_block = let*! o = Block_repr.read_next_block floating_ro_fd in @@ -1984,7 +1984,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct block below the block target. *) let protocol_levels = Protocol_levels.filter - (fun _ {Protocol_levels.block = (_, activation_level); _} -> + (fun _ {Protocol_levels.block = _, activation_level; _} -> activation_level < export_level) all_protocol_levels in @@ -2055,7 +2055,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct *) let check_export_block_validity chain_store block = let open Lwt_result_syntax in - let (block_hash, block_level) = Store.Block.descriptor block in + let block_hash, block_level = Store.Block.descriptor block in let*! is_known = Store.Block.is_known_valid chain_store block_hash in let* () = fail_unless @@ -2067,7 +2067,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct (Store.Block.is_genesis chain_store block_hash) (Invalid_export_block {block = Some block_hash; reason = `Genesis}) in - let*! (_, savepoint_level) = Store.Chain.savepoint chain_store in + let*! _, savepoint_level = Store.Chain.savepoint chain_store in let* () = fail_when Compare.Int32.(savepoint_level > block_level) @@ -2102,7 +2102,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct (Invalid_export_block {block = Some block_hash; reason = `Pruned}) | Some block_metadata -> return block_metadata in - let*! (_, caboose_level) = Store.Chain.caboose chain_store in + let*! _, caboose_level = Store.Chain.caboose chain_store in (* We will need the following blocks [ (target_block - max_op_ttl(target_block)) ; ... ; target_block ] *) let block_max_op_ttl = Store.Block.max_operations_ttl block_metadata in @@ -2141,12 +2141,12 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct (* With the caboose, we do not allow to use the ~/- as it is a non sense. Additionally, it is not allowed to export the caboose block. *) - let*! (hash, _) = Store.Chain.caboose chain_store in + let*! hash, _ = Store.Chain.caboose chain_store in tzfail (Invalid_export_block {block = Some hash; reason = `Caboose}) | _ -> Store.Chain.block_of_identifier chain_store block) |> trace (Invalid_export_block {block = None; reason = `Unknown}) in - let* (pred_block, minimum_level_needed) = + let* pred_block, minimum_level_needed = check_export_block_validity chain_store export_block in return (export_block, pred_block, minimum_level_needed) @@ -2185,7 +2185,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct else (* If the export block is cemented, cut the cycle containing the export block accordingly and retrieve the extra blocks *) - let (filtered_table, extra_cycles) = + let filtered_table, extra_cycles = List.partition (fun {Cemented_block_store.end_level; _} -> Compare.Int32.(export_block_level > end_level)) @@ -2212,7 +2212,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct then (* When the cycles are short, we may keep more blocks in the floating store than in cemented *) - let*! (_, caboose_level) = Store.Chain.caboose chain_store in + let*! _, caboose_level = Store.Chain.caboose chain_store in Store.Block.read_block_by_level chain_store caboose_level else return first_block_in_cycle in @@ -2267,7 +2267,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct let open Lwt_result_syntax in let export_rolling_f chain_store = let* () = check_history_mode chain_store ~rolling in - let* (export_block, pred_block, lowest_block_level_needed) = + let* export_block, pred_block, lowest_block_level_needed = retrieve_export_block chain_store block in (* The number of additional cycles to export is fixed as the @@ -2347,7 +2347,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct let open Lwt_result_syntax in let export_full_f chain_store = let* () = check_history_mode chain_store ~rolling in - let* (export_block, pred_block, _lowest_block_level_needed) = + let* export_block, pred_block, _lowest_block_level_needed = retrieve_export_block chain_store block in (* The number of additional cycles to export is fixed as the @@ -2383,7 +2383,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct (fun () -> let src_cemented_dir = Naming.cemented_blocks_dir chain_dir in (* Compute the necessary cemented table *) - let* (cemented_table, extra_floating_blocks) = + let* cemented_table, extra_floating_blocks = compute_cemented_table_and_extra_cycle chain_store ~src_cemented_dir @@ -2441,7 +2441,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct let*! _ = Lwt_utils_unix.safe_close floating_rw_fd in Lwt.return_unit in - let* (reading_thread, floating_block_stream) = + let* reading_thread, floating_block_stream = match extra_floating_blocks with | Some floating_blocks -> let*! () = finalizer () in @@ -2452,7 +2452,7 @@ module Make_snapshot_exporter (Exporter : EXPORTER) : Snapshot_exporter = struct | None -> (* The export block is in the floating stores, copy all the floating stores until the block is reached *) - let* (reading_thread, floating_block_stream) = + let* reading_thread, floating_block_stream = export_floating_blocks ~floating_ro_fd ~floating_rw_fd ~export_block in let reading_thread = @@ -2994,12 +2994,12 @@ module Raw_importer : IMPORTER = struct return (return_unit, Lwt_stream.of_list []) else let*! fd = Lwt_unix.openfile floating_blocks_file Unix.[O_RDONLY] 0o444 in - let (stream, bounded_push) = Lwt_stream.create_bounded 1000 in + let stream, bounded_push = Lwt_stream.create_bounded 1000 in let rec loop ?pred_block nb_bytes_left = if nb_bytes_left < 0 then tzfail Corrupted_floating_store else if nb_bytes_left = 0 then return_unit else - let*! (block, len_read) = Block_repr.read_next_block_exn fd in + let*! block, len_read = Block_repr.read_next_block_exn fd in let* () = Block_repr.check_block_consistency ~genesis_hash ?pred_block block in @@ -3123,7 +3123,7 @@ module Tar_importer : IMPORTER = struct in match o with | Some str -> - let (_ofs, res) = + let _ofs, res = Data_encoding.Binary.read_exn Protocol_levels.encoding str @@ -3279,12 +3279,12 @@ module Tar_importer : IMPORTER = struct | Some floating_blocks_file -> let file_size = Onthefly.get_file_size floating_blocks_file in let floating_blocks_file_fd = Onthefly.get_raw_input_fd t.tar in - let (stream, bounded_push) = Lwt_stream.create_bounded 1000 in + let stream, bounded_push = Lwt_stream.create_bounded 1000 in let rec loop ?pred_block nb_bytes_left = if nb_bytes_left < 0L then tzfail Corrupted_floating_store else if nb_bytes_left = 0L then return_unit else - let*! (block, len_read) = + let*! block, len_read = Block_repr.read_next_block_exn floating_blocks_file_fd in let* () = @@ -3619,7 +3619,7 @@ module Make_snapshot_importer (Importer : IMPORTER) : Snapshot_importer = struct (Snapshot_file_not_found snapshot_path) in let* snapshot_header = Importer.load_snapshot_header snapshot_importer in - let (snapshot_version, snapshot_metadata) = snapshot_header in + let snapshot_version, snapshot_metadata = snapshot_header in let* () = fail_unless (Version.is_supported snapshot_version) @@ -3667,7 +3667,7 @@ module Make_snapshot_importer (Importer : IMPORTER) : Snapshot_importer = struct dst_context_dir in (* Restore context *) - let* (block_data, genesis_context_hash, block_validation_result) = + let* block_data, genesis_context_hash, block_validation_result = restore_and_apply_context snapshot_importer ?user_expected_block @@ -3696,7 +3696,7 @@ module Make_snapshot_importer (Importer : IMPORTER) : Snapshot_importer = struct ~genesis_hash:genesis.block ~progress_display_mode in - let* (reading_thread, floating_blocks_stream) = + let* reading_thread, floating_blocks_stream = read_floating_blocks snapshot_importer ~genesis_hash:genesis.block in let {Block_validation.validation_store; block_metadata; ops_metadata} = @@ -3837,7 +3837,7 @@ let read_snapshot_header ~snapshot_path = | Tar -> (module Make_snapshot_loader (Tar_loader) : Snapshot_loader) | Raw -> (module Make_snapshot_loader (Raw_loader) : Snapshot_loader) in - let* (version, metadata) = Loader.load_snapshot_header ~snapshot_path in + let* version, metadata = Loader.load_snapshot_header ~snapshot_path in return (Current_header (version, metadata)) let import ~snapshot_path ?patch_context ?block ?check_consistency diff --git a/src/lib_store/store.ml b/src/lib_store/store.ml index 61c7697100ba..6cf059dcdcd4 100644 --- a/src/lib_store/store.ml +++ b/src/lib_store/store.ml @@ -45,10 +45,10 @@ module Shared = struct Lwt_idle_waiter.force_idle v.lock (fun () -> let* o_r = f v.data in match o_r with - | (Some new_data, res) -> + | Some new_data, res -> v.data <- new_data ; return res - | (None, res) -> return res) + | None, res -> return res) end type store = { @@ -143,7 +143,7 @@ let read_ancestor_hash_by_level chain_store head level = target. *) let locked_is_acceptable_block chain_state (hash, level) = let open Lwt_syntax in - let* (_checkpoint_hash, checkpoint_level) = + let* _checkpoint_hash, checkpoint_level = Stored_data.get chain_state.checkpoint_data in (* The block must be above the checkpoint. *) @@ -480,7 +480,7 @@ module Block = struct | false -> (* Safety check: never ever commit a block that is not compatible with the current checkpoint/target. *) - let*! (acceptable_block, known_invalid) = + let*! acceptable_block, known_invalid = Shared.use chain_store.chain_state (fun chain_state -> let*! acceptable_block = locked_is_acceptable_block @@ -1010,7 +1010,7 @@ module Chain = struct new_cache in chain_state.live_data_cache <- Some new_cache ; - let (live_blocks, live_ops) = + let live_blocks, live_ops = Ringo.Ring.fold new_cache ~init:(Block_hash.Set.empty, Operation_hash.Set.empty) @@ -1064,7 +1064,7 @@ module Chain = struct let compute_locator_from_hash chain_store ?(max_size = max_locator_size) ?min_level (head_hash, head_header) seed = let open Lwt_syntax in - let* (caboose, _) = + let* caboose, _ = Shared.use chain_store.chain_state (fun chain_state -> match min_level with | None -> Block_store.caboose chain_store.block_store @@ -1105,7 +1105,7 @@ module Chain = struct let compute_locator chain_store ?(max_size = 200) head seed = let open Lwt_syntax in - let* (caboose, _caboose_level) = caboose chain_store in + let* caboose, _caboose_level = caboose chain_store in Block_locator.compute ~get_predecessor:(fun h n -> Block.read_ancestor_hash_opt chain_store h ~distance:n) @@ -1306,7 +1306,7 @@ module Chain = struct Lwt.return_some hcb | None -> (* If we don't, check that the head lafl is > caboose *) - let* (_, caboose_level) = Block_store.caboose block_store in + let* _, caboose_level = Block_store.caboose block_store in if Compare.Int32.(head_lafl >= caboose_level) then Lwt.return_some head_lafl else Lwt.return_none) @@ -1421,7 +1421,7 @@ module Chain = struct new_head new_head_lafl in - let* (new_checkpoint, new_target) = + let* new_checkpoint, new_target = match lafl_block_opt with | None -> (* This case may occur when importing a rolling @@ -1552,7 +1552,7 @@ module Chain = struct let* () = write_alternate_heads chain_state new_alternate_heads in let* () = Stored_data.write chain_state.target_data new_target in (* Update live_data *) - let*! (live_blocks, live_operations) = + let*! live_blocks, live_operations = locked_compute_live_blocks ~update_cache:true chain_store @@ -1638,7 +1638,7 @@ module Chain = struct let best_known_head_for_checkpoint chain_store ~checkpoint = let open Lwt_result_syntax in - let (_, checkpoint_level) = checkpoint in + let _, checkpoint_level = checkpoint in let*! current_head = current_head chain_store in let* valid = is_valid_for_checkpoint @@ -1730,7 +1730,7 @@ module Chain = struct in let find_best_head heads = assert (heads <> []) ; - let (first_alternate_head, alternate_heads) = + let first_alternate_head, alternate_heads = ( List.hd heads |> WithExceptions.Option.get ~loc:__LOC__, List.tl heads |> WithExceptions.Option.get ~loc:__LOC__ ) @@ -1760,9 +1760,9 @@ module Chain = struct all_heads ) in (* Case 1 *) - let* (new_current_head, new_alternate_heads, new_checkpoint) = + let* new_current_head, new_alternate_heads, new_checkpoint = if filtered_heads <> [] then - let* (best_alternate_head, alternate_heads) = + let* best_alternate_head, alternate_heads = find_best_head filtered_heads in return (best_alternate_head, alternate_heads, new_target) @@ -1778,7 +1778,7 @@ module Chain = struct all_heads in if filtered_heads <> [] then - let* (best_alternate_head, alternate_heads) = + let* best_alternate_head, alternate_heads = find_best_head filtered_heads in return (best_alternate_head, alternate_heads, new_target) @@ -1931,14 +1931,14 @@ module Chain = struct ( Cemented_block_store.get_highest_cemented_level cemented_store, cementing_highwatermark ) with - | (None, (Some _ | None)) -> return_ok_unit - | (Some highest_cemented_level, None) -> + | None, (Some _ | None) -> return_ok_unit + | Some highest_cemented_level, None -> (* This case only happens after the store has been imported from a snapshot. *) Stored_data.write cementing_highwatermark_data (Some highest_cemented_level) - | (Some highest_cemented_level, Some cementing_highwatermark) -> + | Some highest_cemented_level, Some cementing_highwatermark -> (* Invariant: the cemented blocks are always correct *) if Compare.Int32.(highest_cemented_level > cementing_highwatermark) then Stored_data.write @@ -1970,7 +1970,7 @@ module Chain = struct let* checkpoint_data = Stored_data.load (Naming.checkpoint_file chain_dir) in - let*! (_, checkpoint_level) = Stored_data.get checkpoint_data in + let*! _, checkpoint_level = Stored_data.get checkpoint_data in Prometheus.Gauge.set Store_metrics.metrics.checkpoint_level (Int32.to_float checkpoint_level) ; @@ -1981,7 +1981,7 @@ module Chain = struct let* forked_chains_data = Stored_data.load (Naming.forked_chains_file chain_dir) in - let*! (current_head_hash, _) = Stored_data.get current_head_data in + let*! current_head_hash, _ = Stored_data.get current_head_data in let* o = Block_store.read_block ~read_metadata:true @@ -2131,7 +2131,7 @@ module Chain = struct | None -> tzfail Inconsistent_chain_store | Some metadata -> Shared.update_with chain_state (fun chain_state -> - let*! (live_blocks, live_operations) = + let*! live_blocks, live_operations = locked_compute_live_blocks ~force:true ~update_cache:true @@ -2376,7 +2376,7 @@ module Chain = struct if Compare.Int.(prev_proto_level < protocol_level) then let*! o = find_activation_block chain_store ~protocol_level in match o with - | Some {block = (bh, _); _} -> + | Some {block = bh, _; _} -> if Block_hash.(bh <> Block.hash block) then set_protocol_level chain_store ~protocol_level (block, protocol_hash) else return_unit @@ -2393,7 +2393,7 @@ module Chain = struct match o with | None -> return_unit | Some {block; protocol; _} -> ( - let*! (_, savepoint_level) = savepoint chain_store in + let*! _, savepoint_level = savepoint chain_store in if Compare.Int32.(savepoint_level > snd block) then (* the block is too far in the past *) return_unit @@ -2432,7 +2432,7 @@ module Chain = struct | Some pred when Block_hash.equal (Block.hash pred) (Block.hash block) -> Lwt.return_none (* genesis *) | Some pred -> ( - let* (_, save_point_level) = savepoint chain_store in + let* _, save_point_level = savepoint chain_store in let* protocol = if Compare.Int32.(Block.level pred < save_point_level) then let* o = @@ -2623,7 +2623,7 @@ let init ?patch_context ?commit_genesis ?history_mode ?(readonly = false) let open Lwt_result_syntax in let store_dir = Naming.store_dir ~dir_path:store_dir in let chain_id = Chain_id.of_block_hash genesis.Genesis.block in - let*! (context_index, commit_genesis) = + let*! context_index, commit_genesis = match commit_genesis with | Some commit_genesis -> let*! context_index = @@ -2713,12 +2713,12 @@ let may_switch_history_mode ~store_dir ~context_dir genesis ~new_history_mode = else let is_valid_switch = match (previous_history_mode, new_history_mode) with - | ((Full n, Full m) | (Rolling n, Rolling m)) when n = m -> false - | (Archive, Full _) - | (Archive, Rolling _) - | (Full _, Full _) - | (Full _, Rolling _) - | (Rolling _, Rolling _) -> + | (Full n, Full m | Rolling n, Rolling m) when n = m -> false + | Archive, Full _ + | Archive, Rolling _ + | Full _, Full _ + | Full _, Rolling _ + | Rolling _, Rolling _ -> true | _ -> (* The remaining combinations are invalid switches *) @@ -3186,7 +3186,7 @@ module Unsafe = struct List.iter_es (fun ( _, { - Protocol_levels.block = (bh, _); + Protocol_levels.block = bh, _; protocol; commit_info = commit_info_opt; } ) -> @@ -3197,7 +3197,7 @@ module Unsafe = struct (Block (bh, 0)) in match (block_opt, commit_info_opt) with - | (None, _) -> ( + | None, _ -> ( match history_mode with | Rolling _ -> (* If we are importing a rolling snapshot then allow the @@ -3207,8 +3207,8 @@ module Unsafe = struct fail_unless (Block_hash.equal real_genesis_hash bh) (Missing_activation_block (bh, protocol, history_mode))) - | (Some _block, None) -> return_unit - | (Some block, Some commit_info) -> + | Some _block, None -> return_unit + | Some block, Some commit_info -> let*! is_consistent = Context.check_protocol_commit_consistency ~expected_context_hash:(Block.context_hash block) diff --git a/src/lib_store/test/alpha_utils.ml b/src/lib_store/test/alpha_utils.ml index ed69fbe23945..cfa2f23ffea2 100644 --- a/src/lib_store/test/alpha_utils.ml +++ b/src/lib_store/test/alpha_utils.ml @@ -79,7 +79,7 @@ module Account = struct let known_accounts = Signature.Public_key_hash.Table.create 17 let new_account ?seed () = - let (pkh, pk, sk) = Signature.generate_key ?seed () in + let pkh, pk, sk = Signature.generate_key ?seed () in let account = {pkh; pk; sk} in Signature.Public_key_hash.Table.add known_accounts pkh account ; account @@ -119,7 +119,7 @@ module Account = struct let new_commitment ?seed () = let open Lwt_result_syntax in - let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in + let pkh, pk, sk = Signature.generate_key ?seed ~algo:Ed25519 () in let unactivated_account = {pkh; pk; sk} in let open Commitment in let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in @@ -306,7 +306,7 @@ module Forge = struct | _ -> Round.zero in let proto_level = Store.Block.proto_level pred in - let* (pkh, round, expected_timestamp) = + let* pkh, round, expected_timestamp = dispatch_policy rpc_ctxt policy pred in let timestamp = Option.value ~default:expected_timestamp timestamp in @@ -511,7 +511,7 @@ let apply ctxt chain_id ~policy ?(operations = empty_operations) pred = `Lazy element_of_key in - let* (validation, block_header_metadata) = + let* validation, block_header_metadata = let*! r = let open Environment.Error_monad in let* vstate = @@ -529,7 +529,7 @@ let apply ctxt chain_id ~policy ?(operations = empty_operations) pred = let* vstate = List.fold_left_es (List.fold_left_es (fun vstate op -> - let* (state, _result) = apply_operation vstate op in + let* state, _result = apply_operation vstate op in return state)) vstate operations @@ -671,10 +671,10 @@ let apply_and_store chain_store ?(synchronous_merge = true) ?policy let bake chain_store ?synchronous_merge ?policy ?operation ?operations pred = let operations = match (operation, operations) with - | (Some op, Some ops) -> Some (op :: ops) - | (Some op, None) -> Some [op] - | (None, Some ops) -> Some ops - | (None, None) -> None + | Some op, Some ops -> Some (op :: ops) + | Some op, None -> Some [op] + | None, Some ops -> Some ops + | None, None -> None in apply_and_store ?synchronous_merge chain_store ?policy ?operations pred @@ -685,7 +685,7 @@ let get_constants rpc_ctxt b = Alpha_services.Constants.all rpc_ctxt b let bake_n chain_store ?synchronous_merge ?policy n b = let open Lwt_result_syntax in - let* (bl, last) = + let* bl, last = List.fold_left_es (fun (bl, last) _ -> let* b = bake ?synchronous_merge chain_store ?policy last in @@ -711,10 +711,10 @@ let bake_until_cycle_end chain_store ?synchronous_merge ?policy b = let bake_until_n_cycle_end chain_store ?synchronous_merge ?policy n b = let open Lwt_result_syntax in - let* (bll, last) = + let* bll, last = List.fold_left_es (fun (bll, last) _ -> - let* (bl, last) = + let* bl, last = bake_until_cycle_end chain_store ?synchronous_merge ?policy last in return (bl :: bll, last)) @@ -739,7 +739,7 @@ let bake_until_cycle chain_store ?synchronous_merge ?policy cycle b = in if Int32.equal (Cycle.to_int32 cycle) current_cycle then return (bl, b) else - let* (bl', b') = + let* bl', b' = bake_until_cycle_end chain_store ?synchronous_merge ?policy b in loop (bl @ bl', b') diff --git a/src/lib_store/test/test_block_store.ml b/src/lib_store/test/test_block_store.ml index e10901b20f0b..bf57b3d89323 100644 --- a/src/lib_store/test/test_block_store.ml +++ b/src/lib_store/test/test_block_store.ml @@ -139,7 +139,7 @@ let assert_cemented_bound block_store (lowest, highest) = let test_storing_and_access_predecessors block_store = let open Lwt_result_syntax in - let*! (blocks, _head) = + let*! blocks, _head = make_raw_block_list ~kind:`Full (genesis_hash, -1l) 50 in let* () = List.iter_es (Block_store.store_block block_store) blocks in @@ -177,7 +177,7 @@ let test_storing_and_access_predecessors block_store = let make_raw_block_list_with_lafl pred size ~lafl = let open Lwt_syntax in - let* (chunk, head) = make_raw_block_list ~kind:`Full pred size in + let* chunk, head = make_raw_block_list ~kind:`Full pred size in let change_lafl block = let metadata = WithExceptions.Option.to_exn ~none:Not_found block.Block_repr.metadata @@ -205,7 +205,7 @@ let make_n_consecutive_cycles pred ~cycle_length ~nb_cycles = else cycle_length in let lafl = max 0l (snd pred) in - let* (chunk, head) = + let* chunk, head = make_raw_block_list_with_lafl pred cycle_length ~lafl in loop (chunk :: acc) (Block_repr.descriptor head) (n - 1) @@ -220,7 +220,7 @@ let make_n_initial_consecutive_cycles block_store ~cycle_length ~nb_cycles = let test_simple_merge block_store = let open Lwt_result_syntax in - let*! (cycles, head) = + let*! cycles, head = make_n_initial_consecutive_cycles block_store ~cycle_length:10 ~nb_cycles:2 in let head_metadata = @@ -249,7 +249,7 @@ let test_simple_merge block_store = let test_consecutive_concurrent_merges block_store = let open Lwt_result_syntax in (* Append 10 cycles of 10 blocks *) - let*! (cycles, head) = + let*! cycles, head = make_n_initial_consecutive_cycles block_store ~cycle_length:10 ~nb_cycles:10 in let head_metadata = @@ -310,7 +310,7 @@ let test_consecutive_concurrent_merges block_store = let test_ten_cycles_merge block_store = let open Lwt_result_syntax in (* Append 10 cycles *) - let*! (cycles, head) = + let*! cycles, head = make_n_initial_consecutive_cycles block_store ~cycle_length:100 @@ -344,7 +344,7 @@ let test_merge_with_branches block_store = (* make an initial chain of 2 cycles of 100 blocks with each block's lafl pointing to the highest block of its preceding cycle. i.e. 1st cycle's lafl = 0, 2nd cycle's lafl = 99 *) - let*! (cycles, head) = + let*! cycles, head = make_n_initial_consecutive_cycles block_store ~cycle_length:100 ~nb_cycles:2 in let all_blocks = List.concat cycles in @@ -358,7 +358,7 @@ let test_merge_with_branches block_store = List.nth all_blocks (level - 1) |> WithExceptions.Option.get ~loc:__LOC__ in - let*! (blocks, _head) = + let*! blocks, _head = make_raw_block_list_with_lafl ~lafl:0l (Block_repr.descriptor fork_root) @@ -386,7 +386,7 @@ let test_merge_with_branches block_store = List.nth all_blocks (level - 1) |> WithExceptions.Option.get ~loc:__LOC__ in - let*! (blocks, _head) = + let*! blocks, _head = make_raw_block_list_with_lafl ~lafl:99l (Block_repr.descriptor fork_root) @@ -431,7 +431,7 @@ let test_merge_with_branches block_store = let perform_n_cycles_merge ?(cycle_length = 10) block_store history_mode nb_cycles = let open Lwt_result_syntax in - let*! (cycles, head) = + let*! cycles, head = make_n_initial_consecutive_cycles block_store ~cycle_length ~nb_cycles in let all_blocks = List.concat cycles in @@ -495,7 +495,7 @@ let test_full_0_merge block_store = ((nb_cycles - 1) * cycle_length) - 1 (* lafl *) - 1 (* lafl max_op_ttl *) in - let (expected_pruned_blocks, expected_preserved_blocks) = + let expected_pruned_blocks, expected_preserved_blocks = List.split_n (expected_savepoint_level - 1) (* the genesis block is not counted *) all_blocks @@ -586,7 +586,7 @@ let test_rolling_0_merge block_store = ((nb_cycles - 1) * cycle_length) - 1 (* lafl *) - 1 (* lafl max_op_ttl *) in - let (expected_pruned_blocks, expected_preserved_blocks) = + let expected_pruned_blocks, expected_preserved_blocks = List.split_n (expected_savepoint_level - 1) (* the genesis block is not counted *) all_blocks diff --git a/src/lib_store/test/test_cemented_store.ml b/src/lib_store/test/test_cemented_store.ml index b95881a2e313..3cde545a4d90 100644 --- a/src/lib_store/test/test_cemented_store.ml +++ b/src/lib_store/test/test_cemented_store.ml @@ -58,7 +58,7 @@ let assert_presence_in_cemented_store ?(with_metadata = true) cemented_store let test_cement_pruned_blocks cemented_store = let open Lwt_result_syntax in - let*! (blocks, _head) = + let*! blocks, _head = make_raw_block_list ~kind:`Pruned (genesis_hash, -1l) 4095 in let* () = @@ -71,7 +71,7 @@ let test_cement_pruned_blocks cemented_store = let test_cement_full_blocks cemented_store = let open Lwt_result_syntax in - let*! (blocks, _head) = + let*! blocks, _head = make_raw_block_list ~kind:`Full (genesis_hash, -1l) 4095 in let* () = @@ -84,7 +84,7 @@ let test_cement_full_blocks cemented_store = let test_metadata_retrieval cemented_store = let open Lwt_result_syntax in - let*! (blocks, _head) = + let*! blocks, _head = make_raw_block_list ~kind:`Full (genesis_hash, -1l) 100 in let* () = diff --git a/src/lib_store/test/test_history_mode_switch.ml b/src/lib_store/test/test_history_mode_switch.ml index da4f9b0d9e4a..7db2efd20673 100644 --- a/src/lib_store/test/test_history_mode_switch.ml +++ b/src/lib_store/test/test_history_mode_switch.ml @@ -229,16 +229,16 @@ let check_consistency_after_switch descr chain_store ~previous_mode ~target_mode ~msg:("expected history mode: " ^ descr) stored_history_mode target_mode ; - let*! (_, savepoint_level) = Store.Chain.savepoint chain_store in - let*! (_, caboose_level) = Store.Chain.caboose chain_store in + let*! _, savepoint_level = Store.Chain.savepoint chain_store in + let*! _, caboose_level = Store.Chain.caboose chain_store in let* () = match (previous_mode, target_mode) with - | (Archive, Archive) - | (Archive, Rolling _) - | (Archive, Full _) - | (Full _, Full _) - | (Full _, Rolling _) - | (Rolling _, Rolling _) -> + | Archive, Archive + | Archive, Rolling _ + | Archive, Full _ + | Full _, Full _ + | Full _, Rolling _ + | Rolling _, Rolling _ -> let* expected_savepoint_level = expected_savepoint chain_store @@ -268,8 +268,8 @@ let check_consistency_after_switch descr chain_store ~previous_mode ~target_mode | _ -> Alcotest.fail "Should not happen in test" in match (previous_mode, target_mode) with - | (Archive, Full _) | (Full _, Full _) -> - let (below_savepoint, above_savepoint) = + | Archive, Full _ | Full _, Full _ -> + let below_savepoint, above_savepoint = List.split_n (Int32.to_int savepoint_level) blocks in let* () = @@ -285,11 +285,11 @@ let check_consistency_after_switch descr chain_store ~previous_mode ~target_mode above_savepoint in return_unit - | (Archive, Rolling _) | (Full _, Rolling _) | (Rolling _, Rolling _) -> - let (below_caboose, above_caboose) = + | Archive, Rolling _ | Full _, Rolling _ | Rolling _, Rolling _ -> + let below_caboose, above_caboose = List.split_n Int32.(to_int (pred caboose_level)) blocks in - let (below_savepoint, above_savepoint) = + let below_savepoint, above_savepoint = List.split_n (Int32.to_int savepoint_level) above_caboose in let* () = assert_absence_in_store chain_store below_caboose in @@ -306,7 +306,7 @@ let check_consistency_after_switch descr chain_store ~previous_mode ~target_mode above_savepoint in return_unit - | (p, n) when History_mode.equal p n -> return_unit + | p, n when History_mode.equal p n -> return_unit | _ -> assert false let test ~test_descr ~from_hm ~to_hm ~nb_blocks_to_bake (store_dir, context_dir) @@ -314,7 +314,7 @@ let test ~test_descr ~from_hm ~to_hm ~nb_blocks_to_bake (store_dir, context_dir) let open Lwt_result_syntax in let chain_store = Store.main_chain_store store in let*! genesis_block = Store.Chain.genesis_block chain_store in - let* (previously_baked_blocks, _current_head) = + let* previously_baked_blocks, _current_head = Alpha_utils.bake_n chain_store nb_blocks_to_bake genesis_block in let*! () = @@ -337,8 +337,8 @@ let test ~test_descr ~from_hm ~to_hm ~nb_blocks_to_bake (store_dir, context_dir) | [Store_errors.Cannot_switch_history_mode _] -> return (match (from_hm, to_hm) with - | (_, Archive) -> true - | (Rolling _, Full _) -> true + | _, Archive -> true + | Rolling _, Full _ -> true | _ -> false) | err -> Format.printf diff --git a/src/lib_store/test/test_reconstruct.ml b/src/lib_store/test/test_reconstruct.ml index 7d7ed61b6ca6..aef3f5071ad6 100644 --- a/src/lib_store/test/test_reconstruct.ml +++ b/src/lib_store/test/test_reconstruct.ml @@ -62,7 +62,7 @@ let test_from_bootstrapped ~descr (store_dir, context_dir) store let chain_store = Store.main_chain_store store in let genesis = Store.Chain.genesis chain_store in let*! genesis_block = Store.Chain.genesis_block chain_store in - let* (baked_blocks, last) = + let* baked_blocks, last = Alpha_utils.bake_n chain_store nb_blocks_to_bake genesis_block in let*! savepoint = Store.Chain.savepoint chain_store in @@ -175,7 +175,7 @@ let test_from_snapshot ~descr:_ (store_dir, context_dir) store let open Lwt_result_syntax in let chain_store = Store.main_chain_store store in let*! genesis_block = Store.Chain.genesis_block chain_store in - let* (baked_blocks, last) = + let* baked_blocks, last = Alpha_utils.bake_n chain_store nb_blocks_to_bake genesis_block in let*! lafl = diff --git a/src/lib_store/test/test_snapshots.ml b/src/lib_store/test/test_snapshots.ml index dfb9b88ca26c..61330b27f1d9 100644 --- a/src/lib_store/test/test_snapshots.ml +++ b/src/lib_store/test/test_snapshots.ml @@ -55,7 +55,7 @@ let check_import_invariants ~test_descr ~rolling let*! savepoint = Store.Chain.savepoint imported_chain_store in let*! checkpoint = Store.Chain.checkpoint imported_chain_store in let*! caboose = Store.Chain.caboose imported_chain_store in - let (expected_present, expected_absent) = + let expected_present, expected_absent = List.partition (fun b -> Compare.Int32.(Store.Block.level b <= snd checkpoint) @@ -236,7 +236,7 @@ let check_baking_continuity ~test_descr ~exported_chain_store Int32.( to_int (sub level_to_reach (Store.Block.level export_store_head))) in - let* (_blocks, last) = + let* _blocks, last = Alpha_utils.bake_n exported_chain_store nb_blocks_to_bake_in_export @@ -265,7 +265,7 @@ let test store_path ~test_descr ?exported_block_level let open Lwt_result_syntax in let chain_store = Store.main_chain_store store in let*! genesis_block = Store.Chain.genesis_block chain_store in - let* (previously_baked_blocks, _current_head) = + let* previously_baked_blocks, _current_head = Alpha_utils.bake_n chain_store nb_blocks_to_bake_before_export genesis_block in (* We don't have a way to lock two stores in the same process => @@ -486,7 +486,7 @@ let test_rolling () = let chain_store = Store.main_chain_store store in let*! genesis_block = Store.Chain.genesis_block chain_store in let nb_cycles_to_bake = 6 in - let* (_blocks, head) = + let* _blocks, head = Alpha_utils.bake_until_n_cycle_end chain_store nb_cycles_to_bake @@ -601,7 +601,7 @@ let test_drag_after_import () = let chain_store = Store.main_chain_store store in let*! genesis_block = Store.Chain.genesis_block chain_store in let nb_cycles_to_bake = 2 in - let* (_blocks, head) = + let* _blocks, head = Alpha_utils.bake_until_n_cycle_end chain_store nb_cycles_to_bake @@ -664,10 +664,10 @@ let test_drag_after_import () = in let chain_store' = Store.main_chain_store store' in (* Finish to bake the current cycle. *) - let* (_, _head) = + let* _, _head = Alpha_utils.bake_until_cycle_end chain_store' export_block in - let*! (savepoint_hash, savepoint_level) = + let*! savepoint_hash, savepoint_level = Store.Chain.savepoint chain_store' in let* savepoint = Store.Block.read_block chain_store' savepoint_hash in @@ -676,16 +676,16 @@ let test_drag_after_import () = Int32.( sub savepoint_level (of_int (Store.Block.max_operations_ttl metadata))) in - let*! (_, caboose_level) = Store.Chain.caboose chain_store' in + let*! _, caboose_level = Store.Chain.caboose chain_store' in Assert.Int32.equal ~msg:__LOC__ caboose_level expected_caboose ; let block_store = Store.Unsafe.get_block_store chain_store' in let rec restart n head = if n = 0 then return head else - let* (_, head) = Alpha_utils.bake_until_cycle_end chain_store' head in + let* _, head = Alpha_utils.bake_until_cycle_end chain_store' head in let*! () = Block_store.await_merging block_store in - let*! (_, caboose_level) = Store.Chain.caboose chain_store' in - let*! (_, savepoint_level) = Store.Chain.savepoint chain_store' in + let*! _, caboose_level = Store.Chain.caboose chain_store' in + let*! _, savepoint_level = Store.Chain.savepoint chain_store' in let* () = List.iter_es (fun level -> diff --git a/src/lib_store/test/test_store.ml b/src/lib_store/test/test_store.ml index 39e742ff7a06..b88dd3267ec5 100644 --- a/src/lib_store/test/test_store.ml +++ b/src/lib_store/test/test_store.ml @@ -32,7 +32,7 @@ let test_cycles store = let* blocks = List.fold_left_es (fun acc _ -> - let* (blocks, _head) = append_cycle ~should_set_head:true chain_store in + let* blocks, _head = append_cycle ~should_set_head:true chain_store in return (blocks @ acc)) [] (1 -- 10) @@ -49,8 +49,8 @@ open Example_tree let rec compare_path is_eq p1 p2 = match (p1, p2) with - | ([], []) -> true - | (h1 :: p1, h2 :: p2) -> is_eq h1 h2 && compare_path is_eq p1 p2 + | [], [] -> true + | h1 :: p1, h2 :: p2 -> is_eq h1 h2 && compare_path is_eq p1 p2 | _ -> false let vblock tbl k = @@ -309,7 +309,7 @@ let test_new_blocks chain_store tbl = let open Lwt_syntax in let test head h expected_ancestor expected = let to_block = vblock tbl head and from_block = vblock tbl h in - let* (ancestor, blocks) = + let* ancestor, blocks = Store.Chain_traversal.new_blocks chain_store ~from_block ~to_block in if @@ -374,7 +374,7 @@ let test_basic_checkpoint chain_store table = chain_store (Store.Block.hash block, Store.Block.level block) in - let*! (c_block, c_level) = Store.Chain.checkpoint chain_store in + let*! c_block, c_level = Store.Chain.checkpoint chain_store in (* Target should not be set, only the checkpoint. *) let* () = let*! o = Store.Chain.target chain_store in @@ -456,14 +456,14 @@ let test_best_know_head_for_checkpoint chain_store table = Storing a block at the same level with a different hash is not allowed. - *) +*) let test_future_target chain_store _ = let open Lwt_result_syntax in let*! genesis_block = Store.Chain.genesis_block chain_store in let genesis_descr = Store.Block.descriptor genesis_block in - let*! (bad_chain, bad_head) = make_raw_block_list genesis_descr 5 in - let*! (good_chain, good_head) = make_raw_block_list genesis_descr 5 in + let*! bad_chain, bad_head = make_raw_block_list genesis_descr 5 in + let*! good_chain, good_head = make_raw_block_list genesis_descr 5 in let* () = Store.Chain.set_target chain_store (raw_descriptor good_head) in let* () = List.iter_es @@ -497,7 +497,6 @@ let test_future_target chain_store _ = Genesis - A1 (cp) - A2 (head) - A3 - A4 - A5 \ B1 - B2 - B3 - B4 - B5 - *) let test_reach_target chain_store table = @@ -524,7 +523,7 @@ let test_reach_target chain_store table = let* () = Store.Chain.set_target chain_store (checkpoint_hash, checkpoint_level) in - let*! (c_hash, _c_level) = Store.Chain.checkpoint chain_store in + let*! c_hash, _c_level = Store.Chain.checkpoint chain_store in let time_now = Time.System.to_protocol (Time.System.now ()) in if Time.Protocol.compare diff --git a/src/lib_store/test/test_testchain.ml b/src/lib_store/test/test_testchain.ml index 651084535c93..20a55ace8367 100644 --- a/src/lib_store/test/test_testchain.ml +++ b/src/lib_store/test/test_testchain.ml @@ -70,7 +70,7 @@ let fork_testchain chain_store (blocks, forked_block) = ~expiration in let testchain_store = Store.Chain.testchain_store testchain in - let* (test_blocks, head) = + let* test_blocks, head = append_blocks ~min_lafl:genesis_header.shell.level ~should_commit:true @@ -87,7 +87,7 @@ let fork_testchain chain_store (blocks, forked_block) = let test_simple store = let open Lwt_result_syntax in let chain_store = Store.main_chain_store store in - let* (blocks, head) = + let* blocks, head = append_blocks ~should_commit:true ~should_set_head:true @@ -101,7 +101,7 @@ let test_simple store = let test_inner store = let open Lwt_result_syntax in let chain_store = Store.main_chain_store store in - let* (blocks, head) = + let* blocks, head = append_blocks ~should_commit:true ~should_set_head:true @@ -109,7 +109,7 @@ let test_inner store = ~kind:`Full 10 in - let* (testchain, blocks, head) = fork_testchain chain_store (blocks, head) in + let* testchain, blocks, head = fork_testchain chain_store (blocks, head) in let testchain_store = Store.Chain.testchain_store testchain in let* _ = fork_testchain testchain_store (blocks, head) in return_unit @@ -117,7 +117,7 @@ let test_inner store = let test_shutdown store = let open Lwt_result_syntax in let chain_store = Store.main_chain_store store in - let* (blocks, head) = + let* blocks, head = append_blocks ~should_commit:true ~should_set_head:true @@ -125,7 +125,7 @@ let test_shutdown store = ~kind:`Full 10 in - let* (testchain, blocks, _head) = fork_testchain chain_store (blocks, head) in + let* testchain, blocks, _head = fork_testchain chain_store (blocks, head) in let testchain_store = Store.Chain.testchain_store testchain in let testchain_id = Store.Chain.chain_id testchain_store in let*! o = Store.Chain.testchain chain_store in diff --git a/src/lib_store/test/test_utils.ml b/src/lib_store/test/test_utils.ml index 6f28735d33cd..2c3719ec5388 100644 --- a/src/lib_store/test/test_utils.ml +++ b/src/lib_store/test/test_utils.ml @@ -31,8 +31,8 @@ open Filename.Infix let equal_metadata ?msg m1 m2 = let eq m1 m2 = match (m1, m2) with - | (None, None) -> true - | (Some m1, Some m2) -> m1 = m2 + | None, None -> true + | Some m1, Some m2 -> m1 = m2 | _ -> false in let pp ppf (md : Tezos_store.Store.Block.metadata option) = @@ -131,8 +131,8 @@ let check_invariants ?(expected_checkpoint = None) ?(expected_savepoint = None) in let*! () = match (savepoint_b_opt, savepoint_metadata_opt) with - | (Some _, Some _) -> Lwt.return_unit - | (Some _, None) -> + | Some _, Some _ -> Lwt.return_unit + | Some _, None -> Assert.fail_msg "check_invariant: could not find savepoint's metadata" | _ -> Assert.fail_msg "check_invariant: could not find savepoint block" @@ -142,8 +142,8 @@ let check_invariants ?(expected_checkpoint = None) ?(expected_savepoint = None) Block.read_block_metadata chain_store (fst caboose) in match (caboose_b_opt, caboose_metadata_opt) with - | (Some _, (Some _ | None)) -> return_unit - | (None, _) -> + | Some _, (Some _ | None) -> return_unit + | None, _ -> Format.eprintf "caboose lvl : %ld@." (snd caboose) ; Assert.fail_msg "check_invariant: could not find the caboose block") (fun exn -> @@ -371,13 +371,13 @@ let make_raw_block ?min_lafl ?(max_operations_ttl = default_max_operations_ttl) let prune_block block = block.Block_repr.metadata <- None let pp_block fmt b = - let (h, lvl) = Store.Block.descriptor b in + let h, lvl = Store.Block.descriptor b in Format.fprintf fmt "%a (%ld)" Block_hash.pp h lvl let raw_descriptor b = (Block_repr.hash b, Block_repr.level b) let pp_raw_block fmt b = - let (h, lvl) = raw_descriptor b in + let h, lvl = raw_descriptor b in Format.fprintf fmt "%a (%ld)" Block_hash.pp h lvl let store_raw_block chain_store (raw_block : Block_repr.t) = @@ -484,13 +484,13 @@ let append_blocks ?min_lafl ?constants ?max_operations_ttl ?root ?(kind = `Full) (Store.context_index (Store.Chain.global_store chain_store)) (Store.Block.context_hash root_b) in - let*! (blocks, _last) = + let*! blocks, _last = make_raw_block_list ?min_lafl ?constants ?max_operations_ttl ~kind root n in - let* (_, _, blocks) = + let* _, _, blocks = List.fold_left_es (fun (ctxt_opt, last_opt, blocks) b -> - let* (ctxt, last_opt, b) = + let* ctxt, last_opt, b = if should_commit then let open Tezos_context in let ctxt = WithExceptions.Option.get ~loc:__LOC__ ctxt_opt in @@ -666,7 +666,7 @@ module Example_tree = struct in let chain_store = Store.main_chain_store store in let main_chain = List.map (fun i -> Format.sprintf "A%d" i) (1 -- 8) in - let* (blocks, _head) = + let* blocks, _head = append_blocks chain_store ~kind:`Full (List.length main_chain) in let*! main_blocks = @@ -677,7 +677,7 @@ module Example_tree = struct let a2 = List.nth main_blocks 2 |> WithExceptions.Option.get ~loc:__LOC__ in let main_blocks = combine_exn main_chain main_blocks in let branch_chain = List.map (fun i -> Format.sprintf "B%d" i) (1 -- 8) in - let* (branch, _head) = + let* branch, _head = append_blocks chain_store ~root:(Store.Block.descriptor a2) diff --git a/src/lib_test/assert.ml b/src/lib_test/assert.ml index b0a5a40946bc..9edcfdc9e88f 100644 --- a/src/lib_test/assert.ml +++ b/src/lib_test/assert.ml @@ -175,14 +175,14 @@ module Base = struct let pp_list = pp_list pp in let rec iter i x y = match (x, y) with - | (hd_x :: tl_x, hd_y :: tl_y) -> + | hd_x :: tl_x, hd_y :: tl_y -> if eq hd_x hd_y then iter (succ i) tl_x tl_y else let msg = Format.asprintf "@[<h>%a(at index %d)@]" pp_msg_opt msg i in fail pp hd_x hd_y ~msg ?loc - | (_ :: _, []) | ([], _ :: _) -> + | _ :: _, [] | [], _ :: _ -> fail_msg "@[<v 2>@[<h>%a%a@](lists of different sizes: %d <> %d. The lists \ are %a and %a@]" @@ -196,7 +196,7 @@ module Base = struct x pp_list y - | ([], []) -> () + | [], [] -> () in iter 0 x y diff --git a/src/lib_test/assert_lib.ml b/src/lib_test/assert_lib.ml index 66e9ae531e55..797ffc173c7e 100644 --- a/src/lib_test/assert_lib.ml +++ b/src/lib_test/assert_lib.ml @@ -99,16 +99,16 @@ module Raw_Tree = struct let equal ?loc ?msg r1 r2 = let rec aux r1 r2 = match (r1, r2) with - | (`Value v1, `Value v2) -> + | `Value v1, `Value v2 -> Assert.Bytes.equal ?loc ?msg v1 v2 ; true - | (`Tree t1, `Tree t2) -> + | `Tree t1, `Tree t2 -> if not (Tezos_base.TzPervasives.String.Map.equal aux t1 t2) then Assert.String.fail "<tree>" "<tree>" ?msg ?loc else true - | (`Tree _, `Value v) -> + | `Tree _, `Value v -> Assert.String.fail ?loc ?msg "<tree>" (Bytes.to_string v) - | (`Value v, `Tree _) -> + | `Value v, `Tree _ -> Assert.String.fail ?loc ?msg (Bytes.to_string v) "<tree>" in let _b : bool = aux r1 r2 in diff --git a/src/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml index 0600ea85c8cc..795d9b8df4d1 100644 --- a/src/lib_test/qcheck2_helpers.ml +++ b/src/lib_test/qcheck2_helpers.ml @@ -29,9 +29,9 @@ let qcheck_wrap ?verbose ?long ?rand = let qcheck_eq ?pp ?cmp ?eq expected actual = let pass = match (eq, cmp) with - | (Some eq, _) -> eq expected actual - | (None, Some cmp) -> cmp expected actual = 0 - | (None, None) -> Stdlib.compare expected actual = 0 + | Some eq, _ -> eq expected actual + | None, Some cmp -> cmp expected actual = 0 + | None, None -> Stdlib.compare expected actual = 0 in if pass then true else @@ -175,7 +175,7 @@ let endpoint_gen = ":" ^ Int.to_string port in let url_string_gen = - let+ (protocol, path, opt_part) = + let+ protocol, path, opt_part = triple protocol_gen path_gen (opt port_gen) in String.concat "" [protocol; "://"; path; Option.value ~default:"" opt_part] diff --git a/src/lib_test/qcheck_extra.ml b/src/lib_test/qcheck_extra.ml index e3d57390a7df..d61c40e4dc3d 100644 --- a/src/lib_test/qcheck_extra.ml +++ b/src/lib_test/qcheck_extra.ml @@ -145,7 +145,7 @@ module Stateful_gen = struct let return x _ = F.return x let bind m f g = - let (g1, g2) = Random_pure.split g in + let g1, g2 = Random_pure.split g in F.bind (m g1) (fun a -> f a g2) let ( let* ) = bind @@ -155,7 +155,7 @@ module Stateful_gen = struct return (f a) let map2 f x y g = - let (g1, g2) = Random_pure.split g in + let g1, g2 = Random_pure.split g in F.map2 f (x g1) (y g2) let join x = diff --git a/src/lib_test/qcheck_helpers.ml b/src/lib_test/qcheck_helpers.ml index 7cfe8b7d0763..d2b0f8b74599 100644 --- a/src/lib_test/qcheck_helpers.ml +++ b/src/lib_test/qcheck_helpers.ml @@ -29,9 +29,9 @@ let qcheck_wrap ?verbose ?long ?rand = let qcheck_eq ?pp ?cmp ?eq expected actual = let pass = match (eq, cmp) with - | (Some eq, _) -> eq expected actual - | (None, Some cmp) -> cmp expected actual = 0 - | (None, None) -> Stdlib.compare expected actual = 0 + | Some eq, _ -> eq expected actual + | None, Some cmp -> cmp expected actual = 0 + | None, None -> Stdlib.compare expected actual = 0 in if pass then true else @@ -50,9 +50,9 @@ let qcheck_eq ?pp ?cmp ?eq expected actual = let qcheck_neq ?pp ?cmp ?eq left right = let pass = match (eq, cmp) with - | (Some eq, _) -> eq left right - | (None, Some cmp) -> cmp left right = 0 - | (None, None) -> Stdlib.compare left right = 0 + | Some eq, _ -> eq left right + | None, Some cmp -> cmp left right = 0 + | None, None -> Stdlib.compare left right = 0 in if not pass then true else @@ -141,7 +141,7 @@ let endpoint_arb = ":" ^ Int.to_string port in let url_string_gen = - let+ (protocol, path, opt_part) = + let+ protocol, path, opt_part = triple protocol_gen path_gen (opt port_arb) in String.concat "" [protocol; "://"; path; Option.value ~default:"" opt_part] diff --git a/src/lib_time_measurement/ppx/time_ppx.ml b/src/lib_time_measurement/ppx/time_ppx.ml index 551402c3e2b8..feaaac7bd564 100644 --- a/src/lib_time_measurement/ppx/time_ppx.ml +++ b/src/lib_time_measurement/ppx/time_ppx.ml @@ -142,7 +142,7 @@ let locaction_of_rewriter = function let error loc err = let open Format in - let (msg, hint) = + let msg, hint = match err with | `Too_many_Detection attribute_name -> ( sprintf diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index baa7ecefc5ce..0114db989902 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -523,15 +523,13 @@ module Make (Proto : Registered_protocol.T) = struct ~cache block_header [@time.duration_lwt application_beginning]) in - let* (state, ops_metadata) = + let* state, ops_metadata = (List.fold_left_es (fun (state, acc) ops -> - let* (state, ops_metadata) = + let* state, ops_metadata = List.fold_left_es (fun (state, acc) op -> - let* (state, op_metadata) = - Proto.apply_operation state op - in + let* state, op_metadata = Proto.apply_operation state op in return (state, op_metadata :: acc)) (state, []) ops @@ -541,7 +539,7 @@ module Make (Proto : Registered_protocol.T) = struct operations [@time.duration_lwt operations_application]) in let ops_metadata = List.rev ops_metadata in - let* (validation_result, block_data) = + let* validation_result, block_data = (Proto.finalize_block state (Some block_header.shell) [@time.duration_lwt block_finalization]) @@ -620,7 +618,7 @@ module Make (Proto : Registered_protocol.T) = struct predecessor_context predecessor_hash in - let* (validation_result, block_metadata, ops_metadata) = + let* validation_result, block_metadata, ops_metadata = proto_apply_operations chain_id context @@ -668,7 +666,7 @@ module Make (Proto : Registered_protocol.T) = struct found = validation_result.fitness; })) in - let* (validation_result, new_protocol_env_version) = + let* validation_result, new_protocol_env_version = may_init_new_protocol new_protocol block_header @@ -681,7 +679,7 @@ module Make (Proto : Registered_protocol.T) = struct (min (max_operations_ttl + 1) validation_result.max_operations_ttl) in let validation_result = {validation_result with max_operations_ttl} in - let* (block_metadata, ops_metadata) = + let* block_metadata, ops_metadata = compute_metadata ~operation_metadata_size_limit new_protocol_env_version @@ -735,7 +733,7 @@ module Make (Proto : Registered_protocol.T) = struct predecessor_hash in let* operations = parse_operations block_hash operations in - let* (validation_result, block_metadata, ops_metadata) = + let* validation_result, block_metadata, ops_metadata = proto_apply_operations chain_id context @@ -747,7 +745,7 @@ module Make (Proto : Registered_protocol.T) = struct in let context = Shell_context.unwrap_disk_context validation_result.context in let*! new_protocol = Context.get_protocol context in - let* (_validation_result, new_protocol_env_version) = + let* _validation_result, new_protocol_env_version = may_init_new_protocol new_protocol block_header @@ -918,7 +916,7 @@ module Make (Proto : Registered_protocol.T) = struct receipts, acc_validation_state ) operations -> - let*! (new_validation_result, new_validation_state, rev_receipts) = + let*! new_validation_result, new_validation_state, rev_receipts = List.fold_left_s (fun (acc_validation_result, acc_validation_state, receipts) op -> match parse op with @@ -974,7 +972,7 @@ module Make (Proto : Registered_protocol.T) = struct fitness = []; } in - let* (validation_result, block_header_metadata) = + let* validation_result, block_header_metadata = Proto.finalize_block preapply_state.state (Some shell_header) in let*! validation_result = @@ -995,7 +993,7 @@ module Make (Proto : Registered_protocol.T) = struct let shell_header : Block_header.shell_header = {shell_header with proto_level; fitness = validation_result.fitness} in - let* (validation_result, cache, new_protocol_env_version) = + let* validation_result, cache, new_protocol_env_version = if Protocol_hash.equal protocol Proto.hash then let (Environment_context.Context.Context {cache; _}) = validation_result.context @@ -1034,7 +1032,7 @@ module Make (Proto : Registered_protocol.T) = struct let preapply_result = ({shell_header with context = context_hash}, validation_result_list) in - let* (block_metadata, ops_metadata) = + let* block_metadata, ops_metadata = compute_metadata ~operation_metadata_size_limit new_protocol_env_version @@ -1094,14 +1092,14 @@ module Make (Proto : Registered_protocol.T) = struct (fun state ops -> List.fold_left_es (fun state op -> - let* (state, _op_metadata) = Proto.apply_operation state op in + let* state, _op_metadata = Proto.apply_operation state op in return state) state ops) state operations in - let* (_validation_result, _block_data) = Proto.finalize_block state None in + let* _validation_result, _block_data = Proto.finalize_block state None in return_unit let precheck chain_id ~(predecessor_block_header : Block_header.t) diff --git a/src/lib_validation/protocol_logging.ml b/src/lib_validation/protocol_logging.ml index b71cf381db59..fbd90b5ca07f 100644 --- a/src/lib_validation/protocol_logging.ml +++ b/src/lib_validation/protocol_logging.ml @@ -59,7 +59,7 @@ let logging_failure = ("exc", Data_encoding.string) let make_asynchronous_log_message_consumer () = - let (stream, push) = Lwt_stream.create () in + let stream, push = Lwt_stream.create () in let alive = ref true in Lwt.dont_wait (fun () -> diff --git a/src/lib_version/exe/get_git_info.ml b/src/lib_version/exe/get_git_info.ml index ea86a676e23d..7a6e9c3e021a 100644 --- a/src/lib_version/exe/get_git_info.ml +++ b/src/lib_version/exe/get_git_info.ml @@ -32,7 +32,7 @@ module Configurator = Configurator.V1 let query ?env ~default cmd = let run_git () = try - let (ic, oc, ec) = Unix.open_process_full cmd [||] in + let ic, oc, ec = Unix.open_process_full cmd [||] in let out = input_line ic in if Unix.close_process_full (ic, oc, ec) = Unix.WEXITED 0 then out else default @@ -70,7 +70,7 @@ let raw_current_version = "$Format:%(describe:tags)$" If one commit is associated with two or more tags, output always the most recently added tag that match the regexp `v*` - *) +*) let git_describe = let parse s = match parse_version s with diff --git a/src/lib_version/test/test_parser.ml b/src/lib_version/test/test_parser.ml index 14c609d74ae1..7bbeeea9b179 100644 --- a/src/lib_version/test/test_parser.ml +++ b/src/lib_version/test/test_parser.ml @@ -55,18 +55,18 @@ let eq v1 v2 = let open Version in let additional_info_eq a1 a2 = match (a1, a2) with - | (Dev, Dev) -> true - | (Dev, _) -> false - | (RC n1, RC n2) | (RC_dev n1, RC_dev n2) -> n1 = n2 - | (RC _, _) | (RC_dev _, _) -> false - | (Release, Release) -> true - | (Release, _) -> false + | Dev, Dev -> true + | Dev, _ -> false + | RC n1, RC n2 | RC_dev n1, RC_dev n2 -> n1 = n2 + | RC _, _ | RC_dev _, _ -> false + | Release, Release -> true + | Release, _ -> false in match (v1, v2) with - | (Some v1, Some v2) -> + | Some v1, Some v2 -> v1.major = v2.major && v1.minor = v2.minor && additional_info_eq v1.additional_info v2.additional_info - | (_, _) -> false + | _, _ -> false let prn = function | None -> diff --git a/src/lib_workers/worker.ml b/src/lib_workers/worker.ml index 308233d7f8af..981a8a292f86 100644 --- a/src/lib_workers/worker.ml +++ b/src/lib_workers/worker.ml @@ -313,7 +313,7 @@ struct with Lwt_dropbox.Closed -> () let drop_request_and_wait w message_box request = - let (t, u) = Lwt.wait () in + let t, u = Lwt.wait () in Lwt.catch (fun () -> Lwt_dropbox.put message_box (queue_item ~u request) ; @@ -380,14 +380,14 @@ struct match w.buffer with | Queue_buffer message_queue -> ( try - let (t, u) = Lwt.wait () in + let t, u = Lwt.wait () in Lwt_pipe.Unbounded.push message_queue (queue_item ~u request) ; t with Lwt_pipe.Closed -> let name = Format.asprintf "%a" Name.pp w.name in Lwt_result_syntax.tzfail (Closed {base = base_name; name})) | Bounded_buffer message_queue -> - let (t, u) = Lwt.wait () in + let t, u = Lwt.wait () in Lwt.try_bind (fun () -> Lwt_pipe.Bounded.push message_queue (queue_item ~u request)) @@ -408,9 +408,7 @@ struct Lwt_pipe.Bounded.peek_all_now message_queue with Lwt_pipe.Closed -> [] in - List.map - (function (t, Message (req, _)) -> (t, Request.view req)) - peeked + List.map (function t, Message (req, _) -> (t, Request.view req)) peeked let pending_requests_length (type a) (w : a queue t) = let pipe_length (type a) (q : a buffer) = @@ -424,12 +422,12 @@ struct let close (type a) (w : a t) = let wakeup = function - | (_, Message (_, Some u)) -> + | _, Message (_, Some u) -> let name = Format.asprintf "%a" Name.pp w.name in Lwt.wakeup_later u (Result_syntax.tzfail (Closed {base = base_name; name})) - | (_, Message (_, None)) -> () + | _, Message (_, None) -> () in let close_queue message_queue = let messages = Lwt_pipe.Bounded.pop_all_now message_queue in @@ -716,22 +714,22 @@ struct let state w = match (w.state, w.status) with - | (None, Launching _) -> + | None, Launching _ -> invalid_arg (Format.asprintf "Worker.state (%s[%a]): state called before worker was initialized" base_name Name.pp w.name) - | (None, (Closing _ | Closed _)) -> + | None, (Closing _ | Closed _) -> invalid_arg (Format.asprintf "Worker.state (%s[%a]): state called after worker was terminated" base_name Name.pp w.name) - | (None, _) -> assert false - | (Some state, _) -> state + | None, _ -> assert false + | Some state, _ -> state let pending_requests q = Queue.pending_requests q diff --git a/src/proto_001_PtCJ7pwo/lib_client/client_proto_programs.ml b/src/proto_001_PtCJ7pwo/lib_client/client_proto_programs.ml index d62b99e46ca8..c2681e013770 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/client_proto_programs.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/client_proto_programs.ml @@ -158,7 +158,7 @@ let typecheck_program cctxt ?(chain = `Main) ~block ?gas let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml index 1134064e68b1..0722c986be2a 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml @@ -130,7 +130,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -138,7 +138,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -157,7 +157,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml index 9cd2169d1771..34466e11061d 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml @@ -409,7 +409,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Duplicate_map_keys (_, expr) -> diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_macros.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_macros.ml index 740d10acd877..27aa47493dc4 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_macros.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_macros.ml @@ -109,9 +109,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -224,9 +224,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -372,14 +372,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -394,18 +394,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -428,7 +428,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -436,13 +436,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc @@ -450,7 +450,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -486,7 +486,7 @@ let expand_unpappaiir original = let rec parse p (depth, acc) = match p with | P (i, left, right) -> - let (car_annot, cdr_annot) = + let car_annot, cdr_annot = match IntMap.find i annots_pos with | None -> ([], []) | Some (car_annot, cdr_annot) -> (car_annot, cdr_annot) @@ -495,7 +495,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -543,8 +543,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -713,7 +712,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -725,10 +724,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -794,7 +793,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -804,7 +803,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -871,7 +870,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -881,7 +880,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -925,7 +924,7 @@ let unexpand_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in let name = "D" ^ roman_of_decimal depth ^ "P" in Some (Prim (loc, name, [sub], [])) | _ -> None @@ -958,15 +957,15 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | [], _ -> stack + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -983,10 +982,10 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | [], _ -> stack + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml index 1be097c6eeb9..3f4971a4421c 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -88,8 +88,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -97,8 +97,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml index 8784c416f8af..b26983cb7b25 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml @@ -105,7 +105,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -137,8 +137,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_programs_commands.ml b/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_programs_commands.ml index b8c55499e607..3a24104a7e24 100644 --- a/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_programs_commands.ml @@ -173,7 +173,7 @@ let commands () = (prefixes ["typecheck"; "script"] @@ Program.source_param @@ stop) (fun (show_types, emacs_mode, no_print_source, original_gas) program cctxt -> match program with - | (program, []) -> + | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program cctxt ~block:cctxt#block ~gas:original_gas program @@ -191,7 +191,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -297,8 +297,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> diff --git a/src/proto_002_PsYLVpVv/lib_client/client_proto_context.ml b/src/proto_002_PsYLVpVv/lib_client/client_proto_context.ml index c0777a72376f..285c37a34379 100644 --- a/src/proto_002_PsYLVpVv/lib_client/client_proto_context.ml +++ b/src/proto_002_PsYLVpVv/lib_client/client_proto_context.ml @@ -80,18 +80,18 @@ let get_manager (cctxt : #Alpha_client_context.full) ~chain ~block source = let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #Client_context.full) ~chain predecessors diff --git a/src/proto_002_PsYLVpVv/lib_client/client_proto_programs.ml b/src/proto_002_PsYLVpVv/lib_client/client_proto_programs.ml index 20251648b159..34ecca3d0ca7 100644 --- a/src/proto_002_PsYLVpVv/lib_client/client_proto_programs.ml +++ b/src/proto_002_PsYLVpVv/lib_client/client_proto_programs.ml @@ -160,7 +160,7 @@ let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml index 1134064e68b1..0722c986be2a 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml @@ -130,7 +130,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -138,7 +138,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -157,7 +157,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml index 9cd2169d1771..34466e11061d 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml @@ -409,7 +409,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Duplicate_map_keys (_, expr) -> diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_macros.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_macros.ml index ab0757cfe5fe..11500e48c1f5 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_macros.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_macros.ml @@ -109,9 +109,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -224,9 +224,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -372,14 +372,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -394,18 +394,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -428,7 +428,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -436,13 +436,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc @@ -450,7 +450,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -486,7 +486,7 @@ let expand_unpappaiir original = let rec parse p (depth, acc) = match p with | P (i, left, right) -> - let (car_annot, cdr_annot) = + let car_annot, cdr_annot = match IntMap.find i annots_pos with | None -> ([], []) | Some (car_annot, cdr_annot) -> (car_annot, cdr_annot) @@ -495,7 +495,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -543,8 +543,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -712,7 +711,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -724,10 +723,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -793,7 +792,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -803,7 +802,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -870,7 +869,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -880,7 +879,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -924,7 +923,7 @@ let unexpand_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in let name = "D" ^ roman_of_decimal depth ^ "P" in Some (Prim (loc, name, [sub], [])) | _ -> None @@ -957,15 +956,15 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | [], _ -> stack + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -982,10 +981,10 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | [], _ -> stack + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml index 1be097c6eeb9..3f4971a4421c 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -88,8 +88,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -97,8 +97,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml index 8784c416f8af..b26983cb7b25 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml @@ -105,7 +105,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -137,8 +137,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_programs_commands.ml b/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_programs_commands.ml index c1bc0a607cd5..1dc0025b64fe 100644 --- a/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_programs_commands.ml @@ -189,7 +189,7 @@ let commands () = (prefixes ["typecheck"; "script"] @@ Program.source_param @@ stop) (fun (show_types, emacs_mode, no_print_source, original_gas) program cctxt -> match program with - | (program, []) -> + | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program @@ -212,7 +212,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -345,8 +345,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> diff --git a/src/proto_003_PsddFKi3/lib_client/client_proto_context.ml b/src/proto_003_PsddFKi3/lib_client/client_proto_context.ml index fd4a06e4d824..c6d4bb7c9087 100644 --- a/src/proto_003_PsddFKi3/lib_client/client_proto_context.ml +++ b/src/proto_003_PsddFKi3/lib_client/client_proto_context.ml @@ -123,18 +123,18 @@ let get_proposals (cctxt : #Alpha_client_context.full) ~chain ~block = let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #Client_context.full) ~chain predecessors diff --git a/src/proto_003_PsddFKi3/lib_client/client_proto_programs.ml b/src/proto_003_PsddFKi3/lib_client/client_proto_programs.ml index b0d20e703f25..c9d2848e4c6b 100644 --- a/src/proto_003_PsddFKi3/lib_client/client_proto_programs.ml +++ b/src/proto_003_PsddFKi3/lib_client/client_proto_programs.ml @@ -160,7 +160,7 @@ let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml index 5bb2f158f68d..9387c6a6d177 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml @@ -130,7 +130,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -138,7 +138,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -157,7 +157,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml index 9cd2169d1771..34466e11061d 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml @@ -409,7 +409,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Duplicate_map_keys (_, expr) -> diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml index 9b491d26c298..048c629d2bba 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml @@ -95,9 +95,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -210,9 +210,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -358,14 +358,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -380,18 +380,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -414,7 +414,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -422,13 +422,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc @@ -436,7 +436,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -472,7 +472,7 @@ let expand_unpappaiir original = let rec parse p (depth, acc) = match p with | P (i, left, right) -> - let (car_annot, cdr_annot) = + let car_annot, cdr_annot = match IntMap.find i annots_pos with | None -> ([], []) | Some (car_annot, cdr_annot) -> (car_annot, cdr_annot) @@ -481,7 +481,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -529,8 +529,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -698,7 +697,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -710,10 +709,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -779,7 +778,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -789,7 +788,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -856,7 +855,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -866,7 +865,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -919,7 +918,7 @@ let unexpand_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in let name = "D" ^ dxiiivp_roman_of_decimal depth ^ "P" in Some (Prim (loc, name, [sub], [])) | _ -> None @@ -952,15 +951,15 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | [], _ -> stack + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -977,10 +976,10 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | [], _ -> stack + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml index 1be097c6eeb9..3f4971a4421c 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -88,8 +88,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -97,8 +97,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml index 8784c416f8af..b26983cb7b25 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml @@ -105,7 +105,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -137,8 +137,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_programs_commands.ml b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_programs_commands.ml index 765dd0d50b89..f95e8408f058 100644 --- a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_programs_commands.ml @@ -178,7 +178,7 @@ let commands () = (prefixes ["typecheck"; "script"] @@ Program.source_param @@ stop) (fun (show_types, emacs_mode, no_print_source, original_gas) program cctxt -> match program with - | (program, []) -> + | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program @@ -201,7 +201,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -334,8 +334,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> diff --git a/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml b/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml index 8aa27f5955d4..004daaa7bfc9 100644 --- a/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml +++ b/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml @@ -124,18 +124,18 @@ let get_proposals (cctxt : #Alpha_client_context.full) ~chain ~block = let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #Client_context.full) ~chain predecessors diff --git a/src/proto_004_Pt24m4xi/lib_client/client_proto_programs.ml b/src/proto_004_Pt24m4xi/lib_client/client_proto_programs.ml index 9cc2c954f665..9b1075e8b565 100644 --- a/src/proto_004_Pt24m4xi/lib_client/client_proto_programs.ml +++ b/src/proto_004_Pt24m4xi/lib_client/client_proto_programs.ml @@ -163,7 +163,7 @@ let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml index 5bb2f158f68d..9387c6a6d177 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml @@ -130,7 +130,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -138,7 +138,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -157,7 +157,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml index 9cd2169d1771..34466e11061d 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml @@ -409,7 +409,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Duplicate_map_keys (_, expr) -> diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml index 9b491d26c298..048c629d2bba 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml @@ -95,9 +95,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -210,9 +210,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -358,14 +358,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -380,18 +380,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -414,7 +414,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -422,13 +422,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc @@ -436,7 +436,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -472,7 +472,7 @@ let expand_unpappaiir original = let rec parse p (depth, acc) = match p with | P (i, left, right) -> - let (car_annot, cdr_annot) = + let car_annot, cdr_annot = match IntMap.find i annots_pos with | None -> ([], []) | Some (car_annot, cdr_annot) -> (car_annot, cdr_annot) @@ -481,7 +481,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -529,8 +529,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -698,7 +697,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -710,10 +709,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -779,7 +778,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -789,7 +788,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -856,7 +855,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -866,7 +865,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -919,7 +918,7 @@ let unexpand_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in let name = "D" ^ dxiiivp_roman_of_decimal depth ^ "P" in Some (Prim (loc, name, [sub], [])) | _ -> None @@ -952,15 +951,15 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | [], _ -> stack + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -977,10 +976,10 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | [], _ -> stack + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml index 1be097c6eeb9..3f4971a4421c 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -88,8 +88,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -97,8 +97,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml index 8784c416f8af..b26983cb7b25 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml @@ -105,7 +105,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -137,8 +137,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_programs_commands.ml b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_programs_commands.ml index 2201f4fe95a2..c0952ccd5a2a 100644 --- a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_programs_commands.ml @@ -209,7 +209,7 @@ let commands () = (prefixes ["typecheck"; "script"] @@ Program.source_param @@ stop) (fun (show_types, emacs_mode, no_print_source, original_gas) program cctxt -> match program with - | (program, []) -> + | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program @@ -232,7 +232,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -367,8 +367,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> diff --git a/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml b/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml index 1cb61c70de06..9342a578698c 100644 --- a/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml +++ b/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml @@ -121,18 +121,18 @@ let get_proposals (cctxt : #full) ~chain ~block = let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_005_PsBabyM1/lib_client/client_proto_programs.ml b/src/proto_005_PsBabyM1/lib_client/client_proto_programs.ml index 7f1498d93b50..d0aba61efd94 100644 --- a/src/proto_005_PsBabyM1/lib_client/client_proto_programs.ml +++ b/src/proto_005_PsBabyM1/lib_client/client_proto_programs.ml @@ -163,7 +163,7 @@ let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_005_PsBabyM1/lib_client/injection.ml b/src/proto_005_PsBabyM1/lib_client/injection.ml index 2b003f558735..3e41519e1812 100644 --- a/src/proto_005_PsBabyM1/lib_client/injection.ml +++ b/src/proto_005_PsBabyM1/lib_client/injection.ml @@ -263,7 +263,7 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -281,12 +281,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block (chain, block) (Operation.pack op, chain_id) >>=? function - | (Operation_data op', Operation_metadata result) -> ( + | Operation_data op', Operation_metadata result -> ( match ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -470,10 +470,10 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) | Single _ -> None | Cons ((Manager_operation _ as c), rest) -> ( match (may_need_patching_single c, may_need_patching rest) with - | (None, None) -> None - | (Some c, None) -> Some (Cons (c, rest)) - | (None, Some rest) -> Some (Cons (c, rest)) - | (Some c, Some rest) -> Some (Cons (c, rest))) + | None, None -> None + | Some c, None -> Some (Cons (c, rest)) + | None, Some rest -> Some (Cons (c, rest)) + | Some c, Some rest -> Some (Cons (c, rest))) in let rec patch_fee : type kind. bool -> kind contents -> kind contents = fun first -> function @@ -527,7 +527,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind contents * kind contents_result -> kind contents tzresult Lwt.t = fun first -> function - | (Manager_operation c, (Manager_operation_result _ as result)) -> + | Manager_operation c, (Manager_operation_result _ as result) -> (if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then Lwt.return (estimated_gas_single result) >>=? fun gas -> if Z.equal gas Z.zero then @@ -556,7 +556,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) >>=? fun storage_limit -> let c = Manager_operation {c with gas_limit; storage_limit} in if compute_fee then return (patch_fee first c) else return c - | (c, _) -> return c + | c, _ -> return c in let rec patch_list : type kind. @@ -762,7 +762,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run | Reveal _ -> true | _ -> false in - let (compute_fee, fee) = + let compute_fee, fee = match fee with None -> (true, Tez.zero) | Some fee -> (false, fee) in match key with diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml index a8170db46ac3..642260527e78 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml @@ -131,7 +131,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -139,7 +139,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -158,7 +158,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml index a45cae6f083b..97dbcc234990 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml @@ -444,7 +444,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Duplicate_map_keys (_, expr) -> diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_macros.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_macros.ml index 41a41361a929..b70063ccdf4a 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_macros.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_macros.ml @@ -98,9 +98,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -213,9 +213,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -359,14 +359,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -381,18 +381,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -415,7 +415,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -423,13 +423,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -440,7 +440,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -476,7 +476,7 @@ let expand_unpappaiir original = let rec parse p (depth, acc) = match p with | P (i, left, right) -> - let (car_annot, cdr_annot) = + let car_annot, cdr_annot = match IntMap.find i annots_pos with | None -> ([], []) | Some (car_annot, cdr_annot) -> (car_annot, cdr_annot) @@ -490,7 +490,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -563,8 +563,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -733,7 +732,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -745,10 +744,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -814,7 +813,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -824,7 +823,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -891,7 +890,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -901,7 +900,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -922,7 +921,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -964,46 +963,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1020,41 +1019,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml index 1be097c6eeb9..3f4971a4421c 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -88,8 +88,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -97,8 +97,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml index 44c096f4ec26..603cdcc96ace 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml @@ -143,7 +143,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -175,8 +175,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_programs_commands.ml b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_programs_commands.ml index af4053862731..bb803a52d8ae 100644 --- a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_programs_commands.ml @@ -278,7 +278,7 @@ let commands () = (prefixes ["typecheck"; "script"] @@ Program.source_param @@ stop) (fun (show_types, emacs_mode, no_print_source, original_gas) program cctxt -> match program with - | (program, []) -> + | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program @@ -301,7 +301,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -436,8 +436,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> @@ -476,11 +475,10 @@ let commands () = (args2 emacs_mode_switch no_print_source_flag) (prefixes ["get"; "script"; "entrypoint"; "type"; "of"] @@ string ~name:"entrypoint" ~desc:"the entrypoint to describe" - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) entrypoint program cctxt -> match program with - | (program, []) -> + | program, [] -> entrypoint_type cctxt ~chain:cctxt#chain @@ -501,7 +499,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -521,7 +519,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_entrypoints cctxt ~chain:cctxt#chain ~block:cctxt#block program >>= fun entrypoints -> print_entrypoints_list @@ -536,7 +534,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -558,7 +556,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_unreachables cctxt ~chain:cctxt#chain @@ -577,7 +575,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> diff --git a/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml b/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml index 0085d6673670..e06654fca6df 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml @@ -90,7 +90,7 @@ let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run let reveal cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch ~source ~src_pk ~src_sk ?fee ~fee_parameter () = - let (compute_fee, fee) = + let compute_fee, fee = match fee with None -> (true, Tez.zero) | Some fee -> (false, fee) in Alpha_services.Contract.counter cctxt (chain, block) source @@ -496,18 +496,18 @@ let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_006_PsCARTHA/lib_client/client_proto_fa12.ml b/src/proto_006_PsCARTHA/lib_client/client_proto_fa12.ml index 1c8eb91572f3..0270fa7dd54f 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_fa12.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_fa12.ml @@ -420,8 +420,8 @@ let parse_callback error expr = let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in match (String.sub s 0 pos, name) with - | (addr, "default") -> of_b58_check (addr, None) - | (addr, name) -> of_b58_check (addr, Some name))) + | addr, "default" -> of_b58_check (addr, None) + | addr, name -> of_b58_check (addr, Some name))) | _ -> error () let action_of_expr ~entrypoint expr = @@ -520,7 +520,7 @@ let derive_action expr t_param = | ( Micheline.Prim (_, Script.D_Right, [right], _), Micheline.Prim (_, Script.T_or, [_; t_right], _) ) -> derive right t_right - | (_, Micheline.Prim (_, _, _, annots)) -> + | _, Micheline.Prim (_, _, _, annots) -> find_entrypoint_in_annot error annots expr | _ -> error () in diff --git a/src/proto_006_PsCARTHA/lib_client/client_proto_programs.ml b/src/proto_006_PsCARTHA/lib_client/client_proto_programs.ml index 8d12c681bb7d..eba3b861a517 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_programs.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_programs.ml @@ -165,7 +165,7 @@ let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_006_PsCARTHA/lib_client/injection.ml b/src/proto_006_PsCARTHA/lib_client/injection.ml index 2b003f558735..3e41519e1812 100644 --- a/src/proto_006_PsCARTHA/lib_client/injection.ml +++ b/src/proto_006_PsCARTHA/lib_client/injection.ml @@ -263,7 +263,7 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -281,12 +281,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block (chain, block) (Operation.pack op, chain_id) >>=? function - | (Operation_data op', Operation_metadata result) -> ( + | Operation_data op', Operation_metadata result -> ( match ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -470,10 +470,10 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) | Single _ -> None | Cons ((Manager_operation _ as c), rest) -> ( match (may_need_patching_single c, may_need_patching rest) with - | (None, None) -> None - | (Some c, None) -> Some (Cons (c, rest)) - | (None, Some rest) -> Some (Cons (c, rest)) - | (Some c, Some rest) -> Some (Cons (c, rest))) + | None, None -> None + | Some c, None -> Some (Cons (c, rest)) + | None, Some rest -> Some (Cons (c, rest)) + | Some c, Some rest -> Some (Cons (c, rest))) in let rec patch_fee : type kind. bool -> kind contents -> kind contents = fun first -> function @@ -527,7 +527,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind contents * kind contents_result -> kind contents tzresult Lwt.t = fun first -> function - | (Manager_operation c, (Manager_operation_result _ as result)) -> + | Manager_operation c, (Manager_operation_result _ as result) -> (if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then Lwt.return (estimated_gas_single result) >>=? fun gas -> if Z.equal gas Z.zero then @@ -556,7 +556,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) >>=? fun storage_limit -> let c = Manager_operation {c with gas_limit; storage_limit} in if compute_fee then return (patch_fee first c) else return c - | (c, _) -> return c + | c, _ -> return c in let rec patch_list : type kind. @@ -762,7 +762,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run | Reveal _ -> true | _ -> false in - let (compute_fee, fee) = + let compute_fee, fee = match fee with None -> (true, Tez.zero) | Some fee -> (false, fee) in match key with diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml index a8170db46ac3..642260527e78 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml @@ -131,7 +131,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -139,7 +139,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -158,7 +158,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml index 75e693137109..2ffd1255fae3 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml @@ -440,7 +440,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Duplicate_map_keys (_, expr) -> diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_macros.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_macros.ml index 41a41361a929..b70063ccdf4a 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_macros.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_macros.ml @@ -98,9 +98,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -213,9 +213,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -359,14 +359,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -381,18 +381,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -415,7 +415,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -423,13 +423,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -440,7 +440,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -476,7 +476,7 @@ let expand_unpappaiir original = let rec parse p (depth, acc) = match p with | P (i, left, right) -> - let (car_annot, cdr_annot) = + let car_annot, cdr_annot = match IntMap.find i annots_pos with | None -> ([], []) | Some (car_annot, cdr_annot) -> (car_annot, cdr_annot) @@ -490,7 +490,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -563,8 +563,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -733,7 +732,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -745,10 +744,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -814,7 +813,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -824,7 +823,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -891,7 +890,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -901,7 +900,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -922,7 +921,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -964,46 +963,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1020,41 +1019,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml index 1be097c6eeb9..3f4971a4421c 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -88,8 +88,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -97,8 +97,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml index 44c096f4ec26..603cdcc96ace 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml @@ -143,7 +143,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -175,8 +175,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml index dd1f72b51761..b653260006fb 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml @@ -925,8 +925,7 @@ let commands network () = ~desc:"Register and activate an Alphanet/Zeronet faucet account." (args2 (Secret_key.force_switch ()) encrypted_switch) (prefixes ["activate"; "account"] - @@ Secret_key.fresh_alias_param - @@ prefixes ["with"] + @@ Secret_key.fresh_alias_param @@ prefixes ["with"] @@ param ~name:"activation_key" ~desc: @@ -970,8 +969,7 @@ let commands network () = ~desc:"Activate a fundraiser account." (args1 dry_run_switch) (prefixes ["activate"; "fundraiser"; "account"] - @@ Public_key_hash.alias_param - @@ prefixes ["with"] + @@ Public_key_hash.alias_param @@ prefixes ["with"] @@ param ~name:"code" (Clic.parameter (fun _ctx code -> diff --git a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_multisig_commands.ml index 0d4a7d54b038..cf424aaec0da 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_multisig_commands.ml @@ -719,8 +719,7 @@ let commands () : #Protocol_client_context.full Clic.command list = @@ Client_proto_contracts.ContractAlias.destination_param ~name:"multisig" ~desc:"name or address of the originated multisig contract" - @@ prefixes ["to"] - @@ threshold_param () + @@ prefixes ["to"] @@ threshold_param () @@ prefixes ["and"; "public"; "keys"; "to"] @@ non_terminal_seq (public_key_param ()) ~suffix:["on"; "behalf"; "of"] @@ Client_proto_contracts.ContractAlias.destination_param diff --git a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_programs_commands.ml b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_programs_commands.ml index af4053862731..bb803a52d8ae 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_programs_commands.ml @@ -278,7 +278,7 @@ let commands () = (prefixes ["typecheck"; "script"] @@ Program.source_param @@ stop) (fun (show_types, emacs_mode, no_print_source, original_gas) program cctxt -> match program with - | (program, []) -> + | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program @@ -301,7 +301,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -436,8 +436,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> @@ -476,11 +475,10 @@ let commands () = (args2 emacs_mode_switch no_print_source_flag) (prefixes ["get"; "script"; "entrypoint"; "type"; "of"] @@ string ~name:"entrypoint" ~desc:"the entrypoint to describe" - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) entrypoint program cctxt -> match program with - | (program, []) -> + | program, [] -> entrypoint_type cctxt ~chain:cctxt#chain @@ -501,7 +499,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -521,7 +519,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_entrypoints cctxt ~chain:cctxt#chain ~block:cctxt#block program >>= fun entrypoints -> print_entrypoints_list @@ -536,7 +534,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -558,7 +556,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_unreachables cctxt ~chain:cctxt#chain @@ -577,7 +575,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> diff --git a/src/proto_007_PsDELPH1/lib_client/client_proto_context.ml b/src/proto_007_PsDELPH1/lib_client/client_proto_context.ml index e601c577f53b..20a302ed42ed 100644 --- a/src/proto_007_PsDELPH1/lib_client/client_proto_context.ml +++ b/src/proto_007_PsDELPH1/lib_client/client_proto_context.ml @@ -136,18 +136,18 @@ let get_proposals (cctxt : #full) ~chain ~block = let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_007_PsDELPH1/lib_client/client_proto_fa12.ml b/src/proto_007_PsDELPH1/lib_client/client_proto_fa12.ml index 1c8eb91572f3..0270fa7dd54f 100644 --- a/src/proto_007_PsDELPH1/lib_client/client_proto_fa12.ml +++ b/src/proto_007_PsDELPH1/lib_client/client_proto_fa12.ml @@ -420,8 +420,8 @@ let parse_callback error expr = let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in match (String.sub s 0 pos, name) with - | (addr, "default") -> of_b58_check (addr, None) - | (addr, name) -> of_b58_check (addr, Some name))) + | addr, "default" -> of_b58_check (addr, None) + | addr, name -> of_b58_check (addr, Some name))) | _ -> error () let action_of_expr ~entrypoint expr = @@ -520,7 +520,7 @@ let derive_action expr t_param = | ( Micheline.Prim (_, Script.D_Right, [right], _), Micheline.Prim (_, Script.T_or, [_; t_right], _) ) -> derive right t_right - | (_, Micheline.Prim (_, _, _, annots)) -> + | _, Micheline.Prim (_, _, _, annots) -> find_entrypoint_in_annot error annots expr | _ -> error () in diff --git a/src/proto_007_PsDELPH1/lib_client/client_proto_programs.ml b/src/proto_007_PsDELPH1/lib_client/client_proto_programs.ml index 6d40503a2d02..b52908d46873 100644 --- a/src/proto_007_PsDELPH1/lib_client/client_proto_programs.ml +++ b/src/proto_007_PsDELPH1/lib_client/client_proto_programs.ml @@ -78,7 +78,7 @@ let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml index a8170db46ac3..642260527e78 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml @@ -131,7 +131,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -139,7 +139,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -158,7 +158,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml index 349bf7275b38..89f5cd3a845d 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml @@ -440,7 +440,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Duplicate_map_keys (_, expr) -> diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_macros.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_macros.ml index 41a41361a929..b70063ccdf4a 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_macros.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_macros.ml @@ -98,9 +98,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -213,9 +213,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -359,14 +359,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -381,18 +381,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -415,7 +415,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -423,13 +423,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -440,7 +440,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -476,7 +476,7 @@ let expand_unpappaiir original = let rec parse p (depth, acc) = match p with | P (i, left, right) -> - let (car_annot, cdr_annot) = + let car_annot, cdr_annot = match IntMap.find i annots_pos with | None -> ([], []) | Some (car_annot, cdr_annot) -> (car_annot, cdr_annot) @@ -490,7 +490,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -563,8 +563,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -733,7 +732,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -745,10 +744,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -814,7 +813,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -824,7 +823,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -891,7 +890,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -901,7 +900,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -922,7 +921,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -964,46 +963,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1020,41 +1019,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml index 1be097c6eeb9..3f4971a4421c 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -88,8 +88,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -97,8 +97,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml index 8bb24bc5b918..8ea2985290ff 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml @@ -143,7 +143,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -175,8 +175,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_programs_commands.ml b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_programs_commands.ml index b29b787961ce..9cf612df54b2 100644 --- a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_programs_commands.ml @@ -219,11 +219,10 @@ let commands () = (args2 emacs_mode_switch no_print_source_flag) (prefixes ["get"; "script"; "entrypoint"; "type"; "of"] @@ string ~name:"entrypoint" ~desc:"the entrypoint to describe" - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) entrypoint program cctxt -> match program with - | (program, []) -> + | program, [] -> entrypoint_type cctxt ~chain:cctxt#chain @@ -244,7 +243,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -264,7 +263,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_entrypoints cctxt ~chain:cctxt#chain ~block:cctxt#block program >>= fun entrypoints -> print_entrypoints_list @@ -279,7 +278,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> diff --git a/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml index 58718469ee0c..dc05d83397b2 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml @@ -570,18 +570,18 @@ let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_008_PtEdo2Zk/lib_client/client_proto_fa12.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_fa12.ml index 9cf87ee2c8ed..df89b8d5dcbc 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/client_proto_fa12.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_fa12.ml @@ -272,7 +272,7 @@ type type_eq_combinator = node * (node -> bool) check functions, and returns a type of n-ary pair of such types and a function checking syntactical equivalence with another node. *) let t_pair ?(loc = 0) l : type_eq_combinator = - let (values, are_ty) = List.split l in + let values, are_ty = List.split l in let is_pair p = match p with | Micheline.Prim (_, Script.T_pair, l, _) -> ( @@ -535,8 +535,8 @@ let parse_callback error expr = let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in match (String.sub s 0 pos, name) with - | (addr, "default") -> of_b58_check (addr, None) - | (addr, name) -> of_b58_check (addr, Some name))) + | addr, "default" -> of_b58_check (addr, None) + | addr, name -> of_b58_check (addr, Some name))) | _ -> error () let action_of_expr ~entrypoint expr = @@ -647,7 +647,7 @@ let derive_action expr t_param = | ( Micheline.Prim (_, Script.D_Right, [right], _), Micheline.Prim (_, Script.T_or, [_; t_right], _) ) -> derive right t_right - | (_, Micheline.Prim (_, _, _, annots)) -> + | _, Micheline.Prim (_, _, _, annots) -> find_entrypoint_in_annot error annots expr | _ -> error () in @@ -729,7 +729,7 @@ let parse_error = | ( "NotEnoughAllowance", Prim (_, Script.D_Pair, [Int (_, required); Int (_, present)], _) ) -> Some (Not_enough_allowance (required, present)) - | ("UnsafeAllowanceChange", Int (_, previous)) -> + | "UnsafeAllowanceChange", Int (_, previous) -> Some (Unsafe_allowance_change previous) | _ -> None @@ -753,7 +753,7 @@ let call_contract (cctxt : #Protocol_client_context.full) ~chain ~block ~contract ~action ~tez_amount ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () = contract_has_fa12_interface cctxt ~chain ~block ~contract () >>=? fun () -> - let (entrypoint, arg) = translate_action_to_argument action in + let entrypoint, arg = translate_action_to_argument action in Client_proto_context.transfer cctxt ~chain diff --git a/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml index 42fa1d2bc0df..e889f2d67734 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_programs.ml @@ -198,7 +198,7 @@ let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas ?legacy let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_008_PtEdo2Zk/lib_client/injection.ml b/src/proto_008_PtEdo2Zk/lib_client/injection.ml index 0ecd0683b711..3aa7e8714999 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/injection.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/injection.ml @@ -305,7 +305,7 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -324,12 +324,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ~op:(Operation.pack op) ~chain_id >>=? function - | (Operation_data op', Operation_metadata result) -> ( + | Operation_data op', Operation_metadata result -> ( match ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -521,10 +521,10 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) | Single _ -> None | Cons ((Manager_operation _ as c), rest) -> ( match (may_need_patching_single c, may_need_patching rest) with - | (None, None) -> None - | (Some c, None) -> Some (Cons (c, rest)) - | (None, Some rest) -> Some (Cons (c, rest)) - | (Some c, Some rest) -> Some (Cons (c, rest))) + | None, None -> None + | Some c, None -> Some (Cons (c, rest)) + | None, Some rest -> Some (Cons (c, rest)) + | Some c, Some rest -> Some (Cons (c, rest))) in let rec patch_fee : type kind. bool -> kind contents -> kind contents = fun first -> function @@ -576,7 +576,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind contents * kind contents_result -> kind contents tzresult Lwt.t = fun first -> function - | (Manager_operation c, (Manager_operation_result _ as result)) -> + | Manager_operation c, (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then Lwt.return (estimated_gas_single result) >>=? fun gas -> if Gas.Arith.(gas = zero) then @@ -615,7 +615,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) let cm = Manager_operation {c with gas_limit; storage_limit} in if compute_fee && c.fee = Tez.zero then return (patch_fee first cm) else return cm - | (c, _) -> return c + | c, _ -> return c in let rec patch_list : type kind. @@ -830,7 +830,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run | Cons_manager (Manager_info {operation = Reveal _; _}, _) -> true | _ -> false in - let (compute_fee, fee) = + let compute_fee, fee = match fee with None -> (true, Tez.zero) | Some fee -> (false, fee) in let contents_of_manager ~source ~fee ~counter ~gas_limit ~storage_limit @@ -903,7 +903,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run >>=? fun (oph, op, result) -> match pack_contents_list op result with | Cons_and_result (_, _, rest) -> - let (op, result) = unpack_contents_list rest in + let op, result = unpack_contents_list rest in return (oph, op, result) | _ -> assert false) | Some _ when is_reveal operations -> diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml index 2721fa702d46..197b420c6228 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_emacs.ml @@ -133,7 +133,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -141,7 +141,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -160,7 +160,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml index 16cf1eda7195..85d18dbca45a 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_error_reporter.ml @@ -457,7 +457,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Invalid_never_expr loc -> diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml index 471c6b757be9..ca6574ceff29 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml @@ -122,9 +122,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -237,9 +237,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -383,14 +383,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -405,18 +405,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -439,7 +439,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -447,13 +447,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -464,7 +464,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -498,7 +498,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -541,8 +541,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -712,7 +711,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -724,10 +723,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -737,7 +736,7 @@ let expand_rec expr = let unexpand_carn_and_cdrn expanded = match expanded with | Seq (loc, [Prim (_, "GET", [Int (locn, n)], annot)]) -> - let (half, parity) = Z.ediv_rem n (Z.of_int 2) in + let half, parity = Z.ediv_rem n (Z.of_int 2) in if Z.(parity = zero) then Some (Prim (loc, "CDR", [Int (locn, half)], annot)) else Some (Prim (loc, "CAR", [Int (locn, half)], annot)) @@ -802,7 +801,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -812,7 +811,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -879,7 +878,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -889,7 +888,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -910,7 +909,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -952,46 +951,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1008,41 +1007,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml index 1be097c6eeb9..3f4971a4421c 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -88,8 +88,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -97,8 +97,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml index 5eeb4e1fd88c..98848e43b193 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_printer.ml @@ -148,7 +148,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -180,8 +180,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_008_PtEdo2Zk/lib_client/mockup.ml b/src/proto_008_PtEdo2Zk/lib_client/mockup.ml index 58cfec091149..b2e8676c131d 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/mockup.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/mockup.ml @@ -623,7 +623,7 @@ module Parsed_account = struct Client_keys.list_keys wallet >>=? fun all_keys -> List.iter_s (function - | (name, pkh, _pk_opt, Some sk_uri) -> ( + | name, pkh, _pk_opt, Some sk_uri -> ( let contract = Protocol.Alpha_context.Contract.implicit_contract pkh in @@ -831,7 +831,7 @@ let mem_init : | None -> return Protocol_constants_overrides.no_overrides | Some json -> ( match Data_encoding.Json.destruct lib_parameters_json_encoding json with - | (_, x) -> return x + | _, x -> return x | exception error -> failwith "cannot read protocol constants overrides: %a" diff --git a/src/proto_008_PtEdo2Zk/lib_client/proxy.ml b/src/proto_008_PtEdo2Zk/lib_client/proxy.ml index 12b81ab282cf..d4017feae55f 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/proxy.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/proxy.ml @@ -50,11 +50,8 @@ module ProtoRpc : Tezos_proxy.Proxy_proto.PROTO_RPC = struct match key with (* matches paths like: big_maps/index/05/37/bc/fb/1e/39/i/contents/tail *) - | "big_maps" - :: "index" - :: hash0 - :: hash1 - :: hash2 :: hash3 :: hash4 :: hash5 :: i :: "contents" :: tail -> + | "big_maps" :: "index" :: hash0 :: hash1 :: hash2 :: hash3 :: hash4 + :: hash5 :: i :: "contents" :: tail -> Some ( [ "big_maps"; @@ -76,9 +73,8 @@ module ProtoRpc : Tezos_proxy.Proxy_proto.PROTO_RPC = struct match key with (* matches paths like: contracts/index/05/37/bc/fb/1e/39/000002298c03ed7d454a101eb7022bc95f7e5f41ac78/tail *) - | "contracts" - :: index - :: hash0 :: hash1 :: hash2 :: hash3 :: hash4 :: hash5 :: id :: tail -> + | "contracts" :: index :: hash0 :: hash1 :: hash2 :: hash3 :: hash4 :: hash5 + :: id :: tail -> Some ( ["contracts"; index; hash0; hash1; hash2; hash3; hash4; hash5; id], tail ) diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml index ce61ca2b9303..7167e33f7ab0 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml @@ -892,7 +892,7 @@ let commands network () = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith @@ -1180,8 +1180,7 @@ let commands network () = ~desc:"Register and activate an Alphanet/Zeronet faucet account." (args2 (Secret_key.force_switch ()) encrypted_switch) (prefixes ["activate"; "account"] - @@ Secret_key.fresh_alias_param - @@ prefixes ["with"] + @@ Secret_key.fresh_alias_param @@ prefixes ["with"] @@ param ~name:"activation_key" ~desc: @@ -1225,8 +1224,7 @@ let commands network () = ~desc:"Activate a fundraiser account." (args1 dry_run_switch) (prefixes ["activate"; "fundraiser"; "account"] - @@ Public_key_hash.alias_param - @@ prefixes ["with"] + @@ Public_key_hash.alias_param @@ prefixes ["with"] @@ param ~name:"code" (Clic.parameter (fun _ctx code -> diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_fa12_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_fa12_commands.ml index 235b937fd12f..17d018fbc9be 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_fa12_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_fa12_commands.ml @@ -226,7 +226,7 @@ let commands () : #Protocol_client_context.full Clic.command list = src (_, dst) (cctxt : #Protocol_client_context.full) -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in get_contract_caller_keys cctxt caller >>=? fun (source, caller_pk, caller_sk) -> let action = Client_proto_fa12.Transfer (snd src, dst, amount) in @@ -714,7 +714,7 @@ let commands () : #Protocol_client_context.full Clic.command list = src operations_json cctxt -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in let fee_parameter = { Injection.minimal_fees; @@ -760,7 +760,7 @@ let commands () : #Protocol_client_context.full Clic.command list = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_multisig_commands.ml index 2ec9ea5bec9d..d308690b40f5 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_multisig_commands.ml @@ -940,8 +940,7 @@ let commands () : #Protocol_client_context.full Clic.command list = @@ Client_proto_contracts.ContractAlias.destination_param ~name:"multisig" ~desc:"name or address of the originated multisig contract" - @@ prefixes ["to"] - @@ threshold_param () + @@ prefixes ["to"] @@ threshold_param () @@ prefixes ["and"; "public"; "keys"; "to"] @@ non_terminal_seq (public_key_param ()) ~suffix:["on"; "behalf"; "of"] @@ Client_proto_contracts.ContractAlias.destination_param diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml index c29979044087..2da72d861b89 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml @@ -307,7 +307,7 @@ let commands () = program cctxt -> match program with - | (program, []) -> + | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program @@ -331,7 +331,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -555,7 +555,7 @@ let commands () = (prefixes ["normalize"; "script"] @@ Program.source_param @@ stop) (fun unparsing_mode script cctxt -> match script with - | (script, []) -> + | script, [] -> Plugin.RPC.normalize_script cctxt (cctxt#chain, cctxt#block) @@ -564,7 +564,7 @@ let commands () = >>=? fun expr -> cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -612,8 +612,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> @@ -652,11 +651,10 @@ let commands () = (args2 emacs_mode_switch no_print_source_flag) (prefixes ["get"; "script"; "entrypoint"; "type"; "of"] @@ string ~name:"entrypoint" ~desc:"the entrypoint to describe" - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) entrypoint program cctxt -> match program with - | (program, []) -> + | program, [] -> entrypoint_type cctxt ~chain:cctxt#chain @@ -677,7 +675,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -697,7 +695,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_entrypoints cctxt ~chain:cctxt#chain ~block:cctxt#block program >>= fun entrypoints -> print_entrypoints_list @@ -712,7 +710,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -734,7 +732,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_unreachables cctxt ~chain:cctxt#chain @@ -753,7 +751,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> diff --git a/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml index 6729260a8fbf..eadaa5897cfc 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/client_sapling_commands.ml @@ -202,9 +202,7 @@ let commands () = path >>= fun () -> (* TODO must pass contract address for now *) - let (_, contract) = - WithExceptions.Option.get ~loc:__LOC__ contract_opt - in + let _, contract = WithExceptions.Option.get ~loc:__LOC__ contract_opt in Context.Client_state.register cctxt ~default_memo_size diff --git a/src/proto_008_PtEdo2Zk/lib_client_sapling/context.ml b/src/proto_008_PtEdo2Zk/lib_client_sapling/context.ml index f507326b3476..91a6415d6aab 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_sapling/context.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/context.ml @@ -286,7 +286,7 @@ module Contract_state = struct let vks = Accounts.fold (fun account acc -> Account.(account.vk) :: acc) accounts [] in - let (size, _) = Storage.size storage in + let size, _ = Storage.size storage in let rec aux pos accounts = if pos < size then (* try to decrypt each inputs with all vks *) @@ -306,7 +306,7 @@ module Contract_state = struct | _ -> assert false (* got more than one decrypting key *) else accounts in - let (current_size, _) = Storage.size state.storage in + let current_size, _ = Storage.size state.storage in let accounts = aux current_size accounts in {accounts; storage} @@ -398,7 +398,7 @@ module Client_state = struct let sync_and_scan cctxt contract = load cctxt >>=? fun state -> find cctxt contract state >>=? fun contract_state -> - let (cm_pos, nf_pos) = Storage.size contract_state.storage in + let cm_pos, nf_pos = Storage.size contract_state.storage in get_diff cctxt contract cm_pos nf_pos >>=? fun diff -> let contract_state = Contract_state.update_storage contract_state diff in let state = Map.add contract contract_state state in diff --git a/src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.ml b/src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.ml index 5a12d0cc9421..ad842589b12c 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_sapling/wallet.ml @@ -111,7 +111,7 @@ let new_address (cctxt : #Client_context.full) name index_opt = return (Viewing_key.of_sk sk) >>=? fun vk -> (* Viewing_key.new_address finds the smallest index greater or equal to [index] that generates a correct address. *) - let (corrected_index, address) = Viewing_key.new_address vk index in + let corrected_index, address = Viewing_key.new_address vk index in Sapling_key.update cctxt name diff --git a/src/proto_008_PtEdo2Zk/lib_plugin/plugin.ml b/src/proto_008_PtEdo2Zk/lib_plugin/plugin.ml index 0d7210351004..f60ae99f51f4 100644 --- a/src/proto_008_PtEdo2Zk/lib_plugin/plugin.ml +++ b/src/proto_008_PtEdo2Zk/lib_plugin/plugin.ml @@ -727,12 +727,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with @@ -783,12 +783,12 @@ module RPC = struct (View_helpers.make_viewer_script ty) Tez.zero >>=? fun (ctxt, viewer_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (contract, contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (contract, contract) in let gas = Option.value @@ -852,8 +852,8 @@ module RPC = struct (Script.expr * string option) list Environment.Error_monad.tzresult Lwt.t = function - | (Empty_t, ()) -> return_nil - | (Item_t (ty, rest_ty, annot), (v, rest)) -> + | Empty_t, () -> return_nil + | Item_t (ty, rest_ty, annot), (v, rest) -> Script_ir_translator.unparse_data ctxt unparsing_mode ty v >>=? fun (data, _ctxt) -> unparse_stack (rest_ty, rest) >|=? fun rest -> @@ -894,12 +894,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with diff --git a/src/proto_009_PsFLoren/lib_client/client_proto_context.ml b/src/proto_009_PsFLoren/lib_client/client_proto_context.ml index fc21c8c9a46e..7a36aa64560c 100644 --- a/src/proto_009_PsFLoren/lib_client/client_proto_context.ml +++ b/src/proto_009_PsFLoren/lib_client/client_proto_context.ml @@ -580,18 +580,18 @@ let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_009_PsFLoren/lib_client/client_proto_fa12.ml b/src/proto_009_PsFLoren/lib_client/client_proto_fa12.ml index db61193cfe0e..10f0e7bf62be 100644 --- a/src/proto_009_PsFLoren/lib_client/client_proto_fa12.ml +++ b/src/proto_009_PsFLoren/lib_client/client_proto_fa12.ml @@ -272,7 +272,7 @@ type type_eq_combinator = node * (node -> bool) check functions, and returns a type of n-ary pair of such types and a function checking syntactical equivalence with another node. *) let t_pair ?(loc = 0) l : type_eq_combinator = - let (values, are_ty) = List.split l in + let values, are_ty = List.split l in let is_pair p = match p with | Micheline.Prim (_, Script.T_pair, l, _) -> ( @@ -535,8 +535,8 @@ let parse_callback error expr = let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in match (String.sub s 0 pos, name) with - | (addr, "default") -> of_b58_check (addr, None) - | (addr, name) -> of_b58_check (addr, Some name))) + | addr, "default" -> of_b58_check (addr, None) + | addr, name -> of_b58_check (addr, Some name))) | _ -> error () let action_of_expr ~entrypoint expr = @@ -647,7 +647,7 @@ let derive_action expr t_param = | ( Micheline.Prim (_, Script.D_Right, [right], _), Micheline.Prim (_, Script.T_or, [_; t_right], _) ) -> derive right t_right - | (_, Micheline.Prim (_, _, _, annots)) -> + | _, Micheline.Prim (_, _, _, annots) -> find_entrypoint_in_annot error annots expr | _ -> error () in @@ -729,7 +729,7 @@ let parse_error = | ( "NotEnoughAllowance", Prim (_, Script.D_Pair, [Int (_, required); Int (_, present)], _) ) -> Some (Not_enough_allowance (required, present)) - | ("UnsafeAllowanceChange", Int (_, previous)) -> + | "UnsafeAllowanceChange", Int (_, previous) -> Some (Unsafe_allowance_change previous) | _ -> None @@ -753,7 +753,7 @@ let call_contract (cctxt : #Protocol_client_context.full) ~chain ~block ~contract ~action ~tez_amount ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () = contract_has_fa12_interface cctxt ~chain ~block ~contract () >>=? fun () -> - let (entrypoint, arg) = translate_action_to_argument action in + let entrypoint, arg = translate_action_to_argument action in Client_proto_context.transfer cctxt ~chain diff --git a/src/proto_009_PsFLoren/lib_client/client_proto_programs.ml b/src/proto_009_PsFLoren/lib_client/client_proto_programs.ml index 42fa1d2bc0df..e889f2d67734 100644 --- a/src/proto_009_PsFLoren/lib_client/client_proto_programs.ml +++ b/src/proto_009_PsFLoren/lib_client/client_proto_programs.ml @@ -198,7 +198,7 @@ let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas ?legacy let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_009_PsFLoren/lib_client/client_proto_utils.ml b/src/proto_009_PsFLoren/lib_client/client_proto_utils.ml index 27fec54d342a..be6844cc5cf7 100644 --- a/src/proto_009_PsFLoren/lib_client/client_proto_utils.ml +++ b/src/proto_009_PsFLoren/lib_client/client_proto_utils.ml @@ -37,14 +37,14 @@ let to_json_and_bytes branch message = Data_encoding.Binary.to_bytes_exn encoding op ) let sign_message (cctxt : #full) ~src_sk ~block ~message = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in cctxt#message "signed content: @[%a@]" Data_encoding.Json.pp json >>= fun () -> Client_keys.sign cctxt ~watermark:Signature.Generic_operation src_sk bytes let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> diff --git a/src/proto_009_PsFLoren/lib_client/injection.ml b/src/proto_009_PsFLoren/lib_client/injection.ml index 6fc966e055c2..1cc866e20f1c 100644 --- a/src/proto_009_PsFLoren/lib_client/injection.ml +++ b/src/proto_009_PsFLoren/lib_client/injection.ml @@ -266,7 +266,7 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -285,12 +285,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ~op:(Operation.pack op) ~chain_id >>=? function - | (Operation_data op', Operation_metadata result) -> ( + | Operation_data op', Operation_metadata result -> ( match ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -507,7 +507,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) let annotated_op_opt = may_need_patching_single annotated_op in let rest_opt = may_need_patching rest in match (annotated_op_opt, rest_opt) with - | (None, None) -> None + | None, None -> None | _ -> let op = Option.value ~default:annotated_op annotated_op_opt in let rest = Option.value ~default:rest rest_opt in @@ -563,7 +563,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Annotated_manager_operation.t * kind Kind.manager contents_result -> kind Kind.manager contents tzresult Lwt.t = fun ~first -> function - | ((Manager_info c as op), (Manager_operation_result _ as result)) -> + | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then Lwt.return (estimated_gas_single result) >>=? fun gas -> if Gas.Arith.(gas = zero) then @@ -631,9 +631,9 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Kind.manager contents_list tzresult Lwt.t = fun first annotated_list result_list -> match (annotated_list, result_list) with - | (Single_manager annotated, Single_result res) -> + | Single_manager annotated, Single_result res -> patch ~first (annotated, res) >>=? fun op -> return (Single op) - | (Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest)) -> + | Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest) -> patch ~first (annotated, res) >>=? fun op -> patch_list false annotated_rest res_rest >>=? fun rest -> return (Cons (op, rest)) @@ -921,7 +921,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run >>=? fun (oph, op, result) -> match pack_contents_list op result with | Cons_and_result (_, _, rest) -> - let (op, result) = unpack_contents_list rest in + let op, result = unpack_contents_list rest in return (oph, op, result) | _ -> assert false) | Some _ when has_reveal operations -> diff --git a/src/proto_009_PsFLoren/lib_client/limit.ml b/src/proto_009_PsFLoren/lib_client/limit.ml index 3f3c798c02b6..ae20b1d6bf4b 100644 --- a/src/proto_009_PsFLoren/lib_client/limit.ml +++ b/src/proto_009_PsFLoren/lib_client/limit.ml @@ -35,9 +35,9 @@ let is_unknown = Option.is_none let join (type a) ~where eq (l1 : a t) (l2 : a t) = match (l1, l2) with - | (None, None) -> Result.return_none - | (Some x, None) | (None, Some x) -> Result.return_some x - | (Some x, Some y) -> + | None, None -> Result.return_none + | Some x, None | None, Some x -> Result.return_some x + | Some x, Some y -> if eq x y then Result.return_some x else error_with "Limit.join: error (%s)" where diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_emacs.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_emacs.ml index 2721fa702d46..197b420c6228 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_emacs.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_emacs.ml @@ -133,7 +133,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -141,7 +141,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -160,7 +160,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_error_reporter.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_error_reporter.ml index 16cf1eda7195..85d18dbca45a 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_error_reporter.ml @@ -457,7 +457,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Invalid_never_expr loc -> diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_macros.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_macros.ml index 471c6b757be9..ca6574ceff29 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_macros.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_macros.ml @@ -122,9 +122,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -237,9 +237,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -383,14 +383,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -405,18 +405,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -439,7 +439,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -447,13 +447,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -464,7 +464,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -498,7 +498,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -541,8 +541,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -712,7 +711,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -724,10 +723,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -737,7 +736,7 @@ let expand_rec expr = let unexpand_carn_and_cdrn expanded = match expanded with | Seq (loc, [Prim (_, "GET", [Int (locn, n)], annot)]) -> - let (half, parity) = Z.ediv_rem n (Z.of_int 2) in + let half, parity = Z.ediv_rem n (Z.of_int 2) in if Z.(parity = zero) then Some (Prim (loc, "CDR", [Int (locn, half)], annot)) else Some (Prim (loc, "CAR", [Int (locn, half)], annot)) @@ -802,7 +801,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -812,7 +811,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -879,7 +878,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -889,7 +888,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -910,7 +909,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -952,46 +951,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1008,41 +1007,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.ml index 2f44d22c1fca..09a8c7d5b710 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -87,8 +87,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -96,8 +96,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_printer.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_printer.ml index 5eeb4e1fd88c..98848e43b193 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_printer.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_printer.ml @@ -148,7 +148,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -180,8 +180,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_009_PsFLoren/lib_client/mockup.ml b/src/proto_009_PsFLoren/lib_client/mockup.ml index 5fb11134e2db..fc2366e1454d 100644 --- a/src/proto_009_PsFLoren/lib_client/mockup.ml +++ b/src/proto_009_PsFLoren/lib_client/mockup.ml @@ -585,7 +585,7 @@ module Parsed_account = struct Client_keys.list_keys wallet >>=? fun all_keys -> List.iter_s (function - | (name, pkh, _pk_opt, Some sk_uri) -> ( + | name, pkh, _pk_opt, Some sk_uri -> ( let contract = Contract.implicit_contract pkh in Client_proto_context.get_balance rpc_context @@ -787,7 +787,7 @@ let mem_init : | None -> return Protocol_constants_overrides.no_overrides | Some json -> ( match Data_encoding.Json.destruct lib_parameters_json_encoding json with - | (_, x) -> return x + | _, x -> return x | exception error -> failwith "cannot read protocol constants overrides: %a" diff --git a/src/proto_009_PsFLoren/lib_client/proxy.ml b/src/proto_009_PsFLoren/lib_client/proxy.ml index b8cad5206d02..8edc1e3e1c9d 100644 --- a/src/proto_009_PsFLoren/lib_client/proxy.ml +++ b/src/proto_009_PsFLoren/lib_client/proxy.ml @@ -50,11 +50,8 @@ module ProtoRpc : Tezos_proxy.Proxy_proto.PROTO_RPC = struct match key with (* matches paths like: big_maps/index/05/37/bc/fb/1e/39/i/contents/tail *) - | "big_maps" - :: "index" - :: hash0 - :: hash1 - :: hash2 :: hash3 :: hash4 :: hash5 :: i :: "contents" :: tail -> + | "big_maps" :: "index" :: hash0 :: hash1 :: hash2 :: hash3 :: hash4 + :: hash5 :: i :: "contents" :: tail -> Some ( [ "big_maps"; @@ -76,9 +73,8 @@ module ProtoRpc : Tezos_proxy.Proxy_proto.PROTO_RPC = struct match key with (* matches paths like: contracts/index/05/37/bc/fb/1e/39/000002298c03ed7d454a101eb7022bc95f7e5f41ac78/tail *) - | "contracts" - :: index - :: hash0 :: hash1 :: hash2 :: hash3 :: hash4 :: hash5 :: id :: tail -> + | "contracts" :: index :: hash0 :: hash1 :: hash2 :: hash3 :: hash4 :: hash5 + :: id :: tail -> Some ( ["contracts"; index; hash0; hash1; hash2; hash3; hash4; hash5; id], tail ) diff --git a/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml b/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml index 69ffe2dfb0c4..65069a692b19 100644 --- a/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml @@ -885,7 +885,7 @@ let commands network () = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith @@ -1173,8 +1173,7 @@ let commands network () = ~desc:"Register and activate an Alphanet/Zeronet faucet account." (args2 (Secret_key.force_switch ()) encrypted_switch) (prefixes ["activate"; "account"] - @@ Secret_key.fresh_alias_param - @@ prefixes ["with"] + @@ Secret_key.fresh_alias_param @@ prefixes ["with"] @@ param ~name:"activation_key" ~desc: @@ -1218,8 +1217,7 @@ let commands network () = ~desc:"Activate a fundraiser account." (args1 dry_run_switch) (prefixes ["activate"; "fundraiser"; "account"] - @@ Public_key_hash.alias_param - @@ prefixes ["with"] + @@ Public_key_hash.alias_param @@ prefixes ["with"] @@ param ~name:"code" (Clic.parameter (fun _ctx code -> diff --git a/src/proto_009_PsFLoren/lib_client_commands/client_proto_fa12_commands.ml b/src/proto_009_PsFLoren/lib_client_commands/client_proto_fa12_commands.ml index 84c244a2bc11..5857aff73e16 100644 --- a/src/proto_009_PsFLoren/lib_client_commands/client_proto_fa12_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_commands/client_proto_fa12_commands.ml @@ -226,7 +226,7 @@ let commands () : #Protocol_client_context.full Clic.command list = src (_, dst) (cctxt : #Protocol_client_context.full) -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in get_contract_caller_keys cctxt caller >>=? fun (source, caller_pk, caller_sk) -> let action = Client_proto_fa12.Transfer (snd src, dst, amount) in @@ -714,7 +714,7 @@ let commands () : #Protocol_client_context.full Clic.command list = src operations_json cctxt -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in let fee_parameter = { Injection.minimal_fees; @@ -760,7 +760,7 @@ let commands () : #Protocol_client_context.full Clic.command list = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith diff --git a/src/proto_009_PsFLoren/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_009_PsFLoren/lib_client_commands/client_proto_multisig_commands.ml index 2ec9ea5bec9d..d308690b40f5 100644 --- a/src/proto_009_PsFLoren/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_commands/client_proto_multisig_commands.ml @@ -940,8 +940,7 @@ let commands () : #Protocol_client_context.full Clic.command list = @@ Client_proto_contracts.ContractAlias.destination_param ~name:"multisig" ~desc:"name or address of the originated multisig contract" - @@ prefixes ["to"] - @@ threshold_param () + @@ prefixes ["to"] @@ threshold_param () @@ prefixes ["and"; "public"; "keys"; "to"] @@ non_terminal_seq (public_key_param ()) ~suffix:["on"; "behalf"; "of"] @@ Client_proto_contracts.ContractAlias.destination_param diff --git a/src/proto_009_PsFLoren/lib_client_commands/client_proto_programs_commands.ml b/src/proto_009_PsFLoren/lib_client_commands/client_proto_programs_commands.ml index 26962b781cea..90dabf780d70 100644 --- a/src/proto_009_PsFLoren/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_commands/client_proto_programs_commands.ml @@ -307,7 +307,7 @@ let commands () = program cctxt -> match program with - | (program, []) -> + | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program @@ -331,7 +331,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -630,8 +630,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> @@ -670,11 +669,10 @@ let commands () = (args2 emacs_mode_switch no_print_source_flag) (prefixes ["get"; "script"; "entrypoint"; "type"; "of"] @@ string ~name:"entrypoint" ~desc:"the entrypoint to describe" - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) entrypoint program cctxt -> match program with - | (program, []) -> + | program, [] -> entrypoint_type cctxt ~chain:cctxt#chain @@ -695,7 +693,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -715,7 +713,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_entrypoints cctxt ~chain:cctxt#chain ~block:cctxt#block program >>= fun entrypoints -> print_entrypoints_list @@ -730,7 +728,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -752,7 +750,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_unreachables cctxt ~chain:cctxt#chain @@ -771,7 +769,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> diff --git a/src/proto_009_PsFLoren/lib_client_sapling/client_sapling_commands.ml b/src/proto_009_PsFLoren/lib_client_sapling/client_sapling_commands.ml index 486843afc57f..530821594502 100644 --- a/src/proto_009_PsFLoren/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_sapling/client_sapling_commands.ml @@ -202,9 +202,7 @@ let commands () = path >>= fun () -> (* TODO must pass contract address for now *) - let (_, contract) = - WithExceptions.Option.get ~loc:__LOC__ contract_opt - in + let _, contract = WithExceptions.Option.get ~loc:__LOC__ contract_opt in Context.Client_state.register cctxt ~default_memo_size diff --git a/src/proto_009_PsFLoren/lib_client_sapling/context.ml b/src/proto_009_PsFLoren/lib_client_sapling/context.ml index 477b5d59a423..d78924b5e544 100644 --- a/src/proto_009_PsFLoren/lib_client_sapling/context.ml +++ b/src/proto_009_PsFLoren/lib_client_sapling/context.ml @@ -286,7 +286,7 @@ module Contract_state = struct let vks = Accounts.fold (fun account acc -> Account.(account.vk) :: acc) accounts [] in - let (size, _) = Storage.size storage in + let size, _ = Storage.size storage in let rec aux pos accounts = if pos < size then (* try to decrypt each inputs with all vks *) @@ -306,7 +306,7 @@ module Contract_state = struct | _ -> assert false (* got more than one decrypting key *) else accounts in - let (current_size, _) = Storage.size state.storage in + let current_size, _ = Storage.size state.storage in let accounts = aux current_size accounts in {accounts; storage} @@ -398,7 +398,7 @@ module Client_state = struct let sync_and_scan cctxt contract = load cctxt >>=? fun state -> find cctxt contract state >>=? fun contract_state -> - let (cm_pos, nf_pos) = Storage.size contract_state.storage in + let cm_pos, nf_pos = Storage.size contract_state.storage in get_diff cctxt contract cm_pos nf_pos >>=? fun diff -> let contract_state = Contract_state.update_storage contract_state diff in let state = Map.add contract contract_state state in diff --git a/src/proto_009_PsFLoren/lib_client_sapling/wallet.ml b/src/proto_009_PsFLoren/lib_client_sapling/wallet.ml index 5a12d0cc9421..ad842589b12c 100644 --- a/src/proto_009_PsFLoren/lib_client_sapling/wallet.ml +++ b/src/proto_009_PsFLoren/lib_client_sapling/wallet.ml @@ -111,7 +111,7 @@ let new_address (cctxt : #Client_context.full) name index_opt = return (Viewing_key.of_sk sk) >>=? fun vk -> (* Viewing_key.new_address finds the smallest index greater or equal to [index] that generates a correct address. *) - let (corrected_index, address) = Viewing_key.new_address vk index in + let corrected_index, address = Viewing_key.new_address vk index in Sapling_key.update cctxt name diff --git a/src/proto_009_PsFLoren/lib_plugin/plugin.ml b/src/proto_009_PsFLoren/lib_plugin/plugin.ml index af1e63e9675a..d90e50d5cb84 100644 --- a/src/proto_009_PsFLoren/lib_plugin/plugin.ml +++ b/src/proto_009_PsFLoren/lib_plugin/plugin.ml @@ -709,12 +709,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with @@ -768,8 +768,8 @@ module RPC = struct (Script.expr * string option) list Environment.Error_monad.tzresult Lwt.t = function - | (Empty_t, ()) -> return_nil - | (Item_t (ty, rest_ty, annot), (v, rest)) -> + | Empty_t, () -> return_nil + | Item_t (ty, rest_ty, annot), (v, rest) -> Script_ir_translator.unparse_data ctxt unparsing_mode ty v >>=? fun (data, _ctxt) -> unparse_stack (rest_ty, rest) >|=? fun rest -> @@ -810,12 +810,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with @@ -893,12 +893,12 @@ module RPC = struct (View_helpers.make_viewer_script ty) Tez.zero >>=? fun (ctxt, viewer_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (contract, contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (contract, contract) in let gas = Option.value diff --git a/src/proto_010_PtGRANAD/lib_client/client_proto_context.ml b/src/proto_010_PtGRANAD/lib_client/client_proto_context.ml index 113bc43faf9d..43ff1adacff5 100644 --- a/src/proto_010_PtGRANAD/lib_client/client_proto_context.ml +++ b/src/proto_010_PtGRANAD/lib_client/client_proto_context.ml @@ -607,18 +607,18 @@ let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_010_PtGRANAD/lib_client/client_proto_fa12.ml b/src/proto_010_PtGRANAD/lib_client/client_proto_fa12.ml index 7c44b5103c94..8c3ba0f6a162 100644 --- a/src/proto_010_PtGRANAD/lib_client/client_proto_fa12.ml +++ b/src/proto_010_PtGRANAD/lib_client/client_proto_fa12.ml @@ -272,7 +272,7 @@ type type_eq_combinator = node * (node -> bool) check functions, and returns a type of n-ary pair of such types and a function checking syntactical equivalence with another node. *) let t_pair ?(loc = 0) l : type_eq_combinator = - let (values, are_ty) = List.split l in + let values, are_ty = List.split l in let is_pair p = match p with | Micheline.Prim (_, Script.T_pair, l, _) -> ( @@ -535,8 +535,8 @@ let parse_callback error expr = let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in match (String.sub s 0 pos, name) with - | (addr, "default") -> of_b58_check (addr, None) - | (addr, name) -> of_b58_check (addr, Some name))) + | addr, "default" -> of_b58_check (addr, None) + | addr, name -> of_b58_check (addr, Some name))) | _ -> error () let action_of_expr ~entrypoint expr = @@ -647,7 +647,7 @@ let derive_action expr t_param = | ( Micheline.Prim (_, Script.D_Right, [right], _), Micheline.Prim (_, Script.T_or, [_; t_right], _) ) -> derive right t_right - | (_, Micheline.Prim (_, _, _, annots)) -> + | _, Micheline.Prim (_, _, _, annots) -> find_entrypoint_in_annot error annots expr | _ -> error () in @@ -735,7 +735,7 @@ let parse_error = | ( "NotEnoughAllowance", Prim (_, Script.D_Pair, [Int (_, required); Int (_, present)], _) ) -> Some (Not_enough_allowance (required, present)) - | ("UnsafeAllowanceChange", Int (_, previous)) -> + | "UnsafeAllowanceChange", Int (_, previous) -> Some (Unsafe_allowance_change previous) | _ -> None @@ -759,7 +759,7 @@ let call_contract (cctxt : #Protocol_client_context.full) ~chain ~block ~contract ~action ~tez_amount ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () = contract_has_fa12_interface cctxt ~chain ~block ~contract () >>=? fun () -> - let (entrypoint, arg) = translate_action_to_argument action in + let entrypoint, arg = translate_action_to_argument action in Client_proto_context.transfer cctxt ~chain diff --git a/src/proto_010_PtGRANAD/lib_client/client_proto_programs.ml b/src/proto_010_PtGRANAD/lib_client/client_proto_programs.ml index 1ee9d90dd350..36a20cad6d1d 100644 --- a/src/proto_010_PtGRANAD/lib_client/client_proto_programs.ml +++ b/src/proto_010_PtGRANAD/lib_client/client_proto_programs.ml @@ -198,7 +198,7 @@ let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas ?legacy let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_010_PtGRANAD/lib_client/client_proto_utils.ml b/src/proto_010_PtGRANAD/lib_client/client_proto_utils.ml index 27fec54d342a..be6844cc5cf7 100644 --- a/src/proto_010_PtGRANAD/lib_client/client_proto_utils.ml +++ b/src/proto_010_PtGRANAD/lib_client/client_proto_utils.ml @@ -37,14 +37,14 @@ let to_json_and_bytes branch message = Data_encoding.Binary.to_bytes_exn encoding op ) let sign_message (cctxt : #full) ~src_sk ~block ~message = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in cctxt#message "signed content: @[%a@]" Data_encoding.Json.pp json >>= fun () -> Client_keys.sign cctxt ~watermark:Signature.Generic_operation src_sk bytes let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> diff --git a/src/proto_010_PtGRANAD/lib_client/injection.ml b/src/proto_010_PtGRANAD/lib_client/injection.ml index e38764cf6ea3..44b91240dc37 100644 --- a/src/proto_010_PtGRANAD/lib_client/injection.ml +++ b/src/proto_010_PtGRANAD/lib_client/injection.ml @@ -272,7 +272,7 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -291,12 +291,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ~op:(Operation.pack op) ~chain_id >>=? function - | (Operation_data op', Operation_metadata result) -> ( + | Operation_data op', Operation_metadata result -> ( match ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -518,7 +518,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) | Single_manager minfo -> gas_patching_stats minfo need_patching gas_consumed | Cons_manager (minfo, rest) -> - let (need_patching, gas_consumed) = + let need_patching, gas_consumed = gas_patching_stats minfo need_patching gas_consumed in gas_patching_stats_list rest need_patching gas_consumed @@ -568,7 +568,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) in let rest_opt = loop rest in match (annotated_op_opt, rest_opt) with - | (None, None) -> None + | None, None -> None | _ -> let op = Option.value ~default:annotated_op annotated_op_opt in let rest = Option.value ~default:rest rest_opt in @@ -637,7 +637,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Annotated_manager_operation.t * kind Kind.manager contents_result -> kind Kind.manager contents tzresult Lwt.t = fun ~first -> function - | ((Manager_info c as op), (Manager_operation_result _ as result)) -> + | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then Lwt.return (estimated_gas_single result) >>=? fun gas -> if Gas.Arith.(gas = zero) then @@ -705,16 +705,16 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Kind.manager contents_list tzresult Lwt.t = fun first annotated_list result_list -> match (annotated_list, result_list) with - | (Single_manager annotated, Single_result res) -> + | Single_manager annotated, Single_result res -> patch ~first (annotated, res) >>=? fun op -> return (Single op) - | (Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest)) -> + | Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest) -> patch ~first (annotated, res) >>=? fun op -> patch_list false annotated_rest res_rest >>=? fun rest -> return (Cons (op, rest)) | _ -> assert false in let gas_limit_per_patched_op = - let (need_gas_patching, gas_consumed) = + let need_gas_patching, gas_consumed = gas_patching_stats_list annotated_contents 0 Gas.Arith.zero in if need_gas_patching = 0 then hard_gas_limit_per_operation @@ -1012,7 +1012,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run >>=? fun (oph, op, result) -> match pack_contents_list op result with | Cons_and_result (_, _, rest) -> - let (op, result) = unpack_contents_list rest in + let op, result = unpack_contents_list rest in return (oph, op, result) | _ -> assert false) | Some _ when has_reveal operations -> diff --git a/src/proto_010_PtGRANAD/lib_client/limit.ml b/src/proto_010_PtGRANAD/lib_client/limit.ml index 3f3c798c02b6..ae20b1d6bf4b 100644 --- a/src/proto_010_PtGRANAD/lib_client/limit.ml +++ b/src/proto_010_PtGRANAD/lib_client/limit.ml @@ -35,9 +35,9 @@ let is_unknown = Option.is_none let join (type a) ~where eq (l1 : a t) (l2 : a t) = match (l1, l2) with - | (None, None) -> Result.return_none - | (Some x, None) | (None, Some x) -> Result.return_some x - | (Some x, Some y) -> + | None, None -> Result.return_none + | Some x, None | None, Some x -> Result.return_some x + | Some x, Some y -> if eq x y then Result.return_some x else error_with "Limit.join: error (%s)" where diff --git a/src/proto_010_PtGRANAD/lib_client/michelson_v1_emacs.ml b/src/proto_010_PtGRANAD/lib_client/michelson_v1_emacs.ml index 2721fa702d46..197b420c6228 100644 --- a/src/proto_010_PtGRANAD/lib_client/michelson_v1_emacs.ml +++ b/src/proto_010_PtGRANAD/lib_client/michelson_v1_emacs.ml @@ -133,7 +133,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -141,7 +141,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -160,7 +160,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_010_PtGRANAD/lib_client/michelson_v1_error_reporter.ml b/src/proto_010_PtGRANAD/lib_client/michelson_v1_error_reporter.ml index b41076765255..18567c52ccca 100644 --- a/src/proto_010_PtGRANAD/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_010_PtGRANAD/lib_client/michelson_v1_error_reporter.ml @@ -457,7 +457,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Invalid_never_expr loc -> diff --git a/src/proto_010_PtGRANAD/lib_client/michelson_v1_macros.ml b/src/proto_010_PtGRANAD/lib_client/michelson_v1_macros.ml index 471c6b757be9..ca6574ceff29 100644 --- a/src/proto_010_PtGRANAD/lib_client/michelson_v1_macros.ml +++ b/src/proto_010_PtGRANAD/lib_client/michelson_v1_macros.ml @@ -122,9 +122,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -237,9 +237,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -383,14 +383,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -405,18 +405,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -439,7 +439,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -447,13 +447,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -464,7 +464,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -498,7 +498,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -541,8 +541,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -712,7 +711,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -724,10 +723,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -737,7 +736,7 @@ let expand_rec expr = let unexpand_carn_and_cdrn expanded = match expanded with | Seq (loc, [Prim (_, "GET", [Int (locn, n)], annot)]) -> - let (half, parity) = Z.ediv_rem n (Z.of_int 2) in + let half, parity = Z.ediv_rem n (Z.of_int 2) in if Z.(parity = zero) then Some (Prim (loc, "CDR", [Int (locn, half)], annot)) else Some (Prim (loc, "CAR", [Int (locn, half)], annot)) @@ -802,7 +801,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -812,7 +811,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -879,7 +878,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -889,7 +888,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -910,7 +909,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -952,46 +951,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1008,41 +1007,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_010_PtGRANAD/lib_client/michelson_v1_parser.ml b/src/proto_010_PtGRANAD/lib_client/michelson_v1_parser.ml index 2f44d22c1fca..09a8c7d5b710 100644 --- a/src/proto_010_PtGRANAD/lib_client/michelson_v1_parser.ml +++ b/src/proto_010_PtGRANAD/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -87,8 +87,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -96,8 +96,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_010_PtGRANAD/lib_client/michelson_v1_printer.ml b/src/proto_010_PtGRANAD/lib_client/michelson_v1_printer.ml index 5eeb4e1fd88c..98848e43b193 100644 --- a/src/proto_010_PtGRANAD/lib_client/michelson_v1_printer.ml +++ b/src/proto_010_PtGRANAD/lib_client/michelson_v1_printer.ml @@ -148,7 +148,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -180,8 +180,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_010_PtGRANAD/lib_client/mockup.ml b/src/proto_010_PtGRANAD/lib_client/mockup.ml index 8a5d363f1c09..6dd27ae11507 100644 --- a/src/proto_010_PtGRANAD/lib_client/mockup.ml +++ b/src/proto_010_PtGRANAD/lib_client/mockup.ml @@ -645,7 +645,7 @@ module Parsed_account = struct Client_keys.list_keys wallet >>=? fun all_keys -> List.iter_s (function - | (name, pkh, _pk_opt, Some sk_uri) -> ( + | name, pkh, _pk_opt, Some sk_uri -> ( let contract = Contract.implicit_contract pkh in Client_proto_context.get_balance rpc_context @@ -847,7 +847,7 @@ let mem_init : | None -> return Protocol_constants_overrides.no_overrides | Some json -> ( match Data_encoding.Json.destruct lib_parameters_json_encoding json with - | (_, x) -> return x + | _, x -> return x | exception error -> failwith "cannot read protocol constants overrides: %a" diff --git a/src/proto_010_PtGRANAD/lib_client/proxy.ml b/src/proto_010_PtGRANAD/lib_client/proxy.ml index 39c21c67cee2..c3eb5da787e5 100644 --- a/src/proto_010_PtGRANAD/lib_client/proxy.ml +++ b/src/proto_010_PtGRANAD/lib_client/proxy.ml @@ -50,11 +50,8 @@ module ProtoRpc : Tezos_proxy.Proxy_proto.PROTO_RPC = struct match key with (* matches paths like: big_maps/index/05/37/bc/fb/1e/39/i/contents/tail *) - | "big_maps" - :: "index" - :: hash0 - :: hash1 - :: hash2 :: hash3 :: hash4 :: hash5 :: i :: "contents" :: tail -> + | "big_maps" :: "index" :: hash0 :: hash1 :: hash2 :: hash3 :: hash4 + :: hash5 :: i :: "contents" :: tail -> Some ( [ "big_maps"; @@ -76,9 +73,8 @@ module ProtoRpc : Tezos_proxy.Proxy_proto.PROTO_RPC = struct match key with (* matches paths like: contracts/index/05/37/bc/fb/1e/39/000002298c03ed7d454a101eb7022bc95f7e5f41ac78/tail *) - | "contracts" - :: index - :: hash0 :: hash1 :: hash2 :: hash3 :: hash4 :: hash5 :: id :: tail -> + | "contracts" :: index :: hash0 :: hash1 :: hash2 :: hash3 :: hash4 :: hash5 + :: id :: tail -> Some ( ["contracts"; index; hash0; hash1; hash2; hash3; hash4; hash5; id], tail ) diff --git a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_context_commands.ml b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_context_commands.ml index 3a82ca27f85b..2444152bc9ef 100644 --- a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_context_commands.ml @@ -879,7 +879,7 @@ let commands network () = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith @@ -1167,8 +1167,7 @@ let commands network () = ~desc:"Register and activate an Alphanet/Zeronet faucet account." (args2 (Secret_key.force_switch ()) encrypted_switch) (prefixes ["activate"; "account"] - @@ Secret_key.fresh_alias_param - @@ prefixes ["with"] + @@ Secret_key.fresh_alias_param @@ prefixes ["with"] @@ param ~name:"activation_key" ~desc: @@ -1212,8 +1211,7 @@ let commands network () = ~desc:"Activate a fundraiser account." (args1 dry_run_switch) (prefixes ["activate"; "fundraiser"; "account"] - @@ Public_key_hash.alias_param - @@ prefixes ["with"] + @@ Public_key_hash.alias_param @@ prefixes ["with"] @@ param ~name:"code" (Clic.parameter (fun _ctx code -> diff --git a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_fa12_commands.ml b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_fa12_commands.ml index 84c244a2bc11..5857aff73e16 100644 --- a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_fa12_commands.ml +++ b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_fa12_commands.ml @@ -226,7 +226,7 @@ let commands () : #Protocol_client_context.full Clic.command list = src (_, dst) (cctxt : #Protocol_client_context.full) -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in get_contract_caller_keys cctxt caller >>=? fun (source, caller_pk, caller_sk) -> let action = Client_proto_fa12.Transfer (snd src, dst, amount) in @@ -714,7 +714,7 @@ let commands () : #Protocol_client_context.full Clic.command list = src operations_json cctxt -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in let fee_parameter = { Injection.minimal_fees; @@ -760,7 +760,7 @@ let commands () : #Protocol_client_context.full Clic.command list = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith diff --git a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_multisig_commands.ml index 2ec9ea5bec9d..d308690b40f5 100644 --- a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_multisig_commands.ml @@ -940,8 +940,7 @@ let commands () : #Protocol_client_context.full Clic.command list = @@ Client_proto_contracts.ContractAlias.destination_param ~name:"multisig" ~desc:"name or address of the originated multisig contract" - @@ prefixes ["to"] - @@ threshold_param () + @@ prefixes ["to"] @@ threshold_param () @@ prefixes ["and"; "public"; "keys"; "to"] @@ non_terminal_seq (public_key_param ()) ~suffix:["on"; "behalf"; "of"] @@ Client_proto_contracts.ContractAlias.destination_param diff --git a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_programs_commands.ml b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_programs_commands.ml index 9877827a0917..301046cb5a0e 100644 --- a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_programs_commands.ml @@ -307,7 +307,7 @@ let commands () = program cctxt -> match program with - | (program, []) -> + | program, [] -> resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> typecheck_program @@ -331,7 +331,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -630,8 +630,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> @@ -670,11 +669,10 @@ let commands () = (args2 emacs_mode_switch no_print_source_flag) (prefixes ["get"; "script"; "entrypoint"; "type"; "of"] @@ string ~name:"entrypoint" ~desc:"the entrypoint to describe" - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) entrypoint program cctxt -> match program with - | (program, []) -> + | program, [] -> entrypoint_type cctxt ~chain:cctxt#chain @@ -695,7 +693,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -715,7 +713,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_entrypoints cctxt ~chain:cctxt#chain ~block:cctxt#block program >>= fun entrypoints -> print_entrypoints_list @@ -730,7 +728,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -752,7 +750,7 @@ let commands () = @@ Program.source_param @@ stop) (fun (emacs_mode, no_print_source) program cctxt -> match program with - | (program, []) -> + | program, [] -> list_unreachables cctxt ~chain:cctxt#chain @@ -771,7 +769,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> diff --git a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_stresstest_commands.ml index 2c4bfc752c8f..9405999778bc 100644 --- a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_stresstest_commands.ml @@ -305,7 +305,7 @@ let random_seed rng = let generate_fresh_source pool rng = let seed = random_seed rng in - let (pkh, pk, sk) = Signature.generate_key ~seed () in + let pkh, pk, sk = Signature.generate_key ~seed () in let fresh = {source = {pkh; pk; sk}; origin = Explicit} in pool.pool <- fresh :: pool.pool ; pool.pool_size <- pool.pool_size + 1 ; @@ -319,7 +319,7 @@ let heads_iter (cctxt : Protocol_client_context.full) let open Lwt_result_syntax in Error_monad.protect (fun () -> - let* (heads_stream, stopper) = Shell_services.Monitor.heads cctxt `Main in + let* heads_stream, stopper = Shell_services.Monitor.heads cctxt `Main in let rec loop () : unit tzresult Lwt.t = let*! block_hash_and_header = Lwt_stream.get heads_stream in match block_hash_and_header with diff --git a/src/proto_010_PtGRANAD/lib_client_sapling/client_sapling_commands.ml b/src/proto_010_PtGRANAD/lib_client_sapling/client_sapling_commands.ml index bd19c95ce698..d402b903b2c5 100644 --- a/src/proto_010_PtGRANAD/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_010_PtGRANAD/lib_client_sapling/client_sapling_commands.ml @@ -205,9 +205,7 @@ let commands () = path >>= fun () -> (* TODO must pass contract address for now *) - let (_, contract) = - WithExceptions.Option.get ~loc:__LOC__ contract_opt - in + let _, contract = WithExceptions.Option.get ~loc:__LOC__ contract_opt in Context.Client_state.register cctxt ~default_memo_size diff --git a/src/proto_010_PtGRANAD/lib_client_sapling/context.ml b/src/proto_010_PtGRANAD/lib_client_sapling/context.ml index 6e74a9ea1e8e..d2f948cec0ba 100644 --- a/src/proto_010_PtGRANAD/lib_client_sapling/context.ml +++ b/src/proto_010_PtGRANAD/lib_client_sapling/context.ml @@ -289,7 +289,7 @@ module Contract_state = struct let vks = Accounts.fold (fun account acc -> Account.(account.vk) :: acc) accounts [] in - let (size, _) = Storage.size storage in + let size, _ = Storage.size storage in let rec aux pos accounts = if pos < size then (* try to decrypt each inputs with all vks *) @@ -309,7 +309,7 @@ module Contract_state = struct | _ -> assert false (* got more than one decrypting key *) else accounts in - let (current_size, _) = Storage.size state.storage in + let current_size, _ = Storage.size state.storage in let accounts = aux current_size accounts in {accounts; storage} @@ -401,7 +401,7 @@ module Client_state = struct let sync_and_scan cctxt contract = load cctxt >>=? fun state -> find cctxt contract state >>=? fun contract_state -> - let (cm_pos, nf_pos) = Storage.size contract_state.storage in + let cm_pos, nf_pos = Storage.size contract_state.storage in get_diff cctxt contract cm_pos nf_pos >>=? fun diff -> let contract_state = Contract_state.update_storage contract_state diff in let state = Map.add contract contract_state state in diff --git a/src/proto_010_PtGRANAD/lib_client_sapling/wallet.ml b/src/proto_010_PtGRANAD/lib_client_sapling/wallet.ml index 9688adc33f77..7e180e7679b7 100644 --- a/src/proto_010_PtGRANAD/lib_client_sapling/wallet.ml +++ b/src/proto_010_PtGRANAD/lib_client_sapling/wallet.ml @@ -114,7 +114,7 @@ let new_address (cctxt : #Client_context.full) name index_opt = return (Viewing_key.of_sk sk) >>=? fun vk -> (* Viewing_key.new_address finds the smallest index greater or equal to [index] that generates a correct address. *) - let (corrected_index, address) = Viewing_key.new_address vk index in + let corrected_index, address = Viewing_key.new_address vk index in Sapling_key.update cctxt name diff --git a/src/proto_010_PtGRANAD/lib_plugin/plugin.ml b/src/proto_010_PtGRANAD/lib_plugin/plugin.ml index 87d4ddc8ce7a..8644fb38e83c 100644 --- a/src/proto_010_PtGRANAD/lib_plugin/plugin.ml +++ b/src/proto_010_PtGRANAD/lib_plugin/plugin.ml @@ -918,8 +918,8 @@ module RPC = struct type a s. (a, s) Script_typed_ir.stack_ty * (a * s) -> (Script.expr * string option) list tzresult Lwt.t = function - | (Bot_t, (EmptyCell, EmptyCell)) -> return_nil - | (Item_t (ty, rest_ty, annot), (v, rest)) -> + | Bot_t, (EmptyCell, EmptyCell) -> return_nil + | Item_t (ty, rest_ty, annot), (v, rest) -> Script_ir_translator.unparse_data ctxt Unparsing_mode.unparsing_mode @@ -1180,12 +1180,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with @@ -1229,12 +1229,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with @@ -1292,12 +1292,12 @@ module RPC = struct (View_helpers.make_viewer_script ty) Tez.zero >>=? fun (ctxt, viewer_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (contract, contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (contract, contract) in let gas = Option.value @@ -1861,8 +1861,8 @@ module RPC = struct in let ops = match (sourcePubKey, revealed) with - | (None, _) | (_, Some _) -> ops - | (Some pk, None) -> + | None, _ | _, Some _ -> ops + | Some pk, None -> let operation = Reveal pk in Contents (Manager_operation diff --git a/src/proto_011_PtHangz2/lib_client/client_proto_context.ml b/src/proto_011_PtHangz2/lib_client/client_proto_context.ml index 46b018ce2971..d4bf28f70b4c 100644 --- a/src/proto_011_PtHangz2/lib_client/client_proto_context.ml +++ b/src/proto_011_PtHangz2/lib_client/client_proto_context.ml @@ -651,18 +651,18 @@ let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_011_PtHangz2/lib_client/client_proto_fa12.ml b/src/proto_011_PtHangz2/lib_client/client_proto_fa12.ml index 7c44b5103c94..8c3ba0f6a162 100644 --- a/src/proto_011_PtHangz2/lib_client/client_proto_fa12.ml +++ b/src/proto_011_PtHangz2/lib_client/client_proto_fa12.ml @@ -272,7 +272,7 @@ type type_eq_combinator = node * (node -> bool) check functions, and returns a type of n-ary pair of such types and a function checking syntactical equivalence with another node. *) let t_pair ?(loc = 0) l : type_eq_combinator = - let (values, are_ty) = List.split l in + let values, are_ty = List.split l in let is_pair p = match p with | Micheline.Prim (_, Script.T_pair, l, _) -> ( @@ -535,8 +535,8 @@ let parse_callback error expr = let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in match (String.sub s 0 pos, name) with - | (addr, "default") -> of_b58_check (addr, None) - | (addr, name) -> of_b58_check (addr, Some name))) + | addr, "default" -> of_b58_check (addr, None) + | addr, name -> of_b58_check (addr, Some name))) | _ -> error () let action_of_expr ~entrypoint expr = @@ -647,7 +647,7 @@ let derive_action expr t_param = | ( Micheline.Prim (_, Script.D_Right, [right], _), Micheline.Prim (_, Script.T_or, [_; t_right], _) ) -> derive right t_right - | (_, Micheline.Prim (_, _, _, annots)) -> + | _, Micheline.Prim (_, _, _, annots) -> find_entrypoint_in_annot error annots expr | _ -> error () in @@ -735,7 +735,7 @@ let parse_error = | ( "NotEnoughAllowance", Prim (_, Script.D_Pair, [Int (_, required); Int (_, present)], _) ) -> Some (Not_enough_allowance (required, present)) - | ("UnsafeAllowanceChange", Int (_, previous)) -> + | "UnsafeAllowanceChange", Int (_, previous) -> Some (Unsafe_allowance_change previous) | _ -> None @@ -759,7 +759,7 @@ let call_contract (cctxt : #Protocol_client_context.full) ~chain ~block ~contract ~action ~tez_amount ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () = contract_has_fa12_interface cctxt ~chain ~block ~contract () >>=? fun () -> - let (entrypoint, arg) = translate_action_to_argument action in + let entrypoint, arg = translate_action_to_argument action in Client_proto_context.transfer cctxt ~chain diff --git a/src/proto_011_PtHangz2/lib_client/client_proto_programs.ml b/src/proto_011_PtHangz2/lib_client/client_proto_programs.ml index 32fde70f2852..ef9ee78aa81d 100644 --- a/src/proto_011_PtHangz2/lib_client/client_proto_programs.ml +++ b/src/proto_011_PtHangz2/lib_client/client_proto_programs.ml @@ -209,7 +209,7 @@ let script_size cctxt ~(chain : Chain_services.chain) ~block ?gas ?legacy let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_011_PtHangz2/lib_client/client_proto_utils.ml b/src/proto_011_PtHangz2/lib_client/client_proto_utils.ml index 27fec54d342a..be6844cc5cf7 100644 --- a/src/proto_011_PtHangz2/lib_client/client_proto_utils.ml +++ b/src/proto_011_PtHangz2/lib_client/client_proto_utils.ml @@ -37,14 +37,14 @@ let to_json_and_bytes branch message = Data_encoding.Binary.to_bytes_exn encoding op ) let sign_message (cctxt : #full) ~src_sk ~block ~message = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in cctxt#message "signed content: @[%a@]" Data_encoding.Json.pp json >>= fun () -> Client_keys.sign cctxt ~watermark:Signature.Generic_operation src_sk bytes let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> diff --git a/src/proto_011_PtHangz2/lib_client/injection.ml b/src/proto_011_PtHangz2/lib_client/injection.ml index 0cb4f4023c3a..f71f5a3b2728 100644 --- a/src/proto_011_PtHangz2/lib_client/injection.ml +++ b/src/proto_011_PtHangz2/lib_client/injection.ml @@ -272,7 +272,7 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -293,12 +293,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ~chain_id ~latency >>=? function - | (Operation_data op', Operation_metadata result) -> ( + | Operation_data op', Operation_metadata result -> ( match ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -530,7 +530,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) | Single_manager minfo -> gas_patching_stats minfo need_patching gas_consumed | Cons_manager (minfo, rest) -> - let (need_patching, gas_consumed) = + let need_patching, gas_consumed = gas_patching_stats minfo need_patching gas_consumed in gas_patching_stats_list rest need_patching gas_consumed @@ -580,7 +580,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) in let rest_opt = loop rest in match (annotated_op_opt, rest_opt) with - | (None, None) -> None + | None, None -> None | _ -> let op = Option.value ~default:annotated_op annotated_op_opt in let rest = Option.value ~default:rest rest_opt in @@ -649,7 +649,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Annotated_manager_operation.t * kind Kind.manager contents_result -> kind Kind.manager contents tzresult Lwt.t = fun ~first -> function - | ((Manager_info c as op), (Manager_operation_result _ as result)) -> + | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then Lwt.return (estimated_gas_single result) >>=? fun gas -> if Gas.Arith.(gas = zero) then @@ -717,16 +717,16 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Kind.manager contents_list tzresult Lwt.t = fun first annotated_list result_list -> match (annotated_list, result_list) with - | (Single_manager annotated, Single_result res) -> + | Single_manager annotated, Single_result res -> patch ~first (annotated, res) >>=? fun op -> return (Single op) - | (Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest)) -> + | Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest) -> patch ~first (annotated, res) >>=? fun op -> patch_list false annotated_rest res_rest >>=? fun rest -> return (Cons (op, rest)) | _ -> assert false in let gas_limit_per_patched_op = - let (need_gas_patching, gas_consumed) = + let need_gas_patching, gas_consumed = gas_patching_stats_list annotated_contents 0 Gas.Arith.zero in if need_gas_patching = 0 then hard_gas_limit_per_operation @@ -1026,7 +1026,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run >>=? fun (oph, op, result) -> match pack_contents_list op result with | Cons_and_result (_, _, rest) -> - let (op, result) = unpack_contents_list rest in + let op, result = unpack_contents_list rest in return (oph, op, result) | _ -> assert false) | Some _ when has_reveal operations -> diff --git a/src/proto_011_PtHangz2/lib_client/limit.ml b/src/proto_011_PtHangz2/lib_client/limit.ml index 3f3c798c02b6..ae20b1d6bf4b 100644 --- a/src/proto_011_PtHangz2/lib_client/limit.ml +++ b/src/proto_011_PtHangz2/lib_client/limit.ml @@ -35,9 +35,9 @@ let is_unknown = Option.is_none let join (type a) ~where eq (l1 : a t) (l2 : a t) = match (l1, l2) with - | (None, None) -> Result.return_none - | (Some x, None) | (None, Some x) -> Result.return_some x - | (Some x, Some y) -> + | None, None -> Result.return_none + | Some x, None | None, Some x -> Result.return_some x + | Some x, Some y -> if eq x y then Result.return_some x else error_with "Limit.join: error (%s)" where diff --git a/src/proto_011_PtHangz2/lib_client/michelson_v1_emacs.ml b/src/proto_011_PtHangz2/lib_client/michelson_v1_emacs.ml index 2721fa702d46..197b420c6228 100644 --- a/src/proto_011_PtHangz2/lib_client/michelson_v1_emacs.ml +++ b/src/proto_011_PtHangz2/lib_client/michelson_v1_emacs.ml @@ -133,7 +133,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -141,7 +141,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -160,7 +160,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_011_PtHangz2/lib_client/michelson_v1_error_reporter.ml b/src/proto_011_PtHangz2/lib_client/michelson_v1_error_reporter.ml index 93d58a5cd984..e839f4cd0c96 100644 --- a/src/proto_011_PtHangz2/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_011_PtHangz2/lib_client/michelson_v1_error_reporter.ml @@ -458,7 +458,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Invalid_never_expr loc -> diff --git a/src/proto_011_PtHangz2/lib_client/michelson_v1_macros.ml b/src/proto_011_PtHangz2/lib_client/michelson_v1_macros.ml index 448bd000108e..3b1eaa5028d4 100644 --- a/src/proto_011_PtHangz2/lib_client/michelson_v1_macros.ml +++ b/src/proto_011_PtHangz2/lib_client/michelson_v1_macros.ml @@ -122,9 +122,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -237,9 +237,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -383,14 +383,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -405,18 +405,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -439,7 +439,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -447,13 +447,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -464,7 +464,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -498,7 +498,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -541,8 +541,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -712,7 +711,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -724,10 +723,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -737,7 +736,7 @@ let expand_rec expr = let unexpand_carn_and_cdrn expanded = match expanded with | Seq (loc, [Prim (_, "GET", [Int (locn, n)], annot)]) -> - let (half, parity) = Z.ediv_rem n (Z.of_int 2) in + let half, parity = Z.ediv_rem n (Z.of_int 2) in if Z.(parity = zero) then Some (Prim (loc, "CDR", [Int (locn, half)], annot)) else Some (Prim (loc, "CAR", [Int (locn, half)], annot)) @@ -802,7 +801,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -812,7 +811,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -879,7 +878,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -889,7 +888,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -910,7 +909,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -952,46 +951,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1008,41 +1007,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_011_PtHangz2/lib_client/michelson_v1_parser.ml b/src/proto_011_PtHangz2/lib_client/michelson_v1_parser.ml index 2f44d22c1fca..09a8c7d5b710 100644 --- a/src/proto_011_PtHangz2/lib_client/michelson_v1_parser.ml +++ b/src/proto_011_PtHangz2/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -87,8 +87,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -96,8 +96,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_011_PtHangz2/lib_client/michelson_v1_printer.ml b/src/proto_011_PtHangz2/lib_client/michelson_v1_printer.ml index 5eeb4e1fd88c..98848e43b193 100644 --- a/src/proto_011_PtHangz2/lib_client/michelson_v1_printer.ml +++ b/src/proto_011_PtHangz2/lib_client/michelson_v1_printer.ml @@ -148,7 +148,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -180,8 +180,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_011_PtHangz2/lib_client/mockup.ml b/src/proto_011_PtHangz2/lib_client/mockup.ml index c630e3edc91e..59c394d58b62 100644 --- a/src/proto_011_PtHangz2/lib_client/mockup.ml +++ b/src/proto_011_PtHangz2/lib_client/mockup.ml @@ -627,7 +627,7 @@ module Parsed_account = struct Client_keys.list_keys wallet >>=? fun all_keys -> List.iter_s (function - | (name, pkh, _pk_opt, Some sk_uri) -> ( + | name, pkh, _pk_opt, Some sk_uri -> ( let contract = Contract.implicit_contract pkh in Client_proto_context.get_balance rpc_context @@ -871,7 +871,7 @@ let mem_init : | None -> return Protocol_constants_overrides.no_overrides | Some json -> ( match Data_encoding.Json.destruct lib_parameters_json_encoding json with - | (_, x) -> return x + | _, x -> return x | exception error -> failwith "cannot read protocol constants overrides: %a" diff --git a/src/proto_011_PtHangz2/lib_client/test/test_michelson_v1_macros.ml b/src/proto_011_PtHangz2/lib_client/test/test_michelson_v1_macros.ml index 8ddf7d8d8abd..6719e8abb871 100644 --- a/src/proto_011_PtHangz2/lib_client/test/test_michelson_v1_macros.ml +++ b/src/proto_011_PtHangz2/lib_client/test/test_michelson_v1_macros.ml @@ -44,7 +44,7 @@ let print expr : string = let assert_expands (original : (Micheline_parser.location, string) Micheline.node) (expanded : (Micheline_parser.location, string) Micheline.node) = - let ({Michelson_v1_parser.expanded = expansion; _}, errors) = + let {Michelson_v1_parser.expanded = expansion; _}, errors = let source = print (Micheline.strip_locations original) in Michelson_v1_parser.expand_all ~source ~original in @@ -691,7 +691,7 @@ let test_map_cdadr () = [unparse.Michelson_v1_parser.unexpanded] contains the original expression with macros *) let assert_unexpansion original ex = - let ({Michelson_v1_parser.expanded; _}, errors) = + let {Michelson_v1_parser.expanded; _}, errors = let source = print (Micheline.strip_locations original) in Michelson_v1_parser.expand_all ~source ~original in @@ -1318,7 +1318,7 @@ let tests = ("map_car unexpansion", fun _ -> Lwt.return (test_unexpand_map_car ())); ("diip unexpansion", fun _ -> Lwt.return (test_unexpand_diip ())); ("diip_duup1 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup1 ())); - ("diip_duup2 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup2 ())); + ("diip_duup2 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup2 ())) (***********************************************************************) (*BUG the function in Michelson_v1_macros.unexpand_map_caddadr @@ -1327,7 +1327,7 @@ let tests = (*"diip unexpansion", (fun _ -> Lwt.return (test_unexpand_diip ())) ;*) (*"map_cdr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdr ())) ;*) (*"map_caadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_caadr ())) ;*) - (*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*) + (*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*); ] let wrap (n, f) = diff --git a/src/proto_011_PtHangz2/lib_client/test/test_proxy.ml b/src/proto_011_PtHangz2/lib_client/test/test_proxy.ml index fac12dead632..d664151f5aac 100644 --- a/src/proto_011_PtHangz2/lib_client/test/test_proxy.ml +++ b/src/proto_011_PtHangz2/lib_client/test/test_proxy.ml @@ -55,9 +55,9 @@ let key_gen : string list QCheck2.Gen.t = (** Whether [t1] is a prefix of [t2] *) let rec is_prefix t1 t2 = match (t1, t2) with - | ([], _) -> true - | (_, []) -> false - | (x1 :: rest1, x2 :: rest2) when x1 = x2 -> is_prefix rest1 rest2 + | [], _ -> true + | _, [] -> false + | x1 :: rest1, x2 :: rest2 when x1 = x2 -> is_prefix rest1 rest2 | _ -> false let test_split_key = diff --git a/src/proto_011_PtHangz2/lib_client_commands/client_proto_context_commands.ml b/src/proto_011_PtHangz2/lib_client_commands/client_proto_context_commands.ml index 9885bc0090bd..59939e0ccb47 100644 --- a/src/proto_011_PtHangz2/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_commands/client_proto_context_commands.ml @@ -949,7 +949,7 @@ let commands network () = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith @@ -1324,8 +1324,7 @@ let commands network () = ~desc:"Register and activate an Alphanet/Zeronet faucet account." (args2 (Secret_key.force_switch ()) encrypted_switch) (prefixes ["activate"; "account"] - @@ Secret_key.fresh_alias_param - @@ prefixes ["with"] + @@ Secret_key.fresh_alias_param @@ prefixes ["with"] @@ param ~name:"activation_key" ~desc: @@ -1369,8 +1368,7 @@ let commands network () = ~desc:"Activate a fundraiser account." (args1 dry_run_switch) (prefixes ["activate"; "fundraiser"; "account"] - @@ Public_key_hash.alias_param - @@ prefixes ["with"] + @@ Public_key_hash.alias_param @@ prefixes ["with"] @@ param ~name:"code" (Clic.parameter (fun _ctx code -> diff --git a/src/proto_011_PtHangz2/lib_client_commands/client_proto_fa12_commands.ml b/src/proto_011_PtHangz2/lib_client_commands/client_proto_fa12_commands.ml index 624a7c6c4a54..2e729405ac8d 100644 --- a/src/proto_011_PtHangz2/lib_client_commands/client_proto_fa12_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_commands/client_proto_fa12_commands.ml @@ -197,7 +197,7 @@ let commands () : #Protocol_client_context.full Clic.command list = src (_, dst) (cctxt : #Protocol_client_context.full) -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in get_contract_caller_keys cctxt caller >>=? fun (source, caller_pk, caller_sk) -> let action = Client_proto_fa12.Transfer (snd src, dst, amount) in @@ -685,7 +685,7 @@ let commands () : #Protocol_client_context.full Clic.command list = src operations_json cctxt -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in let fee_parameter = { Injection.minimal_fees; @@ -731,7 +731,7 @@ let commands () : #Protocol_client_context.full Clic.command list = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith diff --git a/src/proto_011_PtHangz2/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_011_PtHangz2/lib_client_commands/client_proto_multisig_commands.ml index 2ec9ea5bec9d..d308690b40f5 100644 --- a/src/proto_011_PtHangz2/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_commands/client_proto_multisig_commands.ml @@ -940,8 +940,7 @@ let commands () : #Protocol_client_context.full Clic.command list = @@ Client_proto_contracts.ContractAlias.destination_param ~name:"multisig" ~desc:"name or address of the originated multisig contract" - @@ prefixes ["to"] - @@ threshold_param () + @@ prefixes ["to"] @@ threshold_param () @@ prefixes ["and"; "public"; "keys"; "to"] @@ non_terminal_seq (public_key_param ()) ~suffix:["on"; "behalf"; "of"] @@ Client_proto_contracts.ContractAlias.destination_param diff --git a/src/proto_011_PtHangz2/lib_client_commands/client_proto_programs_commands.ml b/src/proto_011_PtHangz2/lib_client_commands/client_proto_programs_commands.ml index 88dee0b33600..f3fdf634d762 100644 --- a/src/proto_011_PtHangz2/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_commands/client_proto_programs_commands.ml @@ -176,7 +176,7 @@ let commands () = let handle_parsing_error label (cctxt : Protocol_client_context.full) (emacs_mode, no_print_source) program body = match program with - | (program, []) -> body program + | program, [] -> body program | res_with_errors when emacs_mode -> cctxt#message "(@[<v 0>(%s . ())@ (errors . %a)@])" @@ -184,7 +184,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -652,8 +652,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> @@ -692,8 +691,7 @@ let commands () = (args2 emacs_mode_switch no_print_source_flag) (prefixes ["get"; "script"; "entrypoint"; "type"; "of"] @@ string ~name:"entrypoint" ~desc:"the entrypoint to describe" - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun ((emacs_mode, no_print_source) as setup) entrypoint program cctxt -> handle_parsing_error "entrypoint" cctxt setup program @@ fun program -> entrypoint_type diff --git a/src/proto_011_PtHangz2/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_011_PtHangz2/lib_client_commands/client_proto_stresstest_commands.ml index 2c4bfc752c8f..9405999778bc 100644 --- a/src/proto_011_PtHangz2/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_commands/client_proto_stresstest_commands.ml @@ -305,7 +305,7 @@ let random_seed rng = let generate_fresh_source pool rng = let seed = random_seed rng in - let (pkh, pk, sk) = Signature.generate_key ~seed () in + let pkh, pk, sk = Signature.generate_key ~seed () in let fresh = {source = {pkh; pk; sk}; origin = Explicit} in pool.pool <- fresh :: pool.pool ; pool.pool_size <- pool.pool_size + 1 ; @@ -319,7 +319,7 @@ let heads_iter (cctxt : Protocol_client_context.full) let open Lwt_result_syntax in Error_monad.protect (fun () -> - let* (heads_stream, stopper) = Shell_services.Monitor.heads cctxt `Main in + let* heads_stream, stopper = Shell_services.Monitor.heads cctxt `Main in let rec loop () : unit tzresult Lwt.t = let*! block_hash_and_header = Lwt_stream.get heads_stream in match block_hash_and_header with diff --git a/src/proto_011_PtHangz2/lib_client_sapling/client_sapling_commands.ml b/src/proto_011_PtHangz2/lib_client_sapling/client_sapling_commands.ml index 3a268e4a37a3..57ed4456d73a 100644 --- a/src/proto_011_PtHangz2/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_sapling/client_sapling_commands.ml @@ -695,9 +695,7 @@ let commands () = path >>= fun () -> (* TODO must pass contract address for now *) - let (_, contract) = - WithExceptions.Option.get ~loc:__LOC__ contract_opt - in + let _, contract = WithExceptions.Option.get ~loc:__LOC__ contract_opt in Context.Client_state.register cctxt ~default_memo_size diff --git a/src/proto_011_PtHangz2/lib_client_sapling/context.ml b/src/proto_011_PtHangz2/lib_client_sapling/context.ml index 3ecade590557..07ac678504ef 100644 --- a/src/proto_011_PtHangz2/lib_client_sapling/context.ml +++ b/src/proto_011_PtHangz2/lib_client_sapling/context.ml @@ -313,7 +313,7 @@ module Contract_state = struct let vks = Accounts.fold (fun account acc -> Account.(account.vk) :: acc) accounts [] in - let (size, _) = Storage.size storage in + let size, _ = Storage.size storage in let rec aux pos accounts = if pos < size then (* try to decrypt each inputs with all vks *) @@ -333,7 +333,7 @@ module Contract_state = struct | _ -> assert false (* got more than one decrypting key *) else accounts in - let (current_size, _) = Storage.size state.storage in + let current_size, _ = Storage.size state.storage in let accounts = aux current_size accounts in {accounts; storage} @@ -425,7 +425,7 @@ module Client_state = struct let sync_and_scan cctxt contract = load cctxt >>=? fun state -> find cctxt contract state >>=? fun contract_state -> - let (cm_pos, nf_pos) = Storage.size contract_state.storage in + let cm_pos, nf_pos = Storage.size contract_state.storage in get_diff cctxt contract cm_pos nf_pos >>=? fun diff -> let contract_state = Contract_state.update_storage contract_state diff in let state = Map.add contract contract_state state in diff --git a/src/proto_011_PtHangz2/lib_client_sapling/wallet.ml b/src/proto_011_PtHangz2/lib_client_sapling/wallet.ml index 9688adc33f77..7e180e7679b7 100644 --- a/src/proto_011_PtHangz2/lib_client_sapling/wallet.ml +++ b/src/proto_011_PtHangz2/lib_client_sapling/wallet.ml @@ -114,7 +114,7 @@ let new_address (cctxt : #Client_context.full) name index_opt = return (Viewing_key.of_sk sk) >>=? fun vk -> (* Viewing_key.new_address finds the smallest index greater or equal to [index] that generates a correct address. *) - let (corrected_index, address) = Viewing_key.new_address vk index in + let corrected_index, address = Viewing_key.new_address vk index in Sapling_key.update cctxt name diff --git a/src/proto_011_PtHangz2/lib_plugin/plugin.ml b/src/proto_011_PtHangz2/lib_plugin/plugin.ml index 23308c1eadfe..2b0be2c24b04 100644 --- a/src/proto_011_PtHangz2/lib_plugin/plugin.ml +++ b/src/proto_011_PtHangz2/lib_plugin/plugin.ml @@ -940,8 +940,8 @@ module RPC = struct type a s. (a, s) Script_typed_ir.stack_ty * (a * s) -> (Script.expr * string option) list tzresult Lwt.t = function - | (Bot_t, (EmptyCell, EmptyCell)) -> return_nil - | (Item_t (ty, rest_ty, annot), (v, rest)) -> + | Bot_t, (EmptyCell, EmptyCell) -> return_nil + | Item_t (ty, rest_ty, annot), (v, rest) -> Script_ir_translator.unparse_data ctxt Unparsing_mode.unparsing_mode @@ -1345,12 +1345,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with @@ -1401,12 +1401,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with @@ -1467,12 +1467,12 @@ module RPC = struct (View_helpers.make_viewer_script ty) Tez.zero >>=? fun (ctxt, viewer_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (contract, contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (contract, contract) in let gas = Option.value @@ -1557,7 +1557,7 @@ module RPC = struct storage; } in - let (size, cost) = Script_ir_translator.script_size script in + let size, cost = Script_ir_translator.script_size script in Gas.consume ctxt cost >>?= fun _ctxt -> return @@ size) ; Registration.register0 @@ -2012,8 +2012,8 @@ module RPC = struct in let ops = match (sourcePubKey, revealed) with - | (None, _) | (_, Some _) -> ops - | (Some pk, None) -> + | None, _ | _, Some _ -> ops + | Some pk, None -> let operation = Reveal pk in Contents (Manager_operation @@ -2219,8 +2219,8 @@ module RPC = struct let requested_levels ~default ctxt cycles levels = match (levels, cycles) with - | ([], []) -> ok [default] - | (levels, cycles) -> + | [], [] -> ok [default] + | levels, cycles -> (* explicitly fail when requested levels or cycle are in the past... or too far in the future... *) let levels = @@ -2349,8 +2349,8 @@ module RPC = struct (fun (pk', _) -> Signature.Public_key.equal pk pk') delegates with - | ([], _) -> loop l acc (priority + 1) delegates - | ((_, delegate) :: _, delegates') -> + | [], _ -> loop l acc (priority + 1) delegates + | (_, delegate) :: _, delegates' -> (match pred_timestamp with | None -> ok_none | Some pred_timestamp -> diff --git a/src/proto_012_Psithaca/lib_benchmark/autocomp.ml b/src/proto_012_Psithaca/lib_benchmark/autocomp.ml index 1a44dc9826f7..ab3c371190af 100644 --- a/src/proto_012_Psithaca/lib_benchmark/autocomp.ml +++ b/src/proto_012_Psithaca/lib_benchmark/autocomp.ml @@ -141,7 +141,7 @@ module SM = struct let ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t = fun m f rng_state s -> - let (x, s) = m rng_state s in + let x, s = m rng_state s in f x rng_state s [@@inline] @@ -294,14 +294,12 @@ struct complete_data_list path (i + 1) tl (term :: acc) let complete_data typing node rng_state = - let (root_type_opt, _) = - Inference.M.get_data_annot Kernel.Path.root typing - in + let root_type_opt, _ = Inference.M.get_data_annot Kernel.Path.root typing in match root_type_opt with | None -> Stdlib.failwith "Autocomp.complete_data: cannot get type of expr" | Some ty -> - let (_, typing) = Inference.instantiate_base ty typing in - let (result, _) = + let _, typing = Inference.instantiate_base ty typing in + let result, _ = try complete_data node Kernel.Path.root rng_state typing with Autocompletion_error (Cannot_complete_data (subterm, path)) -> Format.eprintf "Cannot complete data@." ; @@ -309,7 +307,7 @@ struct Format.eprintf "%a@." Mikhailsky.pp subterm ; Stdlib.failwith "in autocomp.ml: unrecoverable failure" in - let (typ, _typing) = + let typ, _typing = try Inference.infer_data_with_state result with Inference.Ill_typed_script error -> Format.eprintf "%a@." Inference.pp_inference_error error ; @@ -352,15 +350,15 @@ struct complete_code_list path (i + 1) tl (term :: acc) let complete_code typing node rng_state = - let (root_type_opt, _) = + let root_type_opt, _ = Inference.M.get_instr_annot Kernel.Path.root typing in match root_type_opt with | None -> Stdlib.failwith "Autocomp.complete_code: cannot get type of expr" | Some {bef; aft} -> - let (_, typing) = Inference.instantiate bef typing in - let (_, typing) = Inference.instantiate aft typing in - let (result, _) = + let _, typing = Inference.instantiate bef typing in + let _, typing = Inference.instantiate aft typing in + let result, _ = try complete_code node Kernel.Path.root rng_state typing with | Autocompletion_error (Cannot_complete_code (subterm, path)) -> Format.eprintf "Cannot complete code@." ; @@ -369,14 +367,14 @@ struct Stdlib.failwith "in autocomp.ml: unrecoverable failure" | _ -> assert false in - let ((bef, aft), typing) = + let (bef, aft), typing = try Inference.infer_with_state result with Inference.Ill_typed_script error -> Format.eprintf "%a@." Inference.pp_inference_error error ; Format.eprintf "%a@." Mikhailsky.pp result ; assert false in - let (bef, typing) = instantiate_and_set_stack bef typing in - let (aft, typing) = instantiate_and_set_stack aft typing in + let bef, typing = instantiate_and_set_stack bef typing in + let aft, typing = instantiate_and_set_stack aft typing in (result, (bef, aft), typing) end diff --git a/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/inference.ml b/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/inference.ml index 72dc6c1ef4be..88ba95c8db0f 100644 --- a/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/inference.ml +++ b/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/inference.ml @@ -48,10 +48,10 @@ let pp_comparability fmtr (cmp : comparability) = let sup_comparability (c1 : comparability) (c2 : comparability) = match (c1, c2) with - | (Unconstrained, c) | (c, Unconstrained) -> Some c - | (Comparable, Comparable) -> Some Comparable - | (Not_comparable, Not_comparable) -> Some Not_comparable - | (Comparable, Not_comparable) | (Not_comparable, Comparable) -> None + | Unconstrained, c | c, Unconstrained -> Some c + | Comparable, Comparable -> Some Comparable + | Not_comparable, Not_comparable -> Some Not_comparable + | Comparable, Not_comparable | Not_comparable, Comparable -> None type michelson_type = | Base_type of {repr : Type.Base.t option; comparable : comparability} @@ -247,7 +247,7 @@ module M = struct } let ( >>= ) m f s = - let (x, s) = m s in + let x, s = m s in f x s [@@inline] @@ -257,25 +257,25 @@ module M = struct let uf_lift : 'a UF.M.t -> 'a t = fun computation state -> - let (res, uf) = computation state.uf in + let res, uf = computation state.uf in (res, {state with uf}) [@@inline] let repr_lift : 'a Repr_sm.t -> 'a t = fun computation state -> - let (res, repr) = computation state.repr in + let res, repr = computation state.repr in (res, {state with repr}) [@@inline] let annot_instr_lift : 'a Annot_instr_sm.t -> 'a t = fun computation state -> - let (res, annot_instr) = computation state.annot_instr in + let res, annot_instr = computation state.annot_instr in (res, {state with annot_instr}) [@@inline] let annot_data_lift : 'a Annot_data_sm.t -> 'a t = fun computation state -> - let (res, annot_data) = computation state.annot_data in + let res, annot_data = computation state.annot_data in (res, {state with annot_data}) [@@inline] @@ -380,17 +380,17 @@ let rec unify (x : Type.Stack.t) (y : Type.Stack.t) : unit M.t = if x.tag = y.tag then return () else match (x.node, y.node) with - | (Empty_t, Empty_t) -> return () - | (Stack_var_t x, Stack_var_t y) -> + | Empty_t, Empty_t -> return () + | Stack_var_t x, Stack_var_t y -> M.uf_lift (UF.find x) >>= fun root_x -> M.uf_lift (UF.find y) >>= fun root_y -> get_repr_exn root_x >>= fun repr_x -> get_repr_exn root_y >>= fun repr_y -> M.uf_lift (UF.union x y) >>= fun root -> merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | (Stack_var_t v, _) -> unify_single_stack v y - | (_, Stack_var_t v) -> unify_single_stack v x - | (Item_t (ty1, tail1), Item_t (ty2, tail2)) -> + | Stack_var_t v, _ -> unify_single_stack v y + | _, Stack_var_t v -> unify_single_stack v x + | Item_t (ty1, tail1), Item_t (ty2, tail2) -> unify_base ty1 ty2 >>= fun () -> unify tail1 tail2 >>= fun () -> return () | _ -> raise (Ill_typed_script (Stack_types_incompatible (x, y))) @@ -412,37 +412,37 @@ and unify_base (x : Type.Base.t) (y : Type.Base.t) : unit M.t = if x.tag = y.tag then return () else match (x.node, y.node) with - | (Unit_t, Unit_t) - | (Int_t, Int_t) - | (Nat_t, Nat_t) - | (Bool_t, Bool_t) - | (String_t, String_t) - | (Bytes_t, Bytes_t) - | (Key_hash_t, Key_hash_t) - | (Timestamp_t, Timestamp_t) - | (Mutez_t, Mutez_t) - | (Key_t, Key_t) -> + | Unit_t, Unit_t + | Int_t, Int_t + | Nat_t, Nat_t + | Bool_t, Bool_t + | String_t, String_t + | Bytes_t, Bytes_t + | Key_hash_t, Key_hash_t + | Timestamp_t, Timestamp_t + | Mutez_t, Mutez_t + | Key_t, Key_t -> return () - | (Option_t x, Option_t y) -> unify_base x y - | (List_t x, List_t y) -> unify_base x y - | (Set_t x, Set_t y) -> unify_base x y - | (Map_t (kx, vx), Map_t (ky, vy)) -> + | Option_t x, Option_t y -> unify_base x y + | List_t x, List_t y -> unify_base x y + | Set_t x, Set_t y -> unify_base x y + | Map_t (kx, vx), Map_t (ky, vy) -> unify_base kx ky >>= fun () -> unify_base vx vy - | (Pair_t (x, x'), Pair_t (y, y')) -> + | Pair_t (x, x'), Pair_t (y, y') -> unify_base x y >>= fun () -> unify_base x' y' - | (Union_t (x, x'), Union_t (y, y')) -> + | Union_t (x, x'), Union_t (y, y') -> unify_base x y >>= fun () -> unify_base x' y' - | (Lambda_t (x, x'), Lambda_t (y, y')) -> + | Lambda_t (x, x'), Lambda_t (y, y') -> unify_base x y >>= fun () -> unify_base x' y' - | (Var_t x, Var_t y) -> + | Var_t x, Var_t y -> M.uf_lift (UF.find x) >>= fun root_x -> M.uf_lift (UF.find y) >>= fun root_y -> get_repr_exn root_x >>= fun repr_x -> get_repr_exn root_y >>= fun repr_y -> M.uf_lift (UF.union x y) >>= fun root -> merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | (Var_t v, _) -> unify_single_var v y - | (_, Var_t v) -> unify_single_var v x + | Var_t v, _ -> unify_single_var v y + | _, Var_t v -> unify_single_var v x | _ -> instantiate_base x >>= fun x -> instantiate_base y >>= fun y -> @@ -452,11 +452,11 @@ and merge_reprs (repr1 : michelson_type) (repr2 : michelson_type) : michelson_type M.t = let open M in match (repr1, repr2) with - | ((Stack_type None as repr), Stack_type None) - | ((Stack_type (Some _) as repr), Stack_type None) - | (Stack_type None, (Stack_type (Some _) as repr)) -> + | (Stack_type None as repr), Stack_type None + | (Stack_type (Some _) as repr), Stack_type None + | Stack_type None, (Stack_type (Some _) as repr) -> return repr - | ((Stack_type (Some sty1) as repr), Stack_type (Some sty2)) -> + | (Stack_type (Some sty1) as repr), Stack_type (Some sty2) -> unify sty1 sty2 >>= fun () -> return repr | ( Base_type {repr = opt1; comparable = cmp1}, Base_type {repr = opt2; comparable = cmp2} ) -> ( @@ -469,14 +469,14 @@ and merge_reprs (repr1 : michelson_type) (repr2 : michelson_type) : (Comparability_error_types (repr1, repr2)))) | Some comparable -> ( match (opt1, opt2) with - | (None, None) -> return (Base_type {repr = None; comparable}) - | ((Some ty as repr), None) -> + | None, None -> return (Base_type {repr = None; comparable}) + | (Some ty as repr), None -> assert_comparability comparable ty >>= fun () -> return (Base_type {repr; comparable}) - | (None, (Some ty as repr)) -> + | None, (Some ty as repr) -> assert_comparability comparable ty >>= fun () -> return (Base_type {repr; comparable}) - | (Some ty1, Some ty2) -> + | Some ty1, Some ty2 -> unify_base ty1 ty2 >>= fun () -> assert_comparability comparable ty1 >>= fun () -> assert_comparability comparable ty2 >>= fun () -> @@ -555,7 +555,7 @@ and get_comparability (ty : Type.Base.t) : comparability M.t = get_comparability lt >>= fun lc -> get_comparability rt >>= fun rc -> match (lc, rc) with - | (Comparable, Comparable) -> return Comparable + | Comparable, Comparable -> return Comparable | _ -> return Unconstrained) let fresh = @@ -601,35 +601,35 @@ let parse_uint30 n : int = let arith_type (instr : Mikhailsky_prim.prim) (ty1 : Type.Base.t) (ty2 : Type.Base.t) : Type.Base.t option = match (instr, ty1.node, ty2.node) with - | ((I_ADD | I_MUL), Int_t, Int_t) - | ((I_ADD | I_MUL), Int_t, Nat_t) - | ((I_ADD | I_MUL), Nat_t, Int_t) -> + | (I_ADD | I_MUL), Int_t, Int_t + | (I_ADD | I_MUL), Int_t, Nat_t + | (I_ADD | I_MUL), Nat_t, Int_t -> Some Type.int - | ((I_ADD | I_MUL), Nat_t, Nat_t) -> Some Type.nat - | (I_SUB, Int_t, Int_t) - | (I_SUB, Int_t, Nat_t) - | (I_SUB, Nat_t, Int_t) - | (I_SUB, Nat_t, Nat_t) - | (I_SUB, Timestamp_t, Timestamp_t) -> + | (I_ADD | I_MUL), Nat_t, Nat_t -> Some Type.nat + | I_SUB, Int_t, Int_t + | I_SUB, Int_t, Nat_t + | I_SUB, Nat_t, Int_t + | I_SUB, Nat_t, Nat_t + | I_SUB, Timestamp_t, Timestamp_t -> Some Type.int - | (I_EDIV, Int_t, Int_t) - | (I_EDIV, Int_t, Nat_t) - | (I_EDIV, Nat_t, Int_t) - | (I_EDIV, Nat_t, Nat_t) -> + | I_EDIV, Int_t, Int_t + | I_EDIV, Int_t, Nat_t + | I_EDIV, Nat_t, Int_t + | I_EDIV, Nat_t, Nat_t -> Some Type.(option (pair nat nat)) (* Timestamp *) - | (I_ADD, Timestamp_t, Int_t) - | (I_ADD, Int_t, Timestamp_t) - | (I_SUB, Timestamp_t, Int_t) -> + | I_ADD, Timestamp_t, Int_t + | I_ADD, Int_t, Timestamp_t + | I_SUB, Timestamp_t, Int_t -> Some Type.timestamp (* Mutez *) - | (I_ADD, Mutez_t, Mutez_t) - | (I_SUB, Mutez_t, Mutez_t) - | (I_MUL, Mutez_t, Nat_t) - | (I_MUL, Nat_t, Mutez_t) -> + | I_ADD, Mutez_t, Mutez_t + | I_SUB, Mutez_t, Mutez_t + | I_MUL, Mutez_t, Nat_t + | I_MUL, Nat_t, Mutez_t -> Some Type.mutez - | (I_EDIV, Mutez_t, Nat_t) -> Some Type.(option (pair mutez mutez)) - | (I_EDIV, Mutez_t, Mutez_t) -> Some Type.(option (pair nat mutez)) + | I_EDIV, Mutez_t, Nat_t -> Some Type.(option (pair mutez mutez)) + | I_EDIV, Mutez_t, Mutez_t -> Some Type.(option (pair nat mutez)) | _ -> None let rec generate_constraints (path : Mikhailsky.Path.t) (node : Mikhailsky.node) diff --git a/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/monads.ml b/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/monads.ml index d0939011cb5e..47273406af50 100644 --- a/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/monads.ml +++ b/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/monads.ml @@ -65,7 +65,7 @@ module Make_state_monad (X : Stores.S) : type 'a t = state -> 'a * state let ( >>= ) m f s = - let (x, s) = m s in + let x, s = m s in f x s let return x s = (x, s) diff --git a/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml b/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml index 93aa25022308..4b702dd05667 100644 --- a/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml +++ b/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml @@ -50,7 +50,7 @@ module Test1 = struct let program = seq [add_ii; push bool_ty false_; dip instr_hole; dip swap] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -121,7 +121,7 @@ module Test3 = struct module Rewriter = Rewrite.Make (Mikhailsky.Mikhailsky_signature) (Lang) (Path) (Patt) - let (timing, ((bef, aft), state)) = + let timing, ((bef, aft), state) = try time @@ fun () -> Inference.infer_with_state program with Inference.Ill_typed_script error -> let s = Mikhailsky.to_string program in @@ -195,7 +195,7 @@ module Test4 = struct update_set; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -224,7 +224,7 @@ module Test5 = struct update_map; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -253,7 +253,7 @@ module Test5 = struct ]); ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -325,7 +325,7 @@ module Test7 = struct left; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -370,7 +370,7 @@ module Test8 = struct push_int; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -388,7 +388,7 @@ module Test9 = struct let program = seq [car; if_none hole hole] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -406,7 +406,7 @@ module Test10 = struct let program = seq [hash_key] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -425,7 +425,7 @@ module Test11 = struct let program = seq [lambda [dup; car; dip cdr; add_in]; push_int; apply; push_nat; exec] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -443,7 +443,7 @@ module Test12 = struct let program = seq [dup; dup; if_none hole (seq [drop]); dup; compare] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -462,7 +462,7 @@ module Test13 = struct let program = seq [push Type.(unparse_ty_exn (lambda int int)) (Data.lambda [])] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -480,7 +480,7 @@ module Test14 = struct let program = seq [nil; push_int; cons] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -498,7 +498,7 @@ module Test15 = struct let program = seq [empty_set; size_set; empty_map; size_map; nil; size_list] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -524,7 +524,7 @@ module Test16 = struct iter_set [dup; add_ii; add_ii]; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -559,7 +559,7 @@ module Test17 = struct ]; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -601,7 +601,7 @@ module Test18 = struct (seq [drop; drop; push (option_ty (list_ty bool_ty)) Data.none]); ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; diff --git a/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/type.ml b/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/type.ml index dacd2ac7f8fd..5f66f6ff5e7d 100644 --- a/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/type.ml +++ b/src/proto_012_Psithaca/lib_benchmark/lib_benchmark_type_inference/type.ml @@ -55,27 +55,26 @@ module Base = struct let equal (t1 : t) (t2 : t) = match (t1, t2) with - | (Var_t v1, Var_t v2) -> v1 = v2 - | (Unit_t, Unit_t) - | (Int_t, Int_t) - | (Nat_t, Nat_t) - | (Bool_t, Bool_t) - | (String_t, String_t) - | (Bytes_t, Bytes_t) - | (Key_hash_t, Key_hash_t) - | (Timestamp_t, Timestamp_t) - | (Mutez_t, Mutez_t) - | (Key_t, Key_t) -> + | Var_t v1, Var_t v2 -> v1 = v2 + | Unit_t, Unit_t + | Int_t, Int_t + | Nat_t, Nat_t + | Bool_t, Bool_t + | String_t, String_t + | Bytes_t, Bytes_t + | Key_hash_t, Key_hash_t + | Timestamp_t, Timestamp_t + | Mutez_t, Mutez_t + | Key_t, Key_t -> true - | (Option_t ty1, Option_t ty2) -> ty1.tag = ty2.tag - | (Pair_t (l1, r1), Pair_t (l2, r2)) -> l1.tag = l2.tag && r1.tag = r2.tag - | (Union_t (l1, r1), Union_t (l2, r2)) -> - l1.tag = l2.tag && r1.tag = r2.tag - | (List_t ty1, List_t ty2) -> ty1.tag = ty2.tag - | (Set_t ty1, Set_t ty2) -> ty1.tag = ty2.tag - | (Map_t (kty1, vty1), Map_t (kty2, vty2)) -> + | Option_t ty1, Option_t ty2 -> ty1.tag = ty2.tag + | Pair_t (l1, r1), Pair_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag + | Union_t (l1, r1), Union_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag + | List_t ty1, List_t ty2 -> ty1.tag = ty2.tag + | Set_t ty1, Set_t ty2 -> ty1.tag = ty2.tag + | Map_t (kty1, vty1), Map_t (kty2, vty2) -> kty1.tag = kty2.tag && vty1.tag = vty2.tag - | (Lambda_t (dom1, range1), Lambda_t (dom2, range2)) -> + | Lambda_t (dom1, range1), Lambda_t (dom2, range2) -> dom1.tag = dom2.tag && range1.tag = range2.tag | _ -> false @@ -132,9 +131,9 @@ module Stack = struct let equal (t1 : t) (t2 : t) = match (t1, t2) with - | (Empty_t, Empty_t) -> true - | (Stack_var_t v1, Stack_var_t v2) -> v1 = v2 - | (Item_t (h1, tl1), Item_t (h2, tl2)) -> h1 == h2 && tl1 == tl2 + | Empty_t, Empty_t -> true + | Stack_var_t v1, Stack_var_t v2 -> v1 = v2 + | Item_t (h1, tl1), Item_t (h2, tl2) -> h1 == h2 && tl1 == tl2 | _ -> false let hash (t : t) = Hashtbl.hash t diff --git a/src/proto_012_Psithaca/lib_benchmark/michelson_mcmc_samplers.ml b/src/proto_012_Psithaca/lib_benchmark/michelson_mcmc_samplers.ml index 5926dc38fe01..7dc0f4edd716 100644 --- a/src/proto_012_Psithaca/lib_benchmark/michelson_mcmc_samplers.ml +++ b/src/proto_012_Psithaca/lib_benchmark/michelson_mcmc_samplers.ml @@ -248,7 +248,7 @@ struct let to_michelson {state = ({typing; term} : State_space.t); jump = _} = let typing = Lazy.force typing in - let (node, (bef, aft), state) = + let node, (bef, aft), state = Autocomp.complete_code typing term X.rng_state in let node = @@ -316,8 +316,8 @@ struct let to_michelson {state = ({typing; term} : State_space.t); jump = _} = let typing = Lazy.force typing in - let (node, _) = Autocomp.complete_data typing term X.rng_state in - let (typ, state) = + let node, _ = Autocomp.complete_data typing term X.rng_state in + let typ, state = try Inference.infer_data_with_state node with _ -> Format.eprintf "Bug found!@." ; diff --git a/src/proto_012_Psithaca/lib_benchmark/michelson_samplers.ml b/src/proto_012_Psithaca/lib_benchmark/michelson_samplers.ml index 1b218c41ee26..b763bffe9d2c 100644 --- a/src/proto_012_Psithaca/lib_benchmark/michelson_samplers.ml +++ b/src/proto_012_Psithaca/lib_benchmark/michelson_samplers.ml @@ -366,7 +366,7 @@ end) else bind (uniform all_non_atomic_type_names) @@ function | `TPair -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_ty left) = m_type ~size:lsize in let* (Ex_ty right) = m_type ~size:rsize in match @@ -375,14 +375,14 @@ end) | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TLambda -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_ty domain) = m_type ~size:lsize in let* (Ex_ty range) = m_type ~size:rsize in match lambda_t (-1) domain range ~annot:None with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TUnion -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_ty left) = m_type ~size:lsize in let* (Ex_ty right) = m_type ~size:rsize in match union_t (-1) (left, None) (right, None) ~annot:None with @@ -394,7 +394,7 @@ end) | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TMap -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_comparable_ty key) = m_comparable_type ~size:lsize in let* (Ex_ty elt) = m_type ~size:rsize in match map_t (-1) key elt ~annot:None with @@ -576,7 +576,7 @@ end) elt Script_typed_ir.ty -> elt Script_typed_ir.boxed_list sampler = fun elt_type -> let open M in - let* (length, elements) = + let* length, elements = Structure_samplers.list ~range:P.parameters.list_size ~sampler:(value elt_type) @@ -591,7 +591,7 @@ end) fun elt_ty -> let open M in let ety = comparable_downcast elt_ty in - let* (_, elements) = + let* _, elements = Structure_samplers.list ~range:P.parameters.set_size ~sampler:(value ety) diff --git a/src/proto_012_Psithaca/lib_benchmark/mikhailsky_to_michelson.ml b/src/proto_012_Psithaca/lib_benchmark/mikhailsky_to_michelson.ml index dbe7dd24789f..89741cd4ca0a 100644 --- a/src/proto_012_Psithaca/lib_benchmark/mikhailsky_to_michelson.ml +++ b/src/proto_012_Psithaca/lib_benchmark/mikhailsky_to_michelson.ml @@ -107,7 +107,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (_, r) = project_union aft in + let _, r = project_union aft in Inference.instantiate_base r >>= fun r -> Autocomp.replace_vars r >>= fun r -> let r = unparse_type r in @@ -119,7 +119,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (l, _) = project_union aft in + let l, _ = project_union aft in Inference.instantiate_base l >>= fun l -> Autocomp.replace_vars l >>= fun l -> let l = unparse_type l in @@ -135,7 +135,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (dom, range) = project_lambda aft in + let dom, range = project_lambda aft in Inference.instantiate_base dom >>= fun dom -> Autocomp.replace_vars dom >>= fun dom -> Inference.instantiate_base range >>= fun range -> @@ -165,7 +165,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (k, v) = project_map aft in + let k, v = project_map aft in Inference.instantiate_base k >>= fun k -> Autocomp.replace_vars k >>= fun k -> Inference.instantiate_base v >>= fun v -> diff --git a/src/proto_012_Psithaca/lib_benchmark/rules.ml b/src/proto_012_Psithaca/lib_benchmark/rules.ml index ff66cf05c7c4..5d14fe0c52c7 100644 --- a/src/proto_012_Psithaca/lib_benchmark/rules.ml +++ b/src/proto_012_Psithaca/lib_benchmark/rules.ml @@ -673,7 +673,7 @@ struct (* rules *) (* fresh type variables *) - let (alpha, beta) = (-1, -2) + let alpha, beta = (-1, -2) let replacement ~fresh ~typ ~replacement = { diff --git a/src/proto_012_Psithaca/lib_benchmark/test/test_autocompletion.ml b/src/proto_012_Psithaca/lib_benchmark/test/test_autocompletion.ml index 5d5d65fdee01..c2f3e6c74295 100644 --- a/src/proto_012_Psithaca/lib_benchmark/test/test_autocompletion.ml +++ b/src/proto_012_Psithaca/lib_benchmark/test/test_autocompletion.ml @@ -50,7 +50,7 @@ let () = Format.eprintf "Testing dummy program generator@.%!" let run x = x rng_state (Inference.M.empty ()) let invent_term bef aft = - let (term, _state) = run (Autocomp.invent_term bef aft) in + let term, _state = run (Autocomp.invent_term bef aft) in Mikhailsky.seq term let invent_term bef aft = @@ -61,7 +61,7 @@ let invent_term bef aft = Type.Stack.pp aft ; let term = invent_term bef aft in - let (bef', aft') = Inference.infer term in + let bef', aft' = Inference.infer term in Format.eprintf "generated type: %a => %a@." Type.Stack.pp @@ -88,9 +88,9 @@ let () = Format.eprintf "Testing completion@.%!" let complete term = Format.eprintf "term: %a@." Mikhailsky.pp term ; - let ((bef, aft), state) = Inference.infer_with_state term in + let (bef, aft), state = Inference.infer_with_state term in Format.eprintf "Inferred type: %a => %a@." Type.Stack.pp bef Type.Stack.pp aft ; - let (term, (bef', aft'), _state) = + let term, (bef', aft'), _state = Autocomp.complete_code state term rng_state in Format.eprintf "completed: %a@." Mikhailsky.pp term ; diff --git a/src/proto_012_Psithaca/lib_benchmarks_proto/cache_benchmarks.ml b/src/proto_012_Psithaca/lib_benchmarks_proto/cache_benchmarks.ml index a80889bcbe88..875d80b6897a 100644 --- a/src/proto_012_Psithaca/lib_benchmarks_proto/cache_benchmarks.ml +++ b/src/proto_012_Psithaca/lib_benchmarks_proto/cache_benchmarks.ml @@ -51,15 +51,15 @@ let throwaway_context = let dummy_script : Cache.cached_contract = let str = "{ parameter unit; storage unit; code FAILWITH }" in let storage = - let (parsed, _) = Michelson_v1_parser.parse_expression "Unit" in + let parsed, _ = Michelson_v1_parser.parse_expression "Unit" in Alpha_context.Script.lazy_expr parsed.expanded in let code = - let (parsed, _) = Michelson_v1_parser.parse_expression ~check:false str in + let parsed, _ = Michelson_v1_parser.parse_expression ~check:false str in Alpha_context.Script.lazy_expr parsed.expanded in let script = Alpha_context.Script.{code; storage} in - let (ex_script, _) = + let ex_script, _ = Script_ir_translator.parse_script throwaway_context ~legacy:true @@ -96,7 +96,7 @@ end (* We can't produce a Script_cache.identifier without calling [Script_cache.find]. *) let identifier_of_contract (c : Alpha_context.Contract.t) : Cache.identifier = - let (_, id, _) = Cache.find throwaway_context c |> assert_ok_lwt in + let _, id, _ = Cache.find throwaway_context c |> assert_ok_lwt in id let contract_of_int i : Alpha_context.Contract.t = @@ -185,7 +185,7 @@ module Cache_update_benchmark : Benchmark.S = struct let cache_cardinal = Base_samplers.sample_in_interval ~range:{min = 1; max = 100_000} rng_state in - let (ctxt, some_key_in_domain) = prepare_context rng_state cache_cardinal in + let ctxt, some_key_in_domain = prepare_context rng_state cache_cardinal in cache_update_benchmark ctxt some_key_in_domain cache_cardinal let create_benchmarks ~rng_state ~bench_num config = diff --git a/src/proto_012_Psithaca/lib_benchmarks_proto/encodings_benchmarks.ml b/src/proto_012_Psithaca/lib_benchmarks_proto/encodings_benchmarks.ml index 762b9e2a6be7..711a60f0d1b5 100644 --- a/src/proto_012_Psithaca/lib_benchmarks_proto/encodings_benchmarks.ml +++ b/src/proto_012_Psithaca/lib_benchmarks_proto/encodings_benchmarks.ml @@ -381,7 +381,7 @@ module Timelock = struct let plaintext_size = Base_samplers.sample_in_interval ~range:{min = 1; max = 10000} rng_state in - let (chest, chest_key) = + let chest, chest_key = Timelock.chest_sampler ~plaintext_size ~time ~rng_state in ((chest, chest_key), plaintext_size) @@ -392,7 +392,7 @@ module Timelock = struct ~name:"ENCODING_Chest" ~to_string:(Data_encoding.Binary.to_string_exn Timelock.chest_encoding) ~generator:(fun rng_state -> - let ((chest, _), plaintext_size) = generator rng_state in + let (chest, _), plaintext_size = generator rng_state in (chest, {bytes = plaintext_size})) let () = @@ -402,7 +402,7 @@ module Timelock = struct ~to_string: (Data_encoding.Binary.to_string_exn Timelock.chest_key_encoding) ~generator:(fun rng_state -> - let ((_, chest_key), _w) = generator rng_state in + let (_, chest_key), _w = generator rng_state in chest_key) let () = @@ -412,7 +412,7 @@ module Timelock = struct ~to_bytes:(Data_encoding.Binary.to_bytes_exn Timelock.chest_encoding) ~from_bytes:(Data_encoding.Binary.of_bytes_exn Timelock.chest_encoding) ~generator:(fun rng_state -> - let ((chest, _), _) = generator rng_state in + let (chest, _), _ = generator rng_state in let b = Data_encoding.Binary.to_bytes_exn Timelock.chest_encoding chest in @@ -427,6 +427,6 @@ module Timelock = struct ~from_bytes: (Data_encoding.Binary.of_bytes_exn Timelock.chest_key_encoding) ~generator:(fun rng_state -> - let ((_, chest_key), _w) = generator rng_state in + let (_, chest_key), _w = generator rng_state in chest_key) end diff --git a/src/proto_012_Psithaca/lib_benchmarks_proto/global_constants_storage_benchmarks.ml b/src/proto_012_Psithaca/lib_benchmarks_proto/global_constants_storage_benchmarks.ml index bb8fc4e2c898..e622e9f49072 100644 --- a/src/proto_012_Psithaca/lib_benchmarks_proto/global_constants_storage_benchmarks.ml +++ b/src/proto_012_Psithaca/lib_benchmarks_proto/global_constants_storage_benchmarks.ml @@ -612,8 +612,8 @@ module Global_constants_storage_expand_models = struct let size = (Micheline_sampler.micheline_size node).nodes in let registered_constant = Int (-1, Z.of_int 1) in let hash = registered_constant |> node_to_hash in - let (context, _) = Execution_context.make ~rng_state |> assert_ok_lwt in - let (context, _, _) = + let context, _ = Execution_context.make ~rng_state |> assert_ok_lwt in + let context, _, _ = Alpha_context.Global_constants_storage.register context (strip_locations registered_constant) @@ -700,7 +700,7 @@ module Global_constants_storage_expand_models = struct let open Micheline in let node = Micheline_sampler.sample rng_state in let size = (Micheline_sampler.micheline_size node).nodes in - let (context, _) = Execution_context.make ~rng_state |> assert_ok_lwt in + let context, _ = Execution_context.make ~rng_state |> assert_ok_lwt in let expr = strip_locations node in let closure () = ignore diff --git a/src/proto_012_Psithaca/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_012_Psithaca/lib_benchmarks_proto/interpreter_benchmarks.ml index e09ebd6f243c..df9b11f54315 100644 --- a/src/proto_012_Psithaca/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_012_Psithaca/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -169,8 +169,8 @@ let benchmark_from_kinstr_and_stack : fun ?amplification ctxt step_constants stack_kinstr -> let ctxt = Gas_helpers.set_limit ctxt in match stack_kinstr with - | Ex_stack_and_kinstr {stack = (bef_top, bef); kinstr} -> - let (workload, closure) = + | Ex_stack_and_kinstr {stack = bef_top, bef; kinstr} -> + let workload, closure = match amplification with | None -> let workload = @@ -255,7 +255,7 @@ let make_benchmark : ?amplification (if intercept then None else Some (Instr_name name)) - let (info, name) = + let info, name = info_and_name ~intercept ?salt @@ -296,7 +296,7 @@ let make_simple_benchmark : let kinfo = Script_typed_ir.kinfo_of_kinstr kinstr in let stack_ty = kinfo.kstack_ty in let kinstr_and_stack_sampler config rng_state = - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -418,8 +418,8 @@ let benchmark_from_continuation : fun ?amplification ctxt step_constants stack_cont -> let ctxt = Gas_helpers.set_limit ctxt in match stack_cont with - | Ex_stack_and_cont {stack = (bef_top, bef); cont} -> - let (workload, closure) = + | Ex_stack_and_cont {stack = bef_top, bef; cont} -> + let workload, closure = match amplification with | None -> let workload = @@ -507,7 +507,7 @@ let make_continuation_benchmark : ?amplification (if intercept then None else Some (Cont_name name)) - let (info, name) = + let info, name = info_and_name ~intercept ?salt @@ -552,7 +552,7 @@ let nat_of_positive_int (i : int) = match is_nat (of_int i) with None -> assert false | Some x -> x let adversarial_ints rng_state (cfg : Default_config.config) n = - let (_common_prefix, ls) = + let _common_prefix, ls = Base_samplers.Adversarial.integers ~prefix_size:cfg.sampler.base_parameters.int_size ~card:n @@ -1193,7 +1193,7 @@ module Registration_section = struct ~range:cfg.sampler.set_size in let elts = adversarial_ints rng_state cfg (n + 1) in - let (out_of_set, in_set) = + let out_of_set, in_set = match elts with [] -> assert false | hd :: tl -> (hd, tl) in let set = @@ -1316,7 +1316,7 @@ module Registration_section = struct (let map = Script_map.empty int_cmp in (Alpha_context.Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1336,7 +1336,7 @@ module Registration_section = struct (let map = Script_map.empty int_cmp in (Alpha_context.Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1356,7 +1356,7 @@ module Registration_section = struct (let map = Script_map.empty int_cmp in (Alpha_context.Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () @@ -1377,7 +1377,7 @@ module Registration_section = struct (let map = Script_map.empty int_cmp in (Alpha_context.Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () @@ -1458,7 +1458,7 @@ module Registration_section = struct ( kinfo (int @$ big_map int_cmp unit @$ unit @$ bot), halt (bool @$ unit @$ bot) )) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1478,7 +1478,7 @@ module Registration_section = struct (let map = Script_ir_translator.empty_big_map int_cmp unit in (Alpha_context.Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1498,7 +1498,7 @@ module Registration_section = struct (let map = Script_ir_translator.empty_big_map int_cmp unit in (Alpha_context.Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () @@ -1519,7 +1519,7 @@ module Registration_section = struct (let map = Script_ir_translator.empty_big_map int_cmp unit in (Alpha_context.Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () end @@ -1554,7 +1554,7 @@ module Registration_section = struct (let z = Alpha_context.Script_int.zero_n in (z, (z, (empty, eos)))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let string = Samplers.Random_value.value @@ -1602,7 +1602,7 @@ module Registration_section = struct (let z = Alpha_context.Script_int.zero_n in (z, (z, (Bytes.empty, eos)))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let bytes = Samplers.Random_value.value @@ -1676,7 +1676,7 @@ module Registration_section = struct ~kinstr: (ISub_tez (kinfo (mutez @$ mutez @$ bot), halt (option mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers cfg.Default_config.sampler in fun () -> @@ -1695,7 +1695,7 @@ module Registration_section = struct ~kinstr: (ISub_tez_legacy (kinfo (mutez @$ mutez @$ bot), halt (mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers cfg.Default_config.sampler in fun () -> @@ -1724,9 +1724,9 @@ module Registration_section = struct ~name:Interpreter_workload.N_IMul_teznat ~kinstr:(IMul_teznat (kinfo (mutez @$ nat @$ bot), halt (mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, samplers) = make_default_samplers cfg.sampler in + let _, samplers = make_default_samplers cfg.sampler in fun () -> - let (mutez, nat) = sample_tez_nat samplers rng_state in + let mutez, nat = sample_tez_nat samplers rng_state in (mutez, (nat, eos))) () @@ -1735,9 +1735,9 @@ module Registration_section = struct ~name:Interpreter_workload.N_IMul_nattez ~kinstr:(IMul_nattez (kinfo (nat @$ mutez @$ bot), halt (mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, samplers) = make_default_samplers cfg.sampler in + let _, samplers = make_default_samplers cfg.sampler in fun () -> - let (mutez, nat) = sample_tez_nat samplers rng_state in + let mutez, nat = sample_tez_nat samplers rng_state in (nat, (mutez, eos))) () @@ -1751,9 +1751,9 @@ module Registration_section = struct ( kinfo (mutez @$ nat @$ bot), halt (option (pair mutez mutez) @$ bot) )) ~stack_sampler:(fun cfg rng_state -> - let (_, samplers) = make_default_samplers cfg.sampler in + let _, samplers = make_default_samplers cfg.sampler in fun () -> - let (mutez, nat) = sample_tez_nat samplers rng_state in + let mutez, nat = sample_tez_nat samplers rng_state in (mutez, (nat, eos))) () @@ -1819,7 +1819,7 @@ module Registration_section = struct ~kinstr:(IAbs_int (kinfo (int @$ bot), halt (nat @$ bot))) ~intercept_stack:(zero, eos) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let x = Samplers.Michelson_base.nat rng_state in let neg_x = Alpha_context.Script_int.neg x in @@ -1892,7 +1892,7 @@ module Registration_section = struct ~intercept_stack:(zero_n, (zero_n, eos)) ~kinstr:(ILsl_nat (kinfo (nat @$ nat @$ bot), halt (nat @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let x = Samplers.Michelson_base.nat rng_state in (* shift must be in [0;256]: 1 byte max *) @@ -1908,7 +1908,7 @@ module Registration_section = struct ~intercept_stack:(zero_n, (zero_n, eos)) ~kinstr:(ILsr_nat (kinfo (nat @$ nat @$ bot), halt (nat @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let x = Samplers.Michelson_base.nat rng_state in (* shift must be in [0;256]: 1 byte max *) @@ -2086,7 +2086,7 @@ module Registration_section = struct benchmark ~name:Interpreter_workload.N_ICompare ~kinstr_and_stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let size = Base_samplers.sample_in_interval @@ -2271,11 +2271,11 @@ module Registration_section = struct ( kinfo (public_key @$ signature @$ bytes @$ bot), halt (bool @$ bot) )) ~stack_sampler:(fun cfg rng_state -> - let ((module Crypto_samplers), (module Samplers)) = + let (module Crypto_samplers), (module Samplers) = make_default_samplers ~algo:(`Algo algo) cfg.Default_config.sampler in fun () -> - let (_pkh, pk, sk) = Crypto_samplers.all rng_state in + let _pkh, pk, sk = Crypto_samplers.all rng_state in let unsigned_message = if for_intercept then Environment.Bytes.empty else @@ -2443,7 +2443,7 @@ module Registration_section = struct | Error _ -> assert false | Ok sz -> sz in - let (info, name) = + let info, name = info_and_name ~intercept:false "ISapling_verify_update" in let module B : Benchmark.S = struct @@ -2515,7 +2515,7 @@ module Registration_section = struct in List.map (fun (_, transition) () -> - let (ctxt, state, step_constants) = + let ctxt, state, step_constants = prepare_sapling_execution_environment seed transition in let stack_instr = @@ -2605,7 +2605,7 @@ module Registration_section = struct (IMul_bls12_381_z_fr (kinfo (bls12_381_fr @$ int @$ bot), halt (bls12_381_fr @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in let fr_sampler = Samplers.Random_value.value bls12_381_fr in let zero = Alpha_context.Script_int.zero in fun () -> (fr_sampler rng_state, (zero, eos))) @@ -2627,7 +2627,7 @@ module Registration_section = struct (IMul_bls12_381_fr_z (kinfo (int @$ bls12_381_fr @$ bot), halt (bls12_381_fr @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in let fr_sampler = Samplers.Random_value.value bls12_381_fr in let zero = Alpha_context.Script_int.zero in fun () -> (zero, (fr_sampler rng_state, eos))) @@ -2718,7 +2718,7 @@ module Registration_section = struct benchmark ~name:Interpreter_workload.N_ISplit_ticket ~kinstr_and_stack_sampler:(fun config rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -2748,7 +2748,7 @@ module Registration_section = struct ~intercept:true ~name:Interpreter_workload.N_IJoin_tickets ~kinstr_and_stack_sampler:(fun config rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -2770,7 +2770,7 @@ module Registration_section = struct benchmark ~name:Interpreter_workload.N_IJoin_tickets ~kinstr_and_stack_sampler:(fun config rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -2806,7 +2806,7 @@ module Registration_section = struct ~name ~kinstr ~stack_sampler:(fun _ rng_state () -> - let (chest, chest_key) = + let chest, chest_key = Timelock.chest_sampler ~plaintext_size:1 ~time:0 ~rng_state in resulting_stack chest chest_key 0) @@ -2829,7 +2829,7 @@ module Registration_section = struct rng_state in - let (chest, chest_key) = + let chest, chest_key = Timelock.chest_sampler ~plaintext_size ~time ~rng_state in resulting_stack chest chest_key time) @@ -3021,7 +3021,7 @@ module Registration_section = struct ~name:Interpreter_workload.N_KList_enter_body ~salt:"_terminal" ~cont_and_stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in let kbody = halt_unitunit in fun () -> let ys = Samplers.Random_value.value (list unit) rng_state in @@ -3121,7 +3121,7 @@ module Registration_section = struct ICdr (kinfo (pair int unit @$ unit @$ bot), halt_unitunit) in fun () -> - let (key, map) = Maps.generate_map_and_key_in_map cfg rng_state in + let key, map = Maps.generate_map_and_key_in_map cfg rng_state in let cont = KMap_exit_body (kbody, [], map, key, KNil) in Ex_stack_and_cont {stack = ((), ((), eos)); cont}) () diff --git a/src/proto_012_Psithaca/lib_benchmarks_proto/interpreter_workload.ml b/src/proto_012_Psithaca/lib_benchmarks_proto/interpreter_workload.ml index 7f48a5271d5b..26fc4889d435 100644 --- a/src/proto_012_Psithaca/lib_benchmarks_proto/interpreter_workload.ml +++ b/src/proto_012_Psithaca/lib_benchmarks_proto/interpreter_workload.ml @@ -1141,7 +1141,7 @@ let rec size_of_comparable_value : type a. a comparable_ty -> a -> Size.t = | Timestamp_key _ -> Size.timestamp v | Address_key _ -> Size.address v | Pair_key ((leaf, _), (node, _), _) -> - let (lv, rv) = v in + let lv, rv = v in let size = Size.add (size_of_comparable_value leaf lv) @@ -1179,69 +1179,69 @@ let extract_ir_sized_step : fun ctxt instr stack -> let open Script_typed_ir in match (instr, stack) with - | (IDrop (_, _), _) -> Instructions.drop - | (IDup (_, _), _) -> Instructions.dup - | (ISwap (_, _), _) -> Instructions.swap - | (IConst (_, _, _), _) -> Instructions.const - | (ICons_pair (_, _), _) -> Instructions.cons_pair - | (ICar (_, _), _) -> Instructions.car - | (ICdr (_, _), _) -> Instructions.cdr - | (IUnpair (_, _), _) -> Instructions.unpair - | (ICons_some (_, _), _) -> Instructions.cons_some - | (ICons_none (_, _), _) -> Instructions.cons_none - | (IIf_none _, _) -> Instructions.if_none - | (IOpt_map _, _) -> Instructions.opt_map - | (ICons_left (_, _), _) -> Instructions.left - | (ICons_right (_, _), _) -> Instructions.right - | (IIf_left _, _) -> Instructions.if_left - | (ICons_list (_, _), _) -> Instructions.cons_list - | (INil (_, _), _) -> Instructions.nil - | (IIf_cons _, _) -> Instructions.if_cons - | (IList_iter (_, _, _), _) -> Instructions.list_iter - | (IList_map (_, _, _), _) -> Instructions.list_map - | (IList_size (_, _), (list, _)) -> Instructions.list_size (Size.list list) - | (IEmpty_set (_, _, _), _) -> Instructions.empty_set - | (ISet_iter _, (set, _)) -> Instructions.set_iter (Size.set set) - | (ISet_mem (_, _), (v, (set, _))) -> + | IDrop (_, _), _ -> Instructions.drop + | IDup (_, _), _ -> Instructions.dup + | ISwap (_, _), _ -> Instructions.swap + | IConst (_, _, _), _ -> Instructions.const + | ICons_pair (_, _), _ -> Instructions.cons_pair + | ICar (_, _), _ -> Instructions.car + | ICdr (_, _), _ -> Instructions.cdr + | IUnpair (_, _), _ -> Instructions.unpair + | ICons_some (_, _), _ -> Instructions.cons_some + | ICons_none (_, _), _ -> Instructions.cons_none + | IIf_none _, _ -> Instructions.if_none + | IOpt_map _, _ -> Instructions.opt_map + | ICons_left (_, _), _ -> Instructions.left + | ICons_right (_, _), _ -> Instructions.right + | IIf_left _, _ -> Instructions.if_left + | ICons_list (_, _), _ -> Instructions.cons_list + | INil (_, _), _ -> Instructions.nil + | IIf_cons _, _ -> Instructions.if_cons + | IList_iter (_, _, _), _ -> Instructions.list_iter + | IList_map (_, _, _), _ -> Instructions.list_map + | IList_size (_, _), (list, _) -> Instructions.list_size (Size.list list) + | IEmpty_set (_, _, _), _ -> Instructions.empty_set + | ISet_iter _, (set, _) -> Instructions.set_iter (Size.set set) + | ISet_mem (_, _), (v, (set, _)) -> let (module S) = set in let sz = size_of_comparable_value S.elt_ty v in Instructions.set_mem sz (Size.set set) - | (ISet_update (_, _), (v, (_flag, (set, _)))) -> + | ISet_update (_, _), (v, (_flag, (set, _))) -> let (module S) = set in let sz = size_of_comparable_value S.elt_ty v in Instructions.set_update sz (Size.set set) - | (ISet_size (_, _), (set, _)) -> Instructions.set_size (Size.set set) - | (IEmpty_map (_, _, _), _) -> Instructions.empty_map - | (IMap_map _, (map, _)) -> Instructions.map_map (Size.map map) - | (IMap_iter _, (map, _)) -> Instructions.map_iter (Size.map map) - | (IMap_mem (_, _), (v, (((module Map) as map), _))) -> + | ISet_size (_, _), (set, _) -> Instructions.set_size (Size.set set) + | IEmpty_map (_, _, _), _ -> Instructions.empty_map + | IMap_map _, (map, _) -> Instructions.map_map (Size.map map) + | IMap_iter _, (map, _) -> Instructions.map_iter (Size.map map) + | IMap_mem (_, _), (v, (((module Map) as map), _)) -> let key_size = size_of_comparable_value Map.key_ty v in Instructions.map_mem key_size (Size.map map) - | (IMap_get (_, _), (v, (((module Map) as map), _))) -> + | IMap_get (_, _), (v, (((module Map) as map), _)) -> let key_size = size_of_comparable_value Map.key_ty v in Instructions.map_get key_size (Size.map map) - | (IMap_update (_, _), (v, (_elt_opt, (((module Map) as map), _)))) -> + | IMap_update (_, _), (v, (_elt_opt, (((module Map) as map), _))) -> let key_size = size_of_comparable_value Map.key_ty v in Instructions.map_update key_size (Size.map map) - | (IMap_get_and_update (_, _), (v, (_elt_opt, (((module Map) as map), _)))) -> + | IMap_get_and_update (_, _), (v, (_elt_opt, (((module Map) as map), _))) -> let key_size = size_of_comparable_value Map.key_ty v in Instructions.map_get_and_update key_size (Size.map map) - | (IMap_size (_, _), (map, _)) -> Instructions.map_size (Size.map map) - | (IEmpty_big_map (_, _, _, _), _) -> Instructions.empty_big_map - | (IBig_map_mem (_, _), (v, ({diff = {size; _}; key_type; _}, _))) -> + | IMap_size (_, _), (map, _) -> Instructions.map_size (Size.map map) + | IEmpty_big_map (_, _, _, _), _ -> Instructions.empty_big_map + | IBig_map_mem (_, _), (v, ({diff = {size; _}; key_type; _}, _)) -> let key_size = size_of_comparable_value key_type v in Instructions.big_map_mem key_size size - | (IBig_map_get (_, _), (v, ({diff = {size; _}; key_type; _}, _))) -> + | IBig_map_get (_, _), (v, ({diff = {size; _}; key_type; _}, _)) -> let key_size = size_of_comparable_value key_type v in Instructions.big_map_get key_size size - | (IBig_map_update (_, _), (v, (_, ({diff = {size; _}; key_type; _}, _)))) -> + | IBig_map_update (_, _), (v, (_, ({diff = {size; _}; key_type; _}, _))) -> let key_size = size_of_comparable_value key_type v in Instructions.big_map_update key_size size | ( IBig_map_get_and_update (_, _), (v, (_, ({diff = {size; _}; key_type; _}, _))) ) -> let key_size = size_of_comparable_value key_type v in Instructions.big_map_get_and_update key_size size - | (IConcat_string (_, _), (ss, _)) -> + | IConcat_string (_, _), (ss, _) -> let list_size = Size.list ss in let total_bytes = List.fold_left @@ -1250,109 +1250,109 @@ let extract_ir_sized_step : ss.elements in Instructions.concat_string list_size total_bytes - | (IConcat_string_pair (_, _), (s1, (s2, _))) -> + | IConcat_string_pair (_, _), (s1, (s2, _)) -> Instructions.concat_string_pair (Size.script_string s1) (Size.script_string s2) - | (ISlice_string (_, _), (_off, (_len, (s, _)))) -> + | ISlice_string (_, _), (_off, (_len, (s, _))) -> Instructions.slice_string (Size.script_string s) - | (IString_size (_, _), (s, _)) -> + | IString_size (_, _), (s, _) -> Instructions.string_size (Size.script_string s) - | (IConcat_bytes (_, _), (ss, _)) -> + | IConcat_bytes (_, _), (ss, _) -> let list_size = Size.list ss in let total_bytes = List.fold_left (fun x s -> Size.(add x (bytes s))) Size.zero ss.elements in Instructions.concat_bytes list_size total_bytes - | (IConcat_bytes_pair (_, _), (s1, (s2, _))) -> + | IConcat_bytes_pair (_, _), (s1, (s2, _)) -> Instructions.concat_bytes_pair (Size.bytes s1) (Size.bytes s2) - | (ISlice_bytes (_, _), (_off, (_len, (s, _)))) -> + | ISlice_bytes (_, _), (_off, (_len, (s, _))) -> Instructions.slice_bytes (Size.bytes s) - | (IBytes_size (_, _), _) -> Instructions.bytes_size - | (IAdd_seconds_to_timestamp (_, _), (s, (t, _))) -> + | IBytes_size (_, _), _ -> Instructions.bytes_size + | IAdd_seconds_to_timestamp (_, _), (s, (t, _)) -> Instructions.add_seconds_to_timestamp (Size.timestamp t) (Size.integer s) - | (IAdd_timestamp_to_seconds (_, _), (t, (s, _))) -> + | IAdd_timestamp_to_seconds (_, _), (t, (s, _)) -> Instructions.add_timestamp_to_seconds (Size.timestamp t) (Size.integer s) - | (ISub_timestamp_seconds (_, _), (t, (s, _))) -> + | ISub_timestamp_seconds (_, _), (t, (s, _)) -> Instructions.sub_timestamp_seconds (Size.timestamp t) (Size.integer s) - | (IDiff_timestamps (_, _), (t1, (t2, _))) -> + | IDiff_timestamps (_, _), (t1, (t2, _)) -> Instructions.diff_timestamps (Size.timestamp t1) (Size.timestamp t2) - | (IAdd_tez (_, _), (x, (y, _))) -> + | IAdd_tez (_, _), (x, (y, _)) -> Instructions.add_tez (Size.mutez x) (Size.mutez y) - | (ISub_tez (_, _), (x, (y, _))) -> + | ISub_tez (_, _), (x, (y, _)) -> Instructions.sub_tez (Size.mutez x) (Size.mutez y) - | (ISub_tez_legacy (_, _), (x, (y, _))) -> + | ISub_tez_legacy (_, _), (x, (y, _)) -> Instructions.sub_tez_legacy (Size.mutez x) (Size.mutez y) - | (IMul_teznat (_, _), (x, (y, _))) -> + | IMul_teznat (_, _), (x, (y, _)) -> Instructions.mul_teznat (Size.mutez x) (Size.integer y) - | (IMul_nattez (_, _), (x, (y, _))) -> + | IMul_nattez (_, _), (x, (y, _)) -> Instructions.mul_nattez (Size.integer x) (Size.mutez y) - | (IEdiv_teznat (_, _), (x, (y, _))) -> + | IEdiv_teznat (_, _), (x, (y, _)) -> Instructions.ediv_teznat (Size.mutez x) (Size.integer y) - | (IEdiv_tez (_, _), (x, (y, _))) -> + | IEdiv_tez (_, _), (x, (y, _)) -> Instructions.ediv_tez (Size.mutez x) (Size.mutez y) - | (IOr (_, _), _) -> Instructions.or_ - | (IAnd (_, _), _) -> Instructions.and_ - | (IXor (_, _), _) -> Instructions.xor_ - | (INot (_, _), _) -> Instructions.not_ - | (IIs_nat (_, _), (x, _)) -> Instructions.is_nat (Size.integer x) - | (INeg (_, _), (x, _)) -> Instructions.neg (Size.integer x) - | (IAbs_int (_, _), (x, _)) -> Instructions.abs_int (Size.integer x) - | (IInt_nat (_, _), (x, _)) -> Instructions.int_nat (Size.integer x) - | (IAdd_int (_, _), (x, (y, _))) -> + | IOr (_, _), _ -> Instructions.or_ + | IAnd (_, _), _ -> Instructions.and_ + | IXor (_, _), _ -> Instructions.xor_ + | INot (_, _), _ -> Instructions.not_ + | IIs_nat (_, _), (x, _) -> Instructions.is_nat (Size.integer x) + | INeg (_, _), (x, _) -> Instructions.neg (Size.integer x) + | IAbs_int (_, _), (x, _) -> Instructions.abs_int (Size.integer x) + | IInt_nat (_, _), (x, _) -> Instructions.int_nat (Size.integer x) + | IAdd_int (_, _), (x, (y, _)) -> Instructions.add_int (Size.integer x) (Size.integer y) - | (IAdd_nat (_, _), (x, (y, _))) -> + | IAdd_nat (_, _), (x, (y, _)) -> Instructions.add_nat (Size.integer x) (Size.integer y) - | (ISub_int (_, _), (x, (y, _))) -> + | ISub_int (_, _), (x, (y, _)) -> Instructions.sub_int (Size.integer x) (Size.integer y) - | (IMul_int (_, _), (x, (y, _))) -> + | IMul_int (_, _), (x, (y, _)) -> Instructions.mul_int (Size.integer x) (Size.integer y) - | (IMul_nat (_, _), (x, (y, _))) -> + | IMul_nat (_, _), (x, (y, _)) -> Instructions.mul_nat (Size.integer x) (Size.integer y) - | (IEdiv_int (_, _), (x, (y, _))) -> + | IEdiv_int (_, _), (x, (y, _)) -> Instructions.ediv_int (Size.integer x) (Size.integer y) - | (IEdiv_nat (_, _), (x, (y, _))) -> + | IEdiv_nat (_, _), (x, (y, _)) -> Instructions.ediv_nat (Size.integer x) (Size.integer y) - | (ILsl_nat (_, _), (x, (y, _))) -> + | ILsl_nat (_, _), (x, (y, _)) -> Instructions.lsl_nat (Size.integer x) (Size.integer y) - | (ILsr_nat (_, _), (x, (y, _))) -> + | ILsr_nat (_, _), (x, (y, _)) -> Instructions.lsr_nat (Size.integer x) (Size.integer y) - | (IOr_nat (_, _), (x, (y, _))) -> + | IOr_nat (_, _), (x, (y, _)) -> Instructions.or_nat (Size.integer x) (Size.integer y) - | (IAnd_nat (_, _), (x, (y, _))) -> + | IAnd_nat (_, _), (x, (y, _)) -> Instructions.and_nat (Size.integer x) (Size.integer y) - | (IAnd_int_nat (_, _), (x, (y, _))) -> + | IAnd_int_nat (_, _), (x, (y, _)) -> Instructions.and_int_nat (Size.integer x) (Size.integer y) - | (IXor_nat (_, _), (x, (y, _))) -> + | IXor_nat (_, _), (x, (y, _)) -> Instructions.xor_nat (Size.integer x) (Size.integer y) - | (INot_int (_, _), (x, _)) -> Instructions.not_int (Size.integer x) - | (IIf _, _) -> Instructions.if_ - | (ILoop (_, _, _), _) -> Instructions.loop - | (ILoop_left (_, _, _), _) -> Instructions.loop_left - | (IDip (_, _, _), _) -> Instructions.dip - | (IExec (_, _), _) -> Instructions.exec - | (IApply (_, _, _), _) -> Instructions.apply - | (ILambda (_, _, _), _) -> Instructions.lambda - | (IFailwith (_, _, _), _) -> Instructions.failwith_ - | (ICompare (_, cmp_ty, _), (a, (b, _))) -> + | INot_int (_, _), (x, _) -> Instructions.not_int (Size.integer x) + | IIf _, _ -> Instructions.if_ + | ILoop (_, _, _), _ -> Instructions.loop + | ILoop_left (_, _, _), _ -> Instructions.loop_left + | IDip (_, _, _), _ -> Instructions.dip + | IExec (_, _), _ -> Instructions.exec + | IApply (_, _, _), _ -> Instructions.apply + | ILambda (_, _, _), _ -> Instructions.lambda + | IFailwith (_, _, _), _ -> Instructions.failwith_ + | ICompare (_, cmp_ty, _), (a, (b, _)) -> extract_compare_sized_step cmp_ty a b - | (IEq (_, _), _) -> Instructions.eq - | (INeq (_, _), _) -> Instructions.neq - | (ILt (_, _), _) -> Instructions.lt - | (IGt (_, _), _) -> Instructions.gt - | (ILe (_, _), _) -> Instructions.le - | (IGe (_, _), _) -> Instructions.ge - | (IAddress (_, _), _) -> Instructions.address - | (IContract (_, _, _, _), _) -> Instructions.contract - | (ITransfer_tokens (_, _), _) -> Instructions.transfer_tokens - | (IView (_, _, _), _) -> Instructions.view - | (IImplicit_account (_, _), _) -> Instructions.implicit_account - | (ICreate_contract _, _) -> Instructions.create_contract - | (ISet_delegate (_, _), _) -> Instructions.set_delegate - | (INow (_, _), _) -> Instructions.now - | (IBalance (_, _), _) -> Instructions.balance - | (ILevel (_, _), _) -> Instructions.level - | (ICheck_signature (_, _), (public_key, (_signature, (message, _)))) -> ( + | IEq (_, _), _ -> Instructions.eq + | INeq (_, _), _ -> Instructions.neq + | ILt (_, _), _ -> Instructions.lt + | IGt (_, _), _ -> Instructions.gt + | ILe (_, _), _ -> Instructions.le + | IGe (_, _), _ -> Instructions.ge + | IAddress (_, _), _ -> Instructions.address + | IContract (_, _, _, _), _ -> Instructions.contract + | ITransfer_tokens (_, _), _ -> Instructions.transfer_tokens + | IView (_, _, _), _ -> Instructions.view + | IImplicit_account (_, _), _ -> Instructions.implicit_account + | ICreate_contract _, _ -> Instructions.create_contract + | ISet_delegate (_, _), _ -> Instructions.set_delegate + | INow (_, _), _ -> Instructions.now + | IBalance (_, _), _ -> Instructions.balance + | ILevel (_, _), _ -> Instructions.level + | ICheck_signature (_, _), (public_key, (_signature, (message, _))) -> ( match public_key with | Signature.Ed25519 _pk -> let pk = Size.of_int Ed25519.size in @@ -1369,69 +1369,69 @@ let extract_ir_sized_step : let signature = Size.of_int Signature.size in let message = Size.bytes message in Instructions.check_signature_p256 pk signature message) - | (IHash_key (_, _), _) -> Instructions.hash_key - | (IPack (_, ty, _), (v, _)) -> + | IHash_key (_, _), _ -> Instructions.hash_key + | IPack (_, ty, _), (v, _) -> let encoding_size = Size.of_encoded_value ctxt ty v in Instructions.pack encoding_size - | (IUnpack (_, _, _), _) -> Instructions.unpack - | (IBlake2b (_, _), (bytes, _)) -> Instructions.blake2b (Size.bytes bytes) - | (ISha256 (_, _), (bytes, _)) -> Instructions.sha256 (Size.bytes bytes) - | (ISha512 (_, _), (bytes, _)) -> Instructions.sha512 (Size.bytes bytes) - | (ISource (_, _), _) -> Instructions.source - | (ISender (_, _), _) -> Instructions.sender - | (ISelf (_, _, _, _), _) -> Instructions.self - | (ISelf_address (_, _), _) -> Instructions.self_address - | (IAmount (_, _), _) -> Instructions.amount - | (ISapling_empty_state (_, _, _), _) -> Instructions.sapling_empty_state - | (ISapling_verify_update (_, _), (transaction, (_state, _))) -> + | IUnpack (_, _, _), _ -> Instructions.unpack + | IBlake2b (_, _), (bytes, _) -> Instructions.blake2b (Size.bytes bytes) + | ISha256 (_, _), (bytes, _) -> Instructions.sha256 (Size.bytes bytes) + | ISha512 (_, _), (bytes, _) -> Instructions.sha512 (Size.bytes bytes) + | ISource (_, _), _ -> Instructions.source + | ISender (_, _), _ -> Instructions.sender + | ISelf (_, _, _, _), _ -> Instructions.self + | ISelf_address (_, _), _ -> Instructions.self_address + | IAmount (_, _), _ -> Instructions.amount + | ISapling_empty_state (_, _, _), _ -> Instructions.sapling_empty_state + | ISapling_verify_update (_, _), (transaction, (_state, _)) -> let inputs = Size.sapling_transaction_inputs transaction in let outputs = Size.sapling_transaction_outputs transaction in let state = Size.zero in Instructions.sapling_verify_update inputs outputs state - | (IDig (_, n, _, _), _) -> Instructions.dig n - | (IDug (_, n, _, _), _) -> Instructions.dug n - | (IDipn (_, n, _, _, _), _) -> Instructions.dipn n - | (IDropn (_, n, _, _), _) -> Instructions.dropn n - | (IChainId (_, _), _) -> Instructions.chain_id - | (INever _, _) -> . - | (IVoting_power (_, _), _) -> Instructions.voting_power - | (ITotal_voting_power (_, _), _) -> Instructions.total_voting_power - | (IKeccak (_, _), (bytes, _)) -> Instructions.keccak (Size.bytes bytes) - | (ISha3 (_, _), (bytes, _)) -> Instructions.sha3 (Size.bytes bytes) - | (IAdd_bls12_381_g1 (_, _), _) -> Instructions.add_bls12_381_g1 - | (IAdd_bls12_381_g2 (_, _), _) -> Instructions.add_bls12_381_g2 - | (IAdd_bls12_381_fr (_, _), _) -> Instructions.add_bls12_381_fr - | (IMul_bls12_381_g1 (_, _), _) -> Instructions.mul_bls12_381_g1 - | (IMul_bls12_381_g2 (_, _), _) -> Instructions.mul_bls12_381_g2 - | (IMul_bls12_381_fr (_, _), _) -> Instructions.mul_bls12_381_fr - | (IMul_bls12_381_z_fr (_, _), (_fr, (z, _))) -> + | IDig (_, n, _, _), _ -> Instructions.dig n + | IDug (_, n, _, _), _ -> Instructions.dug n + | IDipn (_, n, _, _, _), _ -> Instructions.dipn n + | IDropn (_, n, _, _), _ -> Instructions.dropn n + | IChainId (_, _), _ -> Instructions.chain_id + | INever _, _ -> . + | IVoting_power (_, _), _ -> Instructions.voting_power + | ITotal_voting_power (_, _), _ -> Instructions.total_voting_power + | IKeccak (_, _), (bytes, _) -> Instructions.keccak (Size.bytes bytes) + | ISha3 (_, _), (bytes, _) -> Instructions.sha3 (Size.bytes bytes) + | IAdd_bls12_381_g1 (_, _), _ -> Instructions.add_bls12_381_g1 + | IAdd_bls12_381_g2 (_, _), _ -> Instructions.add_bls12_381_g2 + | IAdd_bls12_381_fr (_, _), _ -> Instructions.add_bls12_381_fr + | IMul_bls12_381_g1 (_, _), _ -> Instructions.mul_bls12_381_g1 + | IMul_bls12_381_g2 (_, _), _ -> Instructions.mul_bls12_381_g2 + | IMul_bls12_381_fr (_, _), _ -> Instructions.mul_bls12_381_fr + | IMul_bls12_381_z_fr (_, _), (_fr, (z, _)) -> Instructions.mul_bls12_381_z_fr (Size.integer z) - | (IMul_bls12_381_fr_z (_, _), (z, _)) -> + | IMul_bls12_381_fr_z (_, _), (z, _) -> Instructions.mul_bls12_381_fr_z (Size.integer z) - | (IInt_bls12_381_fr (_, _), _) -> Instructions.int_bls12_381_z_fr - | (INeg_bls12_381_g1 (_, _), _) -> Instructions.neg_bls12_381_g1 - | (INeg_bls12_381_g2 (_, _), _) -> Instructions.neg_bls12_381_g2 - | (INeg_bls12_381_fr (_, _), _) -> Instructions.neg_bls12_381_fr - | (IPairing_check_bls12_381 (_, _), (list, _)) -> + | IInt_bls12_381_fr (_, _), _ -> Instructions.int_bls12_381_z_fr + | INeg_bls12_381_g1 (_, _), _ -> Instructions.neg_bls12_381_g1 + | INeg_bls12_381_g2 (_, _), _ -> Instructions.neg_bls12_381_g2 + | INeg_bls12_381_fr (_, _), _ -> Instructions.neg_bls12_381_fr + | IPairing_check_bls12_381 (_, _), (list, _) -> Instructions.pairing_check_bls12_381 (Size.list list) - | (IComb (_, n, _, _), _) -> Instructions.comb (Size.of_int n) - | (IUncomb (_, n, _, _), _) -> Instructions.uncomb (Size.of_int n) - | (IComb_get (_, n, _, _), _) -> Instructions.comb_get (Size.of_int n) - | (IComb_set (_, n, _, _), _) -> Instructions.comb_set (Size.of_int n) - | (IDup_n (_, n, _, _), _) -> Instructions.dupn (Size.of_int n) - | (ITicket (_, _), _) -> Instructions.ticket - | (IRead_ticket (_, _), _) -> Instructions.read_ticket - | (ISplit_ticket (_, _), (_ticket, ((amount_a, amount_b), _))) -> + | IComb (_, n, _, _), _ -> Instructions.comb (Size.of_int n) + | IUncomb (_, n, _, _), _ -> Instructions.uncomb (Size.of_int n) + | IComb_get (_, n, _, _), _ -> Instructions.comb_get (Size.of_int n) + | IComb_set (_, n, _, _), _ -> Instructions.comb_set (Size.of_int n) + | IDup_n (_, n, _, _), _ -> Instructions.dupn (Size.of_int n) + | ITicket (_, _), _ -> Instructions.ticket + | IRead_ticket (_, _), _ -> Instructions.read_ticket + | ISplit_ticket (_, _), (_ticket, ((amount_a, amount_b), _)) -> Instructions.split_ticket (Size.integer amount_a) (Size.integer amount_b) - | (IJoin_tickets (_, cmp_ty, _), ((ticket1, ticket2), _)) -> + | IJoin_tickets (_, cmp_ty, _), ((ticket1, ticket2), _) -> let size1 = size_of_comparable_value cmp_ty ticket1.contents in let size2 = size_of_comparable_value cmp_ty ticket2.contents in let tez1 = Size.integer ticket1.amount in let tez2 = Size.integer ticket2.amount in Instructions.join_tickets size1 size2 tez1 tez2 - | (IHalt _, _) -> Instructions.halt - | (ILog _, _) -> Instructions.log - | (IOpen_chest (_, _), (_, (chest, (time, _)))) -> + | IHalt _, _ -> Instructions.halt + | ILog _, _ -> Instructions.log + | IOpen_chest (_, _), (_, (chest, (time, _))) -> let plaintext_size = Timelock.get_plaintext_size chest - 1 in let log_time = Z.log2 Z.(one + Script_int_repr.to_zint time) in Instructions.open_chest log_time plaintext_size diff --git a/src/proto_012_Psithaca/lib_benchmarks_proto/sapling_generation.ml b/src/proto_012_Psithaca/lib_benchmarks_proto/sapling_generation.ml index 04e8b99bd811..b07bebe1eda6 100644 --- a/src/proto_012_Psithaca/lib_benchmarks_proto/sapling_generation.ml +++ b/src/proto_012_Psithaca/lib_benchmarks_proto/sapling_generation.ml @@ -127,14 +127,14 @@ let rec gen_rcm state = let add_input diff vk index position sum state = let rcm = gen_rcm state in let amount = random_amount sum in - let (new_idx, address) = + let new_idx, address = Tezos_sapling.Core.Client.Viewing_key.new_address vk index in let cv = Tezos_sapling.Core.Client.CV.of_bytes (random_bytes state 32) |> WithExceptions.Option.get ~loc:__LOC__ in - let (ciphertext, cm) = + let ciphertext, cm = Tezos_sapling.Core.Client.Forge.Output.to_ciphertext Tezos_sapling.Core.Client.Forge.Output. {address; amount; memo = Bytes.empty} @@ -221,7 +221,7 @@ let output proving_ctx vk sum = let amount = random_amount sum in let rcm = Tezos_sapling.Core.Client.Rcm.random () in let esk = Tezos_sapling.Core.Client.DH.esk_random () in - let (cv_o, proof_o) = + let cv_o, proof_o = Tezos_sapling.Core.Client.Proving.output_proof proving_ctx esk @@ -229,7 +229,7 @@ let output proving_ctx vk sum = rcm ~amount in - let (ciphertext, cm) = + let ciphertext, cm = Tezos_sapling.Core.Client.Forge.Output.to_ciphertext Tezos_sapling.Core.Client.Forge.Output. {address; amount; memo = Bytes.empty} @@ -246,7 +246,7 @@ let outputs nb_output proving_ctx vk = match nb_output with | 0 -> (output_amount, list_outputs) | nb_output -> - let (output, amount) = output proving_ctx vk sum in + let output, amount = output proving_ctx vk sum in assert ( Int64.compare amount @@ -268,7 +268,7 @@ let make_inputs to_forge local_state proving_ctx sk vk root anti_replay = (fun {rcm; position; amount; address; nf} -> let witness = Tezos_sapling.Storage.get_witness local_state position in let ar = Tezos_sapling.Core.Client.Proving.ar_random () in - let (cv, rk, proof) = + let cv, rk, proof = Tezos_sapling.Core.Client.Proving.spend_proof proving_ctx vk @@ -326,7 +326,7 @@ let prepare_seeded_state_internal ~(nb_input : int) ~(nb_nf : int) init_fresh_sapling_state ctxt >|= Protocol.Environment.wrap_tzresult >>=? fun (ctxt, id) -> let index_start = Tezos_sapling.Core.Client.Viewing_key.default_index in - let (sk, vk) = generate_spending_and_viewing_keys state in + let sk, vk = generate_spending_and_viewing_keys state in generate_commitments ~vk ~nb_input @@ -364,7 +364,7 @@ let generate ~(nb_input : int) ~(nb_output : int) ~(nb_nf : int) ~(nb_cm : int) Tezos_sapling.Core.Client.Proving.with_proving_ctx (fun proving_ctx -> make_inputs to_forge local_state proving_ctx sk vk root anti_replay >>=? fun inputs -> - let (output_amount, outputs) = outputs nb_output proving_ctx vk in + let output_amount, outputs = outputs nb_output proving_ctx vk in let input_amount = List.fold_left (fun sum {amount; _} -> diff --git a/src/proto_012_Psithaca/lib_benchmarks_proto/size.ml b/src/proto_012_Psithaca/lib_benchmarks_proto/size.ml index 4d647094dfc9..58ae70bab6d1 100644 --- a/src/proto_012_Psithaca/lib_benchmarks_proto/size.ml +++ b/src/proto_012_Psithaca/lib_benchmarks_proto/size.ml @@ -139,7 +139,7 @@ let public_key (public_key : Signature.public_key) : t = let chain_id (_chain_id : Chain_id.t) : t = Chain_id.size let address (addr : Script_typed_ir.address) : t = - let (_contract, entrypoint) = addr in + let _contract, entrypoint = addr in Signature.Public_key_hash.size + String.length entrypoint let list (list : 'a Script_typed_ir.boxed_list) : t = diff --git a/src/proto_012_Psithaca/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_012_Psithaca/lib_benchmarks_proto/translator_benchmarks.ml index 9c088f35233e..608ecb18e1ab 100644 --- a/src/proto_012_Psithaca/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_012_Psithaca/lib_benchmarks_proto/translator_benchmarks.ml @@ -502,7 +502,7 @@ let check_printable_benchmark = in (string, {Shared_linear.bytes = String.length string})) ~make_bench:(fun generator () -> - let (generated, workload) = generator () in + let generated, workload = generator () in let closure () = ignore (check_printable_ascii generated (String.length generated - 1)) in @@ -614,7 +614,7 @@ let () = Registration_helpers.register (module Merge_types) This structure is the worse-case of the unparsing function for types because an extra test is performed to determine if the comb type needs to be folded. - *) +*) let rec dummy_type_generator size = let open Script_ir_translator in let open Script_typed_ir in diff --git a/src/proto_012_Psithaca/lib_benchmarks_proto/translator_workload.ml b/src/proto_012_Psithaca/lib_benchmarks_proto/translator_workload.ml index 1ba338327374..c2d92053cbc5 100644 --- a/src/proto_012_Psithaca/lib_benchmarks_proto/translator_workload.ml +++ b/src/proto_012_Psithaca/lib_benchmarks_proto/translator_workload.ml @@ -86,7 +86,7 @@ let pp fmtr (trace : t) = consumed let workload_to_sparse_vec (trace : t) = - let (name, {Size.traversal; int_bytes; string_bytes}, consumed) = + let name, {Size.traversal; int_bytes; string_bytes}, consumed = match trace with | Typechecker_workload {t_kind; code_or_data; micheline_size; consumed} -> let name = diff --git a/src/proto_012_Psithaca/lib_client/client_proto_context.ml b/src/proto_012_Psithaca/lib_client/client_proto_context.ml index 95d9236a00ce..dad71a964233 100644 --- a/src/proto_012_Psithaca/lib_client/client_proto_context.ml +++ b/src/proto_012_Psithaca/lib_client/client_proto_context.ml @@ -687,18 +687,18 @@ let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_012_Psithaca/lib_client/client_proto_fa12.ml b/src/proto_012_Psithaca/lib_client/client_proto_fa12.ml index fb7e31dc856b..eecd89a05a2a 100644 --- a/src/proto_012_Psithaca/lib_client/client_proto_fa12.ml +++ b/src/proto_012_Psithaca/lib_client/client_proto_fa12.ml @@ -266,7 +266,7 @@ type type_eq_combinator = Script.node * (Script.node -> bool) check functions, and returns a type of n-ary pair of such types and a function checking syntactical equivalence with another node. *) let t_pair ~loc l : type_eq_combinator = - let (values, are_ty) = List.split l in + let values, are_ty = List.split l in let is_pair p = match p with | Micheline.Prim (_, Script.T_pair, l, _) -> ( @@ -532,8 +532,8 @@ let parse_callback error expr = let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in match (String.sub s 0 pos, name) with - | (addr, "default") -> of_b58_check (addr, None) - | (addr, name) -> of_b58_check (addr, Some name))) + | addr, "default" -> of_b58_check (addr, None) + | addr, name -> of_b58_check (addr, Some name))) | _ -> error () let action_of_expr ~entrypoint expr = @@ -644,7 +644,7 @@ let derive_action expr t_param = | ( Micheline.Prim (_, Script.D_Right, [right], _), Micheline.Prim (_, Script.T_or, [_; t_right], _) ) -> derive right t_right - | (_, Micheline.Prim (_, _, _, annots)) -> + | _, Micheline.Prim (_, _, _, annots) -> find_entrypoint_in_annot error annots expr | _ -> error () in @@ -732,7 +732,7 @@ let parse_error = | ( "NotEnoughAllowance", Prim (_, Script.D_Pair, [Int (_, required); Int (_, present)], _) ) -> Some (Not_enough_allowance (required, present)) - | ("UnsafeAllowanceChange", Int (_, previous)) -> + | "UnsafeAllowanceChange", Int (_, previous) -> Some (Unsafe_allowance_change previous) | _ -> None @@ -756,7 +756,7 @@ let call_contract (cctxt : #Protocol_client_context.full) ~chain ~block ~contract ~action ~tez_amount ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () = contract_has_fa12_interface cctxt ~chain ~block ~contract () >>=? fun () -> - let (entrypoint, arg) = translate_action_to_argument action in + let entrypoint, arg = translate_action_to_argument action in Client_proto_context.transfer cctxt ~chain diff --git a/src/proto_012_Psithaca/lib_client/client_proto_programs.ml b/src/proto_012_Psithaca/lib_client/client_proto_programs.ml index b4c8085d838f..3ce736ae0a26 100644 --- a/src/proto_012_Psithaca/lib_client/client_proto_programs.ml +++ b/src/proto_012_Psithaca/lib_client/client_proto_programs.ml @@ -265,7 +265,7 @@ let script_size cctxt ~(chain : Chain_services.chain) ~block ?gas ?legacy let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_012_Psithaca/lib_client/client_proto_utils.ml b/src/proto_012_Psithaca/lib_client/client_proto_utils.ml index 27fec54d342a..be6844cc5cf7 100644 --- a/src/proto_012_Psithaca/lib_client/client_proto_utils.ml +++ b/src/proto_012_Psithaca/lib_client/client_proto_utils.ml @@ -37,14 +37,14 @@ let to_json_and_bytes branch message = Data_encoding.Binary.to_bytes_exn encoding op ) let sign_message (cctxt : #full) ~src_sk ~block ~message = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in cctxt#message "signed content: @[%a@]" Data_encoding.Json.pp json >>= fun () -> Client_keys.sign cctxt ~watermark:Signature.Generic_operation src_sk bytes let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> diff --git a/src/proto_012_Psithaca/lib_client/injection.ml b/src/proto_012_Psithaca/lib_client/injection.ml index 0daf51291541..f0ff3cb77c9d 100644 --- a/src/proto_012_Psithaca/lib_client/injection.ml +++ b/src/proto_012_Psithaca/lib_client/injection.ml @@ -276,7 +276,7 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -297,12 +297,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ~chain_id ~latency >>=? function - | (Operation_data op', Operation_metadata result) -> ( + | Operation_data op', Operation_metadata result -> ( match ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -537,7 +537,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) | Single_manager minfo -> gas_patching_stats minfo need_patching gas_consumed | Cons_manager (minfo, rest) -> - let (need_patching, gas_consumed) = + let need_patching, gas_consumed = gas_patching_stats minfo need_patching gas_consumed in gas_patching_stats_list rest need_patching gas_consumed @@ -587,7 +587,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) in let rest_opt = loop rest in match (annotated_op_opt, rest_opt) with - | (None, None) -> None + | None, None -> None | _ -> let op = Option.value ~default:annotated_op annotated_op_opt in let rest = Option.value ~default:rest rest_opt in @@ -656,7 +656,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Annotated_manager_operation.t * kind Kind.manager contents_result -> kind Kind.manager contents tzresult Lwt.t = fun ~first -> function - | ((Manager_info c as op), (Manager_operation_result _ as result)) -> + | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then Lwt.return (estimated_gas_single result) >>=? fun gas -> if Gas.Arith.(gas = zero) then @@ -734,16 +734,16 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Kind.manager contents_list tzresult Lwt.t = fun first annotated_list result_list -> match (annotated_list, result_list) with - | (Single_manager annotated, Single_result res) -> + | Single_manager annotated, Single_result res -> patch ~first (annotated, res) >>=? fun op -> return (Single op) - | (Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest)) -> + | Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest) -> patch ~first (annotated, res) >>=? fun op -> patch_list false annotated_rest res_rest >>=? fun rest -> return (Cons (op, rest)) | _ -> assert false in let gas_limit_per_patched_op = - let (need_gas_patching, gas_consumed) = + let need_gas_patching, gas_consumed = gas_patching_stats_list annotated_contents 0 Gas.Arith.zero in if need_gas_patching = 0 then hard_gas_limit_per_operation @@ -821,7 +821,7 @@ let tenderbake_adjust_confirmations (cctxt : #Client_context.full) = function Any value greater than the tenderbake_finality_confirmations is treated as if it were tenderbake_finality_confirmations. - *) +*) let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?(dry_run = false) ?(simulation = false) ?(force = false) ?branch ?src_sk ?verbose_signing ~fee_parameter (contents : kind contents_list) = @@ -1066,7 +1066,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run >>=? fun (oph, op, result) -> match pack_contents_list op result with | Cons_and_result (_, _, rest) -> - let (op, result) = unpack_contents_list rest in + let op, result = unpack_contents_list rest in return (oph, op, result) | _ -> assert false) | Some _ when has_reveal operations -> diff --git a/src/proto_012_Psithaca/lib_client/limit.ml b/src/proto_012_Psithaca/lib_client/limit.ml index 3f3c798c02b6..ae20b1d6bf4b 100644 --- a/src/proto_012_Psithaca/lib_client/limit.ml +++ b/src/proto_012_Psithaca/lib_client/limit.ml @@ -35,9 +35,9 @@ let is_unknown = Option.is_none let join (type a) ~where eq (l1 : a t) (l2 : a t) = match (l1, l2) with - | (None, None) -> Result.return_none - | (Some x, None) | (None, Some x) -> Result.return_some x - | (Some x, Some y) -> + | None, None -> Result.return_none + | Some x, None | None, Some x -> Result.return_some x + | Some x, Some y -> if eq x y then Result.return_some x else error_with "Limit.join: error (%s)" where diff --git a/src/proto_012_Psithaca/lib_client/michelson_v1_emacs.ml b/src/proto_012_Psithaca/lib_client/michelson_v1_emacs.ml index 2721fa702d46..197b420c6228 100644 --- a/src/proto_012_Psithaca/lib_client/michelson_v1_emacs.ml +++ b/src/proto_012_Psithaca/lib_client/michelson_v1_emacs.ml @@ -133,7 +133,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -141,7 +141,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -160,7 +160,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_012_Psithaca/lib_client/michelson_v1_error_reporter.ml b/src/proto_012_Psithaca/lib_client/michelson_v1_error_reporter.ml index 2aae382fa4f5..300fe282dcde 100644 --- a/src/proto_012_Psithaca/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_012_Psithaca/lib_client/michelson_v1_error_reporter.ml @@ -488,7 +488,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Invalid_never_expr loc -> diff --git a/src/proto_012_Psithaca/lib_client/michelson_v1_macros.ml b/src/proto_012_Psithaca/lib_client/michelson_v1_macros.ml index 448bd000108e..3b1eaa5028d4 100644 --- a/src/proto_012_Psithaca/lib_client/michelson_v1_macros.ml +++ b/src/proto_012_Psithaca/lib_client/michelson_v1_macros.ml @@ -122,9 +122,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -237,9 +237,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -383,14 +383,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -405,18 +405,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -439,7 +439,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -447,13 +447,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -464,7 +464,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -498,7 +498,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -541,8 +541,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -712,7 +711,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -724,10 +723,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -737,7 +736,7 @@ let expand_rec expr = let unexpand_carn_and_cdrn expanded = match expanded with | Seq (loc, [Prim (_, "GET", [Int (locn, n)], annot)]) -> - let (half, parity) = Z.ediv_rem n (Z.of_int 2) in + let half, parity = Z.ediv_rem n (Z.of_int 2) in if Z.(parity = zero) then Some (Prim (loc, "CDR", [Int (locn, half)], annot)) else Some (Prim (loc, "CAR", [Int (locn, half)], annot)) @@ -802,7 +801,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -812,7 +811,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -879,7 +878,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -889,7 +888,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -910,7 +909,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -952,46 +951,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1008,41 +1007,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_012_Psithaca/lib_client/michelson_v1_parser.ml b/src/proto_012_Psithaca/lib_client/michelson_v1_parser.ml index 2f44d22c1fca..09a8c7d5b710 100644 --- a/src/proto_012_Psithaca/lib_client/michelson_v1_parser.ml +++ b/src/proto_012_Psithaca/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -87,8 +87,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -96,8 +96,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_012_Psithaca/lib_client/michelson_v1_printer.ml b/src/proto_012_Psithaca/lib_client/michelson_v1_printer.ml index 5eeb4e1fd88c..98848e43b193 100644 --- a/src/proto_012_Psithaca/lib_client/michelson_v1_printer.ml +++ b/src/proto_012_Psithaca/lib_client/michelson_v1_printer.ml @@ -148,7 +148,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -180,8 +180,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_012_Psithaca/lib_client/mockup.ml b/src/proto_012_Psithaca/lib_client/mockup.ml index 113a10144634..bacbe9a59570 100644 --- a/src/proto_012_Psithaca/lib_client/mockup.ml +++ b/src/proto_012_Psithaca/lib_client/mockup.ml @@ -717,7 +717,7 @@ module Parsed_account = struct Client_keys.list_keys wallet >>=? fun all_keys -> List.iter_s (function - | (name, pkh, _pk_opt, Some sk_uri) -> ( + | name, pkh, _pk_opt, Some sk_uri -> ( let contract = Contract.implicit_contract pkh in Client_proto_context.get_balance rpc_context @@ -971,7 +971,7 @@ let mem_init : | None -> return Protocol_constants_overrides.no_overrides | Some json -> ( match Data_encoding.Json.destruct lib_parameters_json_encoding json with - | (_, x) -> return x + | _, x -> return x | exception error -> failwith "cannot read protocol constants overrides: %a" @@ -1058,7 +1058,7 @@ let mem_init : [Block_hash.to_bytes hash; Operation_list_hash.(to_bytes @@ compute [])] in let open Protocol.Alpha_context.Block_header in - let (_, _, sk) = Signature.generate_key () in + let _, _, sk = Signature.generate_key () in let proof_of_work_nonce = Bytes.create Protocol.Alpha_context.Constants.proof_of_work_nonce_size in diff --git a/src/proto_012_Psithaca/lib_client/operation_result.ml b/src/proto_012_Psithaca/lib_client/operation_result.ml index af99cf5b7e9b..bce11c8a78b3 100644 --- a/src/proto_012_Psithaca/lib_client/operation_result.ml +++ b/src/proto_012_Psithaca/lib_client/operation_result.ml @@ -214,10 +214,10 @@ let pp_balance_updates ppf = function | Lost_endorsing_rewards (pkh, p, r) -> let reason = match (p, r) with - | (false, false) -> "" - | (false, true) -> ",revelation" - | (true, false) -> ",participation" - | (true, true) -> ",participation,revelation" + | false, false -> "" + | false, true -> ",revelation" + | true, false -> ",participation" + | true, true -> ",participation,revelation" in Format.asprintf "lost endorsing rewards(%a%s)" diff --git a/src/proto_012_Psithaca/lib_client/test/test_michelson_v1_macros.ml b/src/proto_012_Psithaca/lib_client/test/test_michelson_v1_macros.ml index 75316f163dfa..fad67b021cbf 100644 --- a/src/proto_012_Psithaca/lib_client/test/test_michelson_v1_macros.ml +++ b/src/proto_012_Psithaca/lib_client/test/test_michelson_v1_macros.ml @@ -44,7 +44,7 @@ let print expr : string = let assert_expands (original : (Micheline_parser.location, string) Micheline.node) (expanded : (Micheline_parser.location, string) Micheline.node) = - let ({Michelson_v1_parser.expanded = expansion; _}, errors) = + let {Michelson_v1_parser.expanded = expansion; _}, errors = let source = print (Micheline.strip_locations original) in Michelson_v1_parser.expand_all ~source ~original in @@ -691,7 +691,7 @@ let test_map_cdadr () = [unparse.Michelson_v1_parser.unexpanded] contains the original expression with macros *) let assert_unexpansion original ex = - let ({Michelson_v1_parser.expanded; _}, errors) = + let {Michelson_v1_parser.expanded; _}, errors = let source = print (Micheline.strip_locations original) in Michelson_v1_parser.expand_all ~source ~original in @@ -1318,7 +1318,7 @@ let tests = ("map_car unexpansion", fun _ -> Lwt.return (test_unexpand_map_car ())); ("diip unexpansion", fun _ -> Lwt.return (test_unexpand_diip ())); ("diip_duup1 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup1 ())); - ("diip_duup2 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup2 ())); + ("diip_duup2 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup2 ())) (***********************************************************************) (*BUG the function in Michelson_v1_macros.unexpand_map_caddadr @@ -1327,7 +1327,7 @@ let tests = (*"diip unexpansion", (fun _ -> Lwt.return (test_unexpand_diip ())) ;*) (*"map_cdr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdr ())) ;*) (*"map_caadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_caadr ())) ;*) - (*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*) + (*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*); ] let wrap (n, f) = diff --git a/src/proto_012_Psithaca/lib_client/test/test_proxy.ml b/src/proto_012_Psithaca/lib_client/test/test_proxy.ml index fac12dead632..d664151f5aac 100644 --- a/src/proto_012_Psithaca/lib_client/test/test_proxy.ml +++ b/src/proto_012_Psithaca/lib_client/test/test_proxy.ml @@ -55,9 +55,9 @@ let key_gen : string list QCheck2.Gen.t = (** Whether [t1] is a prefix of [t2] *) let rec is_prefix t1 t2 = match (t1, t2) with - | ([], _) -> true - | (_, []) -> false - | (x1 :: rest1, x2 :: rest2) when x1 = x2 -> is_prefix rest1 rest2 + | [], _ -> true + | _, [] -> false + | x1 :: rest1, x2 :: rest2 when x1 = x2 -> is_prefix rest1 rest2 | _ -> false let test_split_key = diff --git a/src/proto_012_Psithaca/lib_client_commands/client_proto_context_commands.ml b/src/proto_012_Psithaca/lib_client_commands/client_proto_context_commands.ml index 3f0d66fb73cb..4297a9b56eb2 100644 --- a/src/proto_012_Psithaca/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_012_Psithaca/lib_client_commands/client_proto_context_commands.ml @@ -548,27 +548,27 @@ let commands_ro () = (* ----------------------------------------------------------------------------*) (* After the activation of a new version of the protocol, the older protocols - are only kept in the code base to replay the history of the chain and to query - old states. + are only kept in the code base to replay the history of the chain and to query + old states. - The commands that are not useful anymore in the old protocols are removed, - this is called protocol freezing. The commands below are those that can be - removed during protocol freezing. + The commands that are not useful anymore in the old protocols are removed, + this is called protocol freezing. The commands below are those that can be + removed during protocol freezing. - The rule of thumb to know if a command should be kept at freezing is that all - commands that modify the state of the chain should be removed and conversely - all commands that are used to query the context should be kept. For this - reason, we call read-only (or RO for short) the commands that are kept and - read-write (or RW for short) the commands that are removed. + The rule of thumb to know if a command should be kept at freezing is that all + commands that modify the state of the chain should be removed and conversely + all commands that are used to query the context should be kept. For this + reason, we call read-only (or RO for short) the commands that are kept and + read-write (or RW for short) the commands that are removed. - There are some exceptions to this rule however, for example the command - "tezos-client wait for <op> to be included" is classified as RW despite having - no effect on the context because it has no use case once all RW commands are - removed. + There are some exceptions to this rule however, for example the command + "tezos-client wait for <op> to be included" is classified as RW despite having + no effect on the context because it has no use case once all RW commands are + removed. - Keeping this in mind, the developer should decide where to add a new command. - At the end of the file, RO and RW commands are concatenated into one list that - is then exported in the mli file. *) + Keeping this in mind, the developer should decide where to add a new command. + At the end of the file, RO and RW commands are concatenated into one list that + is then exported in the mli file. *) (* ----------------------------------------------------------------------------*) let dry_run_switch = @@ -753,8 +753,7 @@ let commands_network network () = ~desc:"Register and activate an Alphanet/Zeronet faucet account." (args2 (Secret_key.force_switch ()) encrypted_switch) (prefixes ["activate"; "account"] - @@ Secret_key.fresh_alias_param - @@ prefixes ["with"] + @@ Secret_key.fresh_alias_param @@ prefixes ["with"] @@ param ~name:"activation_key" ~desc: @@ -796,8 +795,7 @@ let commands_network network () = ~desc:"Activate a fundraiser account." (args1 dry_run_switch) (prefixes ["activate"; "fundraiser"; "account"] - @@ Public_key_hash.alias_param - @@ prefixes ["with"] + @@ Public_key_hash.alias_param @@ prefixes ["with"] @@ param ~name:"code" (Clic.parameter (fun _ctx code -> @@ -1224,7 +1222,7 @@ let commands_rw () = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith @@ -1859,7 +1857,7 @@ let commands_rw () = (cctxt#chain, cctxt#block) >>=? fun current_proposal -> (match (info.current_period_kind, current_proposal) with - | ((Exploration | Promotion), Some current_proposal) -> + | (Exploration | Promotion), Some current_proposal -> if Protocol_hash.equal proposal current_proposal then return_unit else diff --git a/src/proto_012_Psithaca/lib_client_commands/client_proto_fa12_commands.ml b/src/proto_012_Psithaca/lib_client_commands/client_proto_fa12_commands.ml index fe6703bbb7fa..3f66279f1829 100644 --- a/src/proto_012_Psithaca/lib_client_commands/client_proto_fa12_commands.ml +++ b/src/proto_012_Psithaca/lib_client_commands/client_proto_fa12_commands.ml @@ -526,7 +526,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = src (_, dst) (cctxt : #Protocol_client_context.full) -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in get_contract_caller_keys cctxt caller >>=? fun (source, caller_pk, caller_sk) -> let action = Client_proto_fa12.Transfer (snd src, dst, amount) in @@ -690,7 +690,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = src operations_json cctxt -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in let fee_parameter = { Injection.minimal_fees; @@ -736,7 +736,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith diff --git a/src/proto_012_Psithaca/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_012_Psithaca/lib_client_commands/client_proto_multisig_commands.ml index db58555539ee..7f57048eafaa 100644 --- a/src/proto_012_Psithaca/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_012_Psithaca/lib_client_commands/client_proto_multisig_commands.ml @@ -813,8 +813,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = @@ Client_proto_contracts.ContractAlias.destination_param ~name:"multisig" ~desc:"name or address of the originated multisig contract" - @@ prefixes ["to"] - @@ threshold_param () + @@ prefixes ["to"] @@ threshold_param () @@ prefixes ["and"; "public"; "keys"; "to"] @@ non_terminal_seq (public_key_param ()) ~suffix:["on"; "behalf"; "of"] @@ Client_proto_contracts.ContractAlias.destination_param diff --git a/src/proto_012_Psithaca/lib_client_commands/client_proto_programs_commands.ml b/src/proto_012_Psithaca/lib_client_commands/client_proto_programs_commands.ml index e0bc75fb83ab..914c7facfce5 100644 --- a/src/proto_012_Psithaca/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_012_Psithaca/lib_client_commands/client_proto_programs_commands.ml @@ -178,7 +178,7 @@ let commands () = let handle_parsing_error label (cctxt : Protocol_client_context.full) (emacs_mode, no_print_source) program body = match program with - | (program, []) -> body program + | program, [] -> body program | res_with_errors when emacs_mode -> cctxt#message "(@[<v 0>(%s . ())@ (errors . %a)@])" @@ -186,7 +186,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -655,8 +655,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> @@ -695,8 +694,7 @@ let commands () = (args2 emacs_mode_switch no_print_source_flag) (prefixes ["get"; "script"; "entrypoint"; "type"; "of"] @@ string ~name:"entrypoint" ~desc:"the entrypoint to describe" - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun ((emacs_mode, no_print_source) as setup) entrypoint program cctxt -> handle_parsing_error "entrypoint" cctxt setup program @@ fun program -> entrypoint_type diff --git a/src/proto_012_Psithaca/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_012_Psithaca/lib_client_commands/client_proto_stresstest_commands.ml index 966129338952..2445d6b7cd8d 100644 --- a/src/proto_012_Psithaca/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_012_Psithaca/lib_client_commands/client_proto_stresstest_commands.ml @@ -305,7 +305,7 @@ let random_seed rng = let generate_fresh_source pool rng = let seed = random_seed rng in - let (pkh, pk, sk) = Signature.generate_key ~seed () in + let pkh, pk, sk = Signature.generate_key ~seed () in let fresh = {source = {pkh; pk; sk}; origin = Explicit} in pool.pool <- fresh :: pool.pool ; pool.pool_size <- pool.pool_size + 1 ; @@ -319,7 +319,7 @@ let heads_iter (cctxt : Protocol_client_context.full) let open Lwt_result_syntax in Error_monad.protect (fun () -> - let* (heads_stream, stopper) = Shell_services.Monitor.heads cctxt `Main in + let* heads_stream, stopper = Shell_services.Monitor.heads cctxt `Main in let rec loop () : unit tzresult Lwt.t = let*! block_hash_and_header = Lwt_stream.get heads_stream in match block_hash_and_header with diff --git a/src/proto_012_Psithaca/lib_client_commands/client_proto_utils_commands.ml b/src/proto_012_Psithaca/lib_client_commands/client_proto_utils_commands.ml index 7f57941fb389..c661dbd2eb6b 100644 --- a/src/proto_012_Psithaca/lib_client_commands/client_proto_utils_commands.ml +++ b/src/proto_012_Psithaca/lib_client_commands/client_proto_utils_commands.ml @@ -133,8 +133,7 @@ let commands () = return the signed block." no_options (prefixes ["sign"; "block"] - @@ unsigned_block_header_param - @@ prefixes ["for"] + @@ unsigned_block_header_param @@ prefixes ["for"] @@ Client_keys.Public_key_hash.source_param ~name:"delegate" ~desc:"signing delegate" diff --git a/src/proto_012_Psithaca/lib_client_sapling/client_sapling_commands.ml b/src/proto_012_Psithaca/lib_client_sapling/client_sapling_commands.ml index 3a268e4a37a3..57ed4456d73a 100644 --- a/src/proto_012_Psithaca/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_012_Psithaca/lib_client_sapling/client_sapling_commands.ml @@ -695,9 +695,7 @@ let commands () = path >>= fun () -> (* TODO must pass contract address for now *) - let (_, contract) = - WithExceptions.Option.get ~loc:__LOC__ contract_opt - in + let _, contract = WithExceptions.Option.get ~loc:__LOC__ contract_opt in Context.Client_state.register cctxt ~default_memo_size diff --git a/src/proto_012_Psithaca/lib_client_sapling/context.ml b/src/proto_012_Psithaca/lib_client_sapling/context.ml index 3ecade590557..07ac678504ef 100644 --- a/src/proto_012_Psithaca/lib_client_sapling/context.ml +++ b/src/proto_012_Psithaca/lib_client_sapling/context.ml @@ -313,7 +313,7 @@ module Contract_state = struct let vks = Accounts.fold (fun account acc -> Account.(account.vk) :: acc) accounts [] in - let (size, _) = Storage.size storage in + let size, _ = Storage.size storage in let rec aux pos accounts = if pos < size then (* try to decrypt each inputs with all vks *) @@ -333,7 +333,7 @@ module Contract_state = struct | _ -> assert false (* got more than one decrypting key *) else accounts in - let (current_size, _) = Storage.size state.storage in + let current_size, _ = Storage.size state.storage in let accounts = aux current_size accounts in {accounts; storage} @@ -425,7 +425,7 @@ module Client_state = struct let sync_and_scan cctxt contract = load cctxt >>=? fun state -> find cctxt contract state >>=? fun contract_state -> - let (cm_pos, nf_pos) = Storage.size contract_state.storage in + let cm_pos, nf_pos = Storage.size contract_state.storage in get_diff cctxt contract cm_pos nf_pos >>=? fun diff -> let contract_state = Contract_state.update_storage contract_state diff in let state = Map.add contract contract_state state in diff --git a/src/proto_012_Psithaca/lib_client_sapling/wallet.ml b/src/proto_012_Psithaca/lib_client_sapling/wallet.ml index e970fd0b2a8a..c5df62f580c8 100644 --- a/src/proto_012_Psithaca/lib_client_sapling/wallet.ml +++ b/src/proto_012_Psithaca/lib_client_sapling/wallet.ml @@ -114,7 +114,7 @@ let new_address (cctxt : #Client_context.full) name index_opt = return (Viewing_key.of_sk sk) >>=? fun vk -> (* Viewing_key.new_address finds the smallest index greater or equal to [index] that generates a correct address. *) - let (corrected_index, address) = Viewing_key.new_address vk index in + let corrected_index, address = Viewing_key.new_address vk index in Sapling_key.update cctxt name diff --git a/src/proto_012_Psithaca/lib_delegate/baking_actions.ml b/src/proto_012_Psithaca/lib_delegate/baking_actions.ml index d0fea8c8347e..f735a615cb34 100644 --- a/src/proto_012_Psithaca/lib_delegate/baking_actions.ml +++ b/src/proto_012_Psithaca/lib_delegate/baking_actions.ml @@ -229,7 +229,7 @@ let inject_block ~state_recorder state block_to_bake ~updated_state = >>?= fun timestamp -> let external_operation_source = state.global_state.config.extra_operations in Operations_source.retrieve external_operation_source >>= fun extern_ops -> - let (simulation_kind, payload_round) = + let simulation_kind, payload_round = match kind with | Fresh pool -> let pool = @@ -516,7 +516,7 @@ let prepare_waiting_for_quorum state = (consensus_threshold, get_consensus_operation_voting_power, candidate) let start_waiting_for_preendorsement_quorum state = - let (consensus_threshold, get_preendorsement_voting_power, candidate) = + let consensus_threshold, get_preendorsement_voting_power, candidate = prepare_waiting_for_quorum state in let operation_worker = state.global_state.operation_worker in @@ -527,7 +527,7 @@ let start_waiting_for_preendorsement_quorum state = candidate let start_waiting_for_endorsement_quorum state = - let (consensus_threshold, get_endorsement_voting_power, candidate) = + let consensus_threshold, get_endorsement_voting_power, candidate = prepare_waiting_for_quorum state in let operation_worker = state.global_state.operation_worker in diff --git a/src/proto_012_Psithaca/lib_delegate/baking_cache.ml b/src/proto_012_Psithaca/lib_delegate/baking_cache.ml index 4ce45c7b7a9d..af2ac36dc1fc 100644 --- a/src/proto_012_Psithaca/lib_delegate/baking_cache.ml +++ b/src/proto_012_Psithaca/lib_delegate/baking_cache.ml @@ -67,12 +67,12 @@ module Round_cache_key = struct { predecessor_timestamp = pred_t; predecessor_round = pred_r; - time_interval = (t_beg, t_end); + time_interval = t_beg, t_end; } { predecessor_timestamp = pred_t'; predecessor_round = pred_r'; - time_interval = (t_beg', t_end'); + time_interval = t_beg', t_end'; } = Timestamp.(pred_t = pred_t') && Round.(pred_r = pred_r') diff --git a/src/proto_012_Psithaca/lib_delegate/baking_commands.ml b/src/proto_012_Psithaca/lib_delegate/baking_commands.ml index 98a7b69a89c8..13b41c6971c2 100644 --- a/src/proto_012_Psithaca/lib_delegate/baking_commands.ml +++ b/src/proto_012_Psithaca/lib_delegate/baking_commands.ml @@ -164,7 +164,7 @@ let get_delegates (cctxt : Protocol_client_context.full) List.map_es (fun pkh -> Client_keys.get_key cctxt pkh >>=? function - | (alias, pk, sk_uri) -> return (proj_delegate (alias, pkh, pk, sk_uri))) + | alias, pk, sk_uri -> return (proj_delegate (alias, pkh, pk, sk_uri))) pkhs) >>=? fun delegates -> Tezos_signer_backends.Encrypted.decrypt_list diff --git a/src/proto_012_Psithaca/lib_delegate/baking_lib.ml b/src/proto_012_Psithaca/lib_delegate/baking_lib.ml index 275575488a8b..1c920a94595b 100644 --- a/src/proto_012_Psithaca/lib_delegate/baking_lib.ml +++ b/src/proto_012_Psithaca/lib_delegate/baking_lib.ml @@ -246,7 +246,7 @@ let propose_at_next_level ~minimal_timestamp state = cctxt#message "Proposal injected" >>= fun () -> return state let endorsement_quorum state = - let (power, endorsements) = state_endorsing_power state in + let power, endorsements = state_endorsing_power state in if Compare.Int.( power >= state.global_state.constants.parametric.consensus_threshold) diff --git a/src/proto_012_Psithaca/lib_delegate/baking_nonces.ml b/src/proto_012_Psithaca/lib_delegate/baking_nonces.ml index 09c649c5473c..d8ecd4c66191 100644 --- a/src/proto_012_Psithaca/lib_delegate/baking_nonces.ml +++ b/src/proto_012_Psithaca/lib_delegate/baking_nonces.ml @@ -154,8 +154,7 @@ let blocks_from_current_cycle {cctxt; chain; _} block ?(offset = 0l) () = let blocks = List.drop_n (length - Int32.to_int (Raw_level.diff last first)) head in - if Int32.equal level (Raw_level.to_int32 last) then - return (hash :: blocks) + if Int32.equal level (Raw_level.to_int32 last) then return (hash :: blocks) else return blocks let get_unrevealed_nonces ({cctxt; chain; _} as state) nonces = diff --git a/src/proto_012_Psithaca/lib_delegate/baking_scheduling.ml b/src/proto_012_Psithaca/lib_delegate/baking_scheduling.ml index 0fe32483f80f..5f5bbcd51405 100644 --- a/src/proto_012_Psithaca/lib_delegate/baking_scheduling.ml +++ b/src/proto_012_Psithaca/lib_delegate/baking_scheduling.ml @@ -48,7 +48,7 @@ type events = Lwt.t let create_loop_state block_stream operation_worker = - let (future_block_stream, push_future_block) = Lwt_stream.create () in + let future_block_stream, push_future_block = Lwt_stream.create () in { block_stream; qc_stream = Operation_worker.get_quorum_event_stream operation_worker; @@ -513,12 +513,12 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t let next_round = compute_next_round_time state in compute_next_potential_baking_time_at_next_level state >>= fun next_baking -> match (next_round, next_baking) with - | (None, None) -> + | None, None -> Events.(emit waiting_for_new_head ()) >>= fun () -> return (Lwt_utils.never_ending () >>= fun () -> assert false) (* We have no slot at the next level in the near future, we will patiently wait for the next round. *) - | (Some next_round, None) -> ( + | Some next_round, None -> ( (* If there is an elected block, then we make the assumption that the bakers at the next level have also received an endorsement quorum, and we delay a bit injecting at the next @@ -529,7 +529,7 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t | Some _elected_block -> delay_next_round_timeout next_round) (* There is no timestamp for a successor round but there is for a future baking slot, we will wait to bake. *) - | (None, Some next_baking) -> wait_baking_time_next_level next_baking + | None, Some next_baking -> wait_baking_time_next_level next_baking (* We choose the earliest timestamp between waiting to bake and waiting for the next round. *) | ( Some ((next_round_time, next_round) as next_round_info), diff --git a/src/proto_012_Psithaca/lib_delegate/baking_state.ml b/src/proto_012_Psithaca/lib_delegate/baking_state.ml index 88a7f80e5b0b..1ce1daeeb575 100644 --- a/src/proto_012_Psithaca/lib_delegate/baking_state.ml +++ b/src/proto_012_Psithaca/lib_delegate/baking_state.ml @@ -483,18 +483,18 @@ let may_record_new_state ~previous_state ~new_state = if Compare.Int32.(new_current_level = previous_current_level) then let is_new_locked_round_consistent = match (new_locked_round, previous_locked_round) with - | (None, None) -> true - | (Some _, None) -> true - | (None, Some _) -> false - | (Some new_locked_round, Some previous_locked_round) -> + | None, None -> true + | Some _, None -> true + | None, Some _ -> false + | Some new_locked_round, Some previous_locked_round -> Round.(new_locked_round.round >= previous_locked_round.round) in let is_new_endorsable_payload_consistent = match (new_endorsable_payload, previous_endorsable_payload) with - | (None, None) -> true - | (Some _, None) -> true - | (None, Some _) -> false - | (Some new_endorsable_payload, Some previous_endorsable_payload) -> + | None, None -> true + | Some _, None -> true + | None, Some _ -> false + | Some new_endorsable_payload, Some previous_endorsable_payload -> Round.( new_endorsable_payload.proposal.block.round >= previous_endorsable_payload.proposal.block.round) @@ -589,7 +589,7 @@ let compute_delegate_slots (cctxt : Protocol_client_context.full) delegates (* FIXME? should we not take `Head 0 ? *) Plugin.RPC.Validators.get cctxt (chain, `Head 0) ~levels:[level] >>=? fun endorsing_rights -> - let (own_delegate_slots, all_delegate_slots) = + let own_delegate_slots, all_delegate_slots = List.fold_left (fun (own_map, all_map) slot -> let {Plugin.RPC.Validators.delegate; slots; _} = slot in diff --git a/src/proto_012_Psithaca/lib_delegate/block_forge.ml b/src/proto_012_Psithaca/lib_delegate/block_forge.ml index 9e53d2d645b0..9b72d39e16c7 100644 --- a/src/proto_012_Psithaca/lib_delegate/block_forge.ml +++ b/src/proto_012_Psithaca/lib_delegate/block_forge.ml @@ -359,13 +359,12 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~pred_info | Apply _ as x -> x in (match (simulation_mode, simulation_kind) with - | (Baking_state.Node, Filter operation_pool) -> - filter_via_node ~operation_pool - | (Node, Apply {ordered_pool; payload_hash}) -> + | Baking_state.Node, Filter operation_pool -> filter_via_node ~operation_pool + | Node, Apply {ordered_pool; payload_hash} -> apply_via_node ~ordered_pool ~payload_hash - | (Local context_index, Filter operation_pool) -> + | Local context_index, Filter operation_pool -> filter_with_context ~context_index ~operation_pool - | (Local context_index, Apply {ordered_pool; payload_hash}) -> + | Local context_index, Apply {ordered_pool; payload_hash} -> apply_with_context ~context_index ~ordered_pool ~payload_hash) >>=? fun (shell_header, operations, payload_hash) -> Baking_pow.mine diff --git a/src/proto_012_Psithaca/lib_delegate/client_baking_blocks.ml b/src/proto_012_Psithaca/lib_delegate/client_baking_blocks.ml index 5296233d2656..b43c7f98ba7b 100644 --- a/src/proto_012_Psithaca/lib_delegate/client_baking_blocks.ml +++ b/src/proto_012_Psithaca/lib_delegate/client_baking_blocks.ml @@ -183,6 +183,5 @@ let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = let blocks = List.drop_n (length - Int32.to_int (Raw_level.diff last first)) head in - if Int32.equal level (Raw_level.to_int32 last) then - return (hash :: blocks) + if Int32.equal level (Raw_level.to_int32 last) then return (hash :: blocks) else return blocks diff --git a/src/proto_012_Psithaca/lib_delegate/client_baking_denunciation.ml b/src/proto_012_Psithaca/lib_delegate/client_baking_denunciation.ml index 280718737ff0..38209f7c5e58 100644 --- a/src/proto_012_Psithaca/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_012_Psithaca/lib_delegate/client_baking_denunciation.ml @@ -117,8 +117,8 @@ let get_block_offset level = let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) (op : kind Operation.t) = match (op_kind, op.protocol_data.contents) with - | (Preendorsement, Single (Preendorsement consensus_content)) - | (Endorsement, Single (Endorsement consensus_content)) -> + | Preendorsement, Single (Preendorsement consensus_content) + | Endorsement, Single (Endorsement consensus_content) -> consensus_content.block_payload_hash | _ -> . @@ -155,10 +155,10 @@ let process_consensus_op (type kind) cctxt get_payload_hash op_kind existing_op <> get_payload_hash op_kind new_op) -> (* same level and round, and different payload hash for this slot *) - let (new_op_hash, existing_op_hash) = + let new_op_hash, existing_op_hash = (Operation.hash new_op, Operation.hash existing_op) in - let (op1, op2) = + let op1, op2 = if Operation_hash.(new_op_hash < existing_op_hash) then (new_op, existing_op) else (existing_op, new_op) @@ -176,7 +176,7 @@ let process_consensus_op (type kind) cctxt () >>=? fun bytes -> let bytes = Signature.concat bytes Signature.zero in - let (double_op_detected, double_op_denounced) = + let double_op_detected, double_op_denounced = Events.( match op_kind with | Endorsement -> @@ -286,7 +286,7 @@ let process_block (cctxt : #Protocol_client_context.full) state context_block_header cctxt ~chain new_hash >>=? fun bh2 -> let hash1 = Block_header.hash bh1 in let hash2 = Block_header.hash bh2 in - let (bh1, bh2) = + let bh1, bh2 = if Block_hash.(hash1 < hash2) then (bh1, bh2) else (bh2, bh1) in (* If the blocks are on different chains then skip it *) diff --git a/src/proto_012_Psithaca/lib_delegate/operation_pool.ml b/src/proto_012_Psithaca/lib_delegate/operation_pool.ml index 33c0de05e90e..1ebe2952d144 100644 --- a/src/proto_012_Psithaca/lib_delegate/operation_pool.ml +++ b/src/proto_012_Psithaca/lib_delegate/operation_pool.ml @@ -47,9 +47,9 @@ module Prioritized_operation = struct let compare_priority t1 t2 = match (t1, t2) with - | (High _, Low _) -> 1 - | (Low _, High _) -> -1 - | (Low _, Low _) | (High _, High _) -> 0 + | High _, Low _ -> 1 + | Low _, High _ -> -1 + | Low _, Low _ | High _, High _ -> 0 let compare a b = let c = compare_priority a b in @@ -203,8 +203,7 @@ let filter_with_relevant_consensus_ops ~(endorsement_filter : consensus_filter) (fun {protocol_data; _} -> match (protocol_data, preendorsement_filter) with (* 1a. Remove preendorsements. *) - | (Operation_data {contents = Single (Preendorsement _); _}, None) -> - false + | Operation_data {contents = Single (Preendorsement _); _}, None -> false (* 1b. Filter preendorsements. *) | ( Operation_data { @@ -305,7 +304,7 @@ let ordered_pool_of_payload ~consensus_operations let extract_operations_of_list_list = function | [consensus; votes_payload; anonymous_payload; managers_payload] -> - let (preendorsements, endorsements) = + let preendorsements, endorsements = List.fold_left (fun ( (preendorsements : Kind.preendorsement Operation.t list), (endorsements : Kind.endorsement Operation.t list) ) diff --git a/src/proto_012_Psithaca/lib_delegate/operation_worker.ml b/src/proto_012_Psithaca/lib_delegate/operation_worker.ml index ec6219d86be5..b30102afe0d8 100644 --- a/src/proto_012_Psithaca/lib_delegate/operation_worker.ml +++ b/src/proto_012_Psithaca/lib_delegate/operation_worker.ml @@ -241,7 +241,7 @@ let monitor_operations (cctxt : #Protocol_client_context.full) = let make_initial_state ?(monitor_node_operations = true) () = let qc_event_stream = - let (stream, push) = Lwt_stream.create () in + let stream, push = Lwt_stream.create () in {stream; push} in let canceler = Lwt_canceler.create () in @@ -280,7 +280,7 @@ let update_monitoring ?(should_lock = true) state ops = _; } as proposal_watched)) -> let preendorsements = Operation_pool.filter_preendorsements ops in - let (preendorsements_count, voting_power) = + let preendorsements_count, voting_power = List.fold_left (fun (count, power) (op : Kind.preendorsement Operation.t) -> let { @@ -340,7 +340,7 @@ let update_monitoring ?(should_lock = true) state ops = _; } as proposal_watched)) -> let endorsements = Operation_pool.filter_endorsements ops in - let (endorsements_count, voting_power) = + let endorsements_count, voting_power = List.fold_left (fun (count, power) (op : Kind.endorsement Operation.t) -> let { diff --git a/src/proto_012_Psithaca/lib_delegate/state_transitions.ml b/src/proto_012_Psithaca/lib_delegate/state_transitions.ml index 4f3930606803..01c7dba40f90 100644 --- a/src/proto_012_Psithaca/lib_delegate/state_transitions.ml +++ b/src/proto_012_Psithaca/lib_delegate/state_transitions.ml @@ -162,14 +162,14 @@ let may_update_endorsable_payload_with_internal_pqc state match (new_proposal.block.prequorum, state.level_state.endorsable_payload) with - | (None, _) -> + | None, _ -> (* The proposal does not contain a PQC: no need to update *) state - | (Some {round = new_round; _}, Some {prequorum = {round = old_round; _}; _}) + | Some {round = new_round; _}, Some {prequorum = {round = old_round; _}; _} when Round.(new_round < old_round) -> (* The proposal pqc is outdated, do not update *) state - | (Some better_prequorum, _) -> + | Some better_prequorum, _ -> assert ( Block_payload_hash.( better_prequorum.block_payload_hash = new_proposal.block.payload_hash)) ; @@ -307,17 +307,17 @@ and may_switch_branch state new_proposal = in let current_endorsable_payload = state.level_state.endorsable_payload in match (current_endorsable_payload, new_proposal.block.prequorum) with - | (None, Some _) | (None, None) -> + | None, Some _ | None, None -> Events.(emit branch_proposal_has_better_fitness ()) >>= fun () -> (* The new branch contains a PQC (and we do not) or a better fitness, we switch. *) switch_branch state - | (Some _, None) -> + | Some _, None -> (* We have a better PQC, we don't switch as we are able to propose a better chain if we stay on our current one. *) Events.(emit branch_proposal_has_no_prequorum ()) >>= fun () -> do_nothing state - | (Some {prequorum = current_pqc; _}, Some new_pqc) -> + | Some {prequorum = current_pqc; _}, Some new_pqc -> if Round.(current_pqc.round > new_pqc.round) then Events.(emit branch_proposal_has_lower_prequorum ()) >>= fun () -> (* The other's branch PQC is lower than ours, do not @@ -557,11 +557,11 @@ let time_to_bake state at_round = at_round in match (state.level_state.elected_block, round_proposer_opt) with - | (None, _) | (_, None) -> + | None, _ | _, None -> (* Unreachable: the [Time_to_bake_next_level] event can only be triggered when we have a slot and an elected block *) assert false - | (Some elected_block, Some (delegate, _)) -> + | Some elected_block, Some (delegate, _) -> let endorsements = elected_block.endorsement_qc in let new_level_state = {state.level_state with next_level_proposed_round = Some at_round} @@ -681,15 +681,15 @@ let step (state : Baking_state.t) (event : Baking_state.event) : Events.(emit step_current_phase (phase, event)) >>= fun () -> match (phase, event) with (* Handle timeouts *) - | (_, Timeout (End_of_round {ending_round})) -> + | _, Timeout (End_of_round {ending_round}) -> (* If the round is ending, stop everything currently going on and increment the round. *) end_of_round state ending_round - | (_, Timeout (Time_to_bake_next_level {at_round})) -> + | _, Timeout (Time_to_bake_next_level {at_round}) -> (* If it is time to bake the next level, stop everything currently going on and propose the next level block *) time_to_bake state at_round - | (Idle, New_proposal block_info) -> + | Idle, New_proposal block_info -> Events.( emit new_head @@ -697,8 +697,8 @@ let step (state : Baking_state.t) (event : Baking_state.event) : block_info.block.shell.level, block_info.block.round )) >>= fun () -> handle_new_proposal state block_info - | (Awaiting_endorsements, New_proposal block_info) - | (Awaiting_preendorsements, New_proposal block_info) -> + | Awaiting_endorsements, New_proposal block_info + | Awaiting_preendorsements, New_proposal block_info -> Events.( emit new_head @@ -718,8 +718,8 @@ let step (state : Baking_state.t) (event : Baking_state.event) : Quorum_reached (candidate, _voting_power, endorsement_qc) ) -> quorum_reached_when_waiting_endorsements state candidate endorsement_qc (* Unreachable cases *) - | (Idle, (Prequorum_reached _ | Quorum_reached _)) - | (Awaiting_preendorsements, Quorum_reached _) - | (Awaiting_endorsements, Prequorum_reached _) -> + | Idle, (Prequorum_reached _ | Quorum_reached _) + | Awaiting_preendorsements, Quorum_reached _ + | Awaiting_endorsements, Prequorum_reached _ -> (* This cannot/should not happen *) do_nothing state diff --git a/src/proto_012_Psithaca/lib_delegate/test/mockup_simulator/mockup_simulator.ml b/src/proto_012_Psithaca/lib_delegate/test/mockup_simulator/mockup_simulator.ml index cb61231de37f..9388eb3d77d5 100644 --- a/src/proto_012_Psithaca/lib_delegate/test/mockup_simulator/mockup_simulator.ml +++ b/src/proto_012_Psithaca/lib_delegate/test/mockup_simulator/mockup_simulator.ml @@ -153,10 +153,10 @@ let locate_blocks (state : state) | None -> failwith "locate_blocks: can't find the block %a" Block_hash.pp hash | Some chain0 -> - let (_, chain) = List.split_n rel chain0 in + let _, chain = List.split_n rel chain0 in return chain) | `Head rel -> - let (_, chain) = List.split_n rel state.chain in + let _, chain = List.split_n rel state.chain in return chain | `Level _ -> failwith "locate_blocks: `Level block spec not handled" | `Genesis -> failwith "locate_blocks: `Genesis block spec net handled" @@ -172,7 +172,7 @@ let locate_block (state : state) (** Return the collection of live blocks for a given block identifier. *) let live_blocks (state : state) block = locate_blocks state block >>=? fun chain -> - let (segment, _) = List.split_n state.live_depth chain in + let segment, _ = List.split_n state.live_depth chain in return (List.fold_left (fun set ({rpc_context; _} : block) -> @@ -686,7 +686,7 @@ let rec listener ~(user_hooks : (module Hooks)) ~state ~broadcast_pipe = let create_fake_node_state ~i ~live_depth ~(genesis_block : Block_header.t * Environment_context.rpc_context) ~global_chain_table ~broadcast_pipes = - let (block_header0, rpc_context0) = genesis_block in + let block_header0, rpc_context0 = genesis_block in parse_protocol_data block_header0.protocol_data >>=? fun protocol_data -> let genesis0 = { @@ -851,7 +851,7 @@ let deduce_baker_sk list) (total_accounts : int) (level : int) : Signature.secret_key tzresult Lwt.t = (match (total_accounts, level) with - | (_, 0) -> return 0 (* apparently this doesn't really matter *) + | _, 0 -> return 0 (* apparently this doesn't really matter *) | _ -> failwith "cannot deduce baker for a genesis block, total accounts = %d, level = \ @@ -859,7 +859,7 @@ let deduce_baker_sk total_accounts level) >>=? fun baker_index -> - let (_, secret) = + let _, secret = List.nth accounts_with_secrets baker_index |> WithExceptions.Option.get ~loc:__LOC__ in @@ -1081,7 +1081,7 @@ let run ?(config = default_config) bakers_spec = (take_third (List.fold_left (fun (i, delegates_acc, ms) (n, user_hooks) -> - let (delegates, leftover_delegates) = + let delegates, leftover_delegates = List.split_n n delegates_acc in let m = diff --git a/src/proto_012_Psithaca/lib_delegate/test/test_scenario.ml b/src/proto_012_Psithaca/lib_delegate/test/test_scenario.ml index d8cd9b29c9f9..ab64d4f472ec 100644 --- a/src/proto_012_Psithaca/lib_delegate/test/test_scenario.ml +++ b/src/proto_012_Psithaca/lib_delegate/test/test_scenario.ml @@ -83,12 +83,12 @@ let test_scenario_t1 () = let check_block_before_processing ~level ~round ~block_hash ~block_header ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = (match (!b_endorsed, level, round) with - | (false, 1l, 0l) -> + | false, 1l, 0l -> (* If any of the checks fails the whole scenario will fail. *) check_block_signature ~block_hash ~block_header ~public_key:bootstrap1 >>=? fun () -> save_proposal_payload ~protocol_data ~var:original_proposal - | (true, 1l, 1l) -> + | true, 1l, 1l -> check_block_signature ~block_hash ~block_header ~public_key:bootstrap2 >>=? fun () -> verify_payload_hash @@ -152,7 +152,7 @@ let test_scenario_t2 () = (* Here we test that the only block that B observes is its own proposal for level 1 at round 1. *) match (level, round) with - | (1l, 1l) -> + | 1l, 1l -> check_block_signature ~block_hash ~block_header ~public_key:bootstrap2 >>=? fun () -> b_proposed := true ; @@ -221,7 +221,7 @@ let test_scenario_t3 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = match (level, round) with - | (1l, 2l) -> + | 1l, 2l -> check_block_signature ~block_hash ~block_header ~public_key:bootstrap2 >>=? fun () -> we_are_done := true ; @@ -266,7 +266,7 @@ let test_scenario_t3 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = match (level, round) with - | (1l, 0l) -> + | 1l, 0l -> check_block_signature ~block_hash ~block_header ~public_key:bootstrap3 >>=? fun () -> save_proposal_payload ~protocol_data ~var:original_proposal @@ -296,7 +296,7 @@ let test_scenario_t3 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (level, round) with - | (1l, 1l) -> + | 1l, 1l -> return (block_hash, block_header, operations, [Block; Pass; Pass; Pass]) | _ -> @@ -365,7 +365,7 @@ let test_scenario_f1 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (!c_proposed_l1_r0, !d_proposed_l1_r1, level, round) with - | (true, true, 2l, 0l) -> + | true, true, 2l, 0l -> check_block_signature ~block_hash ~block_header ~public_key:bootstrap1 >>=? fun () -> (a_proposed_l2_r0 := true ; @@ -380,7 +380,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Block; Block; Block]) + | true, false -> return (op_hash, op, [Pass; Block; Block; Block]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -390,7 +390,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Pass; Block; Block]) + | true, false -> return (op_hash, op, [Pass; Pass; Block; Block]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -401,7 +401,7 @@ let test_scenario_f1 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (!c_proposed_l1_r0, !d_proposed_l1_r1, level, round) with - | (false, false, 1l, 0l) -> + | false, false, 1l, 0l -> check_block_signature ~block_hash ~block_header ~public_key:bootstrap3 >>=? fun () -> (c_proposed_l1_r0 := true ; @@ -416,7 +416,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Block; Pass; Block]) + | true, false -> return (op_hash, op, [Pass; Block; Pass; Block]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -427,7 +427,7 @@ let test_scenario_f1 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (!d_proposed_l1_r1, level, round) with - | (false, 1l, 1l) -> + | false, 1l, 1l -> check_block_signature ~block_hash ~block_header ~public_key:bootstrap4 >>=? fun () -> (d_proposed_l1_r1 := true ; @@ -442,7 +442,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Block; Block; Pass]) + | true, false -> return (op_hash, op, [Pass; Block; Block; Pass]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -489,9 +489,9 @@ let test_scenario_f2 () = ~protocol_data:_ = let propagation_vector = match (level, round) with - | (1l, 0l) -> [Pass; Pass; Pass; Pass] - | (2l, 0l) -> [Pass; Block; Block; Block] - | (2l, 4l) -> + | 1l, 0l -> [Pass; Pass; Pass; Pass] + | 2l, 0l -> [Pass; Block; Block; Block] + | 2l, 4l -> proposal_2_4_observed := true ; [Pass; Pass; Pass; Pass] | _ -> [Block; Block; Block; Block] @@ -714,7 +714,7 @@ let test_scenario_m4 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (level, round) with - | (1l, 0l) -> + | 1l, 0l -> check_block_signature ~block_hash ~block_header ~public_key:bootstrap1 >>=? fun () -> return @@ -805,7 +805,7 @@ let test_scenario_m5 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (level, round) with - | (1l, 0l) -> + | 1l, 0l -> check_block_signature ~block_hash ~block_header ~public_key:bootstrap1 >>=? fun () -> return @@ -881,7 +881,7 @@ let test_scenario_m6 () = ~protocol_data:_ = let propagation_vector = match (level, round) with - | (2l, 0l) -> [Pass; Block; Block; Block] + | 2l, 0l -> [Pass; Block; Block; Block] | _ -> [Pass; Pass; Pass; Pass] in return (block_hash, block_header, operations, propagation_vector) @@ -912,8 +912,8 @@ let test_scenario_m6 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data = (match (level, round) with - | (1l, 1l) -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | (2l, 1l) -> + | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] + | 2l, 1l -> save_proposal_payload ~protocol_data ~var:b_proposal_2_1 >>=? fun () -> return [Pass; Pass; Pass; Pass] | _ -> return [Pass; Pass; Pass; Pass]) @@ -1009,7 +1009,7 @@ let test_scenario_m7 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data = (match (level, round) with - | (2l, 1l) -> save_proposal_payload ~protocol_data ~var:a_proposal_2_1 + | 2l, 1l -> save_proposal_payload ~protocol_data ~var:a_proposal_2_1 | _ -> return_unit) >>=? fun () -> return (block_hash, block_header, operations, [Pass; Pass; Pass; Pass]) @@ -1033,8 +1033,8 @@ let test_scenario_m7 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = (match (level, round) with - | (1l, 1l) -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | (2l, 0l) -> return [Block; Pass; Pass; Pass] + | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] + | 2l, 0l -> return [Block; Pass; Pass; Pass] | _ -> return [Pass; Pass; Pass; Pass]) >>=? fun propagation_vector -> return (block_hash, block_header, operations, propagation_vector) @@ -1049,9 +1049,9 @@ let test_scenario_m7 () = match (is_a10_endorsement, level2_preendorsement, level2_endorsement) with - | (true, _, _) -> [Pass; Block; Block; Block] - | (_, true, _) | (_, _, true) -> [Block; Block; Block; Block] - | (_, _, _) -> [Pass; Pass; Pass; Pass] + | true, _, _ -> [Pass; Block; Block; Block] + | _, true, _ | _, _, true -> [Block; Block; Block; Block] + | _, _, _ -> [Pass; Pass; Pass; Pass] in return (op_hash, op, propagation_vector) @@ -1072,7 +1072,7 @@ let test_scenario_m7 () = let check_chain_after_processing ~level ~round ~chain:_ = match (level, round) with - | (2l, 1l) -> + | 2l, 1l -> c_received_2_1 := true ; return_unit | _ -> return_unit @@ -1090,10 +1090,9 @@ let test_scenario_m7 () = level2_preendorsement, level2_endorsement ) with - | (true, _, _, _) -> [Pass; Block; Block; Block] - | (_, false, true, _) | (_, false, _, true) -> - [Block; Block; Block; Block] - | (_, _, _, _) -> [Pass; Pass; Pass; Pass] + | true, _, _, _ -> [Pass; Block; Block; Block] + | _, false, true, _ | _, false, _, true -> [Block; Block; Block; Block] + | _, _, _, _ -> [Pass; Pass; Pass; Pass] in return (op_hash, op, propagation_vector) @@ -1114,7 +1113,7 @@ let test_scenario_m7 () = let check_chain_after_processing ~level ~round ~chain:_ = match (level, round) with - | (2l, 1l) -> + | 2l, 1l -> d_received_2_1 := true ; return_unit | _ -> return_unit @@ -1132,10 +1131,9 @@ let test_scenario_m7 () = level2_preendorsement, level2_endorsement ) with - | (true, _, _, _) -> [Pass; Block; Block; Block] - | (_, false, true, _) | (_, false, _, true) -> - [Block; Block; Block; Block] - | (_, _, _, _) -> [Pass; Pass; Pass; Pass] + | true, _, _, _ -> [Pass; Block; Block; Block] + | _, false, true, _ | _, false, _, true -> [Block; Block; Block; Block] + | _, _, _, _ -> [Pass; Pass; Pass; Pass] in return (op_hash, op, propagation_vector) @@ -1230,8 +1228,8 @@ let test_scenario_m8 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data = (match (level, round) with - | (1l, 1l) -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | (2l, 0l) -> + | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] + | 2l, 0l -> save_proposal_payload ~protocol_data ~var:b_proposal_2_0 >>=? fun () -> return [Block; Pass; Pass; Pass] | _ -> return [Pass; Pass; Pass; Pass]) @@ -1251,7 +1249,7 @@ let test_scenario_m8 () = ~protocol_data:_ = let propagation_vector = match (level, round) with - | (2l, 1l) -> [Block; Pass; Pass; Pass] + | 2l, 1l -> [Block; Pass; Pass; Pass] | _ -> [Pass; Pass; Pass; Pass] in return (block_hash, block_header, operations, propagation_vector) diff --git a/src/proto_012_Psithaca/lib_plugin/plugin.ml b/src/proto_012_Psithaca/lib_plugin/plugin.ml index 7148ee2ac978..31623a645046 100644 --- a/src/proto_012_Psithaca/lib_plugin/plugin.ml +++ b/src/proto_012_Psithaca/lib_plugin/plugin.ml @@ -607,7 +607,7 @@ module Mempool = struct (** Returns the weight of an operation, i.e. the fees w.r.t the gas and size consumption in the block. *) let weight_manager_operation ~validation_state ?size ~fee ~gas op = - let (weight, _resources) = + let weight, _resources = weight_and_resources_manager_operation ~validation_state ?size @@ -632,7 +632,7 @@ module Mempool = struct match validation_state with | None -> `Weight_ok (`No_replace, []) | Some validation_state -> ( - let (weight, op_resources) = + let weight, op_resources = weight_and_resources_manager_operation ~validation_state ~fee @@ -923,7 +923,7 @@ module Mempool = struct match (grandparent_level_start, validation_state_before, round_zero_duration) with - | (None, _, _) | (_, None, _) | (_, _, None) -> Lwt.return_true + | None, _, _ | _, None, _ | _, _, None -> Lwt.return_true | ( Some grandparent_level_start, Some validation_state_before, Some round_zero_duration ) -> ( @@ -1861,8 +1861,8 @@ module RPC = struct type a s. (a, s) Script_typed_ir.stack_ty * (a * s) -> (Script.expr * string option) list tzresult Lwt.t = function - | (Bot_t, (EmptyCell, EmptyCell)) -> return_nil - | (Item_t (ty, rest_ty, annot), (v, rest)) -> + | Bot_t, (EmptyCell, EmptyCell) -> return_nil + | Item_t (ty, rest_ty, annot), (v, rest) -> Script_ir_translator.unparse_data ctxt Unparsing_mode.unparsing_mode @@ -2290,12 +2290,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with @@ -2356,12 +2356,12 @@ module RPC = struct let code = Script.lazy_expr code in originate_dummy_contract ctxt {storage; code} balance >>=? fun (ctxt, dummy_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (dummy_contract, dummy_contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (dummy_contract, dummy_contract) in let gas = match gas with @@ -2434,12 +2434,12 @@ module RPC = struct (View_helpers.make_viewer_script ty) Tez.zero >>=? fun (ctxt, viewer_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (contract, contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (contract, contract) in let gas = Option.value @@ -2543,7 +2543,7 @@ module RPC = struct storage; } in - let (size, cost) = Script_ir_translator.script_size script in + let size, cost = Script_ir_translator.script_size script in Gas.consume ctxt cost >>?= fun _ctxt -> return @@ size) ; Registration.register0 @@ -3014,8 +3014,8 @@ module RPC = struct in let ops = match (sourcePubKey, revealed) with - | (None, _) | (_, Some _) -> ops - | (Some pk, None) -> + | None, _ | _, Some _ -> ops + | Some pk, None -> let operation = Reveal pk in Contents (Manager_operation @@ -3243,8 +3243,8 @@ module RPC = struct let requested_levels ~default_level ctxt cycles levels = match (levels, cycles) with - | ([], []) -> [default_level] - | (levels, cycles) -> + | [], [] -> [default_level] + | levels, cycles -> (* explicitly fail when requested levels or cycle are in the past... or too far in the future... TODO-TB: this old comment (from version Alpha) conflicts with diff --git a/src/proto_012_Psithaca/lib_plugin/test/generators.ml b/src/proto_012_Psithaca/lib_plugin/test/generators.ml index 2ca5688e7284..38d6e4e13509 100644 --- a/src/proto_012_Psithaca/lib_plugin/test/generators.ml +++ b/src/proto_012_Psithaca/lib_plugin/test/generators.ml @@ -51,7 +51,7 @@ let dummy_manager_op_info oph = let dummy_manager_op_info_with_key_gen : (Plugin.Mempool.manager_op_info * Signature.public_key_hash) QCheck2.Gen.t = let open QCheck2.Gen in - let+ (oph, (pkh, _, _)) = pair operation_hash_gen public_key_hash_gen in + let+ oph, (pkh, _, _) = pair operation_hash_gen public_key_hash_gen in (dummy_manager_op_info oph, pkh) let filter_state_gen : Plugin.Mempool.state QCheck2.Gen.t = diff --git a/src/proto_012_Psithaca/lib_plugin/test/test_consensus_filter.ml b/src/proto_012_Psithaca/lib_plugin/test/test_consensus_filter.ml index 737afa30f888..06ab92ad884b 100644 --- a/src/proto_012_Psithaca/lib_plugin/test/test_consensus_filter.ml +++ b/src/proto_012_Psithaca/lib_plugin/test/test_consensus_filter.ml @@ -105,7 +105,7 @@ module Generator = struct let print_timestamp = Timestamp.to_notation let near_timestamps = - let+ (i, diff) = pair int32 small_signed_32 in + let+ i, diff = pair int32 small_signed_32 in timestamp_of_int32 i |> fun ts1 -> timestamp_of_int32 Int32.(add i diff) |> fun ts2 -> (ts1, ts2) @@ -122,7 +122,7 @@ module Generator = struct | Error _ -> assert false let successive_timestamp = - let+ (ts, (diff : int)) = pair timestamp small_nat in + let+ ts, (diff : int) = pair timestamp small_nat in let x = Period.of_seconds (Int64.of_int diff) >>? fun diff -> Timestamp.(ts +? diff) >>? fun ts2 -> Ok (ts, ts2) diff --git a/src/proto_012_Psithaca/lib_plugin/test/test_utils.ml b/src/proto_012_Psithaca/lib_plugin/test/test_utils.ml index f8926df66571..cf25d367381e 100644 --- a/src/proto_012_Psithaca/lib_plugin/test/test_utils.ml +++ b/src/proto_012_Psithaca/lib_plugin/test/test_utils.ml @@ -125,9 +125,9 @@ let eq_prechecked_managers = let eq_state s1 s2 = let eq_min_prechecked_op_weight = match (s1.min_prechecked_op_weight, s2.min_prechecked_op_weight) with - | (None, None) -> true - | (Some _, None) | (None, Some _) -> false - | (Some w1, Some w2) -> + | None, None -> true + | Some _, None | None, Some _ -> false + | Some w1, Some w2 -> Operation_hash.equal w1.operation_hash w2.operation_hash && Q.equal w1.weight w2.weight in diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/account.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/account.ml index 47e8e5a2e7ec..76047a436749 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/account.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/account.ml @@ -41,7 +41,7 @@ let random_seed ~rng_state = Char.chr (Random.State.int rng_state 256)) let new_account ?seed () = - let (pkh, pk, sk) = Signature.generate_key ~algo:Ed25519 ?seed () in + let pkh, pk, sk = Signature.generate_key ~algo:Ed25519 ?seed () in let account = {pkh; pk; sk} in Signature.Public_key_hash.Table.add known_accounts pkh account ; account @@ -91,7 +91,7 @@ let generate_accounts ?rng_state ?(initial_balances = []) n : (t * Tez.t) list = in List.map (fun i -> - let (pkh, pk, sk) = + let pkh, pk, sk = Signature.generate_key ~algo:Ed25519 ~seed:(random_seed ~rng_state) () in let account = {pkh; pk; sk} in @@ -105,7 +105,7 @@ let commitment_secret = |> WithExceptions.Option.get ~loc:__LOC__ let new_commitment ?seed () = - let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in + let pkh, pk, sk = Signature.generate_key ?seed ~algo:Ed25519 () in let unactivated_account = {pkh; pk; sk} in let open Commitment in let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/block.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/block.ml index 5bbb823d5a6d..2ff8169da265 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/block.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/block.ml @@ -26,7 +26,6 @@ open Protocol module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *) - open Alpha_context (* This type collects a block and the context that results from its application *) @@ -622,10 +621,10 @@ let bake_with_metadata ?locked_round ?policy ?timestamp ?operation ?operations ?payload_round ~baking_mode ?liquidity_baking_escape_vote pred = let operations = match (operation, operations) with - | (Some op, Some ops) -> Some (op :: ops) - | (Some op, None) -> Some [op] - | (None, Some ops) -> Some ops - | (None, None) -> None + | Some op, Some ops -> Some (op :: ops) + | Some op, None -> Some [op] + | None, Some ops -> Some ops + | None, None -> None in Forge.forge_header ?payload_round diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/context.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/context.ml index a6330204f9f5..5eb162dc01a8 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/context.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/context.ml @@ -367,8 +367,8 @@ let init1 ?rng_state ?commitments ?(initial_balances = []) ?consensus_threshold ?blocks_per_cycle 1 >|=? function - | (_, []) -> assert false - | (b, contract_1 :: _) -> (b, contract_1) + | _, [] -> assert false + | b, contract_1 :: _ -> (b, contract_1) let init2 ?rng_state ?commitments ?(initial_balances = []) ?consensus_threshold ?min_proposal_quorum ?level ?cost_per_byte ?liquidity_baking_subsidy @@ -390,8 +390,8 @@ let init2 ?rng_state ?commitments ?(initial_balances = []) ?consensus_threshold ?blocks_per_cycle 2 >|=? function - | (_, []) | (_, [_]) -> assert false - | (b, contract_1 :: contract_2 :: _) -> (b, contract_1, contract_2) + | _, [] | _, [_] -> assert false + | b, contract_1 :: contract_2 :: _ -> (b, contract_1, contract_2) let init_with_constants constants n = let accounts = Account.generate_accounts n in diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/contract_helpers.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/contract_helpers.ml index 6935d7ade5b8..17424586507d 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/contract_helpers.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/contract_helpers.ml @@ -31,7 +31,7 @@ open Error_monad_operators used to bake. *) let init () = Context.init ~consensus_threshold:0 3 >|=? fun (b, contracts) -> - let (src0, src1, src2) = + let src0, src1, src2 = match contracts with | src0 :: src1 :: src2 :: _ -> (src0, src1, src2) | _ -> assert false diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/expr.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/expr.ml index 37074c20b00e..468d09535ae8 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/expr.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/expr.ml @@ -30,7 +30,7 @@ exception Expression_from_string (** Parse a Michelson expression from string, raising an exception on error. *) let from_string ?(check_micheline_indentation = false) str : Script.expr = - let (ast, errs) = + let ast, errs = Michelson_v1_parser.parse_expression ~check:check_micheline_indentation str in (match errs with @@ -42,7 +42,7 @@ let from_string ?(check_micheline_indentation = false) str : Script.expr = (** Parses a Michelson contract from string, raising an exception on error. *) let toplevel_from_string ?(check_micheline_indentation = false) str = - let (ast, errs) = + let ast, errs = Michelson_v1_parser.parse_toplevel ~check:check_micheline_indentation str in match errs with [] -> ast.expanded | _ -> Stdlib.failwith "parse toplevel" diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/incremental.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/incremental.ml index a1d54df718e9..be76aef114dd 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/incremental.ml @@ -25,7 +25,6 @@ open Protocol module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *) - open Alpha_context type t = { @@ -158,12 +157,12 @@ let add_operation ?expect_apply_failure ?expect_failure st op = let open Apply_results in apply_operation st.state op >|= Environment.wrap_tzresult >>= fun result -> match (expect_apply_failure, result) with - | (Some _, Ok _) -> failwith "Error expected while adding operation" - | (Some f, Error err) -> f err >|=? fun () -> st - | (None, result) -> ( + | Some _, Ok _ -> failwith "Error expected while adding operation" + | Some f, Error err -> f err >|=? fun () -> st + | None, result -> ( result >>?= fun result -> match result with - | (state, (Operation_metadata result as metadata)) -> + | state, (Operation_metadata result as metadata) -> detect_script_failure result |> fun result -> (match expect_failure with | None -> Lwt.return result @@ -178,7 +177,7 @@ let add_operation ?expect_apply_failure ?expect_failure st op = rev_operations = op :: st.rev_operations; rev_tickets = metadata :: st.rev_tickets; } - | (state, (No_operation_metadata as metadata)) -> + | state, (No_operation_metadata as metadata) -> return { st with diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/liquidity_baking_generator.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/liquidity_baking_generator.ml index 878d6f4aaa82..6df79e0a3707 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/liquidity_baking_generator.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/liquidity_baking_generator.ml @@ -275,7 +275,7 @@ let gen_scenario : tzbtc -> liquidity -> int -> (specs * contract_id step list) QCheck.Gen.t = fun total_tzbtc total_liquidity size -> let* specs = gen_specs total_tzbtc total_liquidity in - let (state, env) = SymbolicMachine.build specs in + let state, env = SymbolicMachine.build specs in let+ scenario = gen_steps env state size in (specs, scenario) @@ -312,7 +312,7 @@ let gen_adversary_scenario : (specs * contract_id * contract_id step list) QCheck.Gen.t = fun total_tzbtc total_liquidity size -> let* specs = gen_specs total_tzbtc total_liquidity in - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let* c = oneofl env.implicit_accounts in let+ scenario = gen_steps ~source:c ~destination:c env state size in (specs, c, scenario) @@ -341,7 +341,7 @@ let arb_adversary_scenario : We shrink a valid scenario by removing steps from its tails, because a prefix of a valid scenario remains a valid scenario. Removing a random element of a scenario could lead to an - invalid scenario. *) + invalid scenario. *) (* Note (2) diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/liquidity_baking_machine.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/liquidity_baking_machine.ml index 025e97098fbc..94deffdae81f 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/liquidity_baking_machine.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/liquidity_baking_machine.ml @@ -125,7 +125,7 @@ let is_implicit_exn account = module List_helpers = struct let rec zip l r = match (l, r) with - | (xl :: rstl, xr :: rstr) -> (xl, xr) :: zip rstl rstr + | xl :: rstl, xr :: rstr -> (xl, xr) :: zip rstl rstr | _ -> [] let nth_exn l n = @@ -479,7 +479,7 @@ module Machine = struct get_cpmm_total_liquidity env state >>= fun lqtTotal -> let lqtTotal = Z.of_int lqtTotal in let amount = Tez.of_mutez_exn xtz_deposit in - let (_, tokens_deposited) = + let _, tokens_deposited = Cpmm_logic.Simulate_raw.addLiquidity ~tokenPool ~xtzPool @@ -855,7 +855,7 @@ module ConcreteBaseMachine : let init ~invariant ?subsidy accounts_balances = let liquidity_baking_subsidy = Option.map Tez.of_mutez_exn subsidy in - let (n, initial_balances) = initial_xtz_repartition accounts_balances in + let n, initial_balances = initial_xtz_repartition accounts_balances in Context.init n ~consensus_threshold:0 @@ -868,7 +868,7 @@ module ConcreteBaseMachine : ~blocks_per_cycle:10_000l ?liquidity_baking_subsidy >>= function - | (blk, holder :: accounts) -> + | blk, holder :: accounts -> let ctxt = Context.B blk in Context.get_liquidity_baking_cpmm_address ctxt >>= fun cpmm_contract -> Context.Contract.storage ctxt cpmm_contract >>= fun storage -> @@ -1054,13 +1054,13 @@ module AbstractMachine = struct Z.of_int @@ get_tzbtc_balance env.cpmm_contract env state in let tokensSold = Z.of_int tzbtc in - let (xtz_bought, xtz_net_bought) = + let xtz_bought, xtz_net_bought = Cpmm_logic.Simulate_raw.tokenToXtz ~xtzPool ~tokenPool ~tokensSold in (Z.to_int64 xtz_net_bought, Tez.to_mutez xtz_bought) let token_to_xtz ~src dst amount env _ state = - let (xtz_bought, xtz_net_bought) = xtz_bought amount env state in + let xtz_bought, xtz_net_bought = xtz_bought amount env state in state |> transfer_tzbtc_balance src env.cpmm_contract amount |> update_xtz_balance env.cpmm_contract (fun b -> Int64.sub b xtz_bought) @@ -1074,13 +1074,13 @@ module AbstractMachine = struct Z.of_int @@ get_tzbtc_balance env.cpmm_contract env state in let amount = Tez.of_mutez_exn amount in - let (tzbtc_bought, xtz_earnt) = + let tzbtc_bought, xtz_earnt = Cpmm_logic.Simulate_raw.xtzToToken ~xtzPool ~tokenPool ~amount in (Z.to_int tzbtc_bought, Z.to_int64 xtz_earnt) let xtz_to_token ~src dst amount env _ state = - let (tzbtc_bought, xtz_earnt) = tzbtc_bought env state amount in + let tzbtc_bought, xtz_earnt = tzbtc_bought env state amount in update_xtz_balance src (fun b -> Int64.sub b amount) state |> update_xtz_balance env.cpmm_contract (Int64.add xtz_earnt) |> transfer_tzbtc_balance env.cpmm_contract dst tzbtc_bought @@ -1099,7 +1099,7 @@ module AbstractMachine = struct in let lqtTotal = Z.of_int state.cpmm_total_liquidity in let amount = Tez.of_mutez_exn xtz_deposit in - let (lqt_minted, tokens_deposited) = + let lqt_minted, tokens_deposited = Cpmm_logic.Simulate_raw.addLiquidity ~tokenPool ~xtzPool @@ -1127,7 +1127,7 @@ module AbstractMachine = struct in let lqtTotal = Z.of_int state.cpmm_total_liquidity in let lqtBurned = Z.of_int lqt_burned in - let (xtz_withdrawn, tokens_withdrawn) = + let xtz_withdrawn, tokens_withdrawn = Cpmm_logic.Simulate_raw.removeLiquidity ~tokenPool ~xtzPool @@ -1180,7 +1180,7 @@ module SymbolicBaseMachine : end) let init ~invariant:_ ?(subsidy = default_subsidy) accounts_balances = - let (_, initial_balances) = initial_xtz_repartition accounts_balances in + let _, initial_balances = initial_xtz_repartition accounts_balances in let len = Int64.of_int (List.length accounts_balances) in match initial_balances with | holder_xtz :: accounts -> @@ -1192,15 +1192,12 @@ module SymbolicBaseMachine : cpmm_total_liquidity = cpmm_initial_liquidity_supply; accounts_balances = (Cpmm, {cpmm_initial_balance with xtz = xtz_cpmm}) - :: - (Holder, {xtz = holder_xtz; tzbtc = 0; liquidity = 0}) - :: - (TzBTCAdmin, {xtz = 0L; tzbtc = 0; liquidity = 0}) - :: - List.mapi - (fun i xtz -> - (ImplicitAccount i, {xtz; tzbtc = 0; liquidity = 0})) - accounts; + :: (Holder, {xtz = holder_xtz; tzbtc = 0; liquidity = 0}) + :: (TzBTCAdmin, {xtz = 0L; tzbtc = 0; liquidity = 0}) + :: List.mapi + (fun i xtz -> + (ImplicitAccount i, {xtz; tzbtc = 0; liquidity = 0})) + accounts; }, { cpmm_contract = Cpmm; @@ -1324,7 +1321,7 @@ module ValidationBaseMachine : ?subsidy balances >>= fun (blk, env) -> - let (state, _) = + let state, _ = SymbolicBaseMachine.init ~invariant:(fun _ _ -> true) ?subsidy balances in let state = refine_state env state in diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/lqt_fa12_repr.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/lqt_fa12_repr.ml index 937dfb8297b2..4857ff2efe05 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/lqt_fa12_repr.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/lqt_fa12_repr.ml @@ -224,11 +224,11 @@ module Storage = struct >>=? fun (address_hash, ctxt) -> Big_map.get_opt ctxt tokens address_hash >|= Environment.wrap_tzresult >>=? function - | (_, Some canonical) -> ( + | _, Some canonical -> ( match Tezos_micheline.Micheline.root canonical with | Tezos_micheline.Micheline.Int (_, amount) -> return @@ Some amount | _ -> assert false) - | (_, None) -> return @@ None + | _, None -> return @@ None let getBalance (ctxt : Context.t) ~(contract : Contract.t) (owner : Script_typed_ir.address) = diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/op.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/op.ml index 336715cea48f..9c77f6456663 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/op.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/op.ml @@ -201,8 +201,8 @@ let combine_operations ?public_key ?counter ?spurious_operation ~source ctxt let legit_ops = List.length operations in let index = Random.int legit_ops in match List.split_n index operations with - | (preserved_prefix, preserved_suffix) -> - preserved_prefix @ op :: preserved_suffix) + | preserved_prefix, preserved_suffix -> + preserved_prefix @ (op :: preserved_suffix)) in Environment.wrap_tzresult @@ Operation.of_list operations >>?= fun operations -> return @@ sign account.sk ctxt operations diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/sapling_helpers.ml index 4553734a045d..e8aecebaf7b0 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/sapling_helpers.ml @@ -85,7 +85,7 @@ module Common = struct let rec aux n index res = if Compare.Int.( <= ) n 0 then res else - let (new_index, new_addr) = + let new_index, new_addr = Tezos_sapling.Core.Client.Viewing_key.new_address vk index in aux (n - 1) new_index (new_addr :: res) @@ -260,7 +260,7 @@ module Alpha_context_helpers = struct let transfer w cs is = let anti_replay = "anti-replay" in - let (ins, outs) = transfer_inputs_outputs w cs is in + let ins, outs = transfer_inputs_outputs w cs is in (* change the wallet of this last line *) Tezos_sapling.Forge.forge_transaction_legacy ins outs w.sk anti_replay cs @@ -353,7 +353,7 @@ module Interpreter_helpers = struct let rec aux number_transac number_outputs index amount_output total res = if Compare.Int.(number_transac <= 0) then (res, total) else - let (new_index, new_addr) = + let new_index, new_addr = Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk index) in let outputs = diff --git a/src/proto_012_Psithaca/lib_protocol/test/helpers/test_global_constants.ml b/src/proto_012_Psithaca/lib_protocol/test/helpers/test_global_constants.ml index 1e98e513b7d3..368bdd4cbf4e 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/helpers/test_global_constants.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/helpers/test_global_constants.ml @@ -261,9 +261,9 @@ module Generators = struct | [] -> ([], None) | hd :: tl -> ( match replace_with_constant hd loc with - | (node, Some x) -> (node :: tl, Some x) - | (_, None) -> - let (l, x) = loop tl in + | node, Some x -> (node :: tl, Some x) + | _, None -> + let l, x = loop tl in (hd :: l, x)) in match node with @@ -283,7 +283,7 @@ module Generators = struct in (Prim (-1, H_constant, [String (-1, hash)], []), Some node) else - let (result, x) = loop args in + let result, x = loop args in (Prim (l, prim, result, annot), x) | Seq (l, args) as node -> if l = loc then @@ -293,7 +293,7 @@ module Generators = struct in (Prim (-1, H_constant, [String (-1, hash)], []), Some node) else - let (result, x) = loop args in + let result, x = loop args in (Seq (l, result), x) let micheline_gen p_gen annot_gen = @@ -318,8 +318,8 @@ module Generators = struct let size = Script_repr.micheline_nodes (root expr) in 0 -- (size - 1) >|= fun loc -> match replace_with_constant (root expr) loc with - | (_, None) -> assert false - | (node, Some replaced_node) -> + | _, None -> assert false + | node, Some replaced_node -> (expr, strip_locations node, strip_locations replaced_node) let canonical_with_constant_arbitrary () = diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_baking.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_baking.ml index 19267f30a58c..3988af4e1275 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_baking.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_baking.ml @@ -259,7 +259,7 @@ let test_rewards_block_and_payload_producer () = ~payload_round:(Some Round.zero) ~locked_round:(Some Round.zero) ~policy:(By_account baker_b2') - ~operations:(tx :: preendos @ endos) + ~operations:((tx :: preendos) @ endos) b1 >>=? fun b2' -> (* [baker_b2], as payload producer, gets the block reward and the fees *) @@ -310,7 +310,7 @@ let test_enough_active_stake_to_bake ~has_active_stake () = let initial_bal1 = if has_active_stake then tpr else Int64.sub tpr 1L in Context.init ~initial_balances:[initial_bal1; tpr] ~consensus_threshold:0 2 >>=? fun (b0, accounts) -> - let (account1, _account2) = + let account1, _account2 = match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false in Context.Contract.pkh account1 >>=? fun pkh1 -> @@ -336,7 +336,7 @@ let test_enough_active_stake_to_bake ~has_active_stake () = let test_committee_sampling () = let test_distribution max_round distribution = - let (initial_balances, bounds) = List.split distribution in + let initial_balances, bounds = List.split distribution in let accounts = Account.generate_accounts ~initial_balances (List.length initial_balances) in @@ -368,7 +368,7 @@ let test_committee_sampling () = bounds ; List.iter (fun {Plugin.RPC.Baking_rights.delegate = pkh; _} -> - let (bounds, n) = Stdlib.Hashtbl.find stats pkh in + let bounds, n = Stdlib.Hashtbl.find stats pkh in Stdlib.Hashtbl.replace stats pkh (bounds, n + 1)) bakers ; let one_failed = ref false in diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_deactivation.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_deactivation.ml index be252844d55f..d56c5880c47d 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_deactivation.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_deactivation.ml @@ -88,7 +88,7 @@ let check_no_stake ~loc (b : Block.t) (account : Account.t) = (check_stake). *) let test_simple_staking_rights () = Context.init 2 >>=? fun (b, accounts) -> - let (a1, _a2) = account_pair accounts in + let a1, _a2 = account_pair accounts in Context.Contract.balance (B b) a1 >>=? fun balance -> Context.Contract.pkh a1 >>=? fun delegate1 -> Context.Delegate.current_frozen_deposits (B b) delegate1 @@ -111,7 +111,7 @@ let test_simple_staking_rights () = rights. *) let test_simple_staking_rights_after_baking () = Context.init ~consensus_threshold:0 2 >>=? fun (b, accounts) -> - let (a1, a2) = account_pair accounts in + let a1, a2 = account_pair accounts in Context.Contract.manager (B b) a1 >>=? fun m1 -> Context.Contract.manager (B b) a2 >>=? fun m2 -> Block.bake_n ~policy:(By_account m2.pkh) 5 b >>=? fun b -> @@ -131,7 +131,7 @@ let check_active_staking_balance ~loc ~deactivated b (m : Account.t) = let run_until_deactivation () = Context.init ~consensus_threshold:0 2 >>=? fun (b, accounts) -> - let (a1, a2) = account_pair accounts in + let a1, a2 = account_pair accounts in Context.Contract.balance (B b) a1 >>=? fun balance_start -> Context.Contract.manager (B b) a1 >>=? fun m1 -> Context.Contract.manager (B b) a2 >>=? fun m2 -> @@ -298,7 +298,7 @@ let test_deactivation_then_empty_then_self_delegation_then_recredit () = first and third accounts. *) let test_delegation () = Context.init ~consensus_threshold:0 2 >>=? fun (b, accounts) -> - let (a1, a2) = account_pair accounts in + let a1, a2 = account_pair accounts in let m3 = Account.new_account () in Account.add_account m3 ; Context.Contract.manager (B b) a1 >>=? fun m1 -> diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_delegation.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_delegation.ml index 99b571f0d493..6253a12120d7 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_delegation.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_delegation.ml @@ -429,22 +429,22 @@ let tests_bootstrap_contracts = (*****************************************************************************) (* Part A. - Unregistered delegate keys cannot be used for delegation + Unregistered delegate keys cannot be used for delegation - Two main series of tests: without self-delegation and with a failed attempt at self-delegation: + Two main series of tests: without self-delegation and with a failed attempt at self-delegation: - 1/ no self-delegation - a/ no credit - - no token transfer - - credit of 1μꜩ and then debit of 1μꜩ - b/ with credit of 1μꜩ. - For every scenario, we try three different ways of delegating: - - through origination (init origination) - - through delegation when no delegate was assigned (init delegation) - - through delegation when a delegate was assigned (switch delegation). + 1/ no self-delegation + a/ no credit + - no token transfer + - credit of 1μꜩ and then debit of 1μꜩ + b/ with credit of 1μꜩ. + For every scenario, we try three different ways of delegating: + - through origination (init origination) + - through delegation when no delegate was assigned (init delegation) + - through delegation when a delegate was assigned (switch delegation). - 2/ Self-delegation fails if the contract has no credit. We try the - two possibilities of 1a for non-credited contracts. *) + 2/ Self-delegation fails if the contract has no credit. We try the + two possibilities of 1a for non-credited contracts. *) let expect_unregistered_key pkh = function | Environment.Ecoproto_error (Delegate_storage.Unregistered_delegate pkh0) @@ -1434,15 +1434,15 @@ let tests_delegate_registration = ~amount:Tez.one_mutez ~fee:max_tez); Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (switch with \ - delegation, small fee)" + "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, \ + small fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit_debit ~amount:Tez.one_mutez ~fee:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (switch with \ - delegation, large fee)" + "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, \ + large fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit_debit ~amount:Tez.one_mutez @@ -1467,29 +1467,27 @@ let tests_delegate_registration = ~fee:(of_int 10_000_000) ~amount:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (init with delegation, small \ - fee)" + "unregistered delegate key - credit 1μꜩ (init with delegation, small fee)" `Quick (test_unregistered_delegate_key_init_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (init with delegation, large \ - fee)" + "unregistered delegate key - credit 1μꜩ (init with delegation, large fee)" `Quick (test_unregistered_delegate_key_init_delegation_credit ~amount:Tez.one_mutez ~fee:max_tez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (switch with delegation, \ - small fee)" + "unregistered delegate key - credit 1μꜩ (switch with delegation, small \ + fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (switch with delegation, \ - large fee)" + "unregistered delegate key - credit 1μꜩ (switch with delegation, large \ + fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit ~amount:Tez.one_mutez @@ -1534,8 +1532,8 @@ let tests_delegate_registration = (test_failed_self_delegation_emptied_implicit_contract Tez.one_mutez); (* credit 1μtz, delegate, debit 1μtz *) Tztest.tztest - "empty delegated contract is not deleted: credit 1μꜩ, delegate & \ - debit 1μꜩ" + "empty delegated contract is not deleted: credit 1μꜩ, delegate & debit \ + 1μꜩ" `Quick (test_emptying_delegated_implicit_contract_fails Tez.one_mutez); (*** valid registration ***) @@ -1546,20 +1544,20 @@ let tests_delegate_registration = `Quick (test_valid_delegate_registration_init_delegation_credit Tez.one_mutez); Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation (switch \ - with delegation)" + "valid delegate registration: credit 1μꜩ, self delegation (switch with \ + delegation)" `Quick (test_valid_delegate_registration_switch_delegation_credit Tez.one_mutez); (* valid registration: credit 1 μꜩ, self delegation, debit 1μꜩ *) Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation, debit \ - 1μꜩ (init with delegation)" + "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ \ + (init with delegation)" `Quick (test_valid_delegate_registration_init_delegation_credit_debit Tez.one_mutez); Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation, debit \ - 1μꜩ (switch with delegation)" + "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ \ + (switch with delegation)" `Quick (test_valid_delegate_registration_switch_delegation_credit_debit Tez.one_mutez); diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_baking.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_baking.ml index 146eae3b9226..d9a19cf0f7db 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_baking.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_baking.ml @@ -68,7 +68,7 @@ let get_first_different_endorsers ctxt = (** Bake two block at the same level using the same policy (i.e. same baker). *) let block_fork ?policy contracts b = - let (contract_a, contract_b) = get_hd_hd contracts in + let contract_a, contract_b = get_hd_hd contracts in Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent >>=? fun operation -> Block.bake ?policy ~operation b >>=? fun blk_a -> @@ -83,7 +83,7 @@ let order_block_hashes ~correct_order bh1 bh2 = else (bh1, bh2) let double_baking ctxt ?(correct_order = true) bh1 bh2 = - let (bh1, bh2) = order_block_hashes ~correct_order bh1 bh2 in + let bh1, bh2 = order_block_hashes ~correct_order bh1 bh2 in Op.double_baking ctxt bh1 bh2 (****************************************************************) diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_endorsement.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_endorsement.ml index d3d1167931d5..368f95b3e681 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_endorsement.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_endorsement.ml @@ -67,7 +67,7 @@ let block_fork b = (****************************************************************) let get_first_2_accounts_contracts contracts = - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = match contracts with | [a1; a2] -> ( ( a1, @@ -91,7 +91,7 @@ let order_endorsements ~correct_order op1 op2 = else (op1, op2) let double_endorsement ctxt ?(correct_order = true) op1 op2 = - let (e1, e2) = order_endorsements ~correct_order op1 op2 in + let e1, e2 = order_endorsements ~correct_order op1 op2 in Op.double_endorsement ctxt e1 e2 (** This test verifies that when a "cheater" double endorses and @@ -281,7 +281,7 @@ let test_different_delegates () = Context.get_endorser (B blk_a) >>=? fun (endorser_a, a_slots) -> get_first_different_endorsers (B blk_b) >>=? fun (endorser_b1c, endorser_b2c) -> - let (endorser_b, b_slots) = + let endorser_b, b_slots = if Signature.Public_key_hash.( = ) endorser_a endorser_b1c.delegate then (endorser_b2c.delegate, endorser_b2c.slots) else (endorser_b1c.delegate, endorser_b1c.slots) @@ -321,7 +321,7 @@ let test_wrong_delegate () = >>=? fun endorsement_a -> Context.get_endorser_n (B blk_b) 0 >>=? fun (endorser0, slots0) -> Context.get_endorser_n (B blk_b) 1 >>=? fun (endorser1, slots1) -> - let (endorser_b, b_slots) = + let endorser_b, b_slots = if Signature.Public_key_hash.equal endorser_a endorser0 then (endorser1, slots1) else (endorser0, slots0) @@ -396,7 +396,7 @@ let test_freeze_more_with_low_balance = } in Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((_contract1, account1), (_contract2, account2)) = + let (_contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in (* we empty the available balance of [account1]. *) diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_preendorsement.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_preendorsement.ml index 3d705b3e18d8..172aa392b2b1 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_preendorsement.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_double_preendorsement.ml @@ -146,7 +146,7 @@ end = struct situation. In case baker <> endorser, bal_bad of the baker gets half of burnt deposit of d1, so it's higher *) - let (high, low) = + let high, low = if Signature.Public_key_hash.equal baker d1 then (bal_good, bal_bad) else (bal_bad, bal_good) in @@ -188,7 +188,7 @@ end = struct >>=? fun op1 -> Op.preendorsement ~delegate:d2 ~endorsed_block:head_B (B blk) () >>=? fun op2 -> - let (op1, op2) = order_preendorsements ~correct_order:true op1 op2 in + let op1, op2 = order_preendorsements ~correct_order:true op1 op2 in (* bake `nb_blocks_before_denunciation` before double preend. denunciation *) bake_n nb_blocks_before_denunciation blk >>=? fun blk -> let op : Operation.packed = Op.double_preendorsement (B blk) op1 op2 in diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_frozen_deposits.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_frozen_deposits.ml index 9ca7e9edf97f..4d04b2499052 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_frozen_deposits.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_frozen_deposits.ml @@ -47,7 +47,7 @@ let constants = } let get_first_2_accounts_contracts contracts = - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = match contracts with | [a1; a2] -> ( ( a1, @@ -64,24 +64,24 @@ let get_first_2_accounts_contracts contracts = (* Terminology: -- staking balance = full balance + delegated stake; obtained with - Delegate.staking_balance + - staking balance = full balance + delegated stake; obtained with + Delegate.staking_balance -- active stake = the amount of tez with which a delegate participates in - consensus; it must be greater than 1 roll and less or equal the staking - balance; it is computed in [Delegate_storage.select_distribution_for_cycle] + - active stake = the amount of tez with which a delegate participates in + consensus; it must be greater than 1 roll and less or equal the staking + balance; it is computed in [Delegate_storage.select_distribution_for_cycle] -- frozen deposits = represents frozen_deposits_percentage of the maximum stake during - preserved_cycles + max_slashing_period cycles; obtained with - Delegate.current_frozen_deposits + - frozen deposits = represents frozen_deposits_percentage of the maximum stake during + preserved_cycles + max_slashing_period cycles; obtained with + Delegate.current_frozen_deposits -- spendable balance = full balance - frozen deposits; obtained with Contract.balance + - spendable balance = full balance - frozen deposits; obtained with Contract.balance -- full balance = spendable balance + frozen deposits; obtained with Delegate.full_balance + - full balance = spendable balance + frozen deposits; obtained with Delegate.full_balance *) let test_invariants () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, _account2)) = + let (contract1, account1), (contract2, _account2) = get_first_2_accounts_contracts contracts in Context.Delegate.staking_balance (B genesis) account1 @@ -142,7 +142,7 @@ let test_invariants () = let test_set_limit balance_percentage () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in (Context.Delegate.frozen_deposits_limit (B genesis) account1 >>=? function @@ -200,7 +200,7 @@ let test_set_limit balance_percentage () = let test_cannot_bake_with_zero_deposits () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in (* N.B. there is no non-zero frozen deposits value for which one cannot bake: @@ -226,7 +226,7 @@ let test_cannot_bake_with_zero_deposits () = let test_deposits_after_stake_removal () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.current_frozen_deposits (B genesis) account1 @@ -294,7 +294,7 @@ let test_deposits_after_stake_removal () = let test_unfreeze_deposits_after_deactivation () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.full_balance (B genesis) account1 >>=? fun initial_balance -> @@ -340,7 +340,7 @@ let test_unfreeze_deposits_after_deactivation () = let test_frozen_deposits_with_delegation () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((_contract1, account1), (contract2, account2)) = + let (_contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.staking_balance (B genesis) account1 @@ -400,7 +400,7 @@ let test_frozen_deposits_with_delegation () = let test_frozen_deposits_with_overdelegation () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in (* - [account1] and [account2] give their spendable balance to [new_account] @@ -479,7 +479,7 @@ let test_frozen_deposits_with_overdelegation () = let test_set_limit_with_overdelegation () = let constants = {constants with frozen_deposits_percentage = 10} in Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in (* - [account1] and [account2] will give 80% of their balance to @@ -547,7 +547,7 @@ let test_set_limit_with_overdelegation () = [new_cycle + preserved_cycles]. *) let test_error_is_thrown_when_smaller_upper_bound_for_frozen_window () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, _account2)) = + let (contract1, account1), (contract2, _account2) = match contracts with | [a1; a2] -> ( ( a1, diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_participation.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_participation.ml index eedd3b4fc858..3a2c85c75bb9 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_participation.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_participation.ml @@ -78,7 +78,7 @@ let test_participation ~sufficient_participation () = let minimal_nb_active_slots = mpr.numerator * expected_nb_slots / mpr.denominator in - let (account1, account2) = + let account1, account2 = match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false in Context.Contract.pkh account1 >>=? fun del1 -> @@ -94,7 +94,7 @@ let test_participation ~sufficient_participation () = Environment.wrap_tzresult (Raw_level.of_int32 int_level) >>?= fun level -> Context.get_endorsing_power_for_delegate (B b_crt) ~levels:[level] del1 >>=? fun endorsing_power_for_level -> - let (endorser, new_endorsing_power) = + let endorser, new_endorsing_power = if sufficient_participation && endorsing_power < minimal_nb_active_slots then (del2, endorsing_power + endorsing_power_for_level) else (del1, endorsing_power) @@ -126,7 +126,7 @@ let test_participation ~sufficient_participation () = let test_participation_rpc () = let n_accounts = 2 in Context.init ~consensus_threshold:1 n_accounts >>=? fun (b0, accounts) -> - let (account1, account2) = + let account1, account2 = match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false in Context.Contract.pkh account1 >>=? fun del1 -> diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml index 89b4552f24c3..b32c5d1a18f5 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml @@ -82,11 +82,11 @@ end = struct b1 >>= fun res -> match (res, post_process) with - | (Ok ok, Ok success_fun) -> success_fun ok - | (Error _, Error (error_title, _error_category)) -> + | Ok ok, Ok success_fun -> success_fun ok + | Error _, Error (error_title, _error_category) -> Assert.proto_error_with_info ~loc res error_title - | (Ok _, Error _) -> Assert.error ~loc res (fun _ -> false) - | (Error _, Ok _) -> Assert.error ~loc res (fun _ -> false) + | Ok _, Error _ -> Assert.error ~loc res (fun _ -> false) + | Error _, Ok _ -> Assert.error ~loc res (fun _ -> false) (****************************************************************) (* Tests *) diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_seed.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_seed.ml index 4e9e4413fbe5..84ef43684964 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_seed.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/consensus/test_seed.ml @@ -106,7 +106,7 @@ let test_revelation_early_wrong_right_twice () = Block.bake_until_cycle_end ~policy b >>=? fun b -> (* test that revealing at the right time but the wrong value produces an error *) - let (wrong_hash, _) = Nonce.generate () in + let wrong_hash, _ = Nonce.generate () in Op.seed_nonce_revelation (B b) level_commitment @@ -197,12 +197,12 @@ let test_unrevealed () = } in Context.init_with_constants constants 2 >>=? fun (b, accounts) -> - let (account1, account2) = + let account1, account2 = match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false in - let (_delegate1, delegate2) = + let _delegate1, delegate2 = match (Contract.is_implicit account1, Contract.is_implicit account2) with - | (Some d, Some d') -> (d, d') + | Some d, Some d' -> (d, d') | _ -> assert false in (* Delegate 2 will add a nonce but never reveals it *) diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/gas/test_gas_levels.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/gas/test_gas_levels.ml index 123200e84eba..2023b2741512 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/gas/test_gas_levels.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/gas/test_gas_levels.ml @@ -220,10 +220,10 @@ let apply_with_gas header ?(operations = []) (pred : Block.t) = let bake_with_gas ?policy ?timestamp ?operation ?operations pred = let operations = match (operation, operations) with - | (Some op, Some ops) -> Some (op :: ops) - | (Some op, None) -> Some [op] - | (None, Some ops) -> Some ops - | (None, None) -> None + | Some op, Some ops -> Some (op :: ops) + | Some op, None -> Some [op] + | None, Some ops -> Some ops + | None, None -> None in Block.Forge.forge_header ?timestamp ?policy ?operations pred >>=? fun header -> @@ -300,7 +300,7 @@ let block_with_one_origination contract = let full_block () = init_block [nil_contract; fail_contract; loop_contract] >>=? fun (block, src, originated) -> - let (dst_nil, dst_fail, dst_loop) = + let dst_nil, dst_fail, dst_loop = match originated with [c1; c2; c3] -> (c1, c2, c3) | _ -> assert false in return (block, src, dst_nil, dst_fail, dst_loop) @@ -393,10 +393,9 @@ let test_malformed_block_max_limit_reached () = *) let lld = [(dst, Alpha_context.Gas.Arith.integral_of_int_exn 1)] - :: - List.map - (fun _ -> [(dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)]) - [1; 1; 1; 1; 1] + :: List.map + (fun _ -> [(dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)]) + [1; 1; 1; 1; 1] in bake_operations_with_gas ~counter:Z.one block src lld >>= function | Error _ -> return_unit @@ -417,10 +416,9 @@ let test_malformed_block_max_limit_reached' () = let lld = [ (dst, Alpha_context.Gas.Arith.integral_of_int_exn 1) - :: - List.map - (fun _ -> (dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)) - [1; 1; 1; 1; 1]; + :: List.map + (fun _ -> (dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)) + [1; 1; 1; 1; 1]; ] in bake_operations_with_gas ~counter:Z.one block src lld >>= function diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_global_constants_storage.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_global_constants_storage.ml index b8d0fb8e3b88..060f23a48c12 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_global_constants_storage.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_global_constants_storage.ml @@ -42,8 +42,8 @@ let get_next_context b = let register_two_contracts ?consensus_threshold () = Context.init ?consensus_threshold 2 >|=? function - | (_, []) | (_, [_]) -> assert false - | (b, contract_1 :: contract_2 :: _) -> (b, contract_1, contract_2) + | _, [] | _, [_] -> assert false + | b, contract_1 :: contract_2 :: _ -> (b, contract_1, contract_2) let assert_proto_error_id loc id result = let test err = diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml index cd55c3228f92..03a84159c6b2 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml @@ -81,12 +81,11 @@ let gen_diffs idx : list = let open Lazy_storage_diff in Remove - :: - (gen_inits idx - |> List.map (fun (init, updates_lens) -> - gen_updates_list updates_lens - |> List.map (fun updates -> Update {init; updates})) - |> List.flatten) + :: (gen_inits idx + |> List.map (fun (init, updates_lens) -> + gen_updates_list updates_lens + |> List.map (fun updates -> Update {init; updates})) + |> List.flatten) let gen_diffs_items idx : Lazy_storage_diff.diffs_item list = let id = ids.(idx) in diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_sapling.ml index 5e48b3ca0bab..132ee9de6234 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_sapling.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_sapling.ml @@ -554,7 +554,7 @@ module Interpreter_tests = struct originate_contract "contracts/sapling_contract.tz" "{ }" src0 genesis baker >>=? fun (dst, b1, anti_replay) -> let wa = wallet_gen () in - let (list_transac, total) = + let list_transac, total = shield ~memo_size wa.sk @@ -568,7 +568,7 @@ module Interpreter_tests = struct transac_and_sync ~memo_size b1 parameters total src0 dst baker >>=? fun (b2, _state) -> (* we shield again on another block, forging with the empty state *) - let (list_transac, total) = + let list_transac, total = shield ~memo_size wa.sk @@ -730,7 +730,7 @@ module Interpreter_tests = struct it as a parameter *) let wa = wallet_gen () in - let (transactions, _total) = + let transactions, _total = shield ~memo_size wa.sk @@ -909,7 +909,7 @@ module Interpreter_tests = struct originate_contract "contracts/sapling_contract_drop.tz" "Unit" src b baker >>=? fun (dst, b, anti_replay) -> let {sk; vk} = wallet_gen () in - let (list_transac, _total) = + let list_transac, _total = shield ~memo_size:8 sk 4 vk (Format.sprintf "0x%s") anti_replay in let parameters = parameters_of_list list_transac in diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml index 3d9ed9ecc32f..a154eecea7da 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml @@ -40,19 +40,19 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult let new_ctxt () = - let* (block, _) = Context.init 1 in + let* block, _ = Context.init 1 in let* incr = Incremental.begin_construction block in return @@ Incremental.alpha_ctxt incr let make_contract ticketer = wrap @@ Lwt.return @@ Contract.of_b58check ticketer let make_ex_ticket ctxt ~ticketer ~typ ~content ~amount = - let* (Script_ir_translator.Ex_comparable_ty cty, ctxt) = + let* Script_ir_translator.Ex_comparable_ty cty, ctxt = let node = Micheline.root @@ Expr.from_string typ in wrap @@ Lwt.return @@ Script_ir_translator.parse_comparable_ty ctxt node in let* ticketer = make_contract ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content in wrap @@ Script_ir_translator.parse_comparable_data ctxt cty node in @@ -61,11 +61,9 @@ let make_ex_ticket ctxt ~ticketer ~typ ~content ~amount = return (Ticket_scanner.Ex_ticket (cty, ticket), ctxt) let make_key ctxt ~ticketer ~typ ~content ~amount ~owner = - let* (ex_ticket, ctxt) = - make_ex_ticket ctxt ~ticketer ~typ ~content ~amount - in + let* ex_ticket, ctxt = make_ex_ticket ctxt ~ticketer ~typ ~content ~amount in let* owner = make_contract owner in - let* (key, amount, ctxt) = + let* key, amount, ctxt = wrap @@ Ticket_balance_key.ticket_balance_key_and_amount ctxt ex_ticket ~owner in @@ -92,7 +90,7 @@ let not_equal_script_hash ~loc msg key1 key2 = let assert_keys ~ticketer1 ~ticketer2 ~typ1 ~typ2 ~amount1 ~amount2 ~content1 ~content2 ~owner1 ~owner2 assert_condition = let* ctxt = new_ctxt () in - let* (key1, amount1, ctxt) = + let* key1, amount1, ctxt = make_key ctxt ~ticketer:ticketer1 @@ -101,7 +99,7 @@ let assert_keys ~ticketer1 ~ticketer2 ~typ1 ~typ2 ~amount1 ~amount2 ~content1 ~amount:amount1 ~owner:owner1 in - let* (key2, amount2, _) = + let* key2, amount2, _ = make_key ctxt ~ticketer:ticketer2 @@ -122,7 +120,7 @@ let assert_keys_equal ~loc = let assert_amount ~loc ~ticketer ~typ ~content ~amount ~owner expected = let* ctxt = new_ctxt () in - let* (_, amount, _ctxt) = + let* _, amount, _ctxt = make_key ctxt ~ticketer ~typ ~content ~amount ~owner in Assert.equal_int ~loc (Z.to_int amount) expected diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index 1fe5df949649..0bdc63a9699f 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -40,7 +40,7 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult let new_ctxt () = - let* (block, _) = Context.init 1 in + let* block, _ = Context.init 1 in let* incr = Incremental.begin_construction block in return @@ Incremental.alpha_ctxt incr @@ -51,7 +51,7 @@ let string_list_of_ex_tickets ctxt tickets = let accum (xs, ctxt) (Ticket_scanner.Ex_ticket (cty, {Script_typed_ir.ticketer; contents; amount})) = - let* (x, ctxt) = + let* x, ctxt = wrap @@ Script_ir_translator.unparse_data ctxt @@ -78,16 +78,16 @@ let string_list_of_ex_tickets ctxt tickets = in return (str :: xs, ctxt) in - let* (xs, ctxt) = List.fold_left_es accum ([], ctxt) tickets in + let* xs, ctxt = List.fold_left_es accum ([], ctxt) tickets in return (List.rev xs, ctxt) let make_ex_ticket ctxt ~ticketer ~type_exp ~content_exp ~amount = - let* (Script_ir_translator.Ex_comparable_ty cty, ctxt) = + let* Script_ir_translator.Ex_comparable_ty cty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in wrap @@ Lwt.return @@ Script_ir_translator.parse_comparable_ty ctxt node in let* ticketer = wrap @@ Lwt.return @@ Contract.of_b58check ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in wrap @@ Script_ir_translator.parse_comparable_data ctxt cty node in @@ -96,10 +96,8 @@ let make_ex_ticket ctxt ~ticketer ~type_exp ~content_exp ~amount = return (Ticket_scanner.Ex_ticket (cty, ticket), ctxt) let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = - let* (str_tickets, ctxt) = string_list_of_ex_tickets ctxt ex_tickets in - let* (str_tickets_expected, _ctxt) = - string_list_of_ex_tickets ctxt expected - in + let* str_tickets, ctxt = string_list_of_ex_tickets ctxt ex_tickets in + let* str_tickets_expected, _ctxt = string_list_of_ex_tickets ctxt expected in assert_equal_string_list ~loc "Compare with expected tickets" @@ -107,14 +105,14 @@ let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = (List.sort String.compare str_tickets_expected) let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = - let (Script_ir_translator.Ex_ty ty, ctxt) = + let Script_ir_translator.Ex_ty ty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in Result.value_f ~default:(fun () -> Stdlib.failwith "Failed to parse") (Script_ir_translator.parse_any_ty ctxt ~legacy:false node) in let node = Micheline.root @@ Expr.from_string value_exp in - let* (value, ctxt) = + let* value, ctxt = wrap @@ Script_ir_translator.parse_data ctxt @@ -127,7 +125,7 @@ let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = let assert_contains_tickets ctxt ~loc ~include_lazy ~type_exp ~value_exp expected = - let* (ex_tickets, _) = + let* ex_tickets, _ = tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp in assert_equals_ex_tickets ctxt ~loc ex_tickets expected @@ -149,7 +147,7 @@ let assert_fail_non_empty_overlay ctxt ~loc ~include_lazy ~type_exp ~value_exp = let make_string_tickets ctxt ticketer_amounts = List.fold_right_es (fun (ticketer, content, amount) (tickets, ctxt) -> - let* (ticket, ctxt) = + let* ticket, ctxt = make_ex_ticket ctxt ~ticketer @@ -162,21 +160,21 @@ let make_string_tickets ctxt ticketer_amounts = ([], ctxt) let tickets_from_big_map_ref ~pre_populated value_exp = - let* (block, contracts) = Context.init 1 in + let* block, contracts = Context.init 1 in let source = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd contracts in - let* (operation, originated) = + let* operation, originated = Op.origination (B block) source ~script:Op.dummy_script in let* block = Block.bake ~operation block in let* inc = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt inc in - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in let int_ty_expr = Expr.from_string "int" in - let* (diffs, ctxt) = - let* (updates, ctxt) = + let* diffs, ctxt = + let* updates, ctxt = List.fold_left_es (fun (kvs, ctxt) (key, value) -> - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap @@ Script_ir_translator.hash_comparable_data ctxt @@ -218,10 +216,8 @@ let tickets_from_big_map_ref ~pre_populated value_exp = let assert_big_map_int_ticket_string_ref ~loc ~pre_populated ~big_map_exp ex_tickets = - let* (value_exp, ctxt) = - tickets_from_big_map_ref ~pre_populated big_map_exp - in - let* (ex_tickets, ctxt) = make_string_tickets ctxt ex_tickets in + let* value_exp, ctxt = tickets_from_big_map_ref ~pre_populated big_map_exp in + let* ex_tickets, ctxt = make_string_tickets ctxt ex_tickets in assert_contains_tickets ctxt ~include_lazy:true @@ -232,9 +228,7 @@ let assert_big_map_int_ticket_string_ref ~loc ~pre_populated ~big_map_exp let assert_fail_non_empty_overlay_with_big_map_ref ~loc ~pre_populated ~big_map_exp = - let* (value_exp, ctxt) = - tickets_from_big_map_ref ~pre_populated big_map_exp - in + let* value_exp, ctxt = tickets_from_big_map_ref ~pre_populated big_map_exp in assert_fail_non_empty_overlay ctxt ~include_lazy:true @@ -247,7 +241,7 @@ let test_tickets_in_unit_ticket () = let* ctxt = new_ctxt () in let type_exp = "ticket(unit)" in let value_exp = {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" Unit 10|} in - let* (ex_ticket, ctxt) = + let* ex_ticket, ctxt = make_ex_ticket ctxt ~ticketer:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" @@ -265,7 +259,7 @@ let test_tickets_in_unit_ticket () = let assert_string_tickets ~loc ~include_lazy ~type_exp ~value_exp ~expected = let* ctxt = new_ctxt () in - let* (ex_tickets, ctxt) = make_string_tickets ctxt expected in + let* ex_tickets, ctxt = make_string_tickets ctxt expected in assert_contains_tickets ctxt ~include_lazy diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_storage.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_storage.ml index 6c3d9ff6e2c8..6ee824dbbc23 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_storage.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_ticket_storage.ml @@ -40,7 +40,7 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult let make_context () = - let* (block, _) = Context.init 1 in + let* block, _ = Context.init 1 in let* incr = Incremental.begin_construction block in return (Incremental.alpha_ctxt incr) @@ -59,13 +59,13 @@ let hash_key ctxt ~ticketer ~typ ~contents ~owner = ~owner) let assert_balance ctxt ~loc key expected = - let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + let* balance, _ = wrap @@ Ticket_balance.get_balance ctxt key in match balance with | Some b -> Assert.equal_int ~loc (Z.to_int b) expected | None -> failwith "Expected balance %d" expected let assert_no_balance ctxt key = - let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + let* balance, _ = wrap @@ Ticket_balance.get_balance ctxt key in match balance with | Some b -> failwith "Expected empty (none) balance but got %d" (Z.to_int b) | None -> return () @@ -76,7 +76,7 @@ let adjust_balance ctxt key delta = let assert_non_overlapping_keys ~loc ~ticketer1 ~ticketer2 ~contents1 ~contents2 ~typ1 ~typ2 ~owner1 ~owner2 = let* ctxt = make_context () in - let* (k1, ctxt) = + let* k1, ctxt = hash_key ctxt ~ticketer:ticketer1 @@ -84,7 +84,7 @@ let assert_non_overlapping_keys ~loc ~ticketer1 ~ticketer2 ~contents1 ~contents2 ~contents:contents1 ~owner:owner1 in - let* (k2, _ctxt) = + let* k2, _ctxt = hash_key ctxt ~ticketer:ticketer2 @@ -167,18 +167,18 @@ let test_non_overlapping_keys_owner () = *) let test_ticket_balance_single_update () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in assert_balance ctxt ~loc:__LOC__ alice_red 1 (** Test that updating the ticket-balance table with different keys updates both entries. *) let test_ticket_balance_different_owners () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (alice_blue, ctxt) = make_key ctxt "alice_blue" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in - let* (_, ctxt) = adjust_balance ctxt alice_blue 1 in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* alice_blue, ctxt = make_key ctxt "alice_blue" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in + let* _, ctxt = adjust_balance ctxt alice_blue 1 in let* () = assert_balance ctxt ~loc:__LOC__ alice_red 1 in let* () = assert_balance ctxt ~loc:__LOC__ alice_blue 1 in return () @@ -187,33 +187,33 @@ let test_ticket_balance_different_owners () = the net result of all balance updates *) let test_ticket_balance_multiple_updates () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in - let* (_, ctxt) = adjust_balance ctxt alice_red 2 in - let* (_, ctxt) = adjust_balance ctxt alice_red (-1) in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in + let* _, ctxt = adjust_balance ctxt alice_red 2 in + let* _, ctxt = adjust_balance ctxt alice_red (-1) in assert_balance ctxt ~loc:__LOC__ alice_red 2 (** Test that with no updates to the table, no balance is present in the table *) let test_empty_balance () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* alice_red, ctxt = make_key ctxt "alice_red" in assert_no_balance ctxt alice_red (** Test that adding one entry with positive balance and then updating with a negative balance also removes the entry *) let test_empty_balance_after_update () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in - let* (_, ctxt) = adjust_balance ctxt alice_red (-1) in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in + let* _, ctxt = adjust_balance ctxt alice_red (-1) in assert_no_balance ctxt alice_red (** Test that attempting to update an entry with a negative balance results in an error. *) let test_negative_balance () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* alice_red, ctxt = make_key ctxt "alice_red" in adjust_balance ctxt alice_red (-1) >>= fun res -> Assert.proto_error ~loc:__LOC__ res (fun _err -> true) @@ -222,20 +222,20 @@ let test_negative_balance () = *) let test_storage_space () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* alice_red, ctxt = make_key ctxt "alice_red" in (* Space for adding an entry is 65 for the key plus 1 for the value. *) - let* (space, ctxt) = adjust_balance ctxt alice_red 1 in + let* space, ctxt = adjust_balance ctxt alice_red 1 in let* () = Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) in (* Adding one does not consume additional space. *) - let* (space, ctxt) = adjust_balance ctxt alice_red 1 in + let* space, ctxt = adjust_balance ctxt alice_red 1 in let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in (* Adding a big balance costs extra. *) - let* (space, ctxt) = adjust_balance ctxt alice_red 1000 in + let* space, ctxt = adjust_balance ctxt alice_red 1000 in let* () = Assert.equal_int ~loc:__LOC__ 1 (Z.to_int space) in (* Reset balance to zero should free up space. The freed up space is 65 for the key + 2 for the value *) - let* (b, ctxt) = wrap @@ Ticket_balance.get_balance ctxt alice_red in - let* (space, ctxt) = + let* b, ctxt = wrap @@ Ticket_balance.get_balance ctxt alice_red in + let* space, ctxt = wrap (Ticket_balance.adjust_balance ctxt @@ -244,10 +244,10 @@ let test_storage_space () = in let* () = Assert.equal_int ~loc:__LOC__ (-67) (Z.to_int space) in (* Adjusting the space to 0 again should not free anything *) - let* (space, ctxt) = adjust_balance ctxt alice_red 0 in + let* space, ctxt = adjust_balance ctxt alice_red 0 in let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in (* Adding a balance requiers extra space. *) - let* (space, _) = adjust_balance ctxt alice_red 10 in + let* space, _ = adjust_balance ctxt alice_red 10 in Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) let tests = diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_timelock.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_timelock.ml index 6040998b5deb..20ebe45d39de 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_timelock.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_timelock.ml @@ -36,11 +36,11 @@ open Protocol let wrap e = Lwt.return (Environment.wrap_tzresult e) let simple_test () = - let (public, secret) = Timelock.gen_rsa_keys () in + let public, secret = Timelock.gen_rsa_keys () in let locked_value = Timelock.gen_locked_value public in let time = 1000 in let unlocked_value = Timelock.unlock_with_secret secret ~time locked_value in - let (same_unlocked, proof) = + let same_unlocked, proof = Timelock.unlock_and_prove_without_secret public ~time locked_value in assert (unlocked_value = same_unlocked) ; @@ -78,11 +78,11 @@ let contract_test () = Context.init ~consensus_threshold:0 3 >>=? fun (b, contracts) -> let src = match contracts with hd :: _ -> hd | _ -> assert false in originate_contract "contracts/timelock.tz" "0xaa" src b >>=? fun (dst, b) -> - let (public, secret) = Timelock.gen_rsa_keys () in + let public, secret = Timelock.gen_rsa_keys () in let locked_value = Timelock.gen_locked_value public in let time = 1000 in let unlocked_value = Timelock.unlock_with_secret secret ~time locked_value in - let (_same_unlocked, proof) = + let _same_unlocked, proof = Timelock.unlock_and_prove_without_secret public ~time locked_value in let sym_key = Timelock.unlocked_value_to_symmetric_key unlocked_value in @@ -139,13 +139,13 @@ let contract_test () = (Hex.show (Hex.of_bytes message)) >>=? fun () -> (* We redo an RSA parameters generation to create incorrect cipher and proof *) - let (public_bogus, secret_bogus) = Timelock.gen_rsa_keys () in + let public_bogus, secret_bogus = Timelock.gen_rsa_keys () in let locked_value_bogus = Timelock.gen_locked_value public_bogus in let time = 1000 in let unlocked_value_bogus = Timelock.unlock_with_secret secret_bogus ~time locked_value_bogus in - let (_same_unlocked, proof_bogus) = + let _same_unlocked, proof_bogus = Timelock.unlock_and_prove_without_secret public ~time locked_value_bogus in let sym_key_bogus = diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_typechecking.ml index 8e9f1a0e2ef1..5687bef5af51 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -802,9 +802,9 @@ let test_optimal_comb () = ty v >>=? fun (unparsed, ctxt) -> - let (unparsed_canonical, unparsed_size) = size_of_micheline unparsed in + let unparsed_canonical, unparsed_size = size_of_micheline unparsed in List.iter_es (fun other_repr -> - let (other_repr_canonical, other_repr_size) = + let other_repr_canonical, other_repr_size = size_of_micheline other_repr in if other_repr_size < unparsed_size then @@ -845,7 +845,7 @@ let test_optimal_comb () = (* Check that UNPACK on contract is forbidden. See https://gitlab.com/tezos/tezos/-/issues/301 for the motivation behind this restriction. - *) +*) let test_contract_not_packable () = let contract_unit = Prim (0, Script.T_contract, [Prim (0, T_unit, [], [])], []) diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_activation.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_activation.ml index 4da26ecf030d..9e7f7d0bba26 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_activation.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_activation.ml @@ -95,7 +95,7 @@ let secrets () = in List.map (fun (mnemonic, secret, amount, pkh, password, email) -> - let (pkh', pk, sk) = read_key mnemonic email password in + let pkh', pk, sk = read_key mnemonic email password in let pkh = Signature.Public_key_hash.of_b58check_exn pkh in assert (Signature.Public_key_hash.equal pkh pkh') ; let account = Account.{pkh; pk; sk} in diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_combined_operations.ml index 2746283b6943..efc877f42d4f 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_combined_operations.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_combined_operations.ml @@ -53,7 +53,7 @@ let gas_limit = Alpha_context.Gas.Arith.integral_of_int_exn 3000 (** Groups ten transactions between the same parties. *) let test_multiple_transfers () = Context.init 3 >>=? fun (blk, contracts) -> - let (c1, c2, c3) = + let c1, c2, c3 = match contracts with [c1; c2; c3] -> (c1, c2, c3) | _ -> assert false in List.map_es @@ -85,7 +85,7 @@ let test_multiple_transfers () = (** Groups ten delegated originations. *) let test_multiple_origination_and_delegation () = Context.init 2 >>=? fun (blk, contracts) -> - let (c1, c2) = + let c1, c2 = match contracts with [c1; c2] -> (c1, c2) | _ -> assert false in let n = 10 in @@ -108,7 +108,7 @@ let test_multiple_origination_and_delegation () = >>=? fun originations -> (* These computed originated contracts are not the ones really created *) (* We will extract them from the tickets *) - let (originations_operations, _) = List.split originations in + let originations_operations, _ = List.split originations in Op.combine_operations ~source:c1 (B blk) originations_operations >>=? fun operation -> Incremental.begin_construction blk >>=? fun inc -> @@ -171,7 +171,7 @@ let expect_balance_too_low = function Variant without fees. *) let test_failing_operation_in_the_middle () = Context.init 2 >>=? fun (blk, contracts) -> - let (c1, c2) = + let c1, c2 = match contracts with [c1; c2] -> (c1, c2) | _ -> assert false in Op.transaction ~gas_limit ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op1 -> @@ -201,9 +201,9 @@ let test_failing_operation_in_the_middle () = (Manager_operation_result {operation_result = Backtracked _; _}) :: Contents_result (Manager_operation_result {operation_result = Failed (_, trace); _}) - :: Contents_result - (Manager_operation_result {operation_result = Skipped _; _}) - :: _ -> + :: Contents_result + (Manager_operation_result {operation_result = Skipped _; _}) + :: _ -> let trace_string = Format.asprintf "%a" Environment.Error_monad.pp_trace trace in @@ -221,7 +221,7 @@ let test_failing_operation_in_the_middle () = Variant with fees, that should be spent even in case of failure. *) let test_failing_operation_in_the_middle_with_fees () = Context.init 2 >>=? fun (blk, contracts) -> - let (c1, c2) = + let c1, c2 = match contracts with [c1; c2] -> (c1, c2) | _ -> assert false in Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> @@ -250,9 +250,9 @@ let test_failing_operation_in_the_middle_with_fees () = (Manager_operation_result {operation_result = Backtracked _; _}) :: Contents_result (Manager_operation_result {operation_result = Failed (_, trace); _}) - :: Contents_result - (Manager_operation_result {operation_result = Skipped _; _}) - :: _ -> + :: Contents_result + (Manager_operation_result {operation_result = Skipped _; _}) + :: _ -> let trace_string = Format.asprintf "%a" Environment.Error_monad.pp_trace trace in @@ -287,8 +287,8 @@ let expect_wrong_signature list = let test_wrong_signature_in_the_middle () = Context.init 2 >>=? function - | (_, []) | (_, [_]) -> assert false - | (blk, c1 :: c2 :: _) -> + | _, [] | _, [_] -> assert false + | blk, c1 :: c2 :: _ -> Op.transaction ~gas_limit ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~gas_limit ~fee:Tez.one (B blk) c2 c1 Tez.one diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_voting.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_voting.ml index 94e365f108f5..4e181ad5bb27 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_voting.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/operations/test_voting.ml @@ -37,7 +37,7 @@ accounts remain active during a voting period, which roughly translates to the following condition being assumed to hold: `blocks_per_voting_period <= preserved_cycles * blocks_per_cycle.` - *) +*) open Protocol open Alpha_context @@ -467,15 +467,15 @@ let get_smallest_prefix_voters_for_quorum active_delegates active_rolls |> fun active_rolls_sum -> let rec loop delegates rolls sum selected = match (delegates, rolls) with - | ([], []) -> selected - | (del :: delegates, del_rolls :: rolls) -> + | [], [] -> selected + | del :: delegates, del_rolls :: rolls -> if den * sum < Float.to_int (expected_quorum *. Int32.to_float active_rolls_sum) then loop delegates rolls (sum + Int32.to_int del_rolls) (del :: selected) else selected - | (_, _) -> [] + | _, _ -> [] in loop active_delegates active_rolls 0 [] @@ -825,8 +825,8 @@ let test_supermajority_in_exploration supermajority () = (* majority/minority vote depending on the [supermajority] parameter *) let num_yays = if supermajority then num_yays else num_yays - 1 in let open Alpha_context in - let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in - let (yays_delegates, _) = List.split_n num_yays rest in + let nays_delegates, rest = List.split_n num_nays delegates_p2 in + let yays_delegates, _ = List.split_n num_yays rest in List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates >>=? fun operations_yays -> List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/test_liquidity_baking.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/test_liquidity_baking.ml index c4abb8c33d46..3453d76ee8cb 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/test_liquidity_baking.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/test_liquidity_baking.ml @@ -54,7 +54,6 @@ let generate_init_state () = (* The script hash of https://gitlab.com/dexter2tz/dexter2tz/-/blob/d98643881fe14996803997f1283e84ebd2067e35/dexter.liquidity_baking.mligo.tz - *) let expected_cpmm_hash = Script_expr_hash.of_b58check_exn @@ -63,7 +62,6 @@ let expected_cpmm_hash = (* The script hash of https://gitlab.com/dexter2tz/dexter2tz/-/blob/d98643881fe14996803997f1283e84ebd2067e35/lqt_fa12.mligo.tz - *) let expected_lqt_hash = Script_expr_hash.of_b58check_exn diff --git a/src/proto_012_Psithaca/lib_protocol/test/integration/test_token.ml b/src/proto_012_Psithaca/lib_protocol/test/integration/test_token.ml index 041d1ebc472d..78c7a238bcba 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/integration/test_token.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/integration/test_token.ml @@ -57,7 +57,7 @@ let test_simple_balances () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> let src = `Contract (Contract.implicit_contract pkh) in - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = `Contract (Contract.implicit_contract pkh) in let amount = Tez.one in wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) -> @@ -76,7 +76,7 @@ let test_simple_balance_updates () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> let src = Contract.implicit_contract pkh in - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.implicit_contract pkh in let amount = Tez.one in wrap (Token.transfer ctxt (`Contract src) (`Contract dest) amount) @@ -125,7 +125,7 @@ let test_allocated () = create_context () >>=? fun (ctxt, pkh) -> let dest = `Delegate_balance pkh in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = `Contract (Contract.implicit_contract pkh) in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> let dest = `Collected_commitments Blinded_public_key_hash.zero in @@ -169,7 +169,7 @@ let test_transferring_to_sink ctxt sink amount expected_bupds = return_unit let test_transferring_to_contract ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.implicit_contract pkh in let amount = random_amount () in test_transferring_to_sink @@ -188,7 +188,7 @@ let test_transferring_to_collected_commitments ctxt = [(Commitments bpkh, Credited amount, Block_application)] let test_transferring_to_delegate_balance ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.implicit_contract pkh in (* First we need to force the allocation of [dest]. *) wrap (Token.transfer ctxt `Minted (`Contract dest) Tez.one) @@ -203,7 +203,7 @@ let test_transferring_to_delegate_balance ctxt = [(Contract dest, Credited amount, Block_application)] let test_transferring_to_frozen_deposits ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in test_transferring_to_sink ctxt @@ -220,7 +220,7 @@ let test_transferring_to_collected_fees ctxt = [(Block_fees, Credited amount, Block_application)] let test_transferring_to_legacy_deposits ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in let cycle = Cycle.(add root (Random.int 10)) in test_transferring_to_sink @@ -230,7 +230,7 @@ let test_transferring_to_legacy_deposits ctxt = [(Legacy_deposits (pkh, cycle), Credited amount, Block_application)] let test_transferring_to_legacy_fees ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in let cycle = Cycle.(add root (Random.int 10)) in test_transferring_to_sink @@ -240,7 +240,7 @@ let test_transferring_to_legacy_fees ctxt = [(Legacy_fees (pkh, cycle), Credited amount, Block_application)] let test_transferring_to_legacy_rewards ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in let cycle = Cycle.(add root (Random.int 10)) in test_transferring_to_sink @@ -276,7 +276,7 @@ let test_transferring_to_burned ctxt = true >>=? fun () -> let pkh = Signature.Public_key_hash.zero in - let (p, r) = (Random.bool (), Random.bool ()) in + let p, r = (Random.bool (), Random.bool ()) in wrap (Token.transfer ctxt `Minted (`Lost_endorsing_rewards (pkh, p, r)) amount) >>=? fun (_, bupds) -> @@ -342,7 +342,7 @@ let test_transferring_from_bounded_source ctxt src amount expected_bupds = Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true let test_transferring_from_contract ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let src = Contract.implicit_contract pkh in let amount = random_amount () in test_transferring_from_bounded_source @@ -361,7 +361,7 @@ let test_transferring_from_collected_commitments ctxt = [(Commitments bpkh, Debited amount, Block_application)] let test_transferring_from_delegate_balance ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in let src = Contract.implicit_contract pkh in (* First we need to force the allocation of [dest]. *) @@ -374,7 +374,7 @@ let test_transferring_from_delegate_balance ctxt = [(Contract src, Debited amount, Block_application)] let test_transferring_from_frozen_deposits ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in test_transferring_from_bounded_source ctxt @@ -391,7 +391,7 @@ let test_transferring_from_collected_fees ctxt = [(Block_fees, Debited amount, Block_application)] let test_transferring_from_legacy_deposits ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in let cycle = Cycle.(add root (Random.int 10)) in test_transferring_from_bounded_source @@ -401,7 +401,7 @@ let test_transferring_from_legacy_deposits ctxt = [(Legacy_deposits (pkh, cycle), Debited amount, Block_application)] let test_transferring_from_legacy_fees ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in let cycle = Cycle.(add root (Random.int 10)) in test_transferring_from_bounded_source @@ -411,7 +411,7 @@ let test_transferring_from_legacy_fees ctxt = [(Legacy_fees (pkh, cycle), Debited amount, Block_application)] let test_transferring_from_legacy_rewards ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in let cycle = Cycle.(add root (Random.int 10)) in test_transferring_from_bounded_source @@ -481,13 +481,13 @@ let cast_to_container_type x = let build_test_cases () = create_context () >>=? fun (ctxt, pkh) -> let origin = `Contract (Contract.implicit_contract pkh) in - let (user1, _, _) = Signature.generate_key () in + let user1, _, _ = Signature.generate_key () in let user1c = `Contract (Contract.implicit_contract user1) in - let (user2, _, _) = Signature.generate_key () in + let user2, _, _ = Signature.generate_key () in let user2c = `Contract (Contract.implicit_contract user2) in - let (baker1, baker1_pk, _) = Signature.generate_key () in + let baker1, baker1_pk, _ = Signature.generate_key () in let baker1c = `Contract (Contract.implicit_contract baker1) in - let (baker2, baker2_pk, _) = Signature.generate_key () in + let baker2, baker2_pk, _ = Signature.generate_key () in let baker2c = `Contract (Contract.implicit_contract baker2) in (* Allocate contracts for user1, user2, baker1, and baker2. *) wrap (Token.transfer ctxt origin user1c (random_amount ())) @@ -553,23 +553,23 @@ let check_sink_balances ctxt ctxt' dest amount = let rec check_balances ctxt ctxt' src dest amount = match (cast_to_container_type src, cast_to_container_type dest) with - | (None, None) -> return_unit - | (Some (`Delegate_balance d), Some (`Contract c as contract)) + | None, None -> return_unit + | Some (`Delegate_balance d), Some (`Contract c as contract) when Contract.implicit_contract d = c -> (* src and dest are in fact referring to the same contract *) check_balances ctxt ctxt' contract contract amount - | (Some (`Contract c as contract), Some (`Delegate_balance d)) + | Some (`Contract c as contract), Some (`Delegate_balance d) when Contract.implicit_contract d = c -> (* src and dest are in fact referring to the same contract *) check_balances ctxt ctxt' contract contract amount - | (Some src, Some dest) when src = dest -> + | Some src, Some dest when src = dest -> (* src and dest are the same contract *) wrap (Token.balance ctxt dest) >>=? fun bal_dest -> wrap (Token.balance ctxt' dest) >>=? fun bal_dest' -> Assert.equal_tez ~loc:__LOC__ bal_dest bal_dest' - | (Some src, None) -> check_src_balances ctxt ctxt' src amount - | (None, Some dest) -> check_sink_balances ctxt ctxt' dest amount - | (Some src, Some dest) -> + | Some src, None -> check_src_balances ctxt ctxt' src amount + | None, Some dest -> check_sink_balances ctxt ctxt' dest amount + | Some src, Some dest -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> check_sink_balances ctxt ctxt' dest amount @@ -598,22 +598,22 @@ let test_all_combinations_of_sources_and_sinks () = if one is a credit while the other is a debit. *) let coalesce_balance_updates bu1 bu2 = match (bu1, bu2) with - | ((bu1_bal, bu1_balupd, bu1_origin), (bu2_bal, bu2_balupd, bu2_origin)) -> ( + | (bu1_bal, bu1_balupd, bu1_origin), (bu2_bal, bu2_balupd, bu2_origin) -> ( assert (bu1_bal = bu2_bal) ; assert (bu1_origin = bu2_origin) ; let open Receipt in match (bu1_balupd, bu2_balupd) with - | (Credited bu1_am, Credited bu2_am) -> + | Credited bu1_am, Credited bu2_am -> let bu_am = match bu1_am +? bu2_am with Ok am -> am | _ -> assert false in (bu1_bal, Credited bu_am, bu1_origin) - | (Debited bu1_am, Debited bu2_am) -> + | Debited bu1_am, Debited bu2_am -> let bu_am = match bu1_am +? bu2_am with Ok am -> am | _ -> assert false in (bu1_bal, Debited bu_am, bu1_origin) - | (Credited _, Debited _) | (Debited _, Credited _) -> assert false) + | Credited _, Debited _ | Debited _, Credited _ -> assert false) (** Check that elt has the same balance in ctxt1 and ctxt2. *) let check_balances_are_consistent ctxt1 ctxt2 elt = @@ -642,7 +642,7 @@ let test_transfer_n ctxt src dest = (* remove burning balance updates *) let debit_logs = List.filter - (fun b -> match b with (Receipt.Burned, _, _) -> false | _ -> true) + (fun b -> match b with Receipt.Burned, _, _ -> false | _ -> true) debit_logs in (* Credit the sink for each source. *) @@ -656,7 +656,7 @@ let test_transfer_n ctxt src dest = (* remove minting balance updates *) let credit_logs = List.filter - (fun b -> match b with (Receipt.Minted, _, _) -> false | _ -> true) + (fun b -> match b with Receipt.Minted, _, _ -> false | _ -> true) credit_logs in (* Check equivalence of balance updates. *) @@ -681,13 +681,13 @@ let test_transfer_n_with_non_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> let origin = `Contract (Contract.implicit_contract pkh) in - let (user1, _, _) = Signature.generate_key () in + let user1, _, _ = Signature.generate_key () in let user1c = `Contract (Contract.implicit_contract user1) in - let (user2, _, _) = Signature.generate_key () in + let user2, _, _ = Signature.generate_key () in let user2c = `Contract (Contract.implicit_contract user2) in - let (user3, _, _) = Signature.generate_key () in + let user3, _, _ = Signature.generate_key () in let user3c = `Contract (Contract.implicit_contract user3) in - let (user4, _, _) = Signature.generate_key () in + let user4, _, _ = Signature.generate_key () in let user4c = `Contract (Contract.implicit_contract user4) in (* Allocate contracts for user1, user2, user3, and user4. *) let amount = diff --git a/src/proto_012_Psithaca/lib_protocol/test/pbt/liquidity_baking_pbt.ml b/src/proto_012_Psithaca/lib_protocol/test/pbt/liquidity_baking_pbt.ml index 37b5e75902a8..fb854096a0b5 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/pbt/liquidity_baking_pbt.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/pbt/liquidity_baking_pbt.ml @@ -92,8 +92,8 @@ let get_float_balances env state = fraction of tzbtc and xtz returned to the liquidity provider is lesser or equal than the fraction of lqt burnt. *) let is_remove_liquidity_consistent env state state' = - let (xtz, tzbtc, lqt) = get_float_balances env state in - let (xtz', tzbtc', lqt') = get_float_balances env state' in + let xtz, tzbtc, lqt = get_float_balances env state in + let xtz', tzbtc', lqt' = get_float_balances env state' in if lqt' < lqt then let flqt = (lqt -. lqt') /. lqt in let fxtz = (xtz -. xtz') /. xtz in @@ -106,8 +106,8 @@ let is_remove_liquidity_consistent env state state' = See https://blog.nomadic-labs.com/progress-report-on-the-verification-of-liquidity-baking-smart-contracts.html#evolution-of-the-product-of-supplies *) let is_share_price_increasing env state state' = - let (xtz, tzbtc, lqt) = get_float_balances env state in - let (xtz', tzbtc', lqt') = get_float_balances env state' in + let xtz, tzbtc, lqt = get_float_balances env state in + let xtz', tzbtc', lqt' = get_float_balances env state' in xtz *. tzbtc /. (lqt *. lqt) <= xtz' *. tzbtc' /. (lqt' *. lqt') (** [positive_pools env state] returns [true] iff the three pools of @@ -185,12 +185,10 @@ let validate_consistency : fun env state -> all_true (validate_cpmm_total_liquidity env state - :: - validate_balances env.cpmm_contract env state - :: - List.map - (fun account -> validate_balances account env state) - env.implicit_accounts) + :: validate_balances env.cpmm_contract env state + :: List.map + (fun account -> validate_balances account env state) + env.implicit_accounts) (** [validate_storage env blk] returns [true] iff the storage of the CPMM contract is consistent wrt. to its actual balances (tez, @@ -248,7 +246,7 @@ let machine_validation_tests = (fun (specs, scenario) -> extract_qcheck_tzresult (let invariant = positive_pools in - let (state, env) = SymbolicMachine.build ~invariant specs in + let state, env = SymbolicMachine.build ~invariant specs in let _ = SymbolicMachine.run ~invariant scenario env state in return_unit)); ] @@ -263,7 +261,7 @@ let economic_tests = ~name:"No global gain" (Liquidity_baking_generator.arb_adversary_scenario 1_000_000 1_000_000 50) (fun (specs, attacker, scenario) -> - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (one_balance_decreases attacker env) scenario env state in @@ -273,7 +271,7 @@ let economic_tests = ~name:"Remove liquidities is consistent" (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (is_remove_liquidity_consistent env) scenario env state in @@ -283,7 +281,7 @@ let economic_tests = ~name:"Share price only increases" (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (is_share_price_increasing env) scenario env state in diff --git a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_script_comparison.ml index ef2fd198375a..bee814df0699 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_script_comparison.ml @@ -50,33 +50,33 @@ let rec reference_compare_comparable : type a. a comparable_ty -> a -> a -> int = fun ty x y -> match (ty, x, y) with - | (Unit_key _, (), ()) -> 0 - | (Never_key _, _, _) -> . - | (Signature_key _, x, y) -> normalize_compare @@ Signature.compare x y - | (String_key _, x, y) -> normalize_compare @@ Script_string.compare x y - | (Bool_key _, x, y) -> normalize_compare @@ Compare.Bool.compare x y - | (Mutez_key _, x, y) -> normalize_compare @@ Tez.compare x y - | (Key_hash_key _, x, y) -> + | Unit_key _, (), () -> 0 + | Never_key _, _, _ -> . + | Signature_key _, x, y -> normalize_compare @@ Signature.compare x y + | String_key _, x, y -> normalize_compare @@ Script_string.compare x y + | Bool_key _, x, y -> normalize_compare @@ Compare.Bool.compare x y + | Mutez_key _, x, y -> normalize_compare @@ Tez.compare x y + | Key_hash_key _, x, y -> normalize_compare @@ Signature.Public_key_hash.compare x y - | (Key_key _, x, y) -> normalize_compare @@ Signature.Public_key.compare x y - | (Int_key _, x, y) -> normalize_compare @@ Script_int.compare x y - | (Nat_key _, x, y) -> normalize_compare @@ Script_int.compare x y - | (Timestamp_key _, x, y) -> normalize_compare @@ Script_timestamp.compare x y - | (Address_key _, x, y) -> + | Key_key _, x, y -> normalize_compare @@ Signature.Public_key.compare x y + | Int_key _, x, y -> normalize_compare @@ Script_int.compare x y + | Nat_key _, x, y -> normalize_compare @@ Script_int.compare x y + | Timestamp_key _, x, y -> normalize_compare @@ Script_timestamp.compare x y + | Address_key _, x, y -> normalize_compare @@ Script_comparable.compare_address x y - | (Bytes_key _, x, y) -> normalize_compare @@ Compare.Bytes.compare x y - | (Chain_id_key _, x, y) -> normalize_compare @@ Chain_id.compare x y - | (Pair_key ((tl, _), (tr, _), _), (lx, rx), (ly, ry)) -> + | Bytes_key _, x, y -> normalize_compare @@ Compare.Bytes.compare x y + | Chain_id_key _, x, y -> normalize_compare @@ Chain_id.compare x y + | Pair_key ((tl, _), (tr, _), _), (lx, rx), (ly, ry) -> let cl = reference_compare_comparable tl lx ly in if Compare.Int.(cl = 0) then reference_compare_comparable tr rx ry else cl - | (Union_key ((tl, _), _, _), L x, L y) -> reference_compare_comparable tl x y - | (Union_key _, L _, R _) -> -1 - | (Union_key _, R _, L _) -> 1 - | (Union_key (_, (tr, _), _), R x, R y) -> reference_compare_comparable tr x y - | (Option_key _, None, None) -> 0 - | (Option_key _, None, Some _) -> -1 - | (Option_key _, Some _, None) -> 1 - | (Option_key (t, _), Some x, Some y) -> reference_compare_comparable t x y + | Union_key ((tl, _), _, _), L x, L y -> reference_compare_comparable tl x y + | Union_key _, L _, R _ -> -1 + | Union_key _, R _, L _ -> 1 + | Union_key (_, (tr, _), _), R x, R y -> reference_compare_comparable tr x y + | Option_key _, None, None -> 0 + | Option_key _, None, Some _ -> -1 + | Option_key _, Some _, None -> 1 + | Option_key (t, _), Some x, Some y -> reference_compare_comparable t x y (* Generation of one to three values of the same comparable type. *) @@ -324,9 +324,9 @@ let test_transitivity = let cxy = Script_comparable.compare_comparable ty x y in let cyz = Script_comparable.compare_comparable ty y z in match (cxy, cyz) with - | (0, n) | (n, 0) -> qcheck_compare_comparable ~expected:n ty x z - | (-1, -1) -> qcheck_compare_comparable ~expected:(-1) ty x z - | (1, 1) -> qcheck_compare_comparable ~expected:1 ty x z + | 0, n | n, 0 -> qcheck_compare_comparable ~expected:n ty x z + | -1, -1 -> qcheck_compare_comparable ~expected:(-1) ty x z + | 1, 1 -> qcheck_compare_comparable ~expected:1 ty x z | _ -> QCheck.assume_fail ()) (* Test. @@ -334,8 +334,7 @@ let test_transitivity = *) let test_pack_unpack = QCheck.Test.make - ~count: - 100_000 + ~count:100_000 (* We run this test on many more cases than the default (100) because this is a very important property. Packing and then unpacking happens each time data is sent from a contract to another and also each time storage diff --git a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_tez_repr.ml b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_tez_repr.ml index f2a95ce31380..ea1a3f0dd7f7 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_tez_repr.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_tez_repr.ml @@ -45,19 +45,19 @@ let z_in_mutez_bounds (z : Z.t) : bool = let compare (c' : Z.t) (c : Tez.t tzresult) : bool = match (z_in_mutez_bounds @@ c', c) with - | (true, Ok c) -> + | true, Ok c -> Lib_test.Qcheck_helpers.qcheck_eq' ~pp:Z.pp_print ~expected:c' ~actual:(tez_to_z c) () - | (true, Error _) -> + | true, Error _ -> QCheck.Test.fail_reportf "@[<h 0>Results are in Z bounds, but tez operation fails.@]" - | (false, Ok _) -> + | false, Ok _ -> QCheck.Test.fail_reportf "@[<h 0>Results are not in Z bounds, but tez operation did not fail.@]" - | (false, Error _) -> true + | false, Error _ -> true (* [prop_binop f f' (a, b)] compares the function [f] in Tez with a model function function [f'] in [Z]. diff --git a/src/proto_013_PtJakart/bin_sc_rollup_client/configuration.ml b/src/proto_013_PtJakart/bin_sc_rollup_client/configuration.ml index e5cd10551cee..0de3f0b092ae 100644 --- a/src/proto_013_PtJakart/bin_sc_rollup_client/configuration.ml +++ b/src/proto_013_PtJakart/bin_sc_rollup_client/configuration.ml @@ -40,7 +40,7 @@ let default = let valid_endpoint _configuration s = let endpoint = Uri.of_string s in match (Uri.scheme endpoint, Uri.query endpoint, Uri.fragment endpoint) with - | (Some ("http" | "https"), [], None) -> return endpoint + | Some ("http" | "https"), [], None -> return endpoint | _ -> failwith "Endpoint should be of the form http[s]://address:port" let endpoint_arg () = @@ -82,7 +82,7 @@ let make (base_dir, endpoint) = } let parse argv = - let* (opts, argv) = + let* opts, argv = Clic.parse_global_options (global_options ()) default argv in return (make opts, argv) diff --git a/src/proto_013_PtJakart/bin_sc_rollup_node/inbox.ml b/src/proto_013_PtJakart/bin_sc_rollup_node/inbox.ml index b0848b535a17..b0cbc9bc20b0 100644 --- a/src/proto_013_PtJakart/bin_sc_rollup_node/inbox.ml +++ b/src/proto_013_PtJakart/bin_sc_rollup_node/inbox.ml @@ -51,7 +51,7 @@ module State = struct let history_of_hash = Store.Histories.get - let (set_sc_rollup_address, get_sc_rollup_address) = + let set_sc_rollup_address, get_sc_rollup_address = let sc_rollup_address = ref None in ( (fun x -> sc_rollup_address := Some x), fun () -> @@ -109,7 +109,7 @@ let process_head cctxt store Layer1.(Head {level; hash = head_hash} as head) = let*! history = State.history_of_hash store predecessor in let*! messages_tree = State.get_message_tree store predecessor in let*? level = Raw_level.of_int32 level in - let* (messages_tree, history, inbox) = + let* messages_tree, history, inbox = Store.Inbox.add_messages history inbox level messages messages_tree in let*! () = State.set_message_tree store head_hash messages_tree in diff --git a/src/proto_013_PtJakart/bin_sc_rollup_node/layer1.ml b/src/proto_013_PtJakart/bin_sc_rollup_node/layer1.ml index eb2ea3b67496..5179949282de 100644 --- a/src/proto_013_PtJakart/bin_sc_rollup_node/layer1.ml +++ b/src/proto_013_PtJakart/bin_sc_rollup_node/layer1.ml @@ -270,11 +270,11 @@ let chain_events cctxt store chain = | None -> Head {hash = genesis_hash; level = 0l} | Some last_seen_head -> last_seen_head in - let*! (base, events) = catch_up cctxt store chain last_seen_head new_head in + let*! base, events = catch_up cctxt store chain last_seen_head new_head in let*! () = List.iter_s (store_chain_event store base) events in Lwt.return events in - let+ (heads, _) = Tezos_shell_services.Monitor_services.heads cctxt chain in + let+ heads, _ = Tezos_shell_services.Monitor_services.heads cctxt chain in Lwt_stream.map_list_s on_head heads let check_sc_rollup_address_exists sc_rollup_address diff --git a/src/proto_013_PtJakart/bin_tx_rollup_client/configuration.ml b/src/proto_013_PtJakart/bin_tx_rollup_client/configuration.ml index 2b4a9350ed6a..6ce56574360a 100644 --- a/src/proto_013_PtJakart/bin_tx_rollup_client/configuration.ml +++ b/src/proto_013_PtJakart/bin_tx_rollup_client/configuration.ml @@ -40,7 +40,7 @@ let default = let valid_endpoint _configuration s = let endpoint = Uri.of_string s in match (Uri.scheme endpoint, Uri.query endpoint, Uri.fragment endpoint) with - | (Some ("http" | "https"), [], None) -> return endpoint + | Some ("http" | "https"), [], None -> return endpoint | _ -> failwith "Endpoint should be of the form http[s]://address:port" let endpoint_arg () = @@ -83,7 +83,7 @@ let make (base_dir, endpoint) = } let parse argv = - let* (opts, argv) = + let* opts, argv = Clic.parse_global_options (global_options ()) default argv in return (make opts, argv) diff --git a/src/proto_013_PtJakart/lib_benchmark/autocomp.ml b/src/proto_013_PtJakart/lib_benchmark/autocomp.ml index 1a44dc9826f7..ab3c371190af 100644 --- a/src/proto_013_PtJakart/lib_benchmark/autocomp.ml +++ b/src/proto_013_PtJakart/lib_benchmark/autocomp.ml @@ -141,7 +141,7 @@ module SM = struct let ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t = fun m f rng_state s -> - let (x, s) = m rng_state s in + let x, s = m rng_state s in f x rng_state s [@@inline] @@ -294,14 +294,12 @@ struct complete_data_list path (i + 1) tl (term :: acc) let complete_data typing node rng_state = - let (root_type_opt, _) = - Inference.M.get_data_annot Kernel.Path.root typing - in + let root_type_opt, _ = Inference.M.get_data_annot Kernel.Path.root typing in match root_type_opt with | None -> Stdlib.failwith "Autocomp.complete_data: cannot get type of expr" | Some ty -> - let (_, typing) = Inference.instantiate_base ty typing in - let (result, _) = + let _, typing = Inference.instantiate_base ty typing in + let result, _ = try complete_data node Kernel.Path.root rng_state typing with Autocompletion_error (Cannot_complete_data (subterm, path)) -> Format.eprintf "Cannot complete data@." ; @@ -309,7 +307,7 @@ struct Format.eprintf "%a@." Mikhailsky.pp subterm ; Stdlib.failwith "in autocomp.ml: unrecoverable failure" in - let (typ, _typing) = + let typ, _typing = try Inference.infer_data_with_state result with Inference.Ill_typed_script error -> Format.eprintf "%a@." Inference.pp_inference_error error ; @@ -352,15 +350,15 @@ struct complete_code_list path (i + 1) tl (term :: acc) let complete_code typing node rng_state = - let (root_type_opt, _) = + let root_type_opt, _ = Inference.M.get_instr_annot Kernel.Path.root typing in match root_type_opt with | None -> Stdlib.failwith "Autocomp.complete_code: cannot get type of expr" | Some {bef; aft} -> - let (_, typing) = Inference.instantiate bef typing in - let (_, typing) = Inference.instantiate aft typing in - let (result, _) = + let _, typing = Inference.instantiate bef typing in + let _, typing = Inference.instantiate aft typing in + let result, _ = try complete_code node Kernel.Path.root rng_state typing with | Autocompletion_error (Cannot_complete_code (subterm, path)) -> Format.eprintf "Cannot complete code@." ; @@ -369,14 +367,14 @@ struct Stdlib.failwith "in autocomp.ml: unrecoverable failure" | _ -> assert false in - let ((bef, aft), typing) = + let (bef, aft), typing = try Inference.infer_with_state result with Inference.Ill_typed_script error -> Format.eprintf "%a@." Inference.pp_inference_error error ; Format.eprintf "%a@." Mikhailsky.pp result ; assert false in - let (bef, typing) = instantiate_and_set_stack bef typing in - let (aft, typing) = instantiate_and_set_stack aft typing in + let bef, typing = instantiate_and_set_stack bef typing in + let aft, typing = instantiate_and_set_stack aft typing in (result, (bef, aft), typing) end diff --git a/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/inference.ml b/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/inference.ml index 72dc6c1ef4be..88ba95c8db0f 100644 --- a/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/inference.ml +++ b/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/inference.ml @@ -48,10 +48,10 @@ let pp_comparability fmtr (cmp : comparability) = let sup_comparability (c1 : comparability) (c2 : comparability) = match (c1, c2) with - | (Unconstrained, c) | (c, Unconstrained) -> Some c - | (Comparable, Comparable) -> Some Comparable - | (Not_comparable, Not_comparable) -> Some Not_comparable - | (Comparable, Not_comparable) | (Not_comparable, Comparable) -> None + | Unconstrained, c | c, Unconstrained -> Some c + | Comparable, Comparable -> Some Comparable + | Not_comparable, Not_comparable -> Some Not_comparable + | Comparable, Not_comparable | Not_comparable, Comparable -> None type michelson_type = | Base_type of {repr : Type.Base.t option; comparable : comparability} @@ -247,7 +247,7 @@ module M = struct } let ( >>= ) m f s = - let (x, s) = m s in + let x, s = m s in f x s [@@inline] @@ -257,25 +257,25 @@ module M = struct let uf_lift : 'a UF.M.t -> 'a t = fun computation state -> - let (res, uf) = computation state.uf in + let res, uf = computation state.uf in (res, {state with uf}) [@@inline] let repr_lift : 'a Repr_sm.t -> 'a t = fun computation state -> - let (res, repr) = computation state.repr in + let res, repr = computation state.repr in (res, {state with repr}) [@@inline] let annot_instr_lift : 'a Annot_instr_sm.t -> 'a t = fun computation state -> - let (res, annot_instr) = computation state.annot_instr in + let res, annot_instr = computation state.annot_instr in (res, {state with annot_instr}) [@@inline] let annot_data_lift : 'a Annot_data_sm.t -> 'a t = fun computation state -> - let (res, annot_data) = computation state.annot_data in + let res, annot_data = computation state.annot_data in (res, {state with annot_data}) [@@inline] @@ -380,17 +380,17 @@ let rec unify (x : Type.Stack.t) (y : Type.Stack.t) : unit M.t = if x.tag = y.tag then return () else match (x.node, y.node) with - | (Empty_t, Empty_t) -> return () - | (Stack_var_t x, Stack_var_t y) -> + | Empty_t, Empty_t -> return () + | Stack_var_t x, Stack_var_t y -> M.uf_lift (UF.find x) >>= fun root_x -> M.uf_lift (UF.find y) >>= fun root_y -> get_repr_exn root_x >>= fun repr_x -> get_repr_exn root_y >>= fun repr_y -> M.uf_lift (UF.union x y) >>= fun root -> merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | (Stack_var_t v, _) -> unify_single_stack v y - | (_, Stack_var_t v) -> unify_single_stack v x - | (Item_t (ty1, tail1), Item_t (ty2, tail2)) -> + | Stack_var_t v, _ -> unify_single_stack v y + | _, Stack_var_t v -> unify_single_stack v x + | Item_t (ty1, tail1), Item_t (ty2, tail2) -> unify_base ty1 ty2 >>= fun () -> unify tail1 tail2 >>= fun () -> return () | _ -> raise (Ill_typed_script (Stack_types_incompatible (x, y))) @@ -412,37 +412,37 @@ and unify_base (x : Type.Base.t) (y : Type.Base.t) : unit M.t = if x.tag = y.tag then return () else match (x.node, y.node) with - | (Unit_t, Unit_t) - | (Int_t, Int_t) - | (Nat_t, Nat_t) - | (Bool_t, Bool_t) - | (String_t, String_t) - | (Bytes_t, Bytes_t) - | (Key_hash_t, Key_hash_t) - | (Timestamp_t, Timestamp_t) - | (Mutez_t, Mutez_t) - | (Key_t, Key_t) -> + | Unit_t, Unit_t + | Int_t, Int_t + | Nat_t, Nat_t + | Bool_t, Bool_t + | String_t, String_t + | Bytes_t, Bytes_t + | Key_hash_t, Key_hash_t + | Timestamp_t, Timestamp_t + | Mutez_t, Mutez_t + | Key_t, Key_t -> return () - | (Option_t x, Option_t y) -> unify_base x y - | (List_t x, List_t y) -> unify_base x y - | (Set_t x, Set_t y) -> unify_base x y - | (Map_t (kx, vx), Map_t (ky, vy)) -> + | Option_t x, Option_t y -> unify_base x y + | List_t x, List_t y -> unify_base x y + | Set_t x, Set_t y -> unify_base x y + | Map_t (kx, vx), Map_t (ky, vy) -> unify_base kx ky >>= fun () -> unify_base vx vy - | (Pair_t (x, x'), Pair_t (y, y')) -> + | Pair_t (x, x'), Pair_t (y, y') -> unify_base x y >>= fun () -> unify_base x' y' - | (Union_t (x, x'), Union_t (y, y')) -> + | Union_t (x, x'), Union_t (y, y') -> unify_base x y >>= fun () -> unify_base x' y' - | (Lambda_t (x, x'), Lambda_t (y, y')) -> + | Lambda_t (x, x'), Lambda_t (y, y') -> unify_base x y >>= fun () -> unify_base x' y' - | (Var_t x, Var_t y) -> + | Var_t x, Var_t y -> M.uf_lift (UF.find x) >>= fun root_x -> M.uf_lift (UF.find y) >>= fun root_y -> get_repr_exn root_x >>= fun repr_x -> get_repr_exn root_y >>= fun repr_y -> M.uf_lift (UF.union x y) >>= fun root -> merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | (Var_t v, _) -> unify_single_var v y - | (_, Var_t v) -> unify_single_var v x + | Var_t v, _ -> unify_single_var v y + | _, Var_t v -> unify_single_var v x | _ -> instantiate_base x >>= fun x -> instantiate_base y >>= fun y -> @@ -452,11 +452,11 @@ and merge_reprs (repr1 : michelson_type) (repr2 : michelson_type) : michelson_type M.t = let open M in match (repr1, repr2) with - | ((Stack_type None as repr), Stack_type None) - | ((Stack_type (Some _) as repr), Stack_type None) - | (Stack_type None, (Stack_type (Some _) as repr)) -> + | (Stack_type None as repr), Stack_type None + | (Stack_type (Some _) as repr), Stack_type None + | Stack_type None, (Stack_type (Some _) as repr) -> return repr - | ((Stack_type (Some sty1) as repr), Stack_type (Some sty2)) -> + | (Stack_type (Some sty1) as repr), Stack_type (Some sty2) -> unify sty1 sty2 >>= fun () -> return repr | ( Base_type {repr = opt1; comparable = cmp1}, Base_type {repr = opt2; comparable = cmp2} ) -> ( @@ -469,14 +469,14 @@ and merge_reprs (repr1 : michelson_type) (repr2 : michelson_type) : (Comparability_error_types (repr1, repr2)))) | Some comparable -> ( match (opt1, opt2) with - | (None, None) -> return (Base_type {repr = None; comparable}) - | ((Some ty as repr), None) -> + | None, None -> return (Base_type {repr = None; comparable}) + | (Some ty as repr), None -> assert_comparability comparable ty >>= fun () -> return (Base_type {repr; comparable}) - | (None, (Some ty as repr)) -> + | None, (Some ty as repr) -> assert_comparability comparable ty >>= fun () -> return (Base_type {repr; comparable}) - | (Some ty1, Some ty2) -> + | Some ty1, Some ty2 -> unify_base ty1 ty2 >>= fun () -> assert_comparability comparable ty1 >>= fun () -> assert_comparability comparable ty2 >>= fun () -> @@ -555,7 +555,7 @@ and get_comparability (ty : Type.Base.t) : comparability M.t = get_comparability lt >>= fun lc -> get_comparability rt >>= fun rc -> match (lc, rc) with - | (Comparable, Comparable) -> return Comparable + | Comparable, Comparable -> return Comparable | _ -> return Unconstrained) let fresh = @@ -601,35 +601,35 @@ let parse_uint30 n : int = let arith_type (instr : Mikhailsky_prim.prim) (ty1 : Type.Base.t) (ty2 : Type.Base.t) : Type.Base.t option = match (instr, ty1.node, ty2.node) with - | ((I_ADD | I_MUL), Int_t, Int_t) - | ((I_ADD | I_MUL), Int_t, Nat_t) - | ((I_ADD | I_MUL), Nat_t, Int_t) -> + | (I_ADD | I_MUL), Int_t, Int_t + | (I_ADD | I_MUL), Int_t, Nat_t + | (I_ADD | I_MUL), Nat_t, Int_t -> Some Type.int - | ((I_ADD | I_MUL), Nat_t, Nat_t) -> Some Type.nat - | (I_SUB, Int_t, Int_t) - | (I_SUB, Int_t, Nat_t) - | (I_SUB, Nat_t, Int_t) - | (I_SUB, Nat_t, Nat_t) - | (I_SUB, Timestamp_t, Timestamp_t) -> + | (I_ADD | I_MUL), Nat_t, Nat_t -> Some Type.nat + | I_SUB, Int_t, Int_t + | I_SUB, Int_t, Nat_t + | I_SUB, Nat_t, Int_t + | I_SUB, Nat_t, Nat_t + | I_SUB, Timestamp_t, Timestamp_t -> Some Type.int - | (I_EDIV, Int_t, Int_t) - | (I_EDIV, Int_t, Nat_t) - | (I_EDIV, Nat_t, Int_t) - | (I_EDIV, Nat_t, Nat_t) -> + | I_EDIV, Int_t, Int_t + | I_EDIV, Int_t, Nat_t + | I_EDIV, Nat_t, Int_t + | I_EDIV, Nat_t, Nat_t -> Some Type.(option (pair nat nat)) (* Timestamp *) - | (I_ADD, Timestamp_t, Int_t) - | (I_ADD, Int_t, Timestamp_t) - | (I_SUB, Timestamp_t, Int_t) -> + | I_ADD, Timestamp_t, Int_t + | I_ADD, Int_t, Timestamp_t + | I_SUB, Timestamp_t, Int_t -> Some Type.timestamp (* Mutez *) - | (I_ADD, Mutez_t, Mutez_t) - | (I_SUB, Mutez_t, Mutez_t) - | (I_MUL, Mutez_t, Nat_t) - | (I_MUL, Nat_t, Mutez_t) -> + | I_ADD, Mutez_t, Mutez_t + | I_SUB, Mutez_t, Mutez_t + | I_MUL, Mutez_t, Nat_t + | I_MUL, Nat_t, Mutez_t -> Some Type.mutez - | (I_EDIV, Mutez_t, Nat_t) -> Some Type.(option (pair mutez mutez)) - | (I_EDIV, Mutez_t, Mutez_t) -> Some Type.(option (pair nat mutez)) + | I_EDIV, Mutez_t, Nat_t -> Some Type.(option (pair mutez mutez)) + | I_EDIV, Mutez_t, Mutez_t -> Some Type.(option (pair nat mutez)) | _ -> None let rec generate_constraints (path : Mikhailsky.Path.t) (node : Mikhailsky.node) diff --git a/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/monads.ml b/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/monads.ml index d0939011cb5e..47273406af50 100644 --- a/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/monads.ml +++ b/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/monads.ml @@ -65,7 +65,7 @@ module Make_state_monad (X : Stores.S) : type 'a t = state -> 'a * state let ( >>= ) m f s = - let (x, s) = m s in + let x, s = m s in f x s let return x s = (x, s) diff --git a/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml b/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml index 93aa25022308..4b702dd05667 100644 --- a/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml +++ b/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml @@ -50,7 +50,7 @@ module Test1 = struct let program = seq [add_ii; push bool_ty false_; dip instr_hole; dip swap] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -121,7 +121,7 @@ module Test3 = struct module Rewriter = Rewrite.Make (Mikhailsky.Mikhailsky_signature) (Lang) (Path) (Patt) - let (timing, ((bef, aft), state)) = + let timing, ((bef, aft), state) = try time @@ fun () -> Inference.infer_with_state program with Inference.Ill_typed_script error -> let s = Mikhailsky.to_string program in @@ -195,7 +195,7 @@ module Test4 = struct update_set; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -224,7 +224,7 @@ module Test5 = struct update_map; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -253,7 +253,7 @@ module Test5 = struct ]); ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -325,7 +325,7 @@ module Test7 = struct left; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -370,7 +370,7 @@ module Test8 = struct push_int; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -388,7 +388,7 @@ module Test9 = struct let program = seq [car; if_none hole hole] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -406,7 +406,7 @@ module Test10 = struct let program = seq [hash_key] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -425,7 +425,7 @@ module Test11 = struct let program = seq [lambda [dup; car; dip cdr; add_in]; push_int; apply; push_nat; exec] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -443,7 +443,7 @@ module Test12 = struct let program = seq [dup; dup; if_none hole (seq [drop]); dup; compare] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -462,7 +462,7 @@ module Test13 = struct let program = seq [push Type.(unparse_ty_exn (lambda int int)) (Data.lambda [])] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -480,7 +480,7 @@ module Test14 = struct let program = seq [nil; push_int; cons] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -498,7 +498,7 @@ module Test15 = struct let program = seq [empty_set; size_set; empty_map; size_map; nil; size_list] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -524,7 +524,7 @@ module Test16 = struct iter_set [dup; add_ii; add_ii]; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -559,7 +559,7 @@ module Test17 = struct ]; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -601,7 +601,7 @@ module Test18 = struct (seq [drop; drop; push (option_ty (list_ty bool_ty)) Data.none]); ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; diff --git a/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/type.ml b/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/type.ml index dacd2ac7f8fd..5f66f6ff5e7d 100644 --- a/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/type.ml +++ b/src/proto_013_PtJakart/lib_benchmark/lib_benchmark_type_inference/type.ml @@ -55,27 +55,26 @@ module Base = struct let equal (t1 : t) (t2 : t) = match (t1, t2) with - | (Var_t v1, Var_t v2) -> v1 = v2 - | (Unit_t, Unit_t) - | (Int_t, Int_t) - | (Nat_t, Nat_t) - | (Bool_t, Bool_t) - | (String_t, String_t) - | (Bytes_t, Bytes_t) - | (Key_hash_t, Key_hash_t) - | (Timestamp_t, Timestamp_t) - | (Mutez_t, Mutez_t) - | (Key_t, Key_t) -> + | Var_t v1, Var_t v2 -> v1 = v2 + | Unit_t, Unit_t + | Int_t, Int_t + | Nat_t, Nat_t + | Bool_t, Bool_t + | String_t, String_t + | Bytes_t, Bytes_t + | Key_hash_t, Key_hash_t + | Timestamp_t, Timestamp_t + | Mutez_t, Mutez_t + | Key_t, Key_t -> true - | (Option_t ty1, Option_t ty2) -> ty1.tag = ty2.tag - | (Pair_t (l1, r1), Pair_t (l2, r2)) -> l1.tag = l2.tag && r1.tag = r2.tag - | (Union_t (l1, r1), Union_t (l2, r2)) -> - l1.tag = l2.tag && r1.tag = r2.tag - | (List_t ty1, List_t ty2) -> ty1.tag = ty2.tag - | (Set_t ty1, Set_t ty2) -> ty1.tag = ty2.tag - | (Map_t (kty1, vty1), Map_t (kty2, vty2)) -> + | Option_t ty1, Option_t ty2 -> ty1.tag = ty2.tag + | Pair_t (l1, r1), Pair_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag + | Union_t (l1, r1), Union_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag + | List_t ty1, List_t ty2 -> ty1.tag = ty2.tag + | Set_t ty1, Set_t ty2 -> ty1.tag = ty2.tag + | Map_t (kty1, vty1), Map_t (kty2, vty2) -> kty1.tag = kty2.tag && vty1.tag = vty2.tag - | (Lambda_t (dom1, range1), Lambda_t (dom2, range2)) -> + | Lambda_t (dom1, range1), Lambda_t (dom2, range2) -> dom1.tag = dom2.tag && range1.tag = range2.tag | _ -> false @@ -132,9 +131,9 @@ module Stack = struct let equal (t1 : t) (t2 : t) = match (t1, t2) with - | (Empty_t, Empty_t) -> true - | (Stack_var_t v1, Stack_var_t v2) -> v1 = v2 - | (Item_t (h1, tl1), Item_t (h2, tl2)) -> h1 == h2 && tl1 == tl2 + | Empty_t, Empty_t -> true + | Stack_var_t v1, Stack_var_t v2 -> v1 = v2 + | Item_t (h1, tl1), Item_t (h2, tl2) -> h1 == h2 && tl1 == tl2 | _ -> false let hash (t : t) = Hashtbl.hash t diff --git a/src/proto_013_PtJakart/lib_benchmark/michelson_mcmc_samplers.ml b/src/proto_013_PtJakart/lib_benchmark/michelson_mcmc_samplers.ml index 5926dc38fe01..7dc0f4edd716 100644 --- a/src/proto_013_PtJakart/lib_benchmark/michelson_mcmc_samplers.ml +++ b/src/proto_013_PtJakart/lib_benchmark/michelson_mcmc_samplers.ml @@ -248,7 +248,7 @@ struct let to_michelson {state = ({typing; term} : State_space.t); jump = _} = let typing = Lazy.force typing in - let (node, (bef, aft), state) = + let node, (bef, aft), state = Autocomp.complete_code typing term X.rng_state in let node = @@ -316,8 +316,8 @@ struct let to_michelson {state = ({typing; term} : State_space.t); jump = _} = let typing = Lazy.force typing in - let (node, _) = Autocomp.complete_data typing term X.rng_state in - let (typ, state) = + let node, _ = Autocomp.complete_data typing term X.rng_state in + let typ, state = try Inference.infer_data_with_state node with _ -> Format.eprintf "Bug found!@." ; diff --git a/src/proto_013_PtJakart/lib_benchmark/michelson_samplers.ml b/src/proto_013_PtJakart/lib_benchmark/michelson_samplers.ml index 6e385870e9f7..670ef8fdf521 100644 --- a/src/proto_013_PtJakart/lib_benchmark/michelson_samplers.ml +++ b/src/proto_013_PtJakart/lib_benchmark/michelson_samplers.ml @@ -377,21 +377,21 @@ end) else bind (uniform all_non_atomic_type_names) @@ function | `TPair -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_ty left) = m_type ~size:lsize in let* (Ex_ty right) = m_type ~size:rsize in match pair_t (-1) left right with | Error _ -> assert false | Ok (Ty_ex_c res_ty) -> return @@ Ex_ty res_ty) | `TLambda -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_ty domain) = m_type ~size:lsize in let* (Ex_ty range) = m_type ~size:rsize in match lambda_t (-1) domain range with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TUnion -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_ty left) = m_type ~size:lsize in let* (Ex_ty right) = m_type ~size:rsize in match union_t (-1) left right with @@ -403,7 +403,7 @@ end) | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TMap -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_comparable_ty key) = m_comparable_type ~size:lsize in let* (Ex_ty elt) = m_type ~size:rsize in match map_t (-1) key elt with @@ -610,7 +610,7 @@ end) = fun elt_type -> let open M in - let* (length, elements) = + let* length, elements = Structure_samplers.list ~range:P.parameters.list_size ~sampler:(value elt_type) @@ -625,7 +625,7 @@ end) fun elt_ty -> let open M in let ety = comparable_downcast elt_ty in - let* (_, elements) = + let* _, elements = Structure_samplers.list ~range:P.parameters.set_size ~sampler:(value ety) diff --git a/src/proto_013_PtJakart/lib_benchmark/mikhailsky_to_michelson.ml b/src/proto_013_PtJakart/lib_benchmark/mikhailsky_to_michelson.ml index dbe7dd24789f..89741cd4ca0a 100644 --- a/src/proto_013_PtJakart/lib_benchmark/mikhailsky_to_michelson.ml +++ b/src/proto_013_PtJakart/lib_benchmark/mikhailsky_to_michelson.ml @@ -107,7 +107,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (_, r) = project_union aft in + let _, r = project_union aft in Inference.instantiate_base r >>= fun r -> Autocomp.replace_vars r >>= fun r -> let r = unparse_type r in @@ -119,7 +119,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (l, _) = project_union aft in + let l, _ = project_union aft in Inference.instantiate_base l >>= fun l -> Autocomp.replace_vars l >>= fun l -> let l = unparse_type l in @@ -135,7 +135,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (dom, range) = project_lambda aft in + let dom, range = project_lambda aft in Inference.instantiate_base dom >>= fun dom -> Autocomp.replace_vars dom >>= fun dom -> Inference.instantiate_base range >>= fun range -> @@ -165,7 +165,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (k, v) = project_map aft in + let k, v = project_map aft in Inference.instantiate_base k >>= fun k -> Autocomp.replace_vars k >>= fun k -> Inference.instantiate_base v >>= fun v -> diff --git a/src/proto_013_PtJakart/lib_benchmark/rules.ml b/src/proto_013_PtJakart/lib_benchmark/rules.ml index ff66cf05c7c4..5d14fe0c52c7 100644 --- a/src/proto_013_PtJakart/lib_benchmark/rules.ml +++ b/src/proto_013_PtJakart/lib_benchmark/rules.ml @@ -673,7 +673,7 @@ struct (* rules *) (* fresh type variables *) - let (alpha, beta) = (-1, -2) + let alpha, beta = (-1, -2) let replacement ~fresh ~typ ~replacement = { diff --git a/src/proto_013_PtJakart/lib_benchmark/test/test_autocompletion.ml b/src/proto_013_PtJakart/lib_benchmark/test/test_autocompletion.ml index 5d5d65fdee01..c2f3e6c74295 100644 --- a/src/proto_013_PtJakart/lib_benchmark/test/test_autocompletion.ml +++ b/src/proto_013_PtJakart/lib_benchmark/test/test_autocompletion.ml @@ -50,7 +50,7 @@ let () = Format.eprintf "Testing dummy program generator@.%!" let run x = x rng_state (Inference.M.empty ()) let invent_term bef aft = - let (term, _state) = run (Autocomp.invent_term bef aft) in + let term, _state = run (Autocomp.invent_term bef aft) in Mikhailsky.seq term let invent_term bef aft = @@ -61,7 +61,7 @@ let invent_term bef aft = Type.Stack.pp aft ; let term = invent_term bef aft in - let (bef', aft') = Inference.infer term in + let bef', aft' = Inference.infer term in Format.eprintf "generated type: %a => %a@." Type.Stack.pp @@ -88,9 +88,9 @@ let () = Format.eprintf "Testing completion@.%!" let complete term = Format.eprintf "term: %a@." Mikhailsky.pp term ; - let ((bef, aft), state) = Inference.infer_with_state term in + let (bef, aft), state = Inference.infer_with_state term in Format.eprintf "Inferred type: %a => %a@." Type.Stack.pp bef Type.Stack.pp aft ; - let (term, (bef', aft'), _state) = + let term, (bef', aft'), _state = Autocomp.complete_code state term rng_state in Format.eprintf "completed: %a@." Mikhailsky.pp term ; diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/cache_benchmarks.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/cache_benchmarks.ml index a80889bcbe88..875d80b6897a 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/cache_benchmarks.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/cache_benchmarks.ml @@ -51,15 +51,15 @@ let throwaway_context = let dummy_script : Cache.cached_contract = let str = "{ parameter unit; storage unit; code FAILWITH }" in let storage = - let (parsed, _) = Michelson_v1_parser.parse_expression "Unit" in + let parsed, _ = Michelson_v1_parser.parse_expression "Unit" in Alpha_context.Script.lazy_expr parsed.expanded in let code = - let (parsed, _) = Michelson_v1_parser.parse_expression ~check:false str in + let parsed, _ = Michelson_v1_parser.parse_expression ~check:false str in Alpha_context.Script.lazy_expr parsed.expanded in let script = Alpha_context.Script.{code; storage} in - let (ex_script, _) = + let ex_script, _ = Script_ir_translator.parse_script throwaway_context ~legacy:true @@ -96,7 +96,7 @@ end (* We can't produce a Script_cache.identifier without calling [Script_cache.find]. *) let identifier_of_contract (c : Alpha_context.Contract.t) : Cache.identifier = - let (_, id, _) = Cache.find throwaway_context c |> assert_ok_lwt in + let _, id, _ = Cache.find throwaway_context c |> assert_ok_lwt in id let contract_of_int i : Alpha_context.Contract.t = @@ -185,7 +185,7 @@ module Cache_update_benchmark : Benchmark.S = struct let cache_cardinal = Base_samplers.sample_in_interval ~range:{min = 1; max = 100_000} rng_state in - let (ctxt, some_key_in_domain) = prepare_context rng_state cache_cardinal in + let ctxt, some_key_in_domain = prepare_context rng_state cache_cardinal in cache_update_benchmark ctxt some_key_in_domain cache_cardinal let create_benchmarks ~rng_state ~bench_num config = diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/carbonated_map_benchmarks.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/carbonated_map_benchmarks.ml index 4e16ebb2653d..1251c88ae5cc 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/carbonated_map_benchmarks.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/carbonated_map_benchmarks.ml @@ -90,7 +90,7 @@ module Fold_benchmark : Benchmark.S = struct let benchmark rng_state config () = let module M = Carbonated_map.Make (Int) in - let (_, list) = + let _, list = let sampler rng_state = let key = Base_samplers.int rng_state ~size:{min = 1; max = 5} in (* Value should not be important *) @@ -239,7 +239,7 @@ module Make (CS : COMPARABLE_SAMPLER) = struct ] let benchmark rng_state (config : config) () = - let (_, list) = + let _, list = let sampler rng_state = (CS.sampler rng_state, ()) in Structure_samplers.list rng_state diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/encodings_benchmarks.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/encodings_benchmarks.ml index 90a668770a56..d68af9cf19cd 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/encodings_benchmarks.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/encodings_benchmarks.ml @@ -384,7 +384,7 @@ module Timelock = struct let plaintext_size = Base_samplers.sample_in_interval ~range:{min = 1; max = 10000} rng_state in - let (chest, chest_key) = + let chest, chest_key = Timelock.chest_sampler ~plaintext_size ~time ~rng_state in ((chest, chest_key), plaintext_size) @@ -395,7 +395,7 @@ module Timelock = struct ~name:"ENCODING_Chest" ~to_string:(Data_encoding.Binary.to_string_exn Timelock.chest_encoding) ~generator:(fun rng_state -> - let ((chest, _), plaintext_size) = generator rng_state in + let (chest, _), plaintext_size = generator rng_state in (chest, {bytes = plaintext_size})) let () = @@ -405,7 +405,7 @@ module Timelock = struct ~to_string: (Data_encoding.Binary.to_string_exn Timelock.chest_key_encoding) ~generator:(fun rng_state -> - let ((_, chest_key), _w) = generator rng_state in + let (_, chest_key), _w = generator rng_state in chest_key) let () = @@ -415,7 +415,7 @@ module Timelock = struct ~to_bytes:(Data_encoding.Binary.to_bytes_exn Timelock.chest_encoding) ~from_bytes:(Data_encoding.Binary.of_bytes_exn Timelock.chest_encoding) ~generator:(fun rng_state -> - let ((chest, _), _) = generator rng_state in + let (chest, _), _ = generator rng_state in let b = Data_encoding.Binary.to_bytes_exn Timelock.chest_encoding chest in @@ -430,6 +430,6 @@ module Timelock = struct ~from_bytes: (Data_encoding.Binary.of_bytes_exn Timelock.chest_key_encoding) ~generator:(fun rng_state -> - let ((_, chest_key), _w) = generator rng_state in + let (_, chest_key), _w = generator rng_state in chest_key) end diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/global_constants_storage_benchmarks.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/global_constants_storage_benchmarks.ml index b378451fc566..665a450488a4 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/global_constants_storage_benchmarks.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/global_constants_storage_benchmarks.ml @@ -612,8 +612,8 @@ module Global_constants_storage_expand_models = struct let size = (Micheline_sampler.micheline_size node).nodes in let registered_constant = Int (-1, Z.of_int 1) in let hash = registered_constant |> node_to_hash in - let (context, _) = Execution_context.make ~rng_state |> assert_ok_lwt in - let (context, _, _) = + let context, _ = Execution_context.make ~rng_state |> assert_ok_lwt in + let context, _, _ = Alpha_context.Global_constants_storage.register context (strip_locations registered_constant) @@ -700,7 +700,7 @@ module Global_constants_storage_expand_models = struct let open Micheline in let node = Micheline_sampler.sample rng_state in let size = (Micheline_sampler.micheline_size node).nodes in - let (context, _) = Execution_context.make ~rng_state |> assert_ok_lwt in + let context, _ = Execution_context.make ~rng_state |> assert_ok_lwt in let expr = strip_locations node in let closure () = ignore diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/interpreter_benchmarks.ml index 5667ddf5a833..4b9c0b32ea99 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -170,8 +170,8 @@ let benchmark_from_kinstr_and_stack : fun ?amplification ctxt step_constants stack_kinstr -> let ctxt = Gas_helpers.set_limit ctxt in match stack_kinstr with - | Ex_stack_and_kinstr {stack = (bef_top, bef); kinstr} -> - let (workload, closure) = + | Ex_stack_and_kinstr {stack = bef_top, bef; kinstr} -> + let workload, closure = match amplification with | None -> let workload = @@ -181,7 +181,7 @@ let benchmark_from_kinstr_and_stack : kinstr (bef_top, bef) in - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in let closure () = @@ -207,7 +207,7 @@ let benchmark_from_kinstr_and_stack : let workload = List.repeat amplification_factor workload |> List.flatten in - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in let closure () = @@ -256,7 +256,7 @@ let make_benchmark : ?amplification (if intercept then None else Some (Instr_name name)) - let (info, name) = + let info, name = info_and_name ~intercept ?salt @@ -297,7 +297,7 @@ let make_simple_benchmark : let kinfo = Script_typed_ir.kinfo_of_kinstr kinstr in let stack_ty = kinfo.kstack_ty in let kinstr_and_stack_sampler config rng_state = - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -419,8 +419,8 @@ let benchmark_from_continuation : fun ?amplification ctxt step_constants stack_cont -> let ctxt = Gas_helpers.set_limit ctxt in match stack_cont with - | Ex_stack_and_cont {stack = (bef_top, bef); cont} -> - let (workload, closure) = + | Ex_stack_and_cont {stack = bef_top, bef; cont} -> + let workload, closure = match amplification with | None -> let workload = @@ -430,7 +430,7 @@ let benchmark_from_continuation : cont (bef_top, bef) in - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in let closure () = @@ -457,7 +457,7 @@ let benchmark_from_continuation : let workload = List.repeat amplification_factor workload |> List.flatten in - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in let closure () = @@ -508,7 +508,7 @@ let make_continuation_benchmark : ?amplification (if intercept then None else Some (Cont_name name)) - let (info, name) = + let info, name = info_and_name ~intercept ?salt @@ -553,7 +553,7 @@ let nat_of_positive_int (i : int) = match is_nat (of_int i) with None -> assert false | Some x -> x let adversarial_ints rng_state (cfg : Default_config.config) n = - let (_common_prefix, ls) = + let _common_prefix, ls = Base_samplers.Adversarial.integers ~prefix_size:cfg.sampler.base_parameters.int_size ~card:n @@ -1193,7 +1193,7 @@ module Registration_section = struct ~range:cfg.sampler.set_size in let elts = adversarial_ints rng_state cfg (n + 1) in - let (out_of_set, in_set) = + let out_of_set, in_set = match elts with [] -> assert false | hd :: tl -> (hd, tl) in let set = @@ -1316,7 +1316,7 @@ module Registration_section = struct (let map = Script_map.empty int_cmp in (Alpha_context.Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1336,7 +1336,7 @@ module Registration_section = struct (let map = Script_map.empty int_cmp in (Alpha_context.Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1356,7 +1356,7 @@ module Registration_section = struct (let map = Script_map.empty int_cmp in (Alpha_context.Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () @@ -1377,7 +1377,7 @@ module Registration_section = struct (let map = Script_map.empty int_cmp in (Alpha_context.Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () @@ -1458,7 +1458,7 @@ module Registration_section = struct ( kinfo (int @$ big_map int_cmp unit @$ unit @$ bot), halt (bool @$ unit @$ bot) )) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1478,7 +1478,7 @@ module Registration_section = struct (let map = Script_ir_translator.empty_big_map int_cmp unit in (Alpha_context.Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1498,7 +1498,7 @@ module Registration_section = struct (let map = Script_ir_translator.empty_big_map int_cmp unit in (Alpha_context.Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () @@ -1519,7 +1519,7 @@ module Registration_section = struct (let map = Script_ir_translator.empty_big_map int_cmp unit in (Alpha_context.Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () end @@ -1554,7 +1554,7 @@ module Registration_section = struct (let z = Alpha_context.Script_int.zero_n in (z, (z, (empty, eos)))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let string = Samplers.Random_value.value Script_typed_ir.string_t rng_state @@ -1600,7 +1600,7 @@ module Registration_section = struct (let z = Alpha_context.Script_int.zero_n in (z, (z, (Bytes.empty, eos)))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let bytes = Samplers.Random_value.value Script_typed_ir.bytes_t rng_state @@ -1672,7 +1672,7 @@ module Registration_section = struct ~kinstr: (ISub_tez (kinfo (mutez @$ mutez @$ bot), halt (option mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers cfg.Default_config.sampler in fun () -> @@ -1691,7 +1691,7 @@ module Registration_section = struct ~kinstr: (ISub_tez_legacy (kinfo (mutez @$ mutez @$ bot), halt (mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers cfg.Default_config.sampler in fun () -> @@ -1720,9 +1720,9 @@ module Registration_section = struct ~name:Interpreter_workload.N_IMul_teznat ~kinstr:(IMul_teznat (kinfo (mutez @$ nat @$ bot), halt (mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, samplers) = make_default_samplers cfg.sampler in + let _, samplers = make_default_samplers cfg.sampler in fun () -> - let (mutez, nat) = sample_tez_nat samplers rng_state in + let mutez, nat = sample_tez_nat samplers rng_state in (mutez, (nat, eos))) () @@ -1731,9 +1731,9 @@ module Registration_section = struct ~name:Interpreter_workload.N_IMul_nattez ~kinstr:(IMul_nattez (kinfo (nat @$ mutez @$ bot), halt (mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, samplers) = make_default_samplers cfg.sampler in + let _, samplers = make_default_samplers cfg.sampler in fun () -> - let (mutez, nat) = sample_tez_nat samplers rng_state in + let mutez, nat = sample_tez_nat samplers rng_state in (nat, (mutez, eos))) () @@ -1747,9 +1747,9 @@ module Registration_section = struct ( kinfo (mutez @$ nat @$ bot), halt (option (cpair mutez mutez) @$ bot) )) ~stack_sampler:(fun cfg rng_state -> - let (_, samplers) = make_default_samplers cfg.sampler in + let _, samplers = make_default_samplers cfg.sampler in fun () -> - let (mutez, nat) = sample_tez_nat samplers rng_state in + let mutez, nat = sample_tez_nat samplers rng_state in (mutez, (nat, eos))) () @@ -1815,7 +1815,7 @@ module Registration_section = struct ~kinstr:(IAbs_int (kinfo (int @$ bot), halt (nat @$ bot))) ~intercept_stack:(zero, eos) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let x = Samplers.Michelson_base.nat rng_state in let neg_x = Alpha_context.Script_int.neg x in @@ -1888,7 +1888,7 @@ module Registration_section = struct ~intercept_stack:(zero_n, (zero_n, eos)) ~kinstr:(ILsl_nat (kinfo (nat @$ nat @$ bot), halt (nat @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let x = Samplers.Michelson_base.nat rng_state in (* shift must be in [0;256]: 1 byte max *) @@ -1904,7 +1904,7 @@ module Registration_section = struct ~intercept_stack:(zero_n, (zero_n, eos)) ~kinstr:(ILsr_nat (kinfo (nat @$ nat @$ bot), halt (nat @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let x = Samplers.Michelson_base.nat rng_state in (* shift must be in [0;256]: 1 byte max *) @@ -2083,7 +2083,7 @@ module Registration_section = struct benchmark ~name:Interpreter_workload.N_ICompare ~kinstr_and_stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let size = Base_samplers.sample_in_interval @@ -2251,11 +2251,11 @@ module Registration_section = struct ( kinfo (public_key @$ signature @$ bytes @$ bot), halt (bool @$ bot) )) ~stack_sampler:(fun cfg rng_state -> - let ((module Crypto_samplers), (module Samplers)) = + let (module Crypto_samplers), (module Samplers) = make_default_samplers ~algo:(`Algo algo) cfg.Default_config.sampler in fun () -> - let (_pkh, pk, sk) = Crypto_samplers.all rng_state in + let _pkh, pk, sk = Crypto_samplers.all rng_state in let unsigned_message = if for_intercept then Environment.Bytes.empty else Samplers.Random_value.value Script_typed_ir.bytes_t rng_state @@ -2421,7 +2421,7 @@ module Registration_section = struct | Error _ -> assert false | Ok sz -> sz in - let (info, name) = + let info, name = info_and_name ~intercept:false "ISapling_verify_update" in let module B : Benchmark.S = struct @@ -2497,7 +2497,7 @@ module Registration_section = struct in List.map (fun (_, transition) () -> - let (ctxt, state, step_constants) = + let ctxt, state, step_constants = prepare_sapling_execution_environment seed transition in let stack_instr = @@ -2587,7 +2587,7 @@ module Registration_section = struct (IMul_bls12_381_z_fr (kinfo (bls12_381_fr @$ int @$ bot), halt (bls12_381_fr @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in let fr_sampler = Samplers.Random_value.value bls12_381_fr in let zero = Alpha_context.Script_int.zero in fun () -> (fr_sampler rng_state, (zero, eos))) @@ -2609,7 +2609,7 @@ module Registration_section = struct (IMul_bls12_381_fr_z (kinfo (int @$ bls12_381_fr @$ bot), halt (bls12_381_fr @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in let fr_sampler = Samplers.Random_value.value bls12_381_fr in let zero = Alpha_context.Script_int.zero in fun () -> (zero, (fr_sampler rng_state, eos))) @@ -2705,7 +2705,7 @@ module Registration_section = struct benchmark ~name:Interpreter_workload.N_ISplit_ticket ~kinstr_and_stack_sampler:(fun config rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -2737,7 +2737,7 @@ module Registration_section = struct ~intercept:true ~name:Interpreter_workload.N_IJoin_tickets ~kinstr_and_stack_sampler:(fun config rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -2759,7 +2759,7 @@ module Registration_section = struct benchmark ~name:Interpreter_workload.N_IJoin_tickets ~kinstr_and_stack_sampler:(fun config rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -2797,7 +2797,7 @@ module Registration_section = struct ~name ~kinstr ~stack_sampler:(fun _ rng_state () -> - let (chest, chest_key) = + let chest, chest_key = Timelock_samplers.chest_sampler ~plaintext_size:1 ~time:0 ~rng_state in resulting_stack chest chest_key 0) @@ -2820,7 +2820,7 @@ module Registration_section = struct rng_state in - let (chest, chest_key) = + let chest, chest_key = Timelock_samplers.chest_sampler ~plaintext_size ~time ~rng_state in resulting_stack chest chest_key time) @@ -3013,7 +3013,7 @@ module Registration_section = struct ~name:Interpreter_workload.N_KList_enter_body ~salt:"_terminal" ~cont_and_stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in let kbody = halt_unitunit in fun () -> let ys = Samplers.Random_value.value (list unit) rng_state in @@ -3113,7 +3113,7 @@ module Registration_section = struct ICdr (kinfo (cpair int unit @$ unit @$ bot), halt_unitunit) in fun () -> - let (key, map) = Maps.generate_map_and_key_in_map cfg rng_state in + let key, map = Maps.generate_map_and_key_in_map cfg rng_state in let cont = KMap_exit_body (kbody, [], map, key, KNil) in Ex_stack_and_cont {stack = ((), ((), eos)); cont}) () diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/interpreter_workload.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/interpreter_workload.ml index 43380b2d0c12..7fbb2934cd03 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/interpreter_workload.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/interpreter_workload.ml @@ -1150,63 +1150,63 @@ let extract_ir_sized_step : fun ctxt instr stack -> let open Script_typed_ir in match (instr, stack) with - | (IDrop (_, _), _) -> Instructions.drop - | (IDup (_, _), _) -> Instructions.dup - | (ISwap (_, _), _) -> Instructions.swap - | (IConst (_, _, _), _) -> Instructions.const - | (ICons_pair (_, _), _) -> Instructions.cons_pair - | (ICar (_, _), _) -> Instructions.car - | (ICdr (_, _), _) -> Instructions.cdr - | (IUnpair (_, _), _) -> Instructions.unpair - | (ICons_some (_, _), _) -> Instructions.cons_some - | (ICons_none (_, _), _) -> Instructions.cons_none - | (IIf_none _, _) -> Instructions.if_none - | (IOpt_map _, _) -> Instructions.opt_map - | (ICons_left (_, _), _) -> Instructions.left - | (ICons_right (_, _), _) -> Instructions.right - | (IIf_left _, _) -> Instructions.if_left - | (ICons_list (_, _), _) -> Instructions.cons_list - | (INil (_, _), _) -> Instructions.nil - | (IIf_cons _, _) -> Instructions.if_cons - | (IList_iter (_, _, _), _) -> Instructions.list_iter - | (IList_map (_, _, _), _) -> Instructions.list_map - | (IList_size (_, _), (list, _)) -> Instructions.list_size (Size.list list) - | (IEmpty_set (_, _, _), _) -> Instructions.empty_set - | (ISet_iter _, (set, _)) -> Instructions.set_iter (Size.set set) - | (ISet_mem (_, _), (v, (set, _))) -> + | IDrop (_, _), _ -> Instructions.drop + | IDup (_, _), _ -> Instructions.dup + | ISwap (_, _), _ -> Instructions.swap + | IConst (_, _, _), _ -> Instructions.const + | ICons_pair (_, _), _ -> Instructions.cons_pair + | ICar (_, _), _ -> Instructions.car + | ICdr (_, _), _ -> Instructions.cdr + | IUnpair (_, _), _ -> Instructions.unpair + | ICons_some (_, _), _ -> Instructions.cons_some + | ICons_none (_, _), _ -> Instructions.cons_none + | IIf_none _, _ -> Instructions.if_none + | IOpt_map _, _ -> Instructions.opt_map + | ICons_left (_, _), _ -> Instructions.left + | ICons_right (_, _), _ -> Instructions.right + | IIf_left _, _ -> Instructions.if_left + | ICons_list (_, _), _ -> Instructions.cons_list + | INil (_, _), _ -> Instructions.nil + | IIf_cons _, _ -> Instructions.if_cons + | IList_iter (_, _, _), _ -> Instructions.list_iter + | IList_map (_, _, _), _ -> Instructions.list_map + | IList_size (_, _), (list, _) -> Instructions.list_size (Size.list list) + | IEmpty_set (_, _, _), _ -> Instructions.empty_set + | ISet_iter _, (set, _) -> Instructions.set_iter (Size.set set) + | ISet_mem (_, _), (v, (set, _)) -> let (module S) = Script_set.get set in let sz = S.OPS.elt_size v in Instructions.set_mem sz (Size.set set) - | (ISet_update (_, _), (v, (_flag, (set, _)))) -> + | ISet_update (_, _), (v, (_flag, (set, _))) -> let (module S) = Script_set.get set in let sz = S.OPS.elt_size v in Instructions.set_update sz (Size.set set) - | (ISet_size (_, _), (set, _)) -> Instructions.set_size (Size.set set) - | (IEmpty_map (_, _, _), _) -> Instructions.empty_map - | (IMap_map _, (map, _)) -> Instructions.map_map (Size.map map) - | (IMap_iter _, (map, _)) -> Instructions.map_iter (Size.map map) - | (IMap_mem (_, _), (v, (map, _))) -> + | ISet_size (_, _), (set, _) -> Instructions.set_size (Size.set set) + | IEmpty_map (_, _, _), _ -> Instructions.empty_map + | IMap_map _, (map, _) -> Instructions.map_map (Size.map map) + | IMap_iter _, (map, _) -> Instructions.map_iter (Size.map map) + | IMap_mem (_, _), (v, (map, _)) -> let (module Map) = Script_map.get_module map in let key_size = Map.OPS.key_size v in Instructions.map_mem key_size (Size.map map) - | (IMap_get (_, _), (v, (map, _))) -> + | IMap_get (_, _), (v, (map, _)) -> let (module Map) = Script_map.get_module map in let key_size = Map.OPS.key_size v in Instructions.map_get key_size (Size.map map) - | (IMap_update (_, _), (v, (_elt_opt, (map, _)))) -> + | IMap_update (_, _), (v, (_elt_opt, (map, _))) -> let (module Map) = Script_map.get_module map in let key_size = Map.OPS.key_size v in Instructions.map_update key_size (Size.map map) - | (IMap_get_and_update (_, _), (v, (_elt_opt, (map, _)))) -> + | IMap_get_and_update (_, _), (v, (_elt_opt, (map, _))) -> let (module Map) = Script_map.get_module map in let key_size = Map.OPS.key_size v in Instructions.map_get_and_update key_size (Size.map map) - | (IMap_size (_, _), (map, _)) -> Instructions.map_size (Size.map map) - | (IEmpty_big_map (_, _, _, _), _) -> Instructions.empty_big_map - | (IBig_map_mem (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _))) -> + | IMap_size (_, _), (map, _) -> Instructions.map_size (Size.map map) + | IEmpty_big_map (_, _, _, _), _ -> Instructions.empty_big_map + | IBig_map_mem (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _)) -> let key_size = Size.size_of_comparable_value key_type v in Instructions.big_map_mem key_size (Size.of_int size) - | (IBig_map_get (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _))) -> + | IBig_map_get (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _)) -> let key_size = Size.size_of_comparable_value key_type v in Instructions.big_map_get key_size (Size.of_int size) | ( IBig_map_update (_, _), @@ -1217,7 +1217,7 @@ let extract_ir_sized_step : (v, (_, (Big_map {diff = {size; _}; key_type; _}, _))) ) -> let key_size = Size.size_of_comparable_value key_type v in Instructions.big_map_get_and_update key_size (Size.of_int size) - | (IConcat_string (_, _), (ss, _)) -> + | IConcat_string (_, _), (ss, _) -> let list_size = Size.list ss in let total_bytes = List.fold_left @@ -1226,109 +1226,109 @@ let extract_ir_sized_step : ss.elements in Instructions.concat_string list_size total_bytes - | (IConcat_string_pair (_, _), (s1, (s2, _))) -> + | IConcat_string_pair (_, _), (s1, (s2, _)) -> Instructions.concat_string_pair (Size.script_string s1) (Size.script_string s2) - | (ISlice_string (_, _), (_off, (_len, (s, _)))) -> + | ISlice_string (_, _), (_off, (_len, (s, _))) -> Instructions.slice_string (Size.script_string s) - | (IString_size (_, _), (s, _)) -> + | IString_size (_, _), (s, _) -> Instructions.string_size (Size.script_string s) - | (IConcat_bytes (_, _), (ss, _)) -> + | IConcat_bytes (_, _), (ss, _) -> let list_size = Size.list ss in let total_bytes = List.fold_left (fun x s -> Size.(add x (bytes s))) Size.zero ss.elements in Instructions.concat_bytes list_size total_bytes - | (IConcat_bytes_pair (_, _), (s1, (s2, _))) -> + | IConcat_bytes_pair (_, _), (s1, (s2, _)) -> Instructions.concat_bytes_pair (Size.bytes s1) (Size.bytes s2) - | (ISlice_bytes (_, _), (_off, (_len, (s, _)))) -> + | ISlice_bytes (_, _), (_off, (_len, (s, _))) -> Instructions.slice_bytes (Size.bytes s) - | (IBytes_size (_, _), _) -> Instructions.bytes_size - | (IAdd_seconds_to_timestamp (_, _), (s, (t, _))) -> + | IBytes_size (_, _), _ -> Instructions.bytes_size + | IAdd_seconds_to_timestamp (_, _), (s, (t, _)) -> Instructions.add_seconds_to_timestamp (Size.timestamp t) (Size.integer s) - | (IAdd_timestamp_to_seconds (_, _), (t, (s, _))) -> + | IAdd_timestamp_to_seconds (_, _), (t, (s, _)) -> Instructions.add_timestamp_to_seconds (Size.timestamp t) (Size.integer s) - | (ISub_timestamp_seconds (_, _), (t, (s, _))) -> + | ISub_timestamp_seconds (_, _), (t, (s, _)) -> Instructions.sub_timestamp_seconds (Size.timestamp t) (Size.integer s) - | (IDiff_timestamps (_, _), (t1, (t2, _))) -> + | IDiff_timestamps (_, _), (t1, (t2, _)) -> Instructions.diff_timestamps (Size.timestamp t1) (Size.timestamp t2) - | (IAdd_tez (_, _), (x, (y, _))) -> + | IAdd_tez (_, _), (x, (y, _)) -> Instructions.add_tez (Size.mutez x) (Size.mutez y) - | (ISub_tez (_, _), (x, (y, _))) -> + | ISub_tez (_, _), (x, (y, _)) -> Instructions.sub_tez (Size.mutez x) (Size.mutez y) - | (ISub_tez_legacy (_, _), (x, (y, _))) -> + | ISub_tez_legacy (_, _), (x, (y, _)) -> Instructions.sub_tez_legacy (Size.mutez x) (Size.mutez y) - | (IMul_teznat (_, _), (x, (y, _))) -> + | IMul_teznat (_, _), (x, (y, _)) -> Instructions.mul_teznat (Size.mutez x) (Size.integer y) - | (IMul_nattez (_, _), (x, (y, _))) -> + | IMul_nattez (_, _), (x, (y, _)) -> Instructions.mul_nattez (Size.integer x) (Size.mutez y) - | (IEdiv_teznat (_, _), (x, (y, _))) -> + | IEdiv_teznat (_, _), (x, (y, _)) -> Instructions.ediv_teznat (Size.mutez x) (Size.integer y) - | (IEdiv_tez (_, _), (x, (y, _))) -> + | IEdiv_tez (_, _), (x, (y, _)) -> Instructions.ediv_tez (Size.mutez x) (Size.mutez y) - | (IOr (_, _), _) -> Instructions.or_ - | (IAnd (_, _), _) -> Instructions.and_ - | (IXor (_, _), _) -> Instructions.xor_ - | (INot (_, _), _) -> Instructions.not_ - | (IIs_nat (_, _), (x, _)) -> Instructions.is_nat (Size.integer x) - | (INeg (_, _), (x, _)) -> Instructions.neg (Size.integer x) - | (IAbs_int (_, _), (x, _)) -> Instructions.abs_int (Size.integer x) - | (IInt_nat (_, _), (x, _)) -> Instructions.int_nat (Size.integer x) - | (IAdd_int (_, _), (x, (y, _))) -> + | IOr (_, _), _ -> Instructions.or_ + | IAnd (_, _), _ -> Instructions.and_ + | IXor (_, _), _ -> Instructions.xor_ + | INot (_, _), _ -> Instructions.not_ + | IIs_nat (_, _), (x, _) -> Instructions.is_nat (Size.integer x) + | INeg (_, _), (x, _) -> Instructions.neg (Size.integer x) + | IAbs_int (_, _), (x, _) -> Instructions.abs_int (Size.integer x) + | IInt_nat (_, _), (x, _) -> Instructions.int_nat (Size.integer x) + | IAdd_int (_, _), (x, (y, _)) -> Instructions.add_int (Size.integer x) (Size.integer y) - | (IAdd_nat (_, _), (x, (y, _))) -> + | IAdd_nat (_, _), (x, (y, _)) -> Instructions.add_nat (Size.integer x) (Size.integer y) - | (ISub_int (_, _), (x, (y, _))) -> + | ISub_int (_, _), (x, (y, _)) -> Instructions.sub_int (Size.integer x) (Size.integer y) - | (IMul_int (_, _), (x, (y, _))) -> + | IMul_int (_, _), (x, (y, _)) -> Instructions.mul_int (Size.integer x) (Size.integer y) - | (IMul_nat (_, _), (x, (y, _))) -> + | IMul_nat (_, _), (x, (y, _)) -> Instructions.mul_nat (Size.integer x) (Size.integer y) - | (IEdiv_int (_, _), (x, (y, _))) -> + | IEdiv_int (_, _), (x, (y, _)) -> Instructions.ediv_int (Size.integer x) (Size.integer y) - | (IEdiv_nat (_, _), (x, (y, _))) -> + | IEdiv_nat (_, _), (x, (y, _)) -> Instructions.ediv_nat (Size.integer x) (Size.integer y) - | (ILsl_nat (_, _), (x, (y, _))) -> + | ILsl_nat (_, _), (x, (y, _)) -> Instructions.lsl_nat (Size.integer x) (Size.integer y) - | (ILsr_nat (_, _), (x, (y, _))) -> + | ILsr_nat (_, _), (x, (y, _)) -> Instructions.lsr_nat (Size.integer x) (Size.integer y) - | (IOr_nat (_, _), (x, (y, _))) -> + | IOr_nat (_, _), (x, (y, _)) -> Instructions.or_nat (Size.integer x) (Size.integer y) - | (IAnd_nat (_, _), (x, (y, _))) -> + | IAnd_nat (_, _), (x, (y, _)) -> Instructions.and_nat (Size.integer x) (Size.integer y) - | (IAnd_int_nat (_, _), (x, (y, _))) -> + | IAnd_int_nat (_, _), (x, (y, _)) -> Instructions.and_int_nat (Size.integer x) (Size.integer y) - | (IXor_nat (_, _), (x, (y, _))) -> + | IXor_nat (_, _), (x, (y, _)) -> Instructions.xor_nat (Size.integer x) (Size.integer y) - | (INot_int (_, _), (x, _)) -> Instructions.not_int (Size.integer x) - | (IIf _, _) -> Instructions.if_ - | (ILoop (_, _, _), _) -> Instructions.loop - | (ILoop_left (_, _, _), _) -> Instructions.loop_left - | (IDip (_, _, _), _) -> Instructions.dip - | (IExec (_, _), _) -> Instructions.exec - | (IApply (_, _, _), _) -> Instructions.apply - | (ILambda (_, _, _), _) -> Instructions.lambda - | (IFailwith (_, _, _), _) -> Instructions.failwith_ - | (ICompare (_, cmp_ty, _), (a, (b, _))) -> + | INot_int (_, _), (x, _) -> Instructions.not_int (Size.integer x) + | IIf _, _ -> Instructions.if_ + | ILoop (_, _, _), _ -> Instructions.loop + | ILoop_left (_, _, _), _ -> Instructions.loop_left + | IDip (_, _, _), _ -> Instructions.dip + | IExec (_, _), _ -> Instructions.exec + | IApply (_, _, _), _ -> Instructions.apply + | ILambda (_, _, _), _ -> Instructions.lambda + | IFailwith (_, _, _), _ -> Instructions.failwith_ + | ICompare (_, cmp_ty, _), (a, (b, _)) -> extract_compare_sized_step cmp_ty a b - | (IEq (_, _), _) -> Instructions.eq - | (INeq (_, _), _) -> Instructions.neq - | (ILt (_, _), _) -> Instructions.lt - | (IGt (_, _), _) -> Instructions.gt - | (ILe (_, _), _) -> Instructions.le - | (IGe (_, _), _) -> Instructions.ge - | (IAddress (_, _), _) -> Instructions.address - | (IContract (_, _, _, _), _) -> Instructions.contract - | (ITransfer_tokens (_, _), _) -> Instructions.transfer_tokens - | (IView (_, _, _), _) -> Instructions.view - | (IImplicit_account (_, _), _) -> Instructions.implicit_account - | (ICreate_contract _, _) -> Instructions.create_contract - | (ISet_delegate (_, _), _) -> Instructions.set_delegate - | (INow (_, _), _) -> Instructions.now - | (IBalance (_, _), _) -> Instructions.balance - | (ILevel (_, _), _) -> Instructions.level - | (ICheck_signature (_, _), (public_key, (_signature, (message, _)))) -> ( + | IEq (_, _), _ -> Instructions.eq + | INeq (_, _), _ -> Instructions.neq + | ILt (_, _), _ -> Instructions.lt + | IGt (_, _), _ -> Instructions.gt + | ILe (_, _), _ -> Instructions.le + | IGe (_, _), _ -> Instructions.ge + | IAddress (_, _), _ -> Instructions.address + | IContract (_, _, _, _), _ -> Instructions.contract + | ITransfer_tokens (_, _), _ -> Instructions.transfer_tokens + | IView (_, _, _), _ -> Instructions.view + | IImplicit_account (_, _), _ -> Instructions.implicit_account + | ICreate_contract _, _ -> Instructions.create_contract + | ISet_delegate (_, _), _ -> Instructions.set_delegate + | INow (_, _), _ -> Instructions.now + | IBalance (_, _), _ -> Instructions.balance + | ILevel (_, _), _ -> Instructions.level + | ICheck_signature (_, _), (public_key, (_signature, (message, _))) -> ( match public_key with | Signature.Ed25519 _pk -> let pk = Size.of_int Ed25519.size in @@ -1345,80 +1345,80 @@ let extract_ir_sized_step : let signature = Size.of_int Signature.size in let message = Size.bytes message in Instructions.check_signature_p256 pk signature message) - | (IHash_key (_, _), _) -> Instructions.hash_key - | (IPack (_, ty, _), (v, _)) -> ( + | IHash_key (_, _), _ -> Instructions.hash_key + | IPack (_, ty, _), (v, _) -> ( let script_res = Lwt_main.run (Script_ir_translator.unparse_data ctxt Optimized ty v) in match script_res with | Ok (node, _ctxt) -> Instructions.pack (Size.of_micheline node) | Error _ -> Stdlib.failwith "IPack workload: could not unparse") - | (IUnpack (_, _, _), _) -> Instructions.unpack - | (IBlake2b (_, _), (bytes, _)) -> Instructions.blake2b (Size.bytes bytes) - | (ISha256 (_, _), (bytes, _)) -> Instructions.sha256 (Size.bytes bytes) - | (ISha512 (_, _), (bytes, _)) -> Instructions.sha512 (Size.bytes bytes) - | (ISource (_, _), _) -> Instructions.source - | (ISender (_, _), _) -> Instructions.sender - | (ISelf (_, _, _, _), _) -> Instructions.self - | (ISelf_address (_, _), _) -> Instructions.self_address - | (IAmount (_, _), _) -> Instructions.amount - | (ISapling_empty_state (_, _, _), _) -> Instructions.sapling_empty_state - | (ISapling_verify_update (_, _), (transaction, (_state, _))) -> + | IUnpack (_, _, _), _ -> Instructions.unpack + | IBlake2b (_, _), (bytes, _) -> Instructions.blake2b (Size.bytes bytes) + | ISha256 (_, _), (bytes, _) -> Instructions.sha256 (Size.bytes bytes) + | ISha512 (_, _), (bytes, _) -> Instructions.sha512 (Size.bytes bytes) + | ISource (_, _), _ -> Instructions.source + | ISender (_, _), _ -> Instructions.sender + | ISelf (_, _, _, _), _ -> Instructions.self + | ISelf_address (_, _), _ -> Instructions.self_address + | IAmount (_, _), _ -> Instructions.amount + | ISapling_empty_state (_, _, _), _ -> Instructions.sapling_empty_state + | ISapling_verify_update (_, _), (transaction, (_state, _)) -> let inputs = Size.sapling_transaction_inputs transaction in let outputs = Size.sapling_transaction_outputs transaction in let bound_data = Size.sapling_transaction_bound_data transaction in let state = Size.zero in Instructions.sapling_verify_update inputs outputs bound_data state - | (ISapling_verify_update_deprecated (_, _), (transaction, (_state, _))) -> + | ISapling_verify_update_deprecated (_, _), (transaction, (_state, _)) -> let inputs = List.length transaction.inputs in let outputs = List.length transaction.outputs in let bound_data = Size.zero in let state = Size.zero in Instructions.sapling_verify_update inputs outputs bound_data state - | (IDig (_, n, _, _), _) -> Instructions.dig (Size.of_int n) - | (IDug (_, n, _, _), _) -> Instructions.dug (Size.of_int n) - | (IDipn (_, n, _, _, _), _) -> Instructions.dipn (Size.of_int n) - | (IDropn (_, n, _, _), _) -> Instructions.dropn (Size.of_int n) - | (IChainId (_, _), _) -> Instructions.chain_id - | (INever _, _) -> . - | (IVoting_power (_, _), _) -> Instructions.voting_power - | (ITotal_voting_power (_, _), _) -> Instructions.total_voting_power - | (IKeccak (_, _), (bytes, _)) -> Instructions.keccak (Size.bytes bytes) - | (ISha3 (_, _), (bytes, _)) -> Instructions.sha3 (Size.bytes bytes) - | (IAdd_bls12_381_g1 (_, _), _) -> Instructions.add_bls12_381_g1 - | (IAdd_bls12_381_g2 (_, _), _) -> Instructions.add_bls12_381_g2 - | (IAdd_bls12_381_fr (_, _), _) -> Instructions.add_bls12_381_fr - | (IMul_bls12_381_g1 (_, _), _) -> Instructions.mul_bls12_381_g1 - | (IMul_bls12_381_g2 (_, _), _) -> Instructions.mul_bls12_381_g2 - | (IMul_bls12_381_fr (_, _), _) -> Instructions.mul_bls12_381_fr - | (IMul_bls12_381_z_fr (_, _), (_fr, (z, _))) -> + | IDig (_, n, _, _), _ -> Instructions.dig (Size.of_int n) + | IDug (_, n, _, _), _ -> Instructions.dug (Size.of_int n) + | IDipn (_, n, _, _, _), _ -> Instructions.dipn (Size.of_int n) + | IDropn (_, n, _, _), _ -> Instructions.dropn (Size.of_int n) + | IChainId (_, _), _ -> Instructions.chain_id + | INever _, _ -> . + | IVoting_power (_, _), _ -> Instructions.voting_power + | ITotal_voting_power (_, _), _ -> Instructions.total_voting_power + | IKeccak (_, _), (bytes, _) -> Instructions.keccak (Size.bytes bytes) + | ISha3 (_, _), (bytes, _) -> Instructions.sha3 (Size.bytes bytes) + | IAdd_bls12_381_g1 (_, _), _ -> Instructions.add_bls12_381_g1 + | IAdd_bls12_381_g2 (_, _), _ -> Instructions.add_bls12_381_g2 + | IAdd_bls12_381_fr (_, _), _ -> Instructions.add_bls12_381_fr + | IMul_bls12_381_g1 (_, _), _ -> Instructions.mul_bls12_381_g1 + | IMul_bls12_381_g2 (_, _), _ -> Instructions.mul_bls12_381_g2 + | IMul_bls12_381_fr (_, _), _ -> Instructions.mul_bls12_381_fr + | IMul_bls12_381_z_fr (_, _), (_fr, (z, _)) -> Instructions.mul_bls12_381_z_fr (Size.integer z) - | (IMul_bls12_381_fr_z (_, _), (z, _)) -> + | IMul_bls12_381_fr_z (_, _), (z, _) -> Instructions.mul_bls12_381_fr_z (Size.integer z) - | (IInt_bls12_381_fr (_, _), _) -> Instructions.int_bls12_381_z_fr - | (INeg_bls12_381_g1 (_, _), _) -> Instructions.neg_bls12_381_g1 - | (INeg_bls12_381_g2 (_, _), _) -> Instructions.neg_bls12_381_g2 - | (INeg_bls12_381_fr (_, _), _) -> Instructions.neg_bls12_381_fr - | (IPairing_check_bls12_381 (_, _), (list, _)) -> + | IInt_bls12_381_fr (_, _), _ -> Instructions.int_bls12_381_z_fr + | INeg_bls12_381_g1 (_, _), _ -> Instructions.neg_bls12_381_g1 + | INeg_bls12_381_g2 (_, _), _ -> Instructions.neg_bls12_381_g2 + | INeg_bls12_381_fr (_, _), _ -> Instructions.neg_bls12_381_fr + | IPairing_check_bls12_381 (_, _), (list, _) -> Instructions.pairing_check_bls12_381 (Size.list list) - | (IComb (_, n, _, _), _) -> Instructions.comb (Size.of_int n) - | (IUncomb (_, n, _, _), _) -> Instructions.uncomb (Size.of_int n) - | (IComb_get (_, n, _, _), _) -> Instructions.comb_get (Size.of_int n) - | (IComb_set (_, n, _, _), _) -> Instructions.comb_set (Size.of_int n) - | (IDup_n (_, n, _, _), _) -> Instructions.dupn (Size.of_int n) - | (ITicket (_, _), _) -> Instructions.ticket - | (IRead_ticket (_, _), _) -> Instructions.read_ticket - | (ISplit_ticket (_, _), (_ticket, ((amount_a, amount_b), _))) -> + | IComb (_, n, _, _), _ -> Instructions.comb (Size.of_int n) + | IUncomb (_, n, _, _), _ -> Instructions.uncomb (Size.of_int n) + | IComb_get (_, n, _, _), _ -> Instructions.comb_get (Size.of_int n) + | IComb_set (_, n, _, _), _ -> Instructions.comb_set (Size.of_int n) + | IDup_n (_, n, _, _), _ -> Instructions.dupn (Size.of_int n) + | ITicket (_, _), _ -> Instructions.ticket + | IRead_ticket (_, _), _ -> Instructions.read_ticket + | ISplit_ticket (_, _), (_ticket, ((amount_a, amount_b), _)) -> Instructions.split_ticket (Size.integer amount_a) (Size.integer amount_b) - | (IJoin_tickets (_, cmp_ty, _), ((ticket1, ticket2), _)) -> + | IJoin_tickets (_, cmp_ty, _), ((ticket1, ticket2), _) -> let size1 = Size.size_of_comparable_value cmp_ty ticket1.contents in let size2 = Size.size_of_comparable_value cmp_ty ticket2.contents in let tez1 = Size.integer ticket1.amount in let tez2 = Size.integer ticket2.amount in Instructions.join_tickets size1 size2 tez1 tez2 - | (IHalt _, _) -> Instructions.halt - | (ILog _, _) -> Instructions.log - | (IOpen_chest (_, _), (_, (chest, (time, _)))) -> + | IHalt _, _ -> Instructions.halt + | ILog _, _ -> Instructions.log + | IOpen_chest (_, _), (_, (chest, (time, _))) -> let plaintext_size = Script_timelock.get_plaintext_size chest - 1 |> Size.of_int in @@ -1426,7 +1426,7 @@ let extract_ir_sized_step : Z.log2 Z.(one + Script_int_repr.to_zint time) |> Size.of_int in Instructions.open_chest log_time plaintext_size - | (IMin_block_time _, _) -> Instructions.min_block_time + | IMin_block_time _, _ -> Instructions.min_block_time let extract_control_trace (type bef_top bef aft_top aft) (cont : (bef_top, bef, aft_top, aft) Script_typed_ir.continuation) = @@ -1518,7 +1518,7 @@ let extract_deps_continuation (type bef_top bef aft_top aft) ctxt step_constants let logger = {log_interp; log_entry; log_control; log_exit; get_log} in try let res = - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in Lwt_main.run diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/sapling_generation.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/sapling_generation.ml index 52a0f924a186..15b69c5e1208 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/sapling_generation.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/sapling_generation.ml @@ -127,14 +127,14 @@ let rec gen_rcm state = let add_input diff vk index position sum state = let rcm = gen_rcm state in let amount = random_amount sum in - let (new_idx, address) = + let new_idx, address = Tezos_sapling.Core.Client.Viewing_key.new_address vk index in let cv = Tezos_sapling.Core.Client.CV.of_bytes (random_bytes state 32) |> WithExceptions.Option.get ~loc:__LOC__ in - let (ciphertext, cm) = + let ciphertext, cm = Tezos_sapling.Core.Client.Forge.Output.to_ciphertext Tezos_sapling.Core.Client.Forge.Output. {address; amount; memo = Bytes.empty} @@ -221,7 +221,7 @@ let output proving_ctx vk sum = let amount = random_amount sum in let rcm = Tezos_sapling.Core.Client.Rcm.random () in let esk = Tezos_sapling.Core.Client.DH.esk_random () in - let (cv_o, proof_o) = + let cv_o, proof_o = Tezos_sapling.Core.Client.Proving.output_proof proving_ctx esk @@ -229,7 +229,7 @@ let output proving_ctx vk sum = rcm ~amount in - let (ciphertext, cm) = + let ciphertext, cm = Tezos_sapling.Core.Client.Forge.Output.to_ciphertext Tezos_sapling.Core.Client.Forge.Output. {address; amount; memo = Bytes.empty} @@ -246,7 +246,7 @@ let outputs nb_output proving_ctx vk = match nb_output with | 0 -> (output_amount, list_outputs) | nb_output -> - let (output, amount) = output proving_ctx vk sum in + let output, amount = output proving_ctx vk sum in assert ( Int64.compare amount @@ -268,7 +268,7 @@ let make_inputs to_forge local_state proving_ctx sk vk root anti_replay = (fun {rcm; position; amount; address; nf} -> let witness = Tezos_sapling.Storage.get_witness local_state position in let ar = Tezos_sapling.Core.Client.Proving.ar_random () in - let (cv, rk, proof) = + let cv, rk, proof = Tezos_sapling.Core.Client.Proving.spend_proof proving_ctx vk @@ -326,7 +326,7 @@ let prepare_seeded_state_internal ~(nb_input : int) ~(nb_nf : int) init_fresh_sapling_state ctxt >|= Protocol.Environment.wrap_tzresult >>=? fun (ctxt, id) -> let index_start = Tezos_sapling.Core.Client.Viewing_key.default_index in - let (sk, vk) = generate_spending_and_viewing_keys state in + let sk, vk = generate_spending_and_viewing_keys state in generate_commitments ~vk ~nb_input @@ -364,7 +364,7 @@ let generate ~(nb_input : int) ~(nb_output : int) ~(nb_nf : int) ~(nb_cm : int) Tezos_sapling.Core.Client.Proving.with_proving_ctx (fun proving_ctx -> make_inputs to_forge local_state proving_ctx sk vk root anti_replay >>=? fun inputs -> - let (output_amount, outputs) = outputs nb_output proving_ctx vk in + let output_amount, outputs = outputs nb_output proving_ctx vk in let input_amount = List.fold_left (fun sum {amount; _} -> diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/ticket_benchmarks.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/ticket_benchmarks.ml index 23fadf09a62a..c541f989433f 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/ticket_benchmarks.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/ticket_benchmarks.ml @@ -188,7 +188,7 @@ let rec dummy_type_generator ~rng_state size = if size <= 1 then ticket_or_int else match (ticket_or_int, dummy_type_generator ~rng_state (size - 3)) with - | (Ex_ty l, Ex_ty r) -> ( + | Ex_ty l, Ex_ty r -> ( match pair_t (-1) l r with | Error _ -> assert false | Ok (Ty_ex_c t) -> Ex_ty t) @@ -203,7 +203,7 @@ module Has_tickets_type_benchmark : Benchmark.S = struct let make_bench_helper rng_state config () = let open Result_syntax in - let* (ctxt, _) = Lwt_main.run (Execution_context.make ~rng_state) in + let* ctxt, _ = Lwt_main.run (Execution_context.make ~rng_state) in let ctxt = Gas_helpers.set_limit ctxt in let size = Random.State.int rng_state config.max_size in let (Ex_ty ty) = dummy_type_generator ~rng_state size in @@ -245,7 +245,7 @@ let () = Registration_helpers.register (module Has_tickets_type_benchmark) let ticket_sampler rng_state = let seed = Base_samplers.uniform_bytes ~nbytes:32 rng_state in - let (pkh, _, _) = Signature.generate_key ~algo:Signature.Ed25519 ~seed () in + let pkh, _, _ = Signature.generate_key ~algo:Signature.Ed25519 ~seed () in let ticketer = Alpha_context.Contract.implicit_contract pkh in Script_typed_ir. {ticketer; contents = Script_int_repr.zero; amount = Script_int_repr.one_n} @@ -261,12 +261,12 @@ module Collect_tickets_benchmark : Benchmark.S = struct let make_bench_helper rng_state config () = let open Script_typed_ir in let open Result_syntax in - let* (ctxt, _) = Lwt_main.run (Execution_context.make ~rng_state) in + let* ctxt, _ = Lwt_main.run (Execution_context.make ~rng_state) in let ctxt = Gas_helpers.set_limit ctxt in let ty = match list_t (-1) ticket_ty with Error _ -> assert false | Ok t -> t in - let (length, elements) = + let length, elements = Structure_samplers.list ~range:{min = 0; max = config.max_size} ~sampler:ticket_sampler @@ -274,7 +274,7 @@ module Collect_tickets_benchmark : Benchmark.S = struct in let boxed_ticket_list = {elements; length} in Environment.wrap_tzresult - @@ let* (has_tickets, ctxt) = Ticket_scanner.type_has_tickets ctxt ty in + @@ let* has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt ty in let workload = {nodes = length} in let closure () = ignore diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/translator_benchmarks.ml index 5602b226ae4f..fb6577c486c7 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/translator_benchmarks.ml @@ -503,7 +503,7 @@ let check_printable_benchmark = in (string, {Shared_linear.bytes = String.length string})) ~make_bench:(fun generator () -> - let (generated, workload) = generator () in + let generated, workload = generator () in let closure () = ignore (check_printable_ascii generated (String.length generated - 1)) in @@ -629,7 +629,7 @@ let () = Registration_helpers.register (module Ty_eq) This structure is the worse-case of the unparsing function for types because an extra test is performed to determine if the comb type needs to be folded. - *) +*) let rec dummy_type_generator size = let open Script_ir_translator in let open Script_typed_ir in diff --git a/src/proto_013_PtJakart/lib_benchmarks_proto/translator_workload.ml b/src/proto_013_PtJakart/lib_benchmarks_proto/translator_workload.ml index 135fe840eff4..065fd6007e71 100644 --- a/src/proto_013_PtJakart/lib_benchmarks_proto/translator_workload.ml +++ b/src/proto_013_PtJakart/lib_benchmarks_proto/translator_workload.ml @@ -88,7 +88,7 @@ let pp fmtr (trace : t) = consumed let workload_to_sparse_vec (trace : t) = - let (name, {Size.traversal; int_bytes; string_bytes}, consumed) = + let name, {Size.traversal; int_bytes; string_bytes}, consumed = match trace with | Typechecker_workload {t_kind; code_or_data; micheline_size; consumed} -> let name = diff --git a/src/proto_013_PtJakart/lib_client/client_proto_context.ml b/src/proto_013_PtJakart/lib_client/client_proto_context.ml index fdbf108f330b..02ebb6d77743 100644 --- a/src/proto_013_PtJakart/lib_client/client_proto_context.ml +++ b/src/proto_013_PtJakart/lib_client/client_proto_context.ml @@ -721,18 +721,18 @@ let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_013_PtJakart/lib_client/client_proto_fa12.ml b/src/proto_013_PtJakart/lib_client/client_proto_fa12.ml index 279d411cd7ed..c79347ce02c0 100644 --- a/src/proto_013_PtJakart/lib_client/client_proto_fa12.ml +++ b/src/proto_013_PtJakart/lib_client/client_proto_fa12.ml @@ -270,7 +270,7 @@ type type_eq_combinator = Script.node * (Script.node -> bool) check functions, and returns a type of n-ary pair of such types and a function checking syntactical equivalence with another node. *) let t_pair ~loc l : type_eq_combinator = - let (values, are_ty) = List.split l in + let values, are_ty = List.split l in let is_pair p = match p with | Micheline.Prim (_, Script.T_pair, l, _) -> ( @@ -536,8 +536,8 @@ let parse_callback error expr = let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in match (String.sub s 0 pos, name) with - | (addr, "default") -> of_b58_check (addr, None) - | (addr, name) -> of_b58_check (addr, Some name))) + | addr, "default" -> of_b58_check (addr, None) + | addr, name -> of_b58_check (addr, Some name))) | _ -> error () let action_of_expr ~entrypoint expr = @@ -648,7 +648,7 @@ let derive_action expr t_param = | ( Micheline.Prim (_, Script.D_Right, [right], _), Micheline.Prim (_, Script.T_or, [_; t_right], _) ) -> derive right t_right - | (_, Micheline.Prim (_, _, _, annots)) -> + | _, Micheline.Prim (_, _, _, annots) -> find_entrypoint_in_annot error annots expr | _ -> error () in @@ -747,7 +747,7 @@ let parse_error = | ( "NotEnoughAllowance", Prim (_, Script.D_Pair, [Int (_, required); Int (_, present)], _) ) -> Some (Not_enough_allowance (required, present)) - | ("UnsafeAllowanceChange", Int (_, previous)) -> + | "UnsafeAllowanceChange", Int (_, previous) -> Some (Unsafe_allowance_change previous) | _ -> None @@ -771,7 +771,7 @@ let call_contract (cctxt : #Protocol_client_context.full) ~chain ~block ~contract ~action ~tez_amount ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () = contract_has_fa12_interface cctxt ~chain ~block ~contract () >>=? fun () -> - let (entrypoint, parameters) = translate_action_to_argument action in + let entrypoint, parameters = translate_action_to_argument action in Client_proto_context.transfer_with_script cctxt ~chain diff --git a/src/proto_013_PtJakart/lib_client/client_proto_programs.ml b/src/proto_013_PtJakart/lib_client/client_proto_programs.ml index b483f29fe220..f90dd7723a65 100644 --- a/src/proto_013_PtJakart/lib_client/client_proto_programs.ml +++ b/src/proto_013_PtJakart/lib_client/client_proto_programs.ml @@ -270,7 +270,7 @@ let script_size cctxt ~(chain : Chain_services.chain) ~block ?gas ?legacy let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_013_PtJakart/lib_client/client_proto_utils.ml b/src/proto_013_PtJakart/lib_client/client_proto_utils.ml index 27fec54d342a..be6844cc5cf7 100644 --- a/src/proto_013_PtJakart/lib_client/client_proto_utils.ml +++ b/src/proto_013_PtJakart/lib_client/client_proto_utils.ml @@ -37,14 +37,14 @@ let to_json_and_bytes branch message = Data_encoding.Binary.to_bytes_exn encoding op ) let sign_message (cctxt : #full) ~src_sk ~block ~message = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in cctxt#message "signed content: @[%a@]" Data_encoding.Json.pp json >>= fun () -> Client_keys.sign cctxt ~watermark:Signature.Generic_operation src_sk bytes let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> diff --git a/src/proto_013_PtJakart/lib_client/injection.ml b/src/proto_013_PtJakart/lib_client/injection.ml index 128ba6715bed..7277738d26ad 100644 --- a/src/proto_013_PtJakart/lib_client/injection.ml +++ b/src/proto_013_PtJakart/lib_client/injection.ml @@ -275,7 +275,7 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -298,12 +298,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ~chain_id ~latency >>=? function - | (Operation_data op', Operation_metadata result) -> ( + | Operation_data op', Operation_metadata result -> ( match ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -640,7 +640,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) | Single_manager minfo -> gas_patching_stats minfo need_patching gas_consumed | Cons_manager (minfo, rest) -> - let (need_patching, gas_consumed) = + let need_patching, gas_consumed = gas_patching_stats minfo need_patching gas_consumed in gas_patching_stats_list rest need_patching gas_consumed @@ -690,7 +690,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) in let rest_opt = loop rest in match (annotated_op_opt, rest_opt) with - | (None, None) -> None + | None, None -> None | _ -> let op = Option.value ~default:annotated_op annotated_op_opt in let rest = Option.value ~default:rest rest_opt in @@ -759,7 +759,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Annotated_manager_operation.t * kind Kind.manager contents_result -> kind Kind.manager contents tzresult Lwt.t = fun ~first -> function - | ((Manager_info c as op), (Manager_operation_result _ as result)) -> + | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then Lwt.return (estimated_gas_single result) >>= fun gas -> match gas with @@ -855,16 +855,16 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Kind.manager contents_list tzresult Lwt.t = fun first annotated_list result_list -> match (annotated_list, result_list) with - | (Single_manager annotated, Single_result res) -> + | Single_manager annotated, Single_result res -> patch ~first (annotated, res) >>=? fun op -> return (Single op) - | (Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest)) -> + | Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest) -> patch ~first (annotated, res) >>=? fun op -> patch_list false annotated_rest res_rest >>=? fun rest -> return (Cons (op, rest)) | _ -> assert false in let gas_limit_per_patched_op = - let (need_gas_patching, gas_consumed) = + let need_gas_patching, gas_consumed = gas_patching_stats_list annotated_contents 0 Gas.Arith.zero in if need_gas_patching = 0 then hard_gas_limit_per_operation @@ -952,7 +952,7 @@ let tenderbake_adjust_confirmations (cctxt : #Client_context.full) = function Any value greater than the tenderbake_finality_confirmations is treated as if it were tenderbake_finality_confirmations. - *) +*) let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?(dry_run = false) ?(simulation = false) ?(force = false) ?successor_level ?branch ?src_sk ?verbose_signing ~fee_parameter @@ -1394,7 +1394,7 @@ let inject_manager_operation cctxt ~chain ~block ?successor_level ?branch >>=? fun (oph, op, result) -> match pack_contents_list op result with | Cons_and_result (_, _, rest) -> - let (op, result) = unpack_contents_list rest in + let op, result = unpack_contents_list rest in return (oph, op, result) | _ -> assert false) | Some _ when has_reveal operations -> diff --git a/src/proto_013_PtJakart/lib_client/limit.ml b/src/proto_013_PtJakart/lib_client/limit.ml index 3f3c798c02b6..ae20b1d6bf4b 100644 --- a/src/proto_013_PtJakart/lib_client/limit.ml +++ b/src/proto_013_PtJakart/lib_client/limit.ml @@ -35,9 +35,9 @@ let is_unknown = Option.is_none let join (type a) ~where eq (l1 : a t) (l2 : a t) = match (l1, l2) with - | (None, None) -> Result.return_none - | (Some x, None) | (None, Some x) -> Result.return_some x - | (Some x, Some y) -> + | None, None -> Result.return_none + | Some x, None | None, Some x -> Result.return_some x + | Some x, Some y -> if eq x y then Result.return_some x else error_with "Limit.join: error (%s)" where diff --git a/src/proto_013_PtJakart/lib_client/michelson_v1_emacs.ml b/src/proto_013_PtJakart/lib_client/michelson_v1_emacs.ml index 66a970b5e6e1..6de00de8b2f1 100644 --- a/src/proto_013_PtJakart/lib_client/michelson_v1_emacs.ml +++ b/src/proto_013_PtJakart/lib_client/michelson_v1_emacs.ml @@ -129,7 +129,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -137,7 +137,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -156,7 +156,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_013_PtJakart/lib_client/michelson_v1_error_reporter.ml b/src/proto_013_PtJakart/lib_client/michelson_v1_error_reporter.ml index b1b78b40cc4a..f3e28e228c69 100644 --- a/src/proto_013_PtJakart/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_013_PtJakart/lib_client/michelson_v1_error_reporter.ml @@ -512,7 +512,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Invalid_never_expr loc -> diff --git a/src/proto_013_PtJakart/lib_client/michelson_v1_macros.ml b/src/proto_013_PtJakart/lib_client/michelson_v1_macros.ml index 448bd000108e..3b1eaa5028d4 100644 --- a/src/proto_013_PtJakart/lib_client/michelson_v1_macros.ml +++ b/src/proto_013_PtJakart/lib_client/michelson_v1_macros.ml @@ -122,9 +122,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -237,9 +237,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -383,14 +383,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -405,18 +405,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -439,7 +439,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -447,13 +447,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -464,7 +464,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -498,7 +498,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -541,8 +541,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -712,7 +711,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -724,10 +723,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -737,7 +736,7 @@ let expand_rec expr = let unexpand_carn_and_cdrn expanded = match expanded with | Seq (loc, [Prim (_, "GET", [Int (locn, n)], annot)]) -> - let (half, parity) = Z.ediv_rem n (Z.of_int 2) in + let half, parity = Z.ediv_rem n (Z.of_int 2) in if Z.(parity = zero) then Some (Prim (loc, "CDR", [Int (locn, half)], annot)) else Some (Prim (loc, "CAR", [Int (locn, half)], annot)) @@ -802,7 +801,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -812,7 +811,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -879,7 +878,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -889,7 +888,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -910,7 +909,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -952,46 +951,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1008,41 +1007,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_013_PtJakart/lib_client/michelson_v1_parser.ml b/src/proto_013_PtJakart/lib_client/michelson_v1_parser.ml index 2f44d22c1fca..09a8c7d5b710 100644 --- a/src/proto_013_PtJakart/lib_client/michelson_v1_parser.ml +++ b/src/proto_013_PtJakart/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -87,8 +87,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -96,8 +96,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_013_PtJakart/lib_client/michelson_v1_printer.ml b/src/proto_013_PtJakart/lib_client/michelson_v1_printer.ml index 0e53de294bc9..f2dc6bc5e870 100644 --- a/src/proto_013_PtJakart/lib_client/michelson_v1_printer.ml +++ b/src/proto_013_PtJakart/lib_client/michelson_v1_printer.ml @@ -138,7 +138,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -170,8 +170,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_013_PtJakart/lib_client/mockup.ml b/src/proto_013_PtJakart/lib_client/mockup.ml index fd5c9b53cf4c..877cdeb58b37 100644 --- a/src/proto_013_PtJakart/lib_client/mockup.ml +++ b/src/proto_013_PtJakart/lib_client/mockup.ml @@ -1042,7 +1042,7 @@ module Parsed_account = struct Client_keys.list_keys wallet >>=? fun all_keys -> List.iter_s (function - | (name, pkh, _pk_opt, Some sk_uri) -> ( + | name, pkh, _pk_opt, Some sk_uri -> ( let contract = Contract.implicit_contract pkh in Client_proto_context.get_balance rpc_context @@ -1296,7 +1296,7 @@ let mem_init : | None -> return Protocol_constants_overrides.no_overrides | Some json -> ( match Data_encoding.Json.destruct lib_parameters_json_encoding json with - | (_, x) -> return x + | _, x -> return x | exception error -> failwith "cannot read protocol constants overrides: %a" @@ -1383,7 +1383,7 @@ let mem_init : [Block_hash.to_bytes hash; Operation_list_hash.(to_bytes @@ compute [])] in let open Protocol.Alpha_context.Block_header in - let (_, _, sk) = Signature.generate_key () in + let _, _, sk = Signature.generate_key () in let proof_of_work_nonce = Bytes.create Protocol.Alpha_context.Constants.proof_of_work_nonce_size in diff --git a/src/proto_013_PtJakart/lib_client/operation_result.ml b/src/proto_013_PtJakart/lib_client/operation_result.ml index 9b307d950be3..952e4a10c09a 100644 --- a/src/proto_013_PtJakart/lib_client/operation_result.ml +++ b/src/proto_013_PtJakart/lib_client/operation_result.ml @@ -346,10 +346,10 @@ let pp_balance_updates ppf = function | Lost_endorsing_rewards (pkh, p, r) -> let reason = match (p, r) with - | (false, false) -> "" - | (false, true) -> ",revelation" - | (true, false) -> ",participation" - | (true, true) -> ",participation,revelation" + | false, false -> "" + | false, true -> ",revelation" + | true, false -> ",participation" + | true, true -> ",participation,revelation" in Format.asprintf "lost endorsing rewards(%a%s)" diff --git a/src/proto_013_PtJakart/lib_client/test/test_michelson_v1_macros.ml b/src/proto_013_PtJakart/lib_client/test/test_michelson_v1_macros.ml index 75316f163dfa..fad67b021cbf 100644 --- a/src/proto_013_PtJakart/lib_client/test/test_michelson_v1_macros.ml +++ b/src/proto_013_PtJakart/lib_client/test/test_michelson_v1_macros.ml @@ -44,7 +44,7 @@ let print expr : string = let assert_expands (original : (Micheline_parser.location, string) Micheline.node) (expanded : (Micheline_parser.location, string) Micheline.node) = - let ({Michelson_v1_parser.expanded = expansion; _}, errors) = + let {Michelson_v1_parser.expanded = expansion; _}, errors = let source = print (Micheline.strip_locations original) in Michelson_v1_parser.expand_all ~source ~original in @@ -691,7 +691,7 @@ let test_map_cdadr () = [unparse.Michelson_v1_parser.unexpanded] contains the original expression with macros *) let assert_unexpansion original ex = - let ({Michelson_v1_parser.expanded; _}, errors) = + let {Michelson_v1_parser.expanded; _}, errors = let source = print (Micheline.strip_locations original) in Michelson_v1_parser.expand_all ~source ~original in @@ -1318,7 +1318,7 @@ let tests = ("map_car unexpansion", fun _ -> Lwt.return (test_unexpand_map_car ())); ("diip unexpansion", fun _ -> Lwt.return (test_unexpand_diip ())); ("diip_duup1 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup1 ())); - ("diip_duup2 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup2 ())); + ("diip_duup2 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup2 ())) (***********************************************************************) (*BUG the function in Michelson_v1_macros.unexpand_map_caddadr @@ -1327,7 +1327,7 @@ let tests = (*"diip unexpansion", (fun _ -> Lwt.return (test_unexpand_diip ())) ;*) (*"map_cdr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdr ())) ;*) (*"map_caadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_caadr ())) ;*) - (*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*) + (*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*); ] let wrap (n, f) = diff --git a/src/proto_013_PtJakart/lib_client/test/test_proxy.ml b/src/proto_013_PtJakart/lib_client/test/test_proxy.ml index 54596f6aced8..273102db51e5 100644 --- a/src/proto_013_PtJakart/lib_client/test/test_proxy.ml +++ b/src/proto_013_PtJakart/lib_client/test/test_proxy.ml @@ -55,9 +55,9 @@ let key_gen = (** Whether [t1] is a prefix of [t2] *) let rec is_prefix t1 t2 = match (t1, t2) with - | ([], _) -> true - | (_, []) -> false - | (x1 :: rest1, x2 :: rest2) when x1 = x2 -> is_prefix rest1 rest2 + | [], _ -> true + | _, [] -> false + | x1 :: rest1, x2 :: rest2 when x1 = x2 -> is_prefix rest1 rest2 | _ -> false let test_split_key = diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_context_commands.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_context_commands.ml index 9be1a89cad6a..61f514bd182b 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_context_commands.ml @@ -635,27 +635,27 @@ let commands_ro () = (* ----------------------------------------------------------------------------*) (* After the activation of a new version of the protocol, the older protocols - are only kept in the code base to replay the history of the chain and to query - old states. + are only kept in the code base to replay the history of the chain and to query + old states. - The commands that are not useful anymore in the old protocols are removed, - this is called protocol freezing. The commands below are those that can be - removed during protocol freezing. + The commands that are not useful anymore in the old protocols are removed, + this is called protocol freezing. The commands below are those that can be + removed during protocol freezing. - The rule of thumb to know if a command should be kept at freezing is that all - commands that modify the state of the chain should be removed and conversely - all commands that are used to query the context should be kept. For this - reason, we call read-only (or RO for short) the commands that are kept and - read-write (or RW for short) the commands that are removed. + The rule of thumb to know if a command should be kept at freezing is that all + commands that modify the state of the chain should be removed and conversely + all commands that are used to query the context should be kept. For this + reason, we call read-only (or RO for short) the commands that are kept and + read-write (or RW for short) the commands that are removed. - There are some exceptions to this rule however, for example the command - "tezos-client wait for <op> to be included" is classified as RW despite having - no effect on the context because it has no use case once all RW commands are - removed. + There are some exceptions to this rule however, for example the command + "tezos-client wait for <op> to be included" is classified as RW despite having + no effect on the context because it has no use case once all RW commands are + removed. - Keeping this in mind, the developer should decide where to add a new command. - At the end of the file, RO and RW commands are concatenated into one list that - is then exported in the mli file. *) + Keeping this in mind, the developer should decide where to add a new command. + At the end of the file, RO and RW commands are concatenated into one list that + is then exported in the mli file. *) (* ----------------------------------------------------------------------------*) let dry_run_switch = @@ -845,8 +845,7 @@ let commands_network network () = ~desc:"Register and activate an Alphanet/Zeronet faucet account." (args2 (Secret_key.force_switch ()) encrypted_switch) (prefixes ["activate"; "account"] - @@ Secret_key.fresh_alias_param - @@ prefixes ["with"] + @@ Secret_key.fresh_alias_param @@ prefixes ["with"] @@ param ~name:"activation_key" ~desc: @@ -888,8 +887,7 @@ let commands_network network () = ~desc:"Activate a fundraiser account." (args1 dry_run_switch) (prefixes ["activate"; "fundraiser"; "account"] - @@ Public_key_hash.alias_param - @@ prefixes ["with"] + @@ Public_key_hash.alias_param @@ prefixes ["with"] @@ param ~name:"code" (Clic.parameter (fun _ctx code -> @@ -1319,7 +1317,7 @@ let commands_rw () = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith @@ -1966,7 +1964,7 @@ let commands_rw () = (cctxt#chain, cctxt#block) >>=? fun current_proposal -> (match (info.current_period_kind, current_proposal) with - | ((Exploration | Promotion), Some current_proposal) -> + | (Exploration | Promotion), Some current_proposal -> if Protocol_hash.equal proposal current_proposal then return_unit else diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_fa12_commands.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_fa12_commands.ml index fe6703bbb7fa..3f66279f1829 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_fa12_commands.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_fa12_commands.ml @@ -526,7 +526,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = src (_, dst) (cctxt : #Protocol_client_context.full) -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in get_contract_caller_keys cctxt caller >>=? fun (source, caller_pk, caller_sk) -> let action = Client_proto_fa12.Transfer (snd src, dst, amount) in @@ -690,7 +690,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = src operations_json cctxt -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in let fee_parameter = { Injection.minimal_fees; @@ -736,7 +736,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_multisig_commands.ml index d20ca7fa7de4..67ded5e8a0eb 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_multisig_commands.ml @@ -819,8 +819,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = @@ Client_proto_contracts.ContractAlias.destination_param ~name:"multisig" ~desc:"name or address of the originated multisig contract" - @@ prefixes ["to"] - @@ threshold_param () + @@ prefixes ["to"] @@ threshold_param () @@ prefixes ["and"; "public"; "keys"; "to"] @@ non_terminal_seq (public_key_param ()) ~suffix:["on"; "behalf"; "of"] @@ Client_proto_contracts.ContractAlias.destination_param diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_programs_commands.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_programs_commands.ml index 737b858c36e7..54caebc40e9f 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_programs_commands.ml @@ -183,7 +183,7 @@ let commands () = let handle_parsing_error label (cctxt : Protocol_client_context.full) (emacs_mode, no_print_source) program body = match program with - | (program, []) -> body program + | program, [] -> body program | res_with_errors when emacs_mode -> cctxt#message "(@[<v 0>(%s . ())@ (errors . %a)@])" @@ -191,7 +191,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -665,8 +665,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> @@ -708,8 +707,7 @@ let commands () = ~name:"entrypoint" ~desc:"the entrypoint to describe" entrypoint_parameter - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun ((emacs_mode, no_print_source) as setup) entrypoint program cctxt -> handle_parsing_error "entrypoint" cctxt setup program @@ fun program -> entrypoint_type diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_commands.ml index a67a9c0ec94c..f28ef9ab7d47 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_commands.ml @@ -342,7 +342,7 @@ let random_seed rng = let generate_fresh_source pool rng = let seed = random_seed rng in - let (pkh, pk, sk) = Signature.generate_key ~seed () in + let pkh, pk, sk = Signature.generate_key ~seed () in let fresh = {source = {pkh; pk; sk}; origin = Explicit} in pool.pool <- fresh :: pool.pool ; pool.pool_size <- pool.pool_size + 1 ; diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_utils_commands.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_utils_commands.ml index 7f57941fb389..c661dbd2eb6b 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_utils_commands.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_utils_commands.ml @@ -133,8 +133,7 @@ let commands () = return the signed block." no_options (prefixes ["sign"; "block"] - @@ unsigned_block_header_param - @@ prefixes ["for"] + @@ unsigned_block_header_param @@ prefixes ["for"] @@ Client_keys.Public_key_hash.source_param ~name:"delegate" ~desc:"signing delegate" diff --git a/src/proto_013_PtJakart/lib_client_sapling/client_sapling_commands.ml b/src/proto_013_PtJakart/lib_client_sapling/client_sapling_commands.ml index e23b112c14b8..596524d163d0 100644 --- a/src/proto_013_PtJakart/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_013_PtJakart/lib_client_sapling/client_sapling_commands.ml @@ -714,9 +714,7 @@ let commands () = path >>= fun () -> (* TODO must pass contract address for now *) - let (_, contract) = - WithExceptions.Option.get ~loc:__LOC__ contract_opt - in + let _, contract = WithExceptions.Option.get ~loc:__LOC__ contract_opt in Context.Client_state.register cctxt ~default_memo_size diff --git a/src/proto_013_PtJakart/lib_client_sapling/context.ml b/src/proto_013_PtJakart/lib_client_sapling/context.ml index 24615b751ca4..0ce463e82e4e 100644 --- a/src/proto_013_PtJakart/lib_client_sapling/context.ml +++ b/src/proto_013_PtJakart/lib_client_sapling/context.ml @@ -280,7 +280,7 @@ module Contract_state = struct let vks = Accounts.fold (fun account acc -> Account.(account.vk) :: acc) accounts [] in - let (size, _) = Storage.size storage in + let size, _ = Storage.size storage in let rec aux pos accounts = if pos < size then (* try to decrypt each inputs with all vks *) @@ -300,7 +300,7 @@ module Contract_state = struct | _ -> assert false (* got more than one decrypting key *) else accounts in - let (current_size, _) = Storage.size state.storage in + let current_size, _ = Storage.size state.storage in let accounts = aux current_size accounts in {accounts; storage} @@ -392,7 +392,7 @@ module Client_state = struct let sync_and_scan cctxt contract = load cctxt >>=? fun state -> find cctxt contract state >>=? fun contract_state -> - let (cm_pos, nf_pos) = Storage.size contract_state.storage in + let cm_pos, nf_pos = Storage.size contract_state.storage in get_diff cctxt contract cm_pos nf_pos >>=? fun diff -> let contract_state = Contract_state.update_storage contract_state diff in let state = Map.add contract contract_state state in diff --git a/src/proto_013_PtJakart/lib_client_sapling/wallet.ml b/src/proto_013_PtJakart/lib_client_sapling/wallet.ml index e970fd0b2a8a..c5df62f580c8 100644 --- a/src/proto_013_PtJakart/lib_client_sapling/wallet.ml +++ b/src/proto_013_PtJakart/lib_client_sapling/wallet.ml @@ -114,7 +114,7 @@ let new_address (cctxt : #Client_context.full) name index_opt = return (Viewing_key.of_sk sk) >>=? fun vk -> (* Viewing_key.new_address finds the smallest index greater or equal to [index] that generates a correct address. *) - let (corrected_index, address) = Viewing_key.new_address vk index in + let corrected_index, address = Viewing_key.new_address vk index in Sapling_key.update cctxt name diff --git a/src/proto_013_PtJakart/lib_delegate/baking_actions.ml b/src/proto_013_PtJakart/lib_delegate/baking_actions.ml index fee7f9e2f622..6ac4017608b4 100644 --- a/src/proto_013_PtJakart/lib_delegate/baking_actions.ml +++ b/src/proto_013_PtJakart/lib_delegate/baking_actions.ml @@ -228,7 +228,7 @@ let inject_block ~state_recorder state block_to_bake ~updated_state = >>?= fun timestamp -> let external_operation_source = state.global_state.config.extra_operations in Operations_source.retrieve external_operation_source >>= fun extern_ops -> - let (simulation_kind, payload_round) = + let simulation_kind, payload_round = match kind with | Fresh pool -> let pool = @@ -517,7 +517,7 @@ let prepare_waiting_for_quorum state = (consensus_threshold, get_consensus_operation_voting_power, candidate) let start_waiting_for_preendorsement_quorum state = - let (consensus_threshold, get_preendorsement_voting_power, candidate) = + let consensus_threshold, get_preendorsement_voting_power, candidate = prepare_waiting_for_quorum state in let operation_worker = state.global_state.operation_worker in @@ -528,7 +528,7 @@ let start_waiting_for_preendorsement_quorum state = candidate let start_waiting_for_endorsement_quorum state = - let (consensus_threshold, get_endorsement_voting_power, candidate) = + let consensus_threshold, get_endorsement_voting_power, candidate = prepare_waiting_for_quorum state in let operation_worker = state.global_state.operation_worker in diff --git a/src/proto_013_PtJakart/lib_delegate/baking_cache.ml b/src/proto_013_PtJakart/lib_delegate/baking_cache.ml index 4ce45c7b7a9d..af2ac36dc1fc 100644 --- a/src/proto_013_PtJakart/lib_delegate/baking_cache.ml +++ b/src/proto_013_PtJakart/lib_delegate/baking_cache.ml @@ -67,12 +67,12 @@ module Round_cache_key = struct { predecessor_timestamp = pred_t; predecessor_round = pred_r; - time_interval = (t_beg, t_end); + time_interval = t_beg, t_end; } { predecessor_timestamp = pred_t'; predecessor_round = pred_r'; - time_interval = (t_beg', t_end'); + time_interval = t_beg', t_end'; } = Timestamp.(pred_t = pred_t') && Round.(pred_r = pred_r') diff --git a/src/proto_013_PtJakart/lib_delegate/baking_commands.ml b/src/proto_013_PtJakart/lib_delegate/baking_commands.ml index a1142dfd3b50..78d6ec9e61a1 100644 --- a/src/proto_013_PtJakart/lib_delegate/baking_commands.ml +++ b/src/proto_013_PtJakart/lib_delegate/baking_commands.ml @@ -180,7 +180,7 @@ let get_delegates (cctxt : Protocol_client_context.full) List.map_es (fun pkh -> Client_keys.get_key cctxt pkh >>=? function - | (alias, pk, sk_uri) -> return (proj_delegate (alias, pkh, pk, sk_uri))) + | alias, pk, sk_uri -> return (proj_delegate (alias, pkh, pk, sk_uri))) pkhs) >>=? fun delegates -> Tezos_signer_backends.Encrypted.decrypt_list diff --git a/src/proto_013_PtJakart/lib_delegate/baking_lib.ml b/src/proto_013_PtJakart/lib_delegate/baking_lib.ml index 6ddda41e3130..a3dcd86cb678 100644 --- a/src/proto_013_PtJakart/lib_delegate/baking_lib.ml +++ b/src/proto_013_PtJakart/lib_delegate/baking_lib.ml @@ -246,7 +246,7 @@ let propose_at_next_level ~minimal_timestamp state = cctxt#message "Proposal injected" >>= fun () -> return state let endorsement_quorum state = - let (power, endorsements) = state_endorsing_power state in + let power, endorsements = state_endorsing_power state in if Compare.Int.( power >= state.global_state.constants.parametric.consensus_threshold) diff --git a/src/proto_013_PtJakart/lib_delegate/baking_nonces.ml b/src/proto_013_PtJakart/lib_delegate/baking_nonces.ml index 09c649c5473c..d8ecd4c66191 100644 --- a/src/proto_013_PtJakart/lib_delegate/baking_nonces.ml +++ b/src/proto_013_PtJakart/lib_delegate/baking_nonces.ml @@ -154,8 +154,7 @@ let blocks_from_current_cycle {cctxt; chain; _} block ?(offset = 0l) () = let blocks = List.drop_n (length - Int32.to_int (Raw_level.diff last first)) head in - if Int32.equal level (Raw_level.to_int32 last) then - return (hash :: blocks) + if Int32.equal level (Raw_level.to_int32 last) then return (hash :: blocks) else return blocks let get_unrevealed_nonces ({cctxt; chain; _} as state) nonces = diff --git a/src/proto_013_PtJakart/lib_delegate/baking_scheduling.ml b/src/proto_013_PtJakart/lib_delegate/baking_scheduling.ml index b5b3b4545b97..22e097f7ce24 100644 --- a/src/proto_013_PtJakart/lib_delegate/baking_scheduling.ml +++ b/src/proto_013_PtJakart/lib_delegate/baking_scheduling.ml @@ -48,7 +48,7 @@ type events = Lwt.t let create_loop_state block_stream operation_worker = - let (future_block_stream, push_future_block) = Lwt_stream.create () in + let future_block_stream, push_future_block = Lwt_stream.create () in { block_stream; qc_stream = Operation_worker.get_quorum_event_stream operation_worker; @@ -513,12 +513,12 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t let next_round = compute_next_round_time state in compute_next_potential_baking_time_at_next_level state >>= fun next_baking -> match (next_round, next_baking) with - | (None, None) -> + | None, None -> Events.(emit waiting_for_new_head ()) >>= fun () -> return (Lwt_utils.never_ending () >>= fun () -> assert false) (* We have no slot at the next level in the near future, we will patiently wait for the next round. *) - | (Some next_round, None) -> ( + | Some next_round, None -> ( (* If there is an elected block, then we make the assumption that the bakers at the next level have also received an endorsement quorum, and we delay a bit injecting at the next @@ -529,7 +529,7 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t | Some _elected_block -> delay_next_round_timeout next_round) (* There is no timestamp for a successor round but there is for a future baking slot, we will wait to bake. *) - | (None, Some next_baking) -> wait_baking_time_next_level next_baking + | None, Some next_baking -> wait_baking_time_next_level next_baking (* We choose the earliest timestamp between waiting to bake and waiting for the next round. *) | ( Some ((next_round_time, next_round) as next_round_info), diff --git a/src/proto_013_PtJakart/lib_delegate/baking_state.ml b/src/proto_013_PtJakart/lib_delegate/baking_state.ml index 88a7f80e5b0b..1ce1daeeb575 100644 --- a/src/proto_013_PtJakart/lib_delegate/baking_state.ml +++ b/src/proto_013_PtJakart/lib_delegate/baking_state.ml @@ -483,18 +483,18 @@ let may_record_new_state ~previous_state ~new_state = if Compare.Int32.(new_current_level = previous_current_level) then let is_new_locked_round_consistent = match (new_locked_round, previous_locked_round) with - | (None, None) -> true - | (Some _, None) -> true - | (None, Some _) -> false - | (Some new_locked_round, Some previous_locked_round) -> + | None, None -> true + | Some _, None -> true + | None, Some _ -> false + | Some new_locked_round, Some previous_locked_round -> Round.(new_locked_round.round >= previous_locked_round.round) in let is_new_endorsable_payload_consistent = match (new_endorsable_payload, previous_endorsable_payload) with - | (None, None) -> true - | (Some _, None) -> true - | (None, Some _) -> false - | (Some new_endorsable_payload, Some previous_endorsable_payload) -> + | None, None -> true + | Some _, None -> true + | None, Some _ -> false + | Some new_endorsable_payload, Some previous_endorsable_payload -> Round.( new_endorsable_payload.proposal.block.round >= previous_endorsable_payload.proposal.block.round) @@ -589,7 +589,7 @@ let compute_delegate_slots (cctxt : Protocol_client_context.full) delegates (* FIXME? should we not take `Head 0 ? *) Plugin.RPC.Validators.get cctxt (chain, `Head 0) ~levels:[level] >>=? fun endorsing_rights -> - let (own_delegate_slots, all_delegate_slots) = + let own_delegate_slots, all_delegate_slots = List.fold_left (fun (own_map, all_map) slot -> let {Plugin.RPC.Validators.delegate; slots; _} = slot in diff --git a/src/proto_013_PtJakart/lib_delegate/block_forge.ml b/src/proto_013_PtJakart/lib_delegate/block_forge.ml index 4bc63292ac7a..413f5f2eee5e 100644 --- a/src/proto_013_PtJakart/lib_delegate/block_forge.ml +++ b/src/proto_013_PtJakart/lib_delegate/block_forge.ml @@ -359,13 +359,12 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~pred_info | Apply _ as x -> x in (match (simulation_mode, simulation_kind) with - | (Baking_state.Node, Filter operation_pool) -> - filter_via_node ~operation_pool - | (Node, Apply {ordered_pool; payload_hash}) -> + | Baking_state.Node, Filter operation_pool -> filter_via_node ~operation_pool + | Node, Apply {ordered_pool; payload_hash} -> apply_via_node ~ordered_pool ~payload_hash - | (Local context_index, Filter operation_pool) -> + | Local context_index, Filter operation_pool -> filter_with_context ~context_index ~operation_pool - | (Local context_index, Apply {ordered_pool; payload_hash}) -> + | Local context_index, Apply {ordered_pool; payload_hash} -> apply_with_context ~context_index ~ordered_pool ~payload_hash) >>=? fun (shell_header, operations, payload_hash) -> Baking_pow.mine diff --git a/src/proto_013_PtJakart/lib_delegate/client_baking_blocks.ml b/src/proto_013_PtJakart/lib_delegate/client_baking_blocks.ml index 5296233d2656..b43c7f98ba7b 100644 --- a/src/proto_013_PtJakart/lib_delegate/client_baking_blocks.ml +++ b/src/proto_013_PtJakart/lib_delegate/client_baking_blocks.ml @@ -183,6 +183,5 @@ let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = let blocks = List.drop_n (length - Int32.to_int (Raw_level.diff last first)) head in - if Int32.equal level (Raw_level.to_int32 last) then - return (hash :: blocks) + if Int32.equal level (Raw_level.to_int32 last) then return (hash :: blocks) else return blocks diff --git a/src/proto_013_PtJakart/lib_delegate/client_baking_denunciation.ml b/src/proto_013_PtJakart/lib_delegate/client_baking_denunciation.ml index 33ea0f64fa43..e29280816b7f 100644 --- a/src/proto_013_PtJakart/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_013_PtJakart/lib_delegate/client_baking_denunciation.ml @@ -117,8 +117,8 @@ let get_block_offset level = let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) (op : kind Operation.t) = match (op_kind, op.protocol_data.contents) with - | (Preendorsement, Single (Preendorsement consensus_content)) - | (Endorsement, Single (Endorsement consensus_content)) -> + | Preendorsement, Single (Preendorsement consensus_content) + | Endorsement, Single (Endorsement consensus_content) -> consensus_content.block_payload_hash | _ -> . @@ -155,10 +155,10 @@ let process_consensus_op (type kind) cctxt get_payload_hash op_kind existing_op <> get_payload_hash op_kind new_op) -> (* same level and round, and different payload hash for this slot *) - let (new_op_hash, existing_op_hash) = + let new_op_hash, existing_op_hash = (Operation.hash new_op, Operation.hash existing_op) in - let (op1, op2) = + let op1, op2 = if Operation_hash.(new_op_hash < existing_op_hash) then (new_op, existing_op) else (existing_op, new_op) @@ -176,7 +176,7 @@ let process_consensus_op (type kind) cctxt () >>=? fun bytes -> let bytes = Signature.concat bytes Signature.zero in - let (double_op_detected, double_op_denounced) = + let double_op_detected, double_op_denounced = Events.( match op_kind with | Endorsement -> @@ -286,7 +286,7 @@ let process_block (cctxt : #Protocol_client_context.full) state context_block_header cctxt ~chain new_hash >>=? fun bh2 -> let hash1 = Block_header.hash bh1 in let hash2 = Block_header.hash bh2 in - let (bh1, bh2) = + let bh1, bh2 = if Block_hash.(hash1 < hash2) then (bh1, bh2) else (bh2, bh1) in (* If the blocks are on different chains then skip it *) diff --git a/src/proto_013_PtJakart/lib_delegate/node_rpc.ml b/src/proto_013_PtJakart/lib_delegate/node_rpc.ml index 05c7afebdda9..badb4fc204d4 100644 --- a/src/proto_013_PtJakart/lib_delegate/node_rpc.ml +++ b/src/proto_013_PtJakart/lib_delegate/node_rpc.ml @@ -132,7 +132,7 @@ let info cctxt ~chain ~block () = encoding, while we should use the previous protocol's [protocol_data] encoding. For now, this works because the encoding has not changed. *) - let (payload_hash, payload_round) = + let payload_hash, payload_round = match Data_encoding.Binary.of_bytes_opt Protocol.block_header_data_encoding diff --git a/src/proto_013_PtJakart/lib_delegate/operation_pool.ml b/src/proto_013_PtJakart/lib_delegate/operation_pool.ml index 692bb6561500..4eada5daf036 100644 --- a/src/proto_013_PtJakart/lib_delegate/operation_pool.ml +++ b/src/proto_013_PtJakart/lib_delegate/operation_pool.ml @@ -47,9 +47,9 @@ module Prioritized_operation = struct let compare_priority t1 t2 = match (t1, t2) with - | (High _, Low _) -> 1 - | (Low _, High _) -> -1 - | (Low _, Low _) | (High _, High _) -> 0 + | High _, Low _ -> 1 + | Low _, High _ -> -1 + | Low _, Low _ | High _, High _ -> 0 let compare a b = let c = compare_priority a b in @@ -205,8 +205,7 @@ let filter_with_relevant_consensus_ops ~(endorsement_filter : consensus_filter) (fun {protocol_data; _} -> match (protocol_data, preendorsement_filter) with (* 1a. Remove preendorsements. *) - | (Operation_data {contents = Single (Preendorsement _); _}, None) -> - false + | Operation_data {contents = Single (Preendorsement _); _}, None -> false (* 1b. Filter preendorsements. *) | ( Operation_data { @@ -307,7 +306,7 @@ let ordered_pool_of_payload ~consensus_operations let extract_operations_of_list_list = function | [consensus; votes_payload; anonymous_payload; managers_payload] -> - let (preendorsements, endorsements) = + let preendorsements, endorsements = List.fold_left (fun ( (preendorsements : Kind.preendorsement Operation.t list), (endorsements : Kind.endorsement Operation.t list) ) diff --git a/src/proto_013_PtJakart/lib_delegate/operation_worker.ml b/src/proto_013_PtJakart/lib_delegate/operation_worker.ml index dff14de45bc4..7a0191694547 100644 --- a/src/proto_013_PtJakart/lib_delegate/operation_worker.ml +++ b/src/proto_013_PtJakart/lib_delegate/operation_worker.ml @@ -241,7 +241,7 @@ let monitor_operations (cctxt : #Protocol_client_context.full) = let make_initial_state ?(monitor_node_operations = true) () = let qc_event_stream = - let (stream, push) = Lwt_stream.create () in + let stream, push = Lwt_stream.create () in {stream; push} in let canceler = Lwt_canceler.create () in @@ -280,7 +280,7 @@ let update_monitoring ?(should_lock = true) state ops = _; } as proposal_watched)) -> let preendorsements = Operation_pool.filter_preendorsements ops in - let (preendorsements_count, voting_power) = + let preendorsements_count, voting_power = List.fold_left (fun (count, power) (op : Kind.preendorsement Operation.t) -> let { @@ -340,7 +340,7 @@ let update_monitoring ?(should_lock = true) state ops = _; } as proposal_watched)) -> let endorsements = Operation_pool.filter_endorsements ops in - let (endorsements_count, voting_power) = + let endorsements_count, voting_power = List.fold_left (fun (count, power) (op : Kind.endorsement Operation.t) -> let { diff --git a/src/proto_013_PtJakart/lib_delegate/state_transitions.ml b/src/proto_013_PtJakart/lib_delegate/state_transitions.ml index 47977aa2b20e..b6095e75aba7 100644 --- a/src/proto_013_PtJakart/lib_delegate/state_transitions.ml +++ b/src/proto_013_PtJakart/lib_delegate/state_transitions.ml @@ -162,14 +162,14 @@ let may_update_endorsable_payload_with_internal_pqc state match (new_proposal.block.prequorum, state.level_state.endorsable_payload) with - | (None, _) -> + | None, _ -> (* The proposal does not contain a PQC: no need to update *) state - | (Some {round = new_round; _}, Some {prequorum = {round = old_round; _}; _}) + | Some {round = new_round; _}, Some {prequorum = {round = old_round; _}; _} when Round.(new_round < old_round) -> (* The proposal pqc is outdated, do not update *) state - | (Some better_prequorum, _) -> + | Some better_prequorum, _ -> assert ( Block_payload_hash.( better_prequorum.block_payload_hash = new_proposal.block.payload_hash)) ; @@ -307,17 +307,17 @@ and may_switch_branch state new_proposal = in let current_endorsable_payload = state.level_state.endorsable_payload in match (current_endorsable_payload, new_proposal.block.prequorum) with - | (None, Some _) | (None, None) -> + | None, Some _ | None, None -> Events.(emit branch_proposal_has_better_fitness ()) >>= fun () -> (* The new branch contains a PQC (and we do not) or a better fitness, we switch. *) switch_branch state - | (Some _, None) -> + | Some _, None -> (* We have a better PQC, we don't switch as we are able to propose a better chain if we stay on our current one. *) Events.(emit branch_proposal_has_no_prequorum ()) >>= fun () -> do_nothing state - | (Some {prequorum = current_pqc; _}, Some new_pqc) -> + | Some {prequorum = current_pqc; _}, Some new_pqc -> if Round.(current_pqc.round > new_pqc.round) then Events.(emit branch_proposal_has_lower_prequorum ()) >>= fun () -> (* The other's branch PQC is lower than ours, do not @@ -563,11 +563,11 @@ let time_to_bake state at_round = at_round in match (state.level_state.elected_block, round_proposer_opt) with - | (None, _) | (_, None) -> + | None, _ | _, None -> (* Unreachable: the [Time_to_bake_next_level] event can only be triggered when we have a slot and an elected block *) assert false - | (Some elected_block, Some (delegate, _)) -> + | Some elected_block, Some (delegate, _) -> let endorsements = elected_block.endorsement_qc in let new_level_state = {state.level_state with next_level_proposed_round = Some at_round} @@ -687,15 +687,15 @@ let step (state : Baking_state.t) (event : Baking_state.event) : Events.(emit step_current_phase (phase, event)) >>= fun () -> match (phase, event) with (* Handle timeouts *) - | (_, Timeout (End_of_round {ending_round})) -> + | _, Timeout (End_of_round {ending_round}) -> (* If the round is ending, stop everything currently going on and increment the round. *) end_of_round state ending_round - | (_, Timeout (Time_to_bake_next_level {at_round})) -> + | _, Timeout (Time_to_bake_next_level {at_round}) -> (* If it is time to bake the next level, stop everything currently going on and propose the next level block *) time_to_bake state at_round - | (Idle, New_proposal block_info) -> + | Idle, New_proposal block_info -> Events.( emit new_head @@ -703,8 +703,8 @@ let step (state : Baking_state.t) (event : Baking_state.event) : block_info.block.shell.level, block_info.block.round )) >>= fun () -> handle_new_proposal state block_info - | (Awaiting_endorsements, New_proposal block_info) - | (Awaiting_preendorsements, New_proposal block_info) -> + | Awaiting_endorsements, New_proposal block_info + | Awaiting_preendorsements, New_proposal block_info -> Events.( emit new_head @@ -724,8 +724,8 @@ let step (state : Baking_state.t) (event : Baking_state.event) : Quorum_reached (candidate, _voting_power, endorsement_qc) ) -> quorum_reached_when_waiting_endorsements state candidate endorsement_qc (* Unreachable cases *) - | (Idle, (Prequorum_reached _ | Quorum_reached _)) - | (Awaiting_preendorsements, Quorum_reached _) - | (Awaiting_endorsements, Prequorum_reached _) -> + | Idle, (Prequorum_reached _ | Quorum_reached _) + | Awaiting_preendorsements, Quorum_reached _ + | Awaiting_endorsements, Prequorum_reached _ -> (* This cannot/should not happen *) do_nothing state diff --git a/src/proto_013_PtJakart/lib_delegate/test/mockup_simulator/mockup_simulator.ml b/src/proto_013_PtJakart/lib_delegate/test/mockup_simulator/mockup_simulator.ml index e361018fd87c..5194f4dd2cea 100644 --- a/src/proto_013_PtJakart/lib_delegate/test/mockup_simulator/mockup_simulator.ml +++ b/src/proto_013_PtJakart/lib_delegate/test/mockup_simulator/mockup_simulator.ml @@ -153,10 +153,10 @@ let locate_blocks (state : state) | None -> failwith "locate_blocks: can't find the block %a" Block_hash.pp hash | Some chain0 -> - let (_, chain) = List.split_n rel chain0 in + let _, chain = List.split_n rel chain0 in return chain) | `Head rel -> - let (_, chain) = List.split_n rel state.chain in + let _, chain = List.split_n rel state.chain in return chain | `Level _ -> failwith "locate_blocks: `Level block spec not handled" | `Genesis -> failwith "locate_blocks: `Genesis block spec net handled" @@ -172,7 +172,7 @@ let locate_block (state : state) (** Return the collection of live blocks for a given block identifier. *) let live_blocks (state : state) block = locate_blocks state block >>=? fun chain -> - let (segment, _) = List.split_n state.live_depth chain in + let segment, _ = List.split_n state.live_depth chain in return (List.fold_left (fun set ({rpc_context; _} : block) -> @@ -686,7 +686,7 @@ let rec listener ~(user_hooks : (module Hooks)) ~state ~broadcast_pipe = let create_fake_node_state ~i ~live_depth ~(genesis_block : Block_header.t * Environment_context.rpc_context) ~global_chain_table ~broadcast_pipes = - let (block_header0, rpc_context0) = genesis_block in + let block_header0, rpc_context0 = genesis_block in parse_protocol_data block_header0.protocol_data >>=? fun protocol_data -> let genesis0 = { @@ -851,7 +851,7 @@ let deduce_baker_sk list) (total_accounts : int) (level : int) : Signature.secret_key tzresult Lwt.t = (match (total_accounts, level) with - | (_, 0) -> return 0 (* apparently this doesn't really matter *) + | _, 0 -> return 0 (* apparently this doesn't really matter *) | _ -> failwith "cannot deduce baker for a genesis block, total accounts = %d, level = \ @@ -859,7 +859,7 @@ let deduce_baker_sk total_accounts level) >>=? fun baker_index -> - let (_, secret) = + let _, secret = List.nth accounts_with_secrets baker_index |> WithExceptions.Option.get ~loc:__LOC__ in @@ -919,8 +919,8 @@ let make_genesis_context ~delegate_selection ~initial_seed ~round0 ~round1 |> Environment.wrap_tzresult >>?= fun delegate_selection -> (match (delegate_selection, constants.initial_seed) with - | ([], seed_opt) -> return seed_opt - | (selection, (Some _ as seed)) -> ( + | [], seed_opt -> return seed_opt + | selection, (Some _ as seed) -> ( Faked_client_context.logger#warning "Checking provided seed." >>= fun () -> Tenderbrute.check_seed @@ -932,7 +932,7 @@ let make_genesis_context ~delegate_selection ~initial_seed ~round0 ~round1 | true -> return seed | false -> failwith "Provided initial seed does not match delegate selection") - | (_, None) -> + | _, None -> Faked_client_context.logger#warning "No initial seed provided, bruteforcing." >>= fun () -> @@ -1129,7 +1129,7 @@ let run ?(config = default_config) bakers_spec = (take_third (List.fold_left (fun (i, delegates_acc, ms) (n, user_hooks) -> - let (delegates, leftover_delegates) = + let delegates, leftover_delegates = List.split_n n delegates_acc in let m = diff --git a/src/proto_013_PtJakart/lib_delegate/test/test_scenario.ml b/src/proto_013_PtJakart/lib_delegate/test/test_scenario.ml index 814ff87b6470..7543a2b1ab28 100644 --- a/src/proto_013_PtJakart/lib_delegate/test/test_scenario.ml +++ b/src/proto_013_PtJakart/lib_delegate/test/test_scenario.ml @@ -95,7 +95,7 @@ let test_scenario_t1 () = let check_block_before_processing ~level ~round ~block_hash ~block_header ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = (match (!b_endorsed, level, round) with - | (false, 1l, 0l) -> + | false, 1l, 0l -> (* If any of the checks fails the whole scenario will fail. *) check_block_signature ~block_hash @@ -103,7 +103,7 @@ let test_scenario_t1 () = ~public_key:Mockup_simulator.bootstrap1 >>=? fun () -> save_proposal_payload ~protocol_data ~var:original_proposal - | (true, 1l, 1l) -> + | true, 1l, 1l -> check_block_signature ~block_hash ~block_header @@ -171,7 +171,7 @@ let test_scenario_t2 () = (* Here we test that the only block that B observes is its own proposal for level 1 at round 1. *) match (level, round) with - | (1l, 1l) -> + | 1l, 1l -> check_block_signature ~block_hash ~block_header @@ -244,7 +244,7 @@ let test_scenario_t3 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = match (level, round) with - | (1l, 2l) -> + | 1l, 2l -> check_block_signature ~block_hash ~block_header @@ -292,7 +292,7 @@ let test_scenario_t3 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = match (level, round) with - | (1l, 0l) -> + | 1l, 0l -> check_block_signature ~block_hash ~block_header @@ -325,7 +325,7 @@ let test_scenario_t3 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (level, round) with - | (1l, 1l) -> + | 1l, 1l -> return (block_hash, block_header, operations, [Block; Pass; Pass; Pass]) | _ -> @@ -407,7 +407,7 @@ let test_scenario_f1 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (!c_proposed_l1_r0, !d_proposed_l1_r1, level, round) with - | (true, true, 2l, 0l) -> + | true, true, 2l, 0l -> check_block_signature ~block_hash ~block_header @@ -425,7 +425,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Block; Block; Block]) + | true, false -> return (op_hash, op, [Pass; Block; Block; Block]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -435,7 +435,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Pass; Block; Block]) + | true, false -> return (op_hash, op, [Pass; Pass; Block; Block]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -446,7 +446,7 @@ let test_scenario_f1 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (!c_proposed_l1_r0, !d_proposed_l1_r1, level, round) with - | (false, false, 1l, 0l) -> + | false, false, 1l, 0l -> check_block_signature ~block_hash ~block_header @@ -464,7 +464,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Block; Pass; Block]) + | true, false -> return (op_hash, op, [Pass; Block; Pass; Block]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -475,7 +475,7 @@ let test_scenario_f1 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (!d_proposed_l1_r1, level, round) with - | (false, 1l, 1l) -> + | false, 1l, 1l -> check_block_signature ~block_hash ~block_header @@ -493,7 +493,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Block; Block; Pass]) + | true, false -> return (op_hash, op, [Pass; Block; Block; Pass]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -553,9 +553,9 @@ let test_scenario_f2 () = ~protocol_data:_ = let propagation_vector = match (level, round) with - | (1l, 0l) -> [Pass; Pass; Pass; Pass] - | (2l, 0l) -> [Pass; Block; Block; Block] - | (2l, 4l) -> + | 1l, 0l -> [Pass; Pass; Pass; Pass] + | 2l, 0l -> [Pass; Block; Block; Block] + | 2l, 4l -> proposal_2_4_observed := true ; [Pass; Pass; Pass; Pass] | _ -> [Block; Block; Block; Block] @@ -814,7 +814,7 @@ let test_scenario_m4 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (level, round) with - | (1l, 0l) -> + | 1l, 0l -> check_block_signature ~block_hash ~block_header @@ -918,7 +918,7 @@ let test_scenario_m5 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (level, round) with - | (1l, 0l) -> + | 1l, 0l -> check_block_signature ~block_hash ~block_header @@ -1006,7 +1006,7 @@ let test_scenario_m6 () = ~protocol_data:_ = let propagation_vector = match (level, round) with - | (2l, 0l) -> [Pass; Block; Block; Block] + | 2l, 0l -> [Pass; Block; Block; Block] | _ -> [Pass; Pass; Pass; Pass] in return (block_hash, block_header, operations, propagation_vector) @@ -1037,8 +1037,8 @@ let test_scenario_m6 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data = (match (level, round) with - | (1l, 1l) -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | (2l, 1l) -> + | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] + | 2l, 1l -> save_proposal_payload ~protocol_data ~var:b_proposal_2_1 >>=? fun () -> return [Pass; Pass; Pass; Pass] | _ -> return [Pass; Pass; Pass; Pass]) @@ -1147,7 +1147,7 @@ let test_scenario_m7 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data = (match (level, round) with - | (2l, 1l) -> save_proposal_payload ~protocol_data ~var:a_proposal_2_1 + | 2l, 1l -> save_proposal_payload ~protocol_data ~var:a_proposal_2_1 | _ -> return_unit) >>=? fun () -> return (block_hash, block_header, operations, [Pass; Pass; Pass; Pass]) @@ -1171,8 +1171,8 @@ let test_scenario_m7 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = (match (level, round) with - | (1l, 1l) -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | (2l, 0l) -> return [Block; Pass; Pass; Pass] + | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] + | 2l, 0l -> return [Block; Pass; Pass; Pass] | _ -> return [Pass; Pass; Pass; Pass]) >>=? fun propagation_vector -> return (block_hash, block_header, operations, propagation_vector) @@ -1187,9 +1187,9 @@ let test_scenario_m7 () = match (is_a10_endorsement, level2_preendorsement, level2_endorsement) with - | (true, _, _) -> [Pass; Block; Block; Block] - | (_, true, _) | (_, _, true) -> [Block; Block; Block; Block] - | (_, _, _) -> [Pass; Pass; Pass; Pass] + | true, _, _ -> [Pass; Block; Block; Block] + | _, true, _ | _, _, true -> [Block; Block; Block; Block] + | _, _, _ -> [Pass; Pass; Pass; Pass] in return (op_hash, op, propagation_vector) @@ -1210,7 +1210,7 @@ let test_scenario_m7 () = let check_chain_after_processing ~level ~round ~chain:_ = match (level, round) with - | (2l, 1l) -> + | 2l, 1l -> c_received_2_1 := true ; return_unit | _ -> return_unit @@ -1228,10 +1228,9 @@ let test_scenario_m7 () = level2_preendorsement, level2_endorsement ) with - | (true, _, _, _) -> [Pass; Block; Block; Block] - | (_, false, true, _) | (_, false, _, true) -> - [Block; Block; Block; Block] - | (_, _, _, _) -> [Pass; Pass; Pass; Pass] + | true, _, _, _ -> [Pass; Block; Block; Block] + | _, false, true, _ | _, false, _, true -> [Block; Block; Block; Block] + | _, _, _, _ -> [Pass; Pass; Pass; Pass] in return (op_hash, op, propagation_vector) @@ -1252,7 +1251,7 @@ let test_scenario_m7 () = let check_chain_after_processing ~level ~round ~chain:_ = match (level, round) with - | (2l, 1l) -> + | 2l, 1l -> d_received_2_1 := true ; return_unit | _ -> return_unit @@ -1270,10 +1269,9 @@ let test_scenario_m7 () = level2_preendorsement, level2_endorsement ) with - | (true, _, _, _) -> [Pass; Block; Block; Block] - | (_, false, true, _) | (_, false, _, true) -> - [Block; Block; Block; Block] - | (_, _, _, _) -> [Pass; Pass; Pass; Pass] + | true, _, _, _ -> [Pass; Block; Block; Block] + | _, false, true, _ | _, false, _, true -> [Block; Block; Block; Block] + | _, _, _, _ -> [Pass; Pass; Pass; Pass] in return (op_hash, op, propagation_vector) @@ -1381,8 +1379,8 @@ let test_scenario_m8 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data = (match (level, round) with - | (1l, 1l) -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | (2l, 0l) -> + | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] + | 2l, 0l -> save_proposal_payload ~protocol_data ~var:b_proposal_2_0 >>=? fun () -> return [Block; Pass; Pass; Pass] | _ -> return [Pass; Pass; Pass; Pass]) @@ -1402,7 +1400,7 @@ let test_scenario_m8 () = ~protocol_data:_ = let propagation_vector = match (level, round) with - | (2l, 1l) -> [Block; Pass; Pass; Pass] + | 2l, 1l -> [Block; Pass; Pass; Pass] | _ -> [Pass; Pass; Pass; Pass] in return (block_hash, block_header, operations, propagation_vector) diff --git a/src/proto_013_PtJakart/lib_plugin/plugin.ml b/src/proto_013_PtJakart/lib_plugin/plugin.ml index 941647e72476..ce2aef149cfb 100644 --- a/src/proto_013_PtJakart/lib_plugin/plugin.ml +++ b/src/proto_013_PtJakart/lib_plugin/plugin.ml @@ -599,7 +599,7 @@ module Mempool = struct (** Returns the weight of an operation, i.e. the fees w.r.t the gas and size consumption in the block. *) let weight_manager_operation ~validation_state ?size ~fee ~gas op = - let (weight, _resources) = + let weight, _resources = weight_and_resources_manager_operation ~validation_state ?size @@ -624,7 +624,7 @@ module Mempool = struct match validation_state with | None -> `Weight_ok (`No_replace, []) | Some validation_state -> ( - let (weight, op_resources) = + let weight, op_resources = weight_and_resources_manager_operation ~validation_state ~fee @@ -915,7 +915,7 @@ module Mempool = struct match (grandparent_level_start, validation_state_before, round_zero_duration) with - | (None, _, _) | (_, None, _) | (_, _, None) -> Lwt.return_true + | None, _, _ | _, None, _ | _, _, None -> Lwt.return_true | ( Some grandparent_level_start, Some validation_state_before, Some round_zero_duration ) -> ( @@ -1892,8 +1892,8 @@ module RPC = struct type a s. (a, s) Script_typed_ir.stack_ty * (a * s) -> Script.expr list tzresult Lwt.t = function - | (Bot_t, (EmptyCell, EmptyCell)) -> return_nil - | (Item_t (ty, rest_ty), (v, rest)) -> + | Bot_t, (EmptyCell, EmptyCell) -> return_nil + | Item_t (ty, rest_ty), (v, rest) -> Script_ir_translator.unparse_data ctxt Unparsing_mode.unparsing_mode @@ -2222,11 +2222,11 @@ module RPC = struct balance >>=? fun bal -> return (ctxt, addr, bal)) >>=? fun (ctxt, self, balance) -> - let (source, payer) = + let source, payer = match (src_opt, pay_opt) with - | (None, None) -> (self, self) - | (Some c, None) | (None, Some c) -> (c, c) - | (Some src, Some pay) -> (src, pay) + | None, None -> (self, self) + | Some c, None | None, Some c -> (c, c) + | Some src, Some pay -> (src, pay) in return (ctxt, {balance; self; source; payer}) in @@ -2427,12 +2427,12 @@ module RPC = struct (View_helpers.make_viewer_script ty) Tez.zero >>=? fun (ctxt, viewer_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (contract, contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (contract, contract) in let gas = Option.value @@ -2547,7 +2547,7 @@ module RPC = struct storage; }) in - let (size, cost) = Script_ir_translator.script_size script in + let size, cost = Script_ir_translator.script_size script in Gas.consume ctxt cost >>?= fun _ctxt -> return @@ size) ; Registration.register0 @@ -2642,7 +2642,7 @@ module RPC = struct ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type >|? fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _) -> - let (unreachable_entrypoint, map) = + let unreachable_entrypoint, map = Script_ir_translator.list_entrypoints_uncarbonated arg_type entrypoints @@ -3203,8 +3203,8 @@ module RPC = struct in let ops = match (sourcePubKey, revealed) with - | (None, _) | (_, Some _) -> ops - | (Some pk, None) -> + | None, _ | _, Some _ -> ops + | Some pk, None -> let operation = Reveal pk in Contents (Manager_operation @@ -3426,8 +3426,8 @@ module RPC = struct let requested_levels ~default_level ctxt cycles levels = match (levels, cycles) with - | ([], []) -> [default_level] - | (levels, cycles) -> + | [], [] -> [default_level] + | levels, cycles -> (* explicitly fail when requested levels or cycle are in the past... or too far in the future... TODO: https://gitlab.com/tezos/tezos/-/issues/2335 diff --git a/src/proto_013_PtJakart/lib_plugin/test/generators.ml b/src/proto_013_PtJakart/lib_plugin/test/generators.ml index 2ca5688e7284..38d6e4e13509 100644 --- a/src/proto_013_PtJakart/lib_plugin/test/generators.ml +++ b/src/proto_013_PtJakart/lib_plugin/test/generators.ml @@ -51,7 +51,7 @@ let dummy_manager_op_info oph = let dummy_manager_op_info_with_key_gen : (Plugin.Mempool.manager_op_info * Signature.public_key_hash) QCheck2.Gen.t = let open QCheck2.Gen in - let+ (oph, (pkh, _, _)) = pair operation_hash_gen public_key_hash_gen in + let+ oph, (pkh, _, _) = pair operation_hash_gen public_key_hash_gen in (dummy_manager_op_info oph, pkh) let filter_state_gen : Plugin.Mempool.state QCheck2.Gen.t = diff --git a/src/proto_013_PtJakart/lib_plugin/test/test_consensus_filter.ml b/src/proto_013_PtJakart/lib_plugin/test/test_consensus_filter.ml index 737afa30f888..06ab92ad884b 100644 --- a/src/proto_013_PtJakart/lib_plugin/test/test_consensus_filter.ml +++ b/src/proto_013_PtJakart/lib_plugin/test/test_consensus_filter.ml @@ -105,7 +105,7 @@ module Generator = struct let print_timestamp = Timestamp.to_notation let near_timestamps = - let+ (i, diff) = pair int32 small_signed_32 in + let+ i, diff = pair int32 small_signed_32 in timestamp_of_int32 i |> fun ts1 -> timestamp_of_int32 Int32.(add i diff) |> fun ts2 -> (ts1, ts2) @@ -122,7 +122,7 @@ module Generator = struct | Error _ -> assert false let successive_timestamp = - let+ (ts, (diff : int)) = pair timestamp small_nat in + let+ ts, (diff : int) = pair timestamp small_nat in let x = Period.of_seconds (Int64.of_int diff) >>? fun diff -> Timestamp.(ts +? diff) >>? fun ts2 -> Ok (ts, ts2) diff --git a/src/proto_013_PtJakart/lib_plugin/test/test_utils.ml b/src/proto_013_PtJakart/lib_plugin/test/test_utils.ml index f8926df66571..cf25d367381e 100644 --- a/src/proto_013_PtJakart/lib_plugin/test/test_utils.ml +++ b/src/proto_013_PtJakart/lib_plugin/test/test_utils.ml @@ -125,9 +125,9 @@ let eq_prechecked_managers = let eq_state s1 s2 = let eq_min_prechecked_op_weight = match (s1.min_prechecked_op_weight, s2.min_prechecked_op_weight) with - | (None, None) -> true - | (Some _, None) | (None, Some _) -> false - | (Some w1, Some w2) -> + | None, None -> true + | Some _, None | None, Some _ -> false + | Some w1, Some w2 -> Operation_hash.equal w1.operation_hash w2.operation_hash && Q.equal w1.weight w2.weight in diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/account.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/account.ml index 47e8e5a2e7ec..76047a436749 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/account.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/account.ml @@ -41,7 +41,7 @@ let random_seed ~rng_state = Char.chr (Random.State.int rng_state 256)) let new_account ?seed () = - let (pkh, pk, sk) = Signature.generate_key ~algo:Ed25519 ?seed () in + let pkh, pk, sk = Signature.generate_key ~algo:Ed25519 ?seed () in let account = {pkh; pk; sk} in Signature.Public_key_hash.Table.add known_accounts pkh account ; account @@ -91,7 +91,7 @@ let generate_accounts ?rng_state ?(initial_balances = []) n : (t * Tez.t) list = in List.map (fun i -> - let (pkh, pk, sk) = + let pkh, pk, sk = Signature.generate_key ~algo:Ed25519 ~seed:(random_seed ~rng_state) () in let account = {pkh; pk; sk} in @@ -105,7 +105,7 @@ let commitment_secret = |> WithExceptions.Option.get ~loc:__LOC__ let new_commitment ?seed () = - let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in + let pkh, pk, sk = Signature.generate_key ?seed ~algo:Ed25519 () in let unactivated_account = {pkh; pk; sk} in let open Commitment in let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/block.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/block.ml index 24af7839db3f..367a5d67281c 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/block.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/block.ml @@ -27,7 +27,6 @@ open Protocol module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *) - open Alpha_context (* This type collects a block and the context that results from its application *) @@ -658,10 +657,10 @@ let bake_with_metadata ?locked_round ?policy ?timestamp ?operation ?operations ?payload_round ~baking_mode ?liquidity_baking_toggle_vote pred = let operations = match (operation, operations) with - | (Some op, Some ops) -> Some (op :: ops) - | (Some op, None) -> Some [op] - | (None, Some ops) -> Some ops - | (None, None) -> None + | Some op, Some ops -> Some (op :: ops) + | Some op, None -> Some [op] + | None, Some ops -> Some ops + | None, None -> None in Forge.forge_header ?payload_round diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/context.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/context.ml index 751bcc049f85..3cefe2b8e492 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/context.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/context.ml @@ -413,8 +413,8 @@ let init1 ?rng_state ?commitments ?(initial_balances = []) ?consensus_threshold ?sc_rollup_enable 1 >|=? function - | (_, []) -> assert false - | (b, contract_1 :: _) -> (b, contract_1) + | _, [] -> assert false + | b, contract_1 :: _ -> (b, contract_1) let init2 ?rng_state ?commitments ?(initial_balances = []) ?consensus_threshold ?min_proposal_quorum ?level ?cost_per_byte ?liquidity_baking_subsidy @@ -442,8 +442,8 @@ let init2 ?rng_state ?commitments ?(initial_balances = []) ?consensus_threshold ?sc_rollup_enable 2 >|=? function - | (_, []) | (_, [_]) -> assert false - | (b, contract_1 :: contract_2 :: _) -> (b, contract_1, contract_2) + | _, [] | _, [_] -> assert false + | b, contract_1 :: contract_2 :: _ -> (b, contract_1, contract_2) let init_with_constants constants n = let accounts = Account.generate_accounts n in diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/contract_helpers.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/contract_helpers.ml index 503b632e6ae7..adfeb7ec2a16 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/contract_helpers.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/contract_helpers.ml @@ -31,7 +31,7 @@ open Error_monad_operators used to bake. *) let init () = Context.init ~consensus_threshold:0 3 >|=? fun (b, contracts) -> - let (src0, src1, src2) = + let src0, src1, src2 = match contracts with | src0 :: src1 :: src2 :: _ -> (src0, src1, src2) | _ -> assert false diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/expr.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/expr.ml index 37074c20b00e..468d09535ae8 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/expr.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/expr.ml @@ -30,7 +30,7 @@ exception Expression_from_string (** Parse a Michelson expression from string, raising an exception on error. *) let from_string ?(check_micheline_indentation = false) str : Script.expr = - let (ast, errs) = + let ast, errs = Michelson_v1_parser.parse_expression ~check:check_micheline_indentation str in (match errs with @@ -42,7 +42,7 @@ let from_string ?(check_micheline_indentation = false) str : Script.expr = (** Parses a Michelson contract from string, raising an exception on error. *) let toplevel_from_string ?(check_micheline_indentation = false) str = - let (ast, errs) = + let ast, errs = Michelson_v1_parser.parse_toplevel ~check:check_micheline_indentation str in match errs with [] -> ast.expanded | _ -> Stdlib.failwith "parse toplevel" diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/incremental.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/incremental.ml index 179bc2d1d055..bf6e8a61c6b8 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/incremental.ml @@ -25,7 +25,6 @@ open Protocol module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *) - open Alpha_context type t = { @@ -161,12 +160,12 @@ let add_operation ?expect_apply_failure ?expect_failure st op = let open Apply_results in apply_operation st.state op >|= Environment.wrap_tzresult >>= fun result -> match (expect_apply_failure, result) with - | (Some _, Ok _) -> failwith "Error expected while adding operation" - | (Some f, Error err) -> f err >|=? fun () -> st - | (None, result) -> ( + | Some _, Ok _ -> failwith "Error expected while adding operation" + | Some f, Error err -> f err >|=? fun () -> st + | None, result -> ( result >>?= fun result -> match result with - | (state, (Operation_metadata result as metadata)) -> + | state, (Operation_metadata result as metadata) -> detect_script_failure result |> fun result -> (match expect_failure with | None -> Lwt.return result @@ -181,7 +180,7 @@ let add_operation ?expect_apply_failure ?expect_failure st op = rev_operations = op :: st.rev_operations; rev_tickets = metadata :: st.rev_tickets; } - | (state, (No_operation_metadata as metadata)) -> + | state, (No_operation_metadata as metadata) -> return { st with diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/liquidity_baking_generator.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/liquidity_baking_generator.ml index 878d6f4aaa82..6df79e0a3707 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/liquidity_baking_generator.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/liquidity_baking_generator.ml @@ -275,7 +275,7 @@ let gen_scenario : tzbtc -> liquidity -> int -> (specs * contract_id step list) QCheck.Gen.t = fun total_tzbtc total_liquidity size -> let* specs = gen_specs total_tzbtc total_liquidity in - let (state, env) = SymbolicMachine.build specs in + let state, env = SymbolicMachine.build specs in let+ scenario = gen_steps env state size in (specs, scenario) @@ -312,7 +312,7 @@ let gen_adversary_scenario : (specs * contract_id * contract_id step list) QCheck.Gen.t = fun total_tzbtc total_liquidity size -> let* specs = gen_specs total_tzbtc total_liquidity in - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let* c = oneofl env.implicit_accounts in let+ scenario = gen_steps ~source:c ~destination:c env state size in (specs, c, scenario) @@ -341,7 +341,7 @@ let arb_adversary_scenario : We shrink a valid scenario by removing steps from its tails, because a prefix of a valid scenario remains a valid scenario. Removing a random element of a scenario could lead to an - invalid scenario. *) + invalid scenario. *) (* Note (2) diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/liquidity_baking_machine.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/liquidity_baking_machine.ml index 4f92171cc5d8..cb7b3fca29a6 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/liquidity_baking_machine.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/liquidity_baking_machine.ml @@ -126,7 +126,7 @@ let is_implicit_exn account = module List_helpers = struct let rec zip l r = match (l, r) with - | (xl :: rstl, xr :: rstr) -> (xl, xr) :: zip rstl rstr + | xl :: rstl, xr :: rstr -> (xl, xr) :: zip rstl rstr | _ -> [] let nth_exn l n = @@ -480,7 +480,7 @@ module Machine = struct get_cpmm_total_liquidity env state >>= fun lqtTotal -> let lqtTotal = Z.of_int lqtTotal in let amount = Tez.of_mutez_exn xtz_deposit in - let (_, tokens_deposited) = + let _, tokens_deposited = Cpmm_logic.Simulate_raw.addLiquidity ~tokenPool ~xtzPool @@ -858,7 +858,7 @@ module ConcreteBaseMachine : let init ~invariant ?subsidy accounts_balances = let liquidity_baking_subsidy = Option.map Tez.of_mutez_exn subsidy in - let (n, initial_balances) = initial_xtz_repartition accounts_balances in + let n, initial_balances = initial_xtz_repartition accounts_balances in Context.init n ~consensus_threshold:0 @@ -872,7 +872,7 @@ module ConcreteBaseMachine : ~cycles_per_voting_period:1l ?liquidity_baking_subsidy >>= function - | (blk, holder :: accounts) -> + | blk, holder :: accounts -> let ctxt = Context.B blk in Context.get_liquidity_baking_cpmm_address ctxt >>= fun cpmm_contract -> Context.Contract.storage ctxt cpmm_contract >>= fun storage -> @@ -1058,13 +1058,13 @@ module AbstractMachine = struct Z.of_int @@ get_tzbtc_balance env.cpmm_contract env state in let tokensSold = Z.of_int tzbtc in - let (xtz_bought, xtz_net_bought) = + let xtz_bought, xtz_net_bought = Cpmm_logic.Simulate_raw.tokenToXtz ~xtzPool ~tokenPool ~tokensSold in (Z.to_int64 xtz_net_bought, Tez.to_mutez xtz_bought) let token_to_xtz ~src dst amount env _ state = - let (xtz_bought, xtz_net_bought) = xtz_bought amount env state in + let xtz_bought, xtz_net_bought = xtz_bought amount env state in state |> transfer_tzbtc_balance src env.cpmm_contract amount |> update_xtz_balance env.cpmm_contract (fun b -> Int64.sub b xtz_bought) @@ -1078,13 +1078,13 @@ module AbstractMachine = struct Z.of_int @@ get_tzbtc_balance env.cpmm_contract env state in let amount = Tez.of_mutez_exn amount in - let (tzbtc_bought, xtz_earnt) = + let tzbtc_bought, xtz_earnt = Cpmm_logic.Simulate_raw.xtzToToken ~xtzPool ~tokenPool ~amount in (Z.to_int tzbtc_bought, Z.to_int64 xtz_earnt) let xtz_to_token ~src dst amount env _ state = - let (tzbtc_bought, xtz_earnt) = tzbtc_bought env state amount in + let tzbtc_bought, xtz_earnt = tzbtc_bought env state amount in update_xtz_balance src (fun b -> Int64.sub b amount) state |> update_xtz_balance env.cpmm_contract (Int64.add xtz_earnt) |> transfer_tzbtc_balance env.cpmm_contract dst tzbtc_bought @@ -1103,7 +1103,7 @@ module AbstractMachine = struct in let lqtTotal = Z.of_int state.cpmm_total_liquidity in let amount = Tez.of_mutez_exn xtz_deposit in - let (lqt_minted, tokens_deposited) = + let lqt_minted, tokens_deposited = Cpmm_logic.Simulate_raw.addLiquidity ~tokenPool ~xtzPool @@ -1131,7 +1131,7 @@ module AbstractMachine = struct in let lqtTotal = Z.of_int state.cpmm_total_liquidity in let lqtBurned = Z.of_int lqt_burned in - let (xtz_withdrawn, tokens_withdrawn) = + let xtz_withdrawn, tokens_withdrawn = Cpmm_logic.Simulate_raw.removeLiquidity ~tokenPool ~xtzPool @@ -1184,7 +1184,7 @@ module SymbolicBaseMachine : end) let init ~invariant:_ ?(subsidy = default_subsidy) accounts_balances = - let (_, initial_balances) = initial_xtz_repartition accounts_balances in + let _, initial_balances = initial_xtz_repartition accounts_balances in let len = Int64.of_int (List.length accounts_balances) in match initial_balances with | holder_xtz :: accounts -> @@ -1196,15 +1196,12 @@ module SymbolicBaseMachine : cpmm_total_liquidity = cpmm_initial_liquidity_supply; accounts_balances = (Cpmm, {cpmm_initial_balance with xtz = xtz_cpmm}) - :: - (Holder, {xtz = holder_xtz; tzbtc = 0; liquidity = 0}) - :: - (TzBTCAdmin, {xtz = 0L; tzbtc = 0; liquidity = 0}) - :: - List.mapi - (fun i xtz -> - (ImplicitAccount i, {xtz; tzbtc = 0; liquidity = 0})) - accounts; + :: (Holder, {xtz = holder_xtz; tzbtc = 0; liquidity = 0}) + :: (TzBTCAdmin, {xtz = 0L; tzbtc = 0; liquidity = 0}) + :: List.mapi + (fun i xtz -> + (ImplicitAccount i, {xtz; tzbtc = 0; liquidity = 0})) + accounts; }, { cpmm_contract = Cpmm; @@ -1328,7 +1325,7 @@ module ValidationBaseMachine : ?subsidy balances >>= fun (blk, env) -> - let (state, _) = + let state, _ = SymbolicBaseMachine.init ~invariant:(fun _ _ -> true) ?subsidy balances in let state = refine_state env state in diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/lqt_fa12_repr.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/lqt_fa12_repr.ml index 8cdfa341d05c..bc429656282c 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/lqt_fa12_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/lqt_fa12_repr.ml @@ -221,11 +221,11 @@ module Storage = struct >>=? fun (address_hash, ctxt) -> Big_map.get_opt ctxt tokens address_hash >|= Environment.wrap_tzresult >>=? function - | (_, Some canonical) -> ( + | _, Some canonical -> ( match Tezos_micheline.Micheline.root canonical with | Tezos_micheline.Micheline.Int (_, amount) -> return @@ Some amount | _ -> assert false) - | (_, None) -> return @@ None + | _, None -> return @@ None let getBalance (ctxt : Context.t) ~(contract : Contract.t) (owner : Script_typed_ir.address) = diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/op.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/op.ml index 4e3368c7d3ce..a83f817f8edb 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/op.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/op.ml @@ -185,7 +185,7 @@ let combine_operations ?public_key ?counter ?spurious_operation ~source ctxt | true -> (None, counter)) >>=? fun (manager_op, counter) -> (* Update counters and transform into a contents_list *) - let (counter, rev_operations) = + let counter, rev_operations = List.fold_left (fun (counter, acc) -> function | Contents (Manager_operation m) -> diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/sapling_helpers.ml index b08dc98a604e..d3618c979b39 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/sapling_helpers.ml @@ -85,7 +85,7 @@ module Common = struct let rec aux n index res = if Compare.Int.( <= ) n 0 then res else - let (new_index, new_addr) = + let new_index, new_addr = Tezos_sapling.Core.Client.Viewing_key.new_address vk index in aux (n - 1) new_index (new_addr :: res) @@ -316,7 +316,7 @@ module Alpha_context_helpers = struct let transfer w cs is = let anti_replay = "anti-replay" in - let (ins, outs) = transfer_inputs_outputs w cs is in + let ins, outs = transfer_inputs_outputs w cs is in (* change the wallet of this last line *) Tezos_sapling.Forge.forge_transaction ins @@ -328,7 +328,7 @@ module Alpha_context_helpers = struct let transfer_legacy w cs is = let anti_replay = "anti-replay" in - let (ins, outs) = transfer_inputs_outputs w cs is in + let ins, outs = transfer_inputs_outputs w cs is in (* change the wallet of this last line *) Tezos_sapling.Forge.forge_transaction_legacy ins outs w.sk anti_replay cs @@ -422,7 +422,7 @@ module Interpreter_helpers = struct let rec aux number_transac number_outputs index amount_output total res = if Compare.Int.(number_transac <= 0) then (res, total) else - let (new_index, new_addr) = + let new_index, new_addr = Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk index) in let outputs = diff --git a/src/proto_013_PtJakart/lib_protocol/test/helpers/test_global_constants.ml b/src/proto_013_PtJakart/lib_protocol/test/helpers/test_global_constants.ml index f87c824ccb84..cb704d6e0e0f 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/helpers/test_global_constants.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/helpers/test_global_constants.ml @@ -261,9 +261,9 @@ module Generators = struct | [] -> ([], None) | hd :: tl -> ( match replace_with_constant hd loc with - | (node, Some x) -> (node :: tl, Some x) - | (_, None) -> - let (l, x) = loop tl in + | node, Some x -> (node :: tl, Some x) + | _, None -> + let l, x = loop tl in (hd :: l, x)) in match node with @@ -283,7 +283,7 @@ module Generators = struct in (Prim (-1, H_constant, [String (-1, hash)], []), Some node) else - let (result, x) = loop args in + let result, x = loop args in (Prim (l, prim, result, annot), x) | Seq (l, args) as node -> if l = loc then @@ -293,7 +293,7 @@ module Generators = struct in (Prim (-1, H_constant, [String (-1, hash)], []), Some node) else - let (result, x) = loop args in + let result, x = loop args in (Seq (l, result), x) let micheline_gen p_gen annot_gen = @@ -318,8 +318,8 @@ module Generators = struct let size = Script_repr.micheline_nodes (root expr) in 0 -- (size - 1) >|= fun loc -> match replace_with_constant (root expr) loc with - | (_, None) -> assert false - | (node, Some replaced_node) -> + | _, None -> assert false + | node, Some replaced_node -> (expr, strip_locations node, strip_locations replaced_node) let canonical_with_constant_arbitrary () = diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_baking.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_baking.ml index b978a4a24e82..c51e25e61f95 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_baking.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_baking.ml @@ -263,7 +263,7 @@ let test_rewards_block_and_payload_producer () = ~payload_round:(Some Round.zero) ~locked_round:(Some Round.zero) ~policy:(By_account baker_b2') - ~operations:(tx :: preendos @ endos) + ~operations:((tx :: preendos) @ endos) b1 >>=? fun b2' -> (* [baker_b2], as payload producer, gets the block reward and the fees *) @@ -314,7 +314,7 @@ let test_enough_active_stake_to_bake ~has_active_stake () = let initial_bal1 = if has_active_stake then tpr else Int64.sub tpr 1L in Context.init ~initial_balances:[initial_bal1; tpr] ~consensus_threshold:0 2 >>=? fun (b0, accounts) -> - let (account1, _account2) = + let account1, _account2 = match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false in Context.Contract.pkh account1 >>=? fun pkh1 -> @@ -340,7 +340,7 @@ let test_enough_active_stake_to_bake ~has_active_stake () = let test_committee_sampling () = let test_distribution max_round distribution = - let (initial_balances, bounds) = List.split distribution in + let initial_balances, bounds = List.split distribution in let accounts = Account.generate_accounts ~initial_balances (List.length initial_balances) in @@ -378,7 +378,7 @@ let test_committee_sampling () = bounds ; List.iter (fun {Plugin.RPC.Baking_rights.delegate = pkh; _} -> - let (bounds, n) = Stdlib.Hashtbl.find stats pkh in + let bounds, n = Stdlib.Hashtbl.find stats pkh in Stdlib.Hashtbl.replace stats pkh (bounds, n + 1)) bakers ; let one_failed = ref false in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_deactivation.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_deactivation.ml index 7c5218e60587..d21932b2fcec 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_deactivation.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_deactivation.ml @@ -88,7 +88,7 @@ let check_no_stake ~loc (b : Block.t) (account : Account.t) = (check_stake). *) let test_simple_staking_rights () = Context.init 2 >>=? fun (b, accounts) -> - let (a1, _a2) = account_pair accounts in + let a1, _a2 = account_pair accounts in Context.Contract.balance (B b) a1 >>=? fun balance -> Context.Contract.pkh a1 >>=? fun delegate1 -> Context.Delegate.current_frozen_deposits (B b) delegate1 @@ -111,7 +111,7 @@ let test_simple_staking_rights () = rights. *) let test_simple_staking_rights_after_baking () = Context.init ~consensus_threshold:0 2 >>=? fun (b, accounts) -> - let (a1, a2) = account_pair accounts in + let a1, a2 = account_pair accounts in Context.Contract.manager (B b) a1 >>=? fun m1 -> Context.Contract.manager (B b) a2 >>=? fun m2 -> Block.bake_n ~policy:(By_account m2.pkh) 5 b >>=? fun b -> @@ -131,7 +131,7 @@ let check_active_staking_balance ~loc ~deactivated b (m : Account.t) = let run_until_deactivation () = Context.init ~consensus_threshold:0 2 >>=? fun (b, accounts) -> - let (a1, a2) = account_pair accounts in + let a1, a2 = account_pair accounts in Context.Contract.balance (B b) a1 >>=? fun balance_start -> Context.Contract.manager (B b) a1 >>=? fun m1 -> Context.Contract.manager (B b) a2 >>=? fun m2 -> @@ -298,7 +298,7 @@ let test_deactivation_then_empty_then_self_delegation_then_recredit () = first and third accounts. *) let test_delegation () = Context.init ~consensus_threshold:0 2 >>=? fun (b, accounts) -> - let (a1, a2) = account_pair accounts in + let a1, a2 = account_pair accounts in let m3 = Account.new_account () in Account.add_account m3 ; Context.Contract.manager (B b) a1 >>=? fun m1 -> diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_delegation.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_delegation.ml index 2c65f914acbd..95b12d6d0452 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_delegation.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_delegation.ml @@ -1392,15 +1392,15 @@ let tests_delegate_registration = ~amount:Tez.one_mutez ~fee:max_tez); Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (switch with \ - delegation, small fee)" + "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, \ + small fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit_debit ~amount:Tez.one_mutez ~fee:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (switch with \ - delegation, large fee)" + "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, \ + large fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit_debit ~amount:Tez.one_mutez @@ -1425,29 +1425,27 @@ let tests_delegate_registration = ~fee:(of_int 10_000_000) ~amount:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (init with delegation, small \ - fee)" + "unregistered delegate key - credit 1μꜩ (init with delegation, small fee)" `Quick (test_unregistered_delegate_key_init_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (init with delegation, large \ - fee)" + "unregistered delegate key - credit 1μꜩ (init with delegation, large fee)" `Quick (test_unregistered_delegate_key_init_delegation_credit ~amount:Tez.one_mutez ~fee:max_tez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (switch with delegation, \ - small fee)" + "unregistered delegate key - credit 1μꜩ (switch with delegation, small \ + fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (switch with delegation, \ - large fee)" + "unregistered delegate key - credit 1μꜩ (switch with delegation, large \ + fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit ~amount:Tez.one_mutez @@ -1496,8 +1494,8 @@ let tests_delegate_registration = (test_failed_self_delegation_emptied_implicit_contract Tez.one_mutez); (* credit 1μtz, delegate, debit 1μtz *) Tztest.tztest - "empty delegated contract is not deleted: credit 1μꜩ, delegate & \ - debit 1μꜩ" + "empty delegated contract is not deleted: credit 1μꜩ, delegate & debit \ + 1μꜩ" `Quick (test_emptying_delegated_implicit_contract_fails Tez.one_mutez); (*** valid registration ***) @@ -1508,20 +1506,20 @@ let tests_delegate_registration = `Quick (test_valid_delegate_registration_init_delegation_credit Tez.one_mutez); Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation (switch \ - with delegation)" + "valid delegate registration: credit 1μꜩ, self delegation (switch with \ + delegation)" `Quick (test_valid_delegate_registration_switch_delegation_credit Tez.one_mutez); (* valid registration: credit 1 μꜩ, self delegation, debit 1μꜩ *) Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation, debit \ - 1μꜩ (init with delegation)" + "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ \ + (init with delegation)" `Quick (test_valid_delegate_registration_init_delegation_credit_debit Tez.one_mutez); Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation, debit \ - 1μꜩ (switch with delegation)" + "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ \ + (switch with delegation)" `Quick (test_valid_delegate_registration_switch_delegation_credit_debit Tez.one_mutez); diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_baking.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_baking.ml index 76ea9a0efb4d..6612b6704154 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_baking.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_baking.ml @@ -44,7 +44,7 @@ open Alpha_context (** Bake two block at the same level using the same policy (i.e. same baker). *) let block_fork ?policy contracts b = - let (contract_a, contract_b) = + let contract_a, contract_b = match contracts with x :: y :: _ -> (x, y) | _ -> assert false in Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent @@ -61,7 +61,7 @@ let order_block_hashes ~correct_order bh1 bh2 = else (bh1, bh2) let double_baking ctxt ?(correct_order = true) bh1 bh2 = - let (bh1, bh2) = order_block_hashes ~correct_order bh1 bh2 in + let bh1, bh2 = order_block_hashes ~correct_order bh1 bh2 in Op.double_baking ctxt bh1 bh2 (****************************************************************) @@ -107,7 +107,7 @@ let order_endorsements ~correct_order op1 op2 = [test_valid_double_baking_followed_by_double_endorsing] and [test_valid_double_endorsing_followed_by_double_baking] *) let double_endorsement ctxt ?(correct_order = true) op1 op2 = - let (e1, e2) = order_endorsements ~correct_order op1 op2 in + let e1, e2 = order_endorsements ~correct_order op1 op2 in Op.double_endorsement ctxt e1 e2 let test_valid_double_baking_followed_by_double_endorsing () = diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_endorsement.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_endorsement.ml index f4c22ef47f08..43de525174e6 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_endorsement.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_endorsement.ml @@ -50,7 +50,7 @@ let block_fork b = (****************************************************************) let get_first_2_accounts_contracts contracts = - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = match contracts with | [a1; a2] -> ( ( a1, @@ -74,7 +74,7 @@ let order_endorsements ~correct_order op1 op2 = else (op1, op2) let double_endorsement ctxt ?(correct_order = true) op1 op2 = - let (e1, e2) = order_endorsements ~correct_order op1 op2 in + let e1, e2 = order_endorsements ~correct_order op1 op2 in Op.double_endorsement ctxt e1 e2 (** This test verifies that when a "cheater" double endorses and @@ -252,7 +252,7 @@ let test_different_delegates () = Context.get_endorser (B blk_a) >>=? fun (endorser_a, a_slots) -> Context.get_first_different_endorsers (B blk_b) >>=? fun (endorser_b1c, endorser_b2c) -> - let (endorser_b, b_slots) = + let endorser_b, b_slots = if Signature.Public_key_hash.( = ) endorser_a endorser_b1c.delegate then (endorser_b2c.delegate, endorser_b2c.slots) else (endorser_b1c.delegate, endorser_b1c.slots) @@ -290,7 +290,7 @@ let test_wrong_delegate () = >>=? fun endorsement_a -> Context.get_endorser_n (B blk_b) 0 >>=? fun (endorser0, slots0) -> Context.get_endorser_n (B blk_b) 1 >>=? fun (endorser1, slots1) -> - let (endorser_b, b_slots) = + let endorser_b, b_slots = if Signature.Public_key_hash.equal endorser_a endorser0 then (endorser1, slots1) else (endorser0, slots0) @@ -363,7 +363,7 @@ let test_freeze_more_with_low_balance = } in Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((_contract1, account1), (_contract2, account2)) = + let (_contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in (* we empty the available balance of [account1]. *) diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_preendorsement.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_preendorsement.ml index 047a1b79dc74..1dae1b048590 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_preendorsement.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_double_preendorsement.ml @@ -146,7 +146,7 @@ end = struct situation. In case baker <> endorser, bal_bad of the baker gets half of burnt deposit of d1, so it's higher *) - let (high, low) = + let high, low = if Signature.Public_key_hash.equal baker d1 then (bal_good, bal_bad) else (bal_bad, bal_good) in @@ -188,7 +188,7 @@ end = struct >>=? fun op1 -> Op.preendorsement ~delegate:d2 ~endorsed_block:head_B (B blk) () >>=? fun op2 -> - let (op1, op2) = order_preendorsements ~correct_order:true op1 op2 in + let op1, op2 = order_preendorsements ~correct_order:true op1 op2 in (* bake `nb_blocks_before_denunciation` before double preend. denunciation *) bake_n nb_blocks_before_denunciation blk >>=? fun blk -> let op : Operation.packed = Op.double_preendorsement (B blk) op1 op2 in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_frozen_deposits.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_frozen_deposits.ml index 1b15f0387965..75f786db6234 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_frozen_deposits.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_frozen_deposits.ml @@ -47,7 +47,7 @@ let constants = } let get_first_2_accounts_contracts contracts = - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = match contracts with | [a1; a2] -> ( ( a1, @@ -64,24 +64,24 @@ let get_first_2_accounts_contracts contracts = (* Terminology: -- staking balance = full balance + delegated stake; obtained with - Delegate.staking_balance + - staking balance = full balance + delegated stake; obtained with + Delegate.staking_balance -- active stake = the amount of tez with which a delegate participates in - consensus; it must be greater than 1 roll and less or equal the staking - balance; it is computed in [Delegate_storage.select_distribution_for_cycle] + - active stake = the amount of tez with which a delegate participates in + consensus; it must be greater than 1 roll and less or equal the staking + balance; it is computed in [Delegate_storage.select_distribution_for_cycle] -- frozen deposits = represents frozen_deposits_percentage of the maximum stake during - preserved_cycles + max_slashing_period cycles; obtained with - Delegate.current_frozen_deposits + - frozen deposits = represents frozen_deposits_percentage of the maximum stake during + preserved_cycles + max_slashing_period cycles; obtained with + Delegate.current_frozen_deposits -- spendable balance = full balance - frozen deposits; obtained with Contract.balance + - spendable balance = full balance - frozen deposits; obtained with Contract.balance -- full balance = spendable balance + frozen deposits; obtained with Delegate.full_balance + - full balance = spendable balance + frozen deposits; obtained with Delegate.full_balance *) let test_invariants () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, _account2)) = + let (contract1, account1), (contract2, _account2) = get_first_2_accounts_contracts contracts in Context.Delegate.staking_balance (B genesis) account1 @@ -142,7 +142,7 @@ let test_invariants () = let test_set_limit balance_percentage () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in (Context.Delegate.frozen_deposits_limit (B genesis) account1 >>=? function @@ -200,7 +200,7 @@ let test_set_limit balance_percentage () = let test_set_too_high_limit () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, _account1), _) = get_first_2_accounts_contracts contracts in + let (contract1, _account1), _ = get_first_2_accounts_contracts contracts in let max_limit = Tez.of_mutez_exn Int64.( @@ -229,7 +229,7 @@ let test_set_too_high_limit () = let test_unset_limit () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.current_frozen_deposits (B genesis) account1 @@ -276,7 +276,7 @@ let test_unset_limit () = let test_cannot_bake_with_zero_deposits () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in (* N.B. there is no non-zero frozen deposits value for which one cannot bake: @@ -309,7 +309,7 @@ let test_cannot_bake_with_zero_deposits () = let test_deposits_after_stake_removal () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.current_frozen_deposits (B genesis) account1 @@ -377,7 +377,7 @@ let test_deposits_after_stake_removal () = let test_unfreeze_deposits_after_deactivation () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.full_balance (B genesis) account1 >>=? fun initial_balance -> @@ -423,7 +423,7 @@ let test_unfreeze_deposits_after_deactivation () = let test_frozen_deposits_with_delegation () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((_contract1, account1), (contract2, account2)) = + let (_contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.staking_balance (B genesis) account1 @@ -483,7 +483,7 @@ let test_frozen_deposits_with_delegation () = let test_frozen_deposits_with_overdelegation () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in (* - [account1] and [account2] give their spendable balance to [new_account] @@ -562,7 +562,7 @@ let test_frozen_deposits_with_overdelegation () = let test_set_limit_with_overdelegation () = let constants = {constants with frozen_deposits_percentage = 10} in Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in (* - [account1] and [account2] will give 80% of their balance to @@ -630,7 +630,7 @@ let test_set_limit_with_overdelegation () = [new_cycle + preserved_cycles]. *) let test_error_is_thrown_when_smaller_upper_bound_for_frozen_window () = Context.init_with_constants constants 2 >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, _account2)) = + let (contract1, account1), (contract2, _account2) = match contracts with | [a1; a2] -> ( ( a1, diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_participation.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_participation.ml index 64c36f2b1f67..5f47f58d6785 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_participation.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_participation.ml @@ -78,7 +78,7 @@ let test_participation ~sufficient_participation () = let minimal_nb_active_slots = mpr.numerator * expected_nb_slots / mpr.denominator in - let (account1, account2) = + let account1, account2 = match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false in Context.Contract.pkh account1 >>=? fun del1 -> @@ -94,7 +94,7 @@ let test_participation ~sufficient_participation () = Environment.wrap_tzresult (Raw_level.of_int32 int_level) >>?= fun level -> Context.get_endorsing_power_for_delegate (B b_crt) ~levels:[level] del1 >>=? fun endorsing_power_for_level -> - let (endorser, new_endorsing_power) = + let endorser, new_endorsing_power = if sufficient_participation && endorsing_power < minimal_nb_active_slots then (del2, endorsing_power + endorsing_power_for_level) else (del1, endorsing_power) @@ -126,7 +126,7 @@ let test_participation ~sufficient_participation () = let test_participation_rpc () = let n_accounts = 2 in Context.init ~consensus_threshold:1 n_accounts >>=? fun (b0, accounts) -> - let (account1, account2) = + let account1, account2 = match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false in Context.Contract.pkh account1 >>=? fun del1 -> diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml index 0478885ecae9..48a11b28fbd7 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml @@ -82,11 +82,11 @@ end = struct b1 >>= fun res -> match (res, post_process) with - | (Ok ok, Ok success_fun) -> success_fun ok - | (Error _, Error (error_title, _error_category)) -> + | Ok ok, Ok success_fun -> success_fun ok + | Error _, Error (error_title, _error_category) -> Assert.proto_error_with_info ~loc res error_title - | (Ok _, Error _) -> Assert.error ~loc res (fun _ -> false) - | (Error _, Ok _) -> Assert.error ~loc res (fun _ -> false) + | Ok _, Error _ -> Assert.error ~loc res (fun _ -> false) + | Error _, Ok _ -> Assert.error ~loc res (fun _ -> false) (****************************************************************) (* Tests *) diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_seed.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_seed.ml index 90ce2028dd0a..e382a89c473e 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_seed.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/consensus/test_seed.ml @@ -104,7 +104,7 @@ let test_revelation_early_wrong_right_twice () = Block.bake_until_cycle_end ~policy b >>=? fun b -> (* test that revealing at the right time but the wrong value produces an error *) - let (wrong_hash, _) = Nonce.generate () in + let wrong_hash, _ = Nonce.generate () in Op.seed_nonce_revelation (B b) level_commitment @@ -189,12 +189,12 @@ let test_unrevealed () = } in Context.init_with_constants constants 2 >>=? fun (b, accounts) -> - let (account1, account2) = + let account1, account2 = match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false in - let (_delegate1, delegate2) = + let _delegate1, delegate2 = match (Contract.is_implicit account1, Contract.is_implicit account2) with - | (Some d, Some d') -> (d, d') + | Some d, Some d' -> (d, d') | _ -> assert false in (* Delegate 2 will add a nonce but never reveals it *) diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/gas/test_gas_levels.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/gas/test_gas_levels.ml index e61e2e6db1b1..a1bb37283764 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/gas/test_gas_levels.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/gas/test_gas_levels.ml @@ -220,10 +220,10 @@ let apply_with_gas header ?(operations = []) (pred : Block.t) = let bake_with_gas ?policy ?timestamp ?operation ?operations pred = let operations = match (operation, operations) with - | (Some op, Some ops) -> Some (op :: ops) - | (Some op, None) -> Some [op] - | (None, Some ops) -> Some ops - | (None, None) -> None + | Some op, Some ops -> Some (op :: ops) + | Some op, None -> Some [op] + | None, Some ops -> Some ops + | None, None -> None in Block.Forge.forge_header ?timestamp ?policy ?operations pred >>=? fun header -> @@ -300,7 +300,7 @@ let block_with_one_origination contract = let full_block () = init_block [nil_contract; fail_contract; loop_contract] >>=? fun (block, src, originated) -> - let (dst_nil, dst_fail, dst_loop) = + let dst_nil, dst_fail, dst_loop = match originated with [c1; c2; c3] -> (c1, c2, c3) | _ -> assert false in return (block, src, dst_nil, dst_fail, dst_loop) @@ -393,10 +393,9 @@ let test_malformed_block_max_limit_reached () = *) let lld = [(dst, Alpha_context.Gas.Arith.integral_of_int_exn 1)] - :: - List.map - (fun _ -> [(dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)]) - [1; 1; 1; 1; 1] + :: List.map + (fun _ -> [(dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)]) + [1; 1; 1; 1; 1] in bake_operations_with_gas ~counter:Z.one block src lld >>= function | Error _ -> return_unit @@ -417,10 +416,9 @@ let test_malformed_block_max_limit_reached' () = let lld = [ (dst, Alpha_context.Gas.Arith.integral_of_int_exn 1) - :: - List.map - (fun _ -> (dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)) - [1; 1; 1; 1; 1]; + :: List.map + (fun _ -> (dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)) + [1; 1; 1; 1; 1]; ] in bake_operations_with_gas ~counter:Z.one block src lld >>= function diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_block_time_instructions.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_block_time_instructions.ml index ac8de4e6e97b..cfebfa1afff4 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_block_time_instructions.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_block_time_instructions.ml @@ -37,14 +37,14 @@ open Alpha_context let context_with_constants constants = let open Lwt_result_syntax in - let* (block, _contracts) = Context.init_with_constants constants 1 in + let* block, _contracts = Context.init_with_constants constants 1 in let+ incremental = Incremental.begin_construction block in Incremental.alpha_ctxt incremental let test_min_block_time () = let open Lwt_result_syntax in let* context = context_with_constants Default_parameters.constants_mainnet in - let* (result, _) = + let* result, _ = Contract_helpers.run_script context ~storage:"0" diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_global_constants_storage.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_global_constants_storage.ml index dd34a69fa667..d20e3dfccc28 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_global_constants_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_global_constants_storage.ml @@ -42,8 +42,8 @@ let get_next_context b = let register_two_contracts ?consensus_threshold () = Context.init ?consensus_threshold 2 >|=? function - | (_, []) | (_, [_]) -> assert false - | (b, contract_1 :: contract_2 :: _) -> (b, contract_1, contract_2) + | _, [] | _, [_] -> assert false + | b, contract_1 :: contract_2 :: _ -> (b, contract_1, contract_2) let assert_proto_error_id loc id result = let test err = diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml index cd55c3228f92..03a84159c6b2 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml @@ -81,12 +81,11 @@ let gen_diffs idx : list = let open Lazy_storage_diff in Remove - :: - (gen_inits idx - |> List.map (fun (init, updates_lens) -> - gen_updates_list updates_lens - |> List.map (fun updates -> Update {init; updates})) - |> List.flatten) + :: (gen_inits idx + |> List.map (fun (init, updates_lens) -> + gen_updates_list updates_lens + |> List.map (fun updates -> Update {init; updates})) + |> List.flatten) let gen_diffs_items idx : Lazy_storage_diff.diffs_item list = let id = ids.(idx) in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_patched_contracts.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_patched_contracts.ml index b952cb4e9b47..6b3cc3a05742 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_patched_contracts.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_patched_contracts.ml @@ -162,7 +162,7 @@ module Legacy_patch_test (Patches : LEGACY_SCRIPT_PATCHES) : (* Number 3 below controls how many accounts should be created. This number shouldn't be too small or the context won't have enough tokens to form a roll. *) - let* (block, _) = Context.init 3 in + let* block, _ = Context.init 3 in let* inc = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt inc in let* _ = diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_sapling.ml index f36e57486ee3..f22fb8c0f059 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_sapling.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_sapling.ml @@ -607,7 +607,7 @@ module Interpreter_tests = struct originate_contract "contracts/sapling_contract.tz" "{ }" src0 genesis baker >>=? fun (dst, b1, anti_replay) -> let wa = wallet_gen () in - let (list_transac, total) = + let list_transac, total = shield ~memo_size wa.sk 4 wa.vk (Format.sprintf "0x%s") anti_replay in let parameters = parameters_of_list list_transac in @@ -615,7 +615,7 @@ module Interpreter_tests = struct transac_and_sync ~memo_size b1 parameters total src0 dst baker >>=? fun (b2, _state) -> (* we shield again on another block, forging with the empty state *) - let (list_transac, total) = + let list_transac, total = shield ~memo_size wa.sk 4 wa.vk (Format.sprintf "0x%s") anti_replay in let parameters = parameters_of_list list_transac in @@ -810,7 +810,7 @@ module Interpreter_tests = struct it as a parameter *) let wa = wallet_gen () in - let (transactions, _total) = + let transactions, _total = shield ~memo_size wa.sk @@ -990,7 +990,7 @@ module Interpreter_tests = struct originate_contract "contracts/sapling_contract_drop.tz" "Unit" src b baker >>=? fun (dst, b, anti_replay) -> let {sk; vk} = wallet_gen () in - let (list_transac, _total) = + let list_transac, _total = shield ~memo_size:8 sk 4 vk (Format.sprintf "0x%s") anti_replay in let parameters = parameters_of_list list_transac in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_script_cache.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_script_cache.ml index fc461c64dee3..6d943f6e9a50 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_script_cache.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_script_cache.ml @@ -172,12 +172,11 @@ let test_find_correctly_looks_up () = Contract.get_script ctxt addr >|= Environment.wrap_tzresult >>=? fun (ctxt, script) -> (match (result, script) with - | (None, _) -> ok false - | (Some _, None) -> + | None, _ -> ok false + | Some _, None -> (* because we assume that get_script correctly behaves. *) assert false - | (Some (cached_script, _), Some script) -> - equal_scripts script cached_script) + | Some (cached_script, _), Some script -> equal_scripts script cached_script) >>?= fun cond -> fail_unless cond @@ -357,7 +356,7 @@ let test_entries_shows_lru () = (List.length rev_entries) (List.length rev_contracts) ; match (rev_entries, rev_contracts) with - | ([], _) -> + | [], _ -> (* We do not count liquidity baking contract. *) let removed_contracts = List.length rev_contracts - 1 in fail_unless @@ -368,7 +367,7 @@ let test_entries_shows_lru () = is full, %d remaining while expecting %d" removed_contracts (ncontracts / 2))) - | ((contract, size) :: rev_entries, (_, contract') :: rev_contracts) -> + | (contract, size) :: rev_entries, (_, contract') :: rev_contracts -> fail_unless (size = new_size || contract = liquidity_baking_contract) (err @@ -384,7 +383,7 @@ let test_entries_shows_lru () = (Printf.sprintf "entries do not return cached contracts in right order")) >>=? fun () -> aux rev_entries rev_contracts - | (_, []) -> + | _, [] -> (* There cannot be more entries than contracts. *) assert false in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml index 3a06aa4319c0..d4d251c9c80c 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml @@ -163,7 +163,7 @@ let nsample = 100 let check_value_size () = let check (Ex (what, ty, v, error)) = let expected_size = footprint v in - let (_, size) = Script_typed_ir_size.value_size ty v in + let _, size = Script_typed_ir_size.value_size ty v in let size = Saturation_repr.to_int size in fail_when (expected_size + error < size || size < expected_size) @@ -643,7 +643,7 @@ let check_ty_size () = match (sample_ty (Random.int 10 + 1) : ex_ty) with | Ex_ty ty -> let expected_size = footprint ty in - let (_, size) = Script_typed_ir_size.Internal_for_tests.ty_size ty in + let _, size = Script_typed_ir_size.Internal_for_tests.ty_size ty in let size = Saturation_repr.to_int size in let what = "some type" in fail_when diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index 1a717ac3f0ac..b0bc2e72a26c 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -55,7 +55,7 @@ let string_list_of_ex_token_diffs ctxt token_diffs = let open Lwt_result_syntax in let accum (xs, ctxt) (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = - let* (x, ctxt) = + let* x, ctxt = wrap @@ Script_ir_translator.unparse_comparable_data ~loc:() @@ -76,18 +76,18 @@ let string_list_of_ex_token_diffs ctxt token_diffs = in return (str :: xs, ctxt) in - let* (xs, ctxt) = List.fold_left_es accum ([], ctxt) token_diffs in + let* xs, ctxt = List.fold_left_es accum ([], ctxt) token_diffs in return (List.rev xs, ctxt) let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = let open Lwt_result_syntax in wrap - @@ let*? (Script_ir_translator.Ex_comparable_ty contents_type, ctxt) = + @@ let*? Script_ir_translator.Ex_comparable_ty contents_type, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in Script_ir_translator.parse_comparable_ty ctxt node in let*? ticketer = Contract.of_b58check ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in Script_ir_translator.parse_comparable_data ctxt contents_type node in @@ -95,7 +95,7 @@ let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = let assert_equal_ticket_diffs ~loc ctxt given expected = let open Lwt_result_syntax in - let* (ctxt, tbs1) = + let* ctxt, tbs1 = List.fold_left_map_es (fun ctxt ((ticketer, content), delta) -> make_ex_token @@ -107,8 +107,8 @@ let assert_equal_ticket_diffs ~loc ctxt given expected = ctxt expected in - let* (tbs1, ctxt) = string_list_of_ex_token_diffs ctxt tbs1 in - let* (tbs2, _ctxt) = string_list_of_ex_token_diffs ctxt given in + let* tbs1, ctxt = string_list_of_ex_token_diffs ctxt tbs1 in + let* tbs2, _ctxt = string_list_of_ex_token_diffs ctxt given in assert_equal_string_list ~loc "Compare token balances" @@ -119,10 +119,10 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = let open Lwt_result_syntax in List.fold_right_es (fun (key, value) (kvs, ctxt) -> - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap (Script_ir_translator.hash_comparable_data ctxt key_type key) in - let* (key_node, ctxt) = + let* key_node, ctxt = wrap (Script_ir_translator.unparse_comparable_data ~loc:Micheline.dummy_location @@ -131,11 +131,11 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = key_type key) in - let* (value, ctxt) = + let* value, ctxt = match value with | None -> return (None, ctxt) | Some value -> - let* (value_node, ctxt) = + let* value_node, ctxt = wrap (Script_ir_translator.unparse_data ctxt @@ -159,9 +159,9 @@ let make_alloc big_map_id alloc updates = let init () = let open Lwt_result_syntax in - let* (block, contracts) = Context.init 1 in + let* block, contracts = Context.init 1 in let source = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd contracts in - let* (operation, originated) = + let* operation, originated = Op.contract_origination (B block) source ~script:Op.dummy_script in let* block = Block.bake ~operation block in @@ -171,7 +171,7 @@ let init () = (** Initializes one address for operations and one baker. *) let init_for_operation () = Context.init ~consensus_threshold:0 2 >|=? fun (block, contracts) -> - let (src0, src1) = + let src0, src1 = match contracts with src0 :: src1 :: _ -> (src0, src1) | _ -> assert false in let baker = @@ -198,22 +198,22 @@ let ticket_list_script = let setup ctxt ~key_type ~value_type entries = let open Lwt_result_syntax in - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in - let* (updates, ctxt) = + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* updates, ctxt = updates_of_key_values ctxt ~key_type ~value_type (List.map (fun (k, v) -> (k, Some v)) entries) in - let*? (key_type_node, ctxt) = + let*? key_type_node, ctxt = Environment.wrap_tzresult @@ Script_ir_translator.unparse_comparable_ty ~loc:Micheline.dummy_location ctxt key_type in - let*? (value_type_node, ctxt) = + let*? value_type_node, ctxt = Environment.wrap_tzresult @@ Script_ir_translator.unparse_ty ~loc:Micheline.dummy_location @@ -227,7 +227,7 @@ let setup ctxt ~key_type ~value_type entries = let new_big_map ctxt contract ~key_type ~value_type entries = let open Lwt_result_syntax in - let* (alloc, big_map_id, ctxt) = setup ctxt ~key_type ~value_type entries in + let* alloc, big_map_id, ctxt = setup ctxt ~key_type ~value_type entries in let storage = Expr.from_string "{}" in let* ctxt = wrap @@ Contract.update_script_storage ctxt contract storage (Some [alloc]) @@ -236,25 +236,25 @@ let new_big_map ctxt contract ~key_type ~value_type entries = let alloc_diff ctxt ~key_type ~value_type entries = let open Lwt_result_syntax in - let* (allocations, _, ctxt) = setup ctxt ~key_type ~value_type entries in + let* allocations, _, ctxt = setup ctxt ~key_type ~value_type entries in return (allocations, ctxt) let remove_diff ctxt contract ~key_type ~value_type ~existing_entries = let open Lwt_result_syntax in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in return (Lazy_storage.make Lazy_storage.Kind.Big_map big_map_id Remove, ctxt) let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = let open Lwt_result_syntax in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in - let* (updates, ctxt) = + let* updates, ctxt = updates_of_key_values ctxt ~key_type ~value_type updates in - let* (ctxt, new_big_map_id) = wrap @@ Big_map.fresh ctxt ~temporary:false in + let* ctxt, new_big_map_id = wrap @@ Big_map.fresh ctxt ~temporary:false in return ( Lazy_storage.make Lazy_storage.Kind.Big_map @@ -265,10 +265,10 @@ let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = let open Lwt_result_syntax in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in - let* (updates, ctxt) = + let* updates, ctxt = updates_of_key_values ctxt ~key_type ~value_type updates in return @@ -281,7 +281,7 @@ let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates let empty_big_map ctxt ~key_type ~value_type = let open Lwt_result_syntax in let open Script_typed_ir in - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in return ( Big_map { @@ -295,7 +295,7 @@ let empty_big_map ctxt ~key_type ~value_type = let make_big_map ctxt contract ~key_type ~value_type entries = let open Lwt_result_syntax in let open Script_typed_ir in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type entries in return @@ -315,7 +315,7 @@ let originate_script block ~script ~storage ~src ~baker ~forges_tickets = let script = Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} in - let* (operation, destination) = + let* operation, destination = Op.contract_origination (B block) src ~fee:(Test_tez.of_int 10) ~script in let* incr = @@ -370,7 +370,7 @@ let origination_operation ctxt ~src ~script ~orig_contract = let originate block ~src ~baker ~script ~storage ~forges_tickets = let open Lwt_result_syntax in - let* (orig_contract, script, block) = + let* orig_contract, script, block = originate_script block ~script ~storage ~src ~baker ~forges_tickets in let* incr = @@ -380,7 +380,7 @@ let originate block ~src ~baker ~script ~storage ~forges_tickets = let transfer_operation ctxt ~src ~destination ~arg_type ~arg = let open Lwt_result_syntax in - let* (params_node, ctxt) = + let* params_node, ctxt = wrap (Script_ir_translator.unparse_data ctxt @@ -433,9 +433,9 @@ let type_has_tickets ctxt ty = let assert_ticket_diffs ctxt ~loc ~arg_type ~storage_type ~arg ~old_storage ~new_storage ~lazy_storage_diff expected = let open Lwt_result_syntax in - let*? (arg_type_has_tickets, ctxt) = type_has_tickets ctxt arg_type in - let*? (storage_type_has_tickets, ctxt) = type_has_tickets ctxt storage_type in - let* (ticket_diff, ctxt) = + let*? arg_type_has_tickets, ctxt = type_has_tickets ctxt arg_type in + let*? storage_type_has_tickets, ctxt = type_has_tickets ctxt storage_type in + let* ticket_diff, ctxt = wrap (Ticket_accounting.ticket_diffs ctxt @@ -446,19 +446,19 @@ let assert_ticket_diffs ctxt ~loc ~arg_type ~storage_type ~arg ~old_storage ~new_storage ~lazy_storage_diff) in - let*? (ticket_diffs, ctxt) = + let*? ticket_diffs, ctxt = Environment.wrap_tzresult @@ Ticket_token_map.to_list ctxt ticket_diff in assert_equal_ticket_diffs ~loc ctxt ticket_diffs expected let assert_balance ctxt ~loc key expected = let open Lwt_result_syntax in - let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + let* balance, _ = wrap @@ Ticket_balance.get_balance ctxt key in match (balance, expected) with - | (Some b, Some eb) -> Assert.equal_int ~loc (Z.to_int b) eb - | (None, Some eb) -> failwith "Expected balance %d" eb - | (Some eb, None) -> failwith "Expected None but got %d" (Z.to_int eb) - | (None, None) -> return () + | Some b, Some eb -> Assert.equal_int ~loc (Z.to_int b) eb + | None, Some eb -> failwith "Expected balance %d" eb + | Some eb, None -> failwith "Expected None but got %d" (Z.to_int eb) + | None, None -> return () let string_ticket ticketer contents amount = let amount = Script_int.abs @@ Script_int.of_int amount in @@ -486,12 +486,12 @@ let string_ticket_token ticketer content = let test_diffs_empty () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_key ~value_type:ticket_string_type in (* Start with an empty big-map *) - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_key ~value_type:ticket_string_type in assert_ticket_diffs @@ -510,7 +510,7 @@ let test_diffs_empty () = let test_diffs_tickets_in_args () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let arg = string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 in assert_ticket_diffs ctxt @@ -527,7 +527,7 @@ let test_diffs_tickets_in_args () = storage, results in an empty diff. *) let test_diffs_tickets_in_args_and_storage () = let open Lwt_result_syntax in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let arg = string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 in assert_ticket_diffs ctxt @@ -544,7 +544,7 @@ let test_diffs_tickets_in_args_and_storage () = storage results in a negative diff. *) let test_diffs_drop_one_ticket () = let open Lwt_result_syntax in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let arg = boxed_list [ @@ -573,7 +573,7 @@ let test_diffs_drop_one_ticket () = balance. *) let test_diffs_adding_new_ticket_to_storage () = let open Lwt_result_syntax in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let new_storage = boxed_list [string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1] in @@ -592,7 +592,7 @@ let test_diffs_adding_new_ticket_to_storage () = diff. *) let test_diffs_remove_from_storage () = let open Lwt_result_syntax in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let old_storage = boxed_list [ @@ -621,16 +621,16 @@ let test_diffs_remove_from_storage () = let test_diffs_lazy_storage_alloc () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_key ~value_type:ticket_string_type in (* Start with an empty big-map *) - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_key ~value_type:ticket_string_type in (* We add one ticket to the storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = alloc_diff ctxt ~key_type:int_key @@ -655,16 +655,16 @@ let test_diffs_lazy_storage_alloc () = let test_diffs_remove_from_big_map () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (contract, ctxt) = init () in + let* contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_key ~value_type:ticket_string_type in (* Start with an empty big-map *) - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_key ~value_type:ticket_string_type in (* Remove one ticket from the lazy storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = remove_diff ctxt contract @@ -691,16 +691,16 @@ let test_diffs_remove_from_big_map () = let test_diffs_copy_big_map () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (contract, ctxt) = init () in + let* contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_key ~value_type:ticket_string_type in (* Start with an empty big-map *) - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_key ~value_type:ticket_string_type in (* We add one ticket to the storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = copy_diff ctxt contract @@ -740,11 +740,11 @@ let test_diffs_copy_big_map () = let test_diffs_add_to_existing_big_map () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (contract, ctxt) = init () in + let* contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_key ~value_type:ticket_string_type in - let* (old_storage, ctxt) = + let* old_storage, ctxt = make_big_map ctxt contract @@ -761,7 +761,7 @@ let test_diffs_add_to_existing_big_map () = ] in (* We add one ticket to the storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = existing_diff ctxt contract @@ -804,7 +804,7 @@ let test_diffs_add_to_existing_big_map () = let test_diffs_args_storage_and_lazy_diffs () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (contract, ctxt) = init () in + let* contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_key ~value_type:ticket_string_type in @@ -812,7 +812,7 @@ let test_diffs_args_storage_and_lazy_diffs () = Environment.wrap_tzresult @@ pair_t (-1) ticket_string_list_type int_ticket_big_map_ty in - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_key ~value_type:ticket_string_type in (* We send two tickets in the args. *) @@ -824,7 +824,7 @@ let test_diffs_args_storage_and_lazy_diffs () = ] in (* We add three tickets to the storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = existing_diff ctxt contract @@ -894,8 +894,8 @@ let test_diffs_args_storage_and_lazy_diffs () = (** Test that attempting to transfer a ticket that exceeds the budget fails. *) let test_update_invalid_transfer () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (destination, _script, incr) = + let* baker, src, block = init_for_operation () in + let* destination, _script, incr = originate block ~src @@ -909,7 +909,7 @@ let test_update_invalid_transfer () = let arg = boxed_list [string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1] in - let* (operation, ctxt) = + let* operation, ctxt = transfer_operation ctxt ~src ~destination ~arg_type ~arg in assert_fail_with @@ -928,8 +928,8 @@ let test_update_invalid_transfer () = results in a balance update. *) let test_update_ticket_self_diff () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (self, _script, incr) = + let* baker, src, block = init_for_operation () in + let* self, _script, incr = originate block ~src @@ -941,18 +941,18 @@ let test_update_ticket_self_diff () = let ticketer = Contract.to_b58check self in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt ~merge_overlap:(fun _ -> assert false) [(red_token, Z.of_int 10)]) in - let* (_, ctxt) = + let* _, ctxt = wrap (Ticket_accounting.update_ticket_balances ctxt ~self ~ticket_diffs []) in (* After update, we should have 10 added red tokens. *) - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -964,8 +964,8 @@ let test_update_ticket_self_diff () = (* Test that sending tickets to self succeed (there are no budget constraints). *) let test_update_self_ticket_transfer () = let open Lwt_result_syntax in - let* (baker, self, block) = init_for_operation () in - let* (ticket_receiver, _script, incr) = + let* baker, self, block = init_for_operation () in + let* ticket_receiver, _script, incr = originate block ~src:self @@ -979,7 +979,7 @@ let test_update_self_ticket_transfer () = let ticketer = Contract.to_b58check self in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (operation, ctxt) = + let* operation, ctxt = let arg_type = ticket_string_list_type in let arg = boxed_list @@ -998,7 +998,7 @@ let test_update_self_ticket_transfer () = ~arg_type ~arg in - let* (_, ctxt) = + let* _, ctxt = wrap (Ticket_accounting.update_ticket_balances ctxt @@ -1009,7 +1009,7 @@ let test_update_self_ticket_transfer () = (* Once we're done with the update, we expect ticket-receiver to have been credited with 10 units of ticket-tokens. *) let* () = - let* (red_receiver_token_hash, ctxt) = + let* red_receiver_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1023,8 +1023,8 @@ let test_update_self_ticket_transfer () = (** Test that transferring a ticket that does not exceed the budget succeeds. *) let test_update_valid_transfer () = let open Lwt_result_syntax in - let* (baker, self, block) = init_for_operation () in - let* (destination, _script, incr) = + let* baker, self, block = init_for_operation () in + let* destination, _script, incr = originate block ~src:self @@ -1037,14 +1037,14 @@ let test_update_valid_transfer () = assert (ticketer <> Contract.to_b58check self) ; let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt ~owner:(Destination.Contract self) red_token in - let* (red_receiver_token_hash, ctxt) = + let* red_receiver_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1052,16 +1052,16 @@ let test_update_valid_transfer () = red_token in (* Set up the balance so that the self contract owns one ticket. *) - let* (_, ctxt) = + let* _, ctxt = wrap @@ Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:Z.one in - let* (operation, ctxt) = + let* operation, ctxt = let arg_type = ticket_string_list_type in let arg = boxed_list [string_ticket ticketer "red" 1] in transfer_operation ctxt ~src:self ~destination ~arg_type ~arg in - let* (_, ctxt) = - let* (ticket_diffs, ctxt) = + let* _, ctxt = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt @@ -1085,8 +1085,8 @@ let test_update_valid_transfer () = the balance. *) let test_update_transfer_tickets_to_self () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (self, _script, incr) = + let* baker, src, block = init_for_operation () in + let* self, _script, incr = originate block ~src @@ -1099,7 +1099,7 @@ let test_update_transfer_tickets_to_self () = assert (ticketer <> Contract.to_b58check self) ; let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1107,21 +1107,21 @@ let test_update_transfer_tickets_to_self () = red_token in (* Set up the balance so that the self contract owns ten tickets. *) - let* (_, ctxt) = + let* _, ctxt = wrap @@ Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:(Z.of_int 10) in - let* (operation, ctxt) = + let* operation, ctxt = let arg_type = ticket_string_list_type in let arg = boxed_list [string_ticket ticketer "red" 1] in transfer_operation ctxt ~src:self ~destination:self ~arg_type ~arg in - let* (_, ctxt) = + let* _, ctxt = (* Ticket diff removes 5 tickets. *) - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt @@ -1144,8 +1144,8 @@ let test_update_transfer_tickets_to_self () = budget fails. *) let test_update_invalid_origination () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (destination, script, incr) = + let* baker, src, block = init_for_operation () in + let* destination, script, incr = let storage = let ticketer = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" in Printf.sprintf @@ -1163,7 +1163,7 @@ let test_update_invalid_origination () = ~forges_tickets:true in let ctxt = Incremental.alpha_ctxt incr in - let* (operation, ctxt) = + let* operation, ctxt = origination_operation ctxt ~src ~orig_contract:destination ~script in assert_fail_with @@ -1181,10 +1181,10 @@ let test_update_invalid_origination () = (** Test update valid origination. *) let test_update_valid_origination () = let open Lwt_result_syntax in - let* (baker, self, block) = init_for_operation () in + let* baker, self, block = init_for_operation () in let ticketer = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" in assert (ticketer <> Contract.to_b58check self) ; - let* (originated, script, incr) = + let* originated, script, incr = let storage = Printf.sprintf {|{ Pair %S "red" 1; }|} ticketer in originate block @@ -1196,7 +1196,7 @@ let test_update_valid_origination () = in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1204,14 +1204,14 @@ let test_update_valid_origination () = red_token in (* Set up the balance so that the self contract owns one ticket. *) - let* (_, ctxt) = + let* _, ctxt = wrap @@ Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:Z.one in - let* (operation, ctxt) = + let* operation, ctxt = origination_operation ctxt ~src:self ~orig_contract:originated ~script in - let* (_, ctxt) = - let* (ticket_diffs, ctxt) = + let* _, ctxt = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt @@ -1227,7 +1227,7 @@ let test_update_valid_origination () = in (* Once we're done with the update, we expect the balance to have been moved from [self] to [destination]. *) - let* (red_originated_token_hash, ctxt) = + let* red_originated_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1238,9 +1238,9 @@ let test_update_valid_origination () = let test_update_self_origination () = let open Lwt_result_syntax in - let* (baker, self, block) = init_for_operation () in + let* baker, self, block = init_for_operation () in let ticketer = Contract.to_b58check self in - let* (originated, script, incr) = + let* originated, script, incr = let storage = Printf.sprintf {|{ Pair %S "red" 1; }|} ticketer in originate block @@ -1252,17 +1252,17 @@ let test_update_self_origination () = in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (red_originated_token_hash, ctxt) = + let* red_originated_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt ~owner:(Destination.Contract originated) red_token in - let* (operation, ctxt) = + let* operation, ctxt = origination_operation ctxt ~src:self ~orig_contract:originated ~script in - let* (_, ctxt) = + let* _, ctxt = wrap (Ticket_accounting.update_ticket_balances ctxt @@ -1277,8 +1277,8 @@ let test_update_self_origination () = (** Test ticket-token map of list with duplicates. *) let test_ticket_token_map_of_list_with_duplicates () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (self, _script, incr) = + let* baker, src, block = init_for_operation () in + let* self, _script, incr = originate block ~src @@ -1290,18 +1290,18 @@ let test_ticket_token_map_of_list_with_duplicates () = let ticketer = Contract.to_b58check self in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt ~merge_overlap:(fun ctxt v1 v2 -> ok (Z.add v1 v2, ctxt)) [(red_token, Z.of_int 10); (red_token, Z.of_int 5)]) in - let* (_, ctxt) = + let* _, ctxt = wrap (Ticket_accounting.update_ticket_balances ctxt ~self ~ticket_diffs []) in (* After update, we should have 10 + 5 added red tokens. *) - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_balance.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_balance.ml index 4e95525f0e16..bf661dd1dec1 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_balance.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_balance.ml @@ -45,7 +45,7 @@ type init_env = { } let init_env () = - let* (block, baker, contract, _src2) = Contract_helpers.init () in + let* block, baker, contract, _src2 = Contract_helpers.init () in return {block; baker; contract} let transaction block ~baker ~sender ~entrypoint ~recipient ~parameters = @@ -69,7 +69,7 @@ let transaction block ~baker ~sender ~entrypoint ~recipient ~parameters = let originate = Contract_helpers.originate_contract_from_string let get_balance ctxt ~token ~owner = - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt ~owner token in wrap (Ticket_balance.get_balance ctxt key_hash) @@ -77,15 +77,15 @@ let get_balance ctxt ~token ~owner = let assert_token_balance ~loc block token owner expected = let* incr = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt incr in - let* (balance, _) = + let* balance, _ = get_balance ctxt ~token ~owner:(Destination.Contract owner) in match (balance, expected) with - | (Some b, Some e) -> Assert.equal_int ~loc (Z.to_int b) e - | (Some b, None) -> + | Some b, Some e -> Assert.equal_int ~loc (Z.to_int b) e + | Some b, None -> failwith "%s: Expected no balance but got some %d" loc (Z.to_int b) - | (None, Some b) -> failwith "%s: Expected balance %d but got none" loc b - | (None, None) -> return () + | None, Some b -> failwith "%s: Expected balance %d but got none" loc b + | None, None -> return () let string_token ~ticketer content = let contents = @@ -126,7 +126,7 @@ let get_new_contract before f = let test_add_strict () = let* {block; baker; contract = source_contract} = init_env () in (* Originate *) - let* (contract, _script, block) = + let* contract, _script, block = originate ~baker ~source_contract @@ -179,7 +179,7 @@ let test_add_strict () = let test_add_remove () = let* {block; baker; contract = source_contract} = init_env () in (* Originate *) - let* (contract, _script, block) = + let* contract, _script, block = originate ~baker ~source_contract @@ -235,7 +235,7 @@ let test_add_remove () = (** Test adding multiple tickets to a big-map. *) let test_add_to_big_map () = let* {block; baker; contract = source_contract} = init_env () in - let* (contract, _script, block) = + let* contract, _script, block = originate ~baker ~source_contract @@ -298,7 +298,7 @@ let test_add_to_big_map () = *) let test_swap_big_map () = let* {block; baker; contract = source_contract} = init_env () in - let* (contract, _script, block) = + let* contract, _script, block = originate ~baker ~source_contract @@ -385,7 +385,7 @@ let test_swap_big_map () = let test_send_tickets () = let* {block; baker; contract = source_contract} = init_env () in (* A contract that can receive a ticket and store it in a list. *) - let* (ticket_receiver, _script, block) = + let* ticket_receiver, _script, block = originate ~baker ~source_contract @@ -400,7 +400,7 @@ let test_send_tickets () = in (* A contract that, given an address to a contract that receives tickets, mints a ticket and sends it over. *) - let* (ticket_sender, _script, block) = + let* ticket_sender, _script, block = originate ~baker ~source_contract @@ -447,7 +447,7 @@ let test_send_tickets () = let test_send_tickets_in_big_map () = let* {block; baker; contract = source_contract} = init_env () in (* A contract that can receive a big-map with tickets. *) - let* (ticket_receiver, _script, block) = + let* ticket_receiver, _script, block = originate ~baker ~source_contract @@ -465,7 +465,7 @@ let test_send_tickets_in_big_map () = a big-map. - [send (address)] for transferring the big-map to the given address. *) - let* (ticket_manager, _script, block) = + let* ticket_manager, _script, block = originate ~baker ~source_contract @@ -572,7 +572,7 @@ let test_modify_big_map () = - [Add ((int, string))] for adding a ticket to the big-map. - [Remove(int)] for removing an index from the big-map. *) - let* (ticket_manager, _script, block) = + let* ticket_manager, _script, block = originate ~baker ~source_contract @@ -660,7 +660,7 @@ let test_modify_big_map () = let test_send_tickets_in_big_map_and_drop () = let* {block; baker; contract = source_contract} = init_env () in (* A contract that can receive a big-map with tickets but drops it. *) - let* (ticket_receiver, _script, block) = + let* ticket_receiver, _script, block = originate ~baker ~source_contract @@ -675,7 +675,7 @@ let test_send_tickets_in_big_map_and_drop () = in (* A contract that, given an address, creates a ticket and sends it to the corresponding contract in a big-map. *) - let* (ticket_sender, _script, block) = + let* ticket_sender, _script, block = originate ~baker ~source_contract @@ -733,7 +733,7 @@ let test_send_tickets_in_big_map_and_drop () = (* Test create contract with tickets *) let test_create_contract_with_ticket () = let* {block; baker; contract = source_contract} = init_env () in - let* (ticket_creator, _script, block) = + let* ticket_creator, _script, block = originate ~baker ~source_contract @@ -765,7 +765,7 @@ let test_create_contract_with_ticket () = in let token_red = string_token ~ticketer:ticket_creator "Red" in (* Call ticket-creator to originate a new contract with one ticket *) - let* (new_contract, block) = + let* new_contract, block = get_new_contract block (fun block -> transaction ~entrypoint:Entrypoint.default @@ -785,7 +785,7 @@ let test_create_contract_with_ticket () = let test_join_tickets () = let* {block; baker; contract = source_contract} = init_env () in - let* (ticket_joiner, _script, block) = + let* ticket_joiner, _script, block = originate ~baker ~source_contract @@ -976,7 +976,7 @@ let ticket_wallet = (** Test ticket wallet implementation including sending tickets to self. *) let test_ticket_wallet () = let* {block; baker; contract = source_contract} = init_env () in - let* (ticket_builder, _script, block) = + let* ticket_builder, _script, block = originate ~baker ~source_contract @@ -984,7 +984,7 @@ let test_ticket_wallet () = ~storage:(Printf.sprintf "%S" @@ Contract.to_b58check source_contract) block in - let* (ticket_wallet, _script, block) = + let* ticket_wallet, _script, block = originate ~baker ~source_contract diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml index d0a972d392e4..ca0268f08dd4 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml @@ -40,28 +40,28 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult let new_ctxt () = - let* (block, _) = Context.init 1 in + let* block, _ = Context.init 1 in let* incr = Incremental.begin_construction block in return @@ Incremental.alpha_ctxt incr let make_contract ticketer = wrap @@ Lwt.return @@ Contract.of_b58check ticketer let make_ex_token ctxt ~ticketer ~ty ~content = - let* (Script_ir_translator.Ex_comparable_ty cty, ctxt) = + let* Script_ir_translator.Ex_comparable_ty cty, ctxt = let node = Micheline.root @@ Expr.from_string ty in wrap @@ Lwt.return @@ Script_ir_translator.parse_comparable_ty ctxt node in let* ticketer = make_contract ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content in wrap @@ Script_ir_translator.parse_comparable_data ctxt cty node in return (Ticket_token.Ex_token {contents_type = cty; ticketer; contents}, ctxt) let make_key ctxt ~ticketer ~ty ~content ~owner = - let* (ex_token, ctxt) = make_ex_token ctxt ~ticketer ~ty ~content in + let* ex_token, ctxt = make_ex_token ctxt ~ticketer ~ty ~content in let* owner = make_contract owner in - let* (key, ctxt) = + let* key, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -79,10 +79,10 @@ let not_equal_script_hash ~loc msg key1 key2 = let assert_keys ~ticketer1 ~ticketer2 ~ty1 ~ty2 ~amount1 ~amount2 ~content1 ~content2 ~owner1 ~owner2 assert_condition = let* ctxt = new_ctxt () in - let* (key1, ctxt) = + let* key1, ctxt = make_key ctxt ~ticketer:ticketer1 ~ty:ty1 ~content:content1 ~owner:owner1 in - let* (key2, _) = + let* key2, _ = make_key ctxt ~ticketer:ticketer2 ~ty:ty2 ~content:content2 ~owner:owner2 in assert_condition (key1, amount1) (key2, amount2) diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml index a421ad34a8a5..cd8d29fe7213 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml @@ -46,7 +46,7 @@ let assert_equal_string_list ~loc msg = let string_list_of_ex_token_diffs ctxt token_diffs = let accum (xs, ctxt) (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = - let* (x, ctxt) = + let* x, ctxt = wrap @@ Script_ir_translator.unparse_comparable_data ~loc:() @@ -67,23 +67,23 @@ let string_list_of_ex_token_diffs ctxt token_diffs = in return (str :: xs, ctxt) in - let* (xs, ctxt) = List.fold_left_es accum ([], ctxt) token_diffs in + let* xs, ctxt = List.fold_left_es accum ([], ctxt) token_diffs in return (List.rev xs, ctxt) let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = - let* (Script_ir_translator.Ex_comparable_ty contents_type, ctxt) = + let* Script_ir_translator.Ex_comparable_ty contents_type, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in wrap @@ Lwt.return @@ Script_ir_translator.parse_comparable_ty ctxt node in let* ticketer = wrap @@ Lwt.return @@ Contract.of_b58check ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in wrap @@ Script_ir_translator.parse_comparable_data ctxt contents_type node in return (Ticket_token.Ex_token {ticketer; contents_type; contents}, ctxt) let assert_equal_balances ~loc ctxt given expected = - let* (ctxt, tbs1) = + let* ctxt, tbs1 = List.fold_left_map_es (fun ctxt ((ticketer, content), delta) -> make_ex_token @@ -95,8 +95,8 @@ let assert_equal_balances ~loc ctxt given expected = ctxt expected in - let* (tbs1, ctxt) = string_list_of_ex_token_diffs ctxt tbs1 in - let* (tbs2, _ctxt) = string_list_of_ex_token_diffs ctxt given in + let* tbs1, ctxt = string_list_of_ex_token_diffs ctxt tbs1 in + let* tbs2, _ctxt = string_list_of_ex_token_diffs ctxt given in assert_equal_string_list ~loc "Compare token balances" @@ -108,7 +108,7 @@ let wrap_result res = wrap (Lwt.return res) let updates_of_key_values ctxt key_values = List.fold_right_es (fun (key, value) (kvs, ctxt) -> - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap (Script_ir_translator.hash_comparable_data ctxt @@ -133,9 +133,9 @@ let make_alloc big_map_id alloc updates = (Update {init = Lazy_storage.Alloc alloc; updates}) let init () = - let* (block, contracts) = Context.init 1 in + let* block, contracts = Context.init 1 in let source = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd contracts in - let* (operation, originated) = + let* operation, originated = Op.contract_origination (B block) source ~script:Op.dummy_script in let* block = Block.bake ~operation block in @@ -143,15 +143,15 @@ let init () = return (originated, Incremental.alpha_ctxt inc) let setup ctxt contract ~key_type ~value_type entries = - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in let key_type = Expr.from_string key_type in let value_type = Expr.from_string value_type in - let* (updates, ctxt) = updates_of_key_values ctxt entries in + let* updates, ctxt = updates_of_key_values ctxt entries in let alloc = make_alloc big_map_id Big_map.{key_type; value_type} updates in return (alloc, big_map_id, contract, ctxt) let new_big_map ctxt contract ~key_type ~value_type entries = - let* (alloc, big_map_id, contract, ctxt) = + let* alloc, big_map_id, contract, ctxt = setup ctxt contract ~key_type ~value_type @@ List.map (fun (k, v) -> (k, Some v)) entries in @@ -162,7 +162,7 @@ let new_big_map ctxt contract ~key_type ~value_type entries = return (big_map_id, ctxt) let alloc_diff ctxt contract ~key_type ~value_type entries = - let* (allocations, _, _, ctxt) = + let* allocations, _, _, ctxt = setup ctxt contract @@ -173,17 +173,17 @@ let alloc_diff ctxt contract ~key_type ~value_type entries = return (allocations, ctxt) let remove_diff ctxt contract ~key_type ~value_type ~existing_entries = - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in return (Lazy_storage.make Lazy_storage.Kind.Big_map big_map_id Remove, ctxt) let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in - let* (updates, ctxt) = updates_of_key_values ctxt updates in - let* (ctxt, new_big_map_id) = wrap @@ Big_map.fresh ctxt ~temporary:false in + let* updates, ctxt = updates_of_key_values ctxt updates in + let* ctxt, new_big_map_id = wrap @@ Big_map.fresh ctxt ~temporary:false in return ( Lazy_storage.make Lazy_storage.Kind.Big_map @@ -193,10 +193,10 @@ let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in - let* (updates, ctxt) = updates_of_key_values ctxt updates in + let* updates, ctxt = updates_of_key_values ctxt updates in return ( Lazy_storage.make Lazy_storage.Kind.Big_map @@ -207,11 +207,11 @@ let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates (** Test that no ticket-tokens are extracted from a diff for allocating an empty big-map. *) let test_allocate_new_empty () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = alloc_diff ctxt contract ~key_type:"int" ~value_type:"ticket string" [] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -220,8 +220,8 @@ let test_allocate_new_empty () = (** Test that no ticket-tokens are extracted from a lazy-diff of a big-map that does not contain tickets. *) let test_allocate_new_no_tickets () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = alloc_diff ctxt contract @@ -229,7 +229,7 @@ let test_allocate_new_no_tickets () = ~value_type:"string" [(1, {|"A"|}); (2, {|"B"|}); (3, {|"C"|})] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -238,8 +238,8 @@ let test_allocate_new_no_tickets () = (** Test that ticket-tokens can be extracted from a lazy-diff for allocating a new big-map. *) let test_allocate_new () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = alloc_diff ctxt contract @@ -251,7 +251,7 @@ let test_allocate_new () = (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -268,8 +268,8 @@ let test_allocate_new () = (** Test that ticket-tokens with negative balances are extracted from a lazy-diff that removes a big-map. *) let test_remove_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = remove_diff ctxt contract @@ -282,7 +282,7 @@ let test_remove_big_map () = (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -299,8 +299,8 @@ let test_remove_big_map () = (** Test that there are no ticket-token balance deltas extracted from a lazy-diff that applies no updates. *) let test_no_updates_to_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -314,7 +314,7 @@ let test_no_updates_to_existing_big_map () = ] ~updates:[] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -324,8 +324,8 @@ let test_no_updates_to_existing_big_map () = extracted from a lazy-diff that modifies an existing big-map. *) let test_update_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -347,7 +347,7 @@ let test_update_existing_big_map () = (4, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "pink" 5|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -367,8 +367,8 @@ let test_update_existing_big_map () = multiple updates to the same key. *) let test_update_same_key_multiple_times_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -384,7 +384,7 @@ let test_update_same_key_multiple_times_existing_big_map () = (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -404,8 +404,8 @@ let test_update_same_key_multiple_times_existing_big_map () = multiple removals of the same item. *) let test_remove_same_key_multiple_times_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -421,7 +421,7 @@ let test_remove_same_key_multiple_times_existing_big_map () = (1, None); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -436,8 +436,8 @@ let test_remove_same_key_multiple_times_existing_big_map () = multiple additions and removals of the same item. *) let test_update_and_remove_same_key_multiple_times_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -457,7 +457,7 @@ let test_update_and_remove_same_key_multiple_times_existing_big_map () = (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -475,8 +475,8 @@ let test_update_and_remove_same_key_multiple_times_existing_big_map () = (** Test that the extracted ticket-tokens from a lazy diff for copying a big-map reflects the tokens of the source as well as the updates. *) let test_copy_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = copy_diff ctxt contract @@ -490,7 +490,7 @@ let test_copy_big_map () = ] ~updates:[] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -507,8 +507,8 @@ let test_copy_big_map () = (** Test that the extracted ticket-tokens from a lazy diff for copying a big-map reflects the tokens of the source as well as the updates. *) let test_copy_big_map_with_updates () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = copy_diff ctxt contract @@ -530,7 +530,7 @@ let test_copy_big_map_with_updates () = (4, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "pink" 5|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -552,8 +552,8 @@ let test_copy_big_map_with_updates () = with multiple updates to the same key reflects the tokens of the source as well as the updates. *) let test_copy_big_map_with_updates_to_same_key () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = copy_diff ctxt contract @@ -571,7 +571,7 @@ let test_copy_big_map_with_updates_to_same_key () = (1, None); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -592,8 +592,8 @@ let test_copy_big_map_with_updates_to_same_key () = (** Test combinations of lazy-diffs. *) let test_mix_lazy_diffs () = - let* (contract, ctxt) = init () in - let* (diff_copy, ctxt) = + let* contract, ctxt = init () in + let* diff_copy, ctxt = copy_diff ctxt contract @@ -609,7 +609,7 @@ let test_mix_lazy_diffs () = (2, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2|}); ] in - let* (diff_existing, ctxt) = + let* diff_existing, ctxt = existing_diff ctxt contract @@ -625,7 +625,7 @@ let test_mix_lazy_diffs () = (3, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); ] in - let* (diff_remove, ctxt) = + let* diff_remove, ctxt = remove_diff ctxt contract @@ -637,7 +637,7 @@ let test_mix_lazy_diffs () = (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "black" 1|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_manager.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_manager.ml index 7bb0f500951d..59792cdbb07d 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_manager.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_manager.ml @@ -51,24 +51,24 @@ type init_env = { } let init_env () = - let* (block, baker, contract, _src2) = Contract_helpers.init () in + let* block, baker, contract, _src2 = Contract_helpers.init () in return {block; baker; contract} let collect_token_amounts ctxt tickets = let accum (tokens, ctxt) ticket = - let (token, amount) = Ticket_token.token_and_amount_of_ex_ticket ticket in + let token, amount = Ticket_token.token_and_amount_of_ex_ticket ticket in let tokens = (token, Script_int.to_zint amount) :: tokens in return (tokens, ctxt) in List.fold_left_es accum ([], ctxt) tickets let tokens_of_value ~include_lazy ctxt ty x = - let*? (has_tickets, ctxt) = Ticket_scanner.type_has_tickets ctxt ty in - let* (tickets, ctxt) = + let*? has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt ty in + let* tickets, ctxt = Ticket_scanner.tickets_of_value ~include_lazy ctxt has_tickets x in - let* (tas, ctxt) = collect_token_amounts ctxt tickets in - let* (bm, ctxt) = + let* tas, ctxt = collect_token_amounts ctxt tickets in + let* bm, ctxt = Ticket_token_map.of_list ctxt ~merge_overlap:(fun ctxt v1 v2 -> ok (Z.add v1 v2, ctxt)) @@ -78,9 +78,7 @@ let tokens_of_value ~include_lazy ctxt ty x = (* Extract ticket-token balance of storage *) let ticket_balance_of_storage ctxt contract = - let* (ctxt, script) = - wrap @@ Alpha_context.Contract.get_script ctxt contract - in + let* ctxt, script = wrap @@ Alpha_context.Contract.get_script ctxt contract in match script with | None -> return ([], ctxt) | Some script -> @@ -93,14 +91,14 @@ let ticket_balance_of_storage ctxt contract = ~allow_forged_in_storage:true script) in - let* (tokens, ctxt) = + let* tokens, ctxt = wrap (tokens_of_value ~include_lazy:true ctxt storage_type storage) in - let* (tokens, ctxt) = + let* tokens, ctxt = wrap @@ List.fold_left_es (fun (acc, ctxt) (ex_token, amount) -> - let* (key, ctxt) = + let* key, ctxt = Ticket_balance_key.of_ex_token ctxt ~owner:(Contract contract) @@ -208,19 +206,19 @@ let validate_ticket_balances block = let* contracts = all_contracts block in let* incr = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt incr in - let* (kvs_storage, ctxt) = + let* kvs_storage, ctxt = List.fold_left_es (fun (acc, ctxt) contract -> - let* (lists, ctxt) = ticket_balance_of_storage ctxt contract in + let* lists, ctxt = ticket_balance_of_storage ctxt contract in return (lists @ acc, ctxt)) ([], ctxt) contracts in - let* (kvs_balance, _ctxt) = + let* kvs_balance, _ctxt = wrap @@ List.fold_left_es (fun (acc, ctxt) (key, _) -> - let* (balance, ctxt) = Ticket_balance.get_balance ctxt key in + let* balance, ctxt = Ticket_balance.get_balance ctxt key in let acc = match balance with None -> acc | Some b -> (key, b) :: acc in @@ -652,9 +650,7 @@ end let setup_test () = let module TM = Ticket_manager in let* {block; baker; contract = originator} = init_env () in - let* (ticket_manager, _script, block) = - TM.originate block ~originator baker - in + let* ticket_manager, _script, block = TM.originate block ~originator baker in let test block parameters = let* b = TM.transaction block ~sender:originator ~ticket_manager ~parameters @@ -667,7 +663,7 @@ let setup_test () = (** Test create new contracts and send tickets to them. *) let test_create_contract_and_send_tickets () = let module TM = Ticket_manager in - let* (test, originator, b) = setup_test () in + let* test, originator, b = setup_test () in (* Call the `create` endpoint that creates two new ticket receiver contracts: - Both contracts accepts a single ticket as an argument. @@ -675,7 +671,7 @@ let test_create_contract_and_send_tickets () = - The second holds a ticket in its storage and only accepts "green" tickets. - The second contract joins all received tickets. *) - let* (ticket_receiver_green_1, ticket_receiver_green_2, b) = + let* ticket_receiver_green_1, ticket_receiver_green_2, b = get_first_two_new_contracts b @@ fun b -> test b @@ TM.create ~content:"Green" ~amount:1 ~originator in @@ -709,7 +705,7 @@ let test_create_contract_and_send_tickets () = (** Tets add and remove tickets from lazy storage. *) let test_add_remove_from_lazy_storage () = let module TM = Ticket_manager in - let* (tm, _, b) = setup_test () in + let* tm, _, b = setup_test () in let* b = tm b @@ TM.add_lazy ~index:1 ~content:"Red" ~amount:10 in let* b = tm b @@ TM.add_lazy ~index:2 ~content:"Green" ~amount:10 in let* b = tm b @@ TM.add_lazy ~index:3 ~content:"Blue" ~amount:10 in @@ -727,7 +723,7 @@ let test_add_remove_from_lazy_storage () = (** Test send to self and replace big-map. *) let test_send_self_replace_big_map () = let module TM = Ticket_manager in - let* (tm, _, b) = setup_test () in + let* tm, _, b = setup_test () in (* Send self replace bigmap *) let* b = tm b @@ TM.add_lazy ~index:1 ~content:"Red" ~amount:1 in let* b = tm b @@ TM.add_lazy ~index:2 ~content:"Green" ~amount:1 in @@ -740,7 +736,7 @@ let test_send_self_replace_big_map () = (** Test add to and remove from strict storage. *) let test_add_remove_strict () = let module TM = Ticket_manager in - let* (tm, _, b) = setup_test () in + let* tm, _, b = setup_test () in (* Add some more strict tickets *) let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:1 in let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:2 in @@ -756,7 +752,7 @@ let test_add_remove_strict () = (** Test mixed operations. *) let test_mixed_operations () = let module TM = Ticket_manager in - let* (tm, _, b) = setup_test () in + let* tm, _, b = setup_test () in (* Add some more strict tickets *) let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:1 in let* b = tm b @@ TM.add_strict ~content:"Green" ~amount:1 in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index 25c3b57d806a..9ee6e2dea078 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -55,7 +55,7 @@ let wrap m = m >|= Environment.wrap_tzresult let big_map_updates_of_key_values ctxt key_values = List.fold_right_es (fun (key, value) (kvs, ctxt) -> - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap (Script_ir_translator.hash_comparable_data ctxt @@ -74,10 +74,10 @@ let big_map_updates_of_key_values ctxt key_values = ([], ctxt) let new_int_key_big_map ctxt contract ~value_type entries = - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in let key_type = Expr.from_string "int" in let value_type = Expr.from_string value_type in - let* (updates, ctxt) = + let* updates, ctxt = big_map_updates_of_key_values ctxt @@ List.map (fun (k, v) -> (k, Some v)) entries in @@ -99,7 +99,7 @@ let assert_equal_string_list ~loc msg = let string_of_ticket_token ctxt (Ticket_token.Ex_token {ticketer; contents_type; contents}) = - let* (x, _) = + let* x, _ = wrap @@ Script_ir_translator.unparse_comparable_data ctxt @@ -182,7 +182,7 @@ let string_token ~ticketer content = let init ?tx_rollup_enable () = Context.init ?tx_rollup_enable ~consensus_threshold:0 2 >|=? fun (block, contracts) -> - let (src0, src1) = + let src0, src1 = match contracts with src0 :: src1 :: _ -> (src0, src1) | _ -> assert false in let baker = @@ -198,7 +198,7 @@ let originate block ~script ~storage ~src ~baker ~forges_tickets = let script = Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} in - let* (operation, destination) = + let* operation, destination = Op.contract_origination (B block) src ~fee:(Test_tez.of_int 10) ~script in let* incr = @@ -225,7 +225,7 @@ let one_ticketer block = two_ticketers block >|=? fst let nat n = Script_int.(abs @@ of_int n) let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = - let* (orig_contract, script, block) = + let* orig_contract, script, block = originate block ~script ~storage ~src ~baker ~forges_tickets in let* incr = @@ -274,7 +274,7 @@ let delegation_operation ~src = {source = src; operation = Delegation None; nonce = 1} let originate block ~src ~baker ~script ~storage ~forges_tickets = - let* (orig_contract, _script, block) = + let* orig_contract, _script, block = originate block ~script ~storage ~src ~baker ~forges_tickets in let* incr = @@ -285,7 +285,7 @@ let originate block ~src ~baker ~script ~storage ~forges_tickets = let transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters = let open Lwt_result_syntax in let ctxt = Incremental.alpha_ctxt incr in - let* (params_node, ctxt) = + let* params_node, ctxt = wrap (Script_ir_translator.unparse_data ctxt @@ -321,7 +321,7 @@ let transfer_operation_to_tx_rollup ~incr ~src ~parameters_ty ~parameters ~tx_rollup = let open Lwt_result_syntax in let ctxt = Incremental.alpha_ctxt incr in - let* (params_node, ctxt) = + let* params_node, ctxt = wrap (Script_ir_translator.unparse_data ctxt @@ -401,16 +401,16 @@ let transfer_tickets_operation ~incr ~src ~destination tickets = (** Test that no tickets are returned for operations that do not contain tickets. *) let test_non_ticket_operations () = - let* (_baker, src, block) = init () in + let* _baker, src, block = init () in let* incr = Incremental.begin_construction block in let operations = [delegation_operation ~src] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr operations in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr operations in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer to a contract that does not take tickets. *) let test_transfer_to_non_ticket_contract () = - let* (baker, src, block) = init () in - let* (orig_contract, incr) = + let* baker, src, block = init () in + let* orig_contract, incr = originate block ~src @@ -419,7 +419,7 @@ let test_transfer_to_non_ticket_contract () = ~storage:"Unit" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_operation ~incr ~src @@ -427,13 +427,13 @@ let test_transfer_to_non_ticket_contract () = ~parameters_ty:unit_t ~parameters:() in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer an empty list of tickets. *) let test_transfer_empty_ticket_list () = - let* (baker, src, block) = init () in - let* (orig_contract, incr) = + let* baker, src, block = init () in + let* orig_contract, incr = originate block ~src @@ -442,17 +442,17 @@ let test_transfer_empty_ticket_list () = ~storage:"{}" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_tickets_operation ~incr ~src ~destination:orig_contract [] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer a list of one ticket. *) let test_transfer_one_ticket () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in - let* (orig_contract, incr) = + let* orig_contract, incr = originate block ~src @@ -461,14 +461,14 @@ let test_transfer_one_ticket () = ~storage:"{}" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_tickets_operation ~incr ~src ~destination:orig_contract [(ticketer, "white", 1)] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -484,9 +484,9 @@ let test_transfer_one_ticket () = (** Test transfer a list of multiple tickets. *) let test_transfer_multiple_tickets () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in - let* (orig_contract, incr) = + let* orig_contract, incr = originate block ~src @@ -495,7 +495,7 @@ let test_transfer_multiple_tickets () = ~storage:"{}" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_tickets_operation ~incr ~src @@ -507,7 +507,7 @@ let test_transfer_multiple_tickets () = (ticketer, "red", 4); ] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -533,9 +533,9 @@ let test_transfer_multiple_tickets () = (** Test transfer a list of tickets of different types. *) let test_transfer_different_tickets () = - let* (baker, src, block) = init () in - let* (ticketer1, ticketer2) = two_ticketers block in - let* (destination, incr) = + let* baker, src, block = init () in + let* ticketer1, ticketer2 = two_ticketers block in + let* destination, incr = originate block ~src @@ -544,7 +544,7 @@ let test_transfer_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_tickets_operation ~incr ~src @@ -561,7 +561,7 @@ let test_transfer_different_tickets () = (ticketer1, "blue", 1); ] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -602,12 +602,12 @@ let test_transfer_different_tickets () = (** Test transfer to two contracts with different types of tickets. *) let test_transfer_to_two_contracts_with_different_tickets () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let parameters = [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] in - let* (destination1, incr) = + let* destination1, incr = originate block ~src @@ -616,11 +616,11 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let* (operation1, incr) = + let* operation1, incr = transfer_tickets_operation ~incr ~src ~destination:destination1 parameters in let* block = Incremental.finalize_block incr in - let* (destination2, incr) = + let* destination2, incr = originate block ~src @@ -629,10 +629,10 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let* (operation2, incr) = + let* operation2, incr = transfer_tickets_operation ~incr ~src ~destination:destination2 parameters in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation1; operation2] in assert_equal_ticket_token_diffs @@ -672,8 +672,8 @@ let test_transfer_to_two_contracts_with_different_tickets () = (** Test originate a contract that does not contain tickets. *) let test_originate_non_ticket_contract () = - let* (baker, src, block) = init () in - let* (_orig_contract, operation, incr) = + let* baker, src, block = init () in + let* _orig_contract, operation, incr = origination_operation block ~src @@ -682,14 +682,14 @@ let test_originate_non_ticket_contract () = ~storage:"Unit" ~forges_tickets:false in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test originate a contract with an empty list of tickets. *) let test_originate_with_empty_tickets_list () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let storage = "{}" in - let* (_orig_contract, operation, incr) = + let* _orig_contract, operation, incr = origination_operation block ~src @@ -698,17 +698,17 @@ let test_originate_with_empty_tickets_list () = ~storage ~forges_tickets:false in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test originate a contract with a single ticket. *) let test_originate_with_one_ticket () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let storage = Printf.sprintf {|{Pair %S "white" 1}|} (Contract.to_b58check ticketer) in - let* (orig_contract, operation, ctxt) = + let* orig_contract, operation, ctxt = origination_operation block ~src @@ -717,7 +717,7 @@ let test_originate_with_one_ticket () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -733,7 +733,7 @@ let test_originate_with_one_ticket () = (** Test originate a contract with multiple tickets. *) let test_originate_with_multiple_tickets () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let storage = let ticketer_addr = Contract.to_b58check ticketer in @@ -749,7 +749,7 @@ let test_originate_with_multiple_tickets () = ticketer_addr ticketer_addr in - let* (orig_contract, operation, ctxt) = + let* orig_contract, operation, ctxt = origination_operation block ~src @@ -758,7 +758,7 @@ let test_originate_with_multiple_tickets () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -784,8 +784,8 @@ let test_originate_with_multiple_tickets () = (** Test originate a contract with multiple tickets of different types. *) let test_originate_with_different_tickets () = - let* (baker, src, block) = init () in - let* (ticketer1, ticketer2) = two_ticketers block in + let* baker, src, block = init () in + let* ticketer1, ticketer2 = two_ticketers block in let storage = let ticketer1_addr = Contract.to_b58check ticketer1 in let ticketer2_addr = Contract.to_b58check ticketer2 in @@ -811,7 +811,7 @@ let test_originate_with_different_tickets () = ticketer1_addr ticketer1_addr in - let* (orig_contract, operation, ctxt) = + let* orig_contract, operation, ctxt = origination_operation block ~src @@ -820,7 +820,7 @@ let test_originate_with_different_tickets () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -861,7 +861,7 @@ let test_originate_with_different_tickets () = (** Test originate two contracts with multiple tickets of different types. *) let test_originate_two_contracts_with_different_tickets () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let storage = let ticketer_addr = Contract.to_b58check ticketer in @@ -871,7 +871,7 @@ let test_originate_two_contracts_with_different_tickets () = ticketer_addr ticketer_addr in - let* (orig_contract1, operation1, incr) = + let* orig_contract1, operation1, incr = origination_operation block ~src @@ -881,7 +881,7 @@ let test_originate_two_contracts_with_different_tickets () = ~forges_tickets:true in let* block = Incremental.finalize_block incr in - let* (orig_contract2, operations2, incr) = + let* orig_contract2, operations2, incr = origination_operation block ~src @@ -890,7 +890,7 @@ let test_originate_two_contracts_with_different_tickets () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation1; operations2] in assert_equal_ticket_token_diffs @@ -930,7 +930,7 @@ let test_originate_two_contracts_with_different_tickets () = (** Test originate and transfer tickets. *) let test_originate_and_transfer () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let ticketer_addr = Contract.to_b58check ticketer in let storage = @@ -940,7 +940,7 @@ let test_originate_and_transfer () = ticketer_addr ticketer_addr in - let* (orig_contract1, operation1, incr) = + let* orig_contract1, operation1, incr = origination_operation block ~src @@ -950,7 +950,7 @@ let test_originate_and_transfer () = ~forges_tickets:true in let* block = Incremental.finalize_block incr in - let* (destination2, incr) = + let* destination2, incr = originate block ~src @@ -959,14 +959,14 @@ let test_originate_and_transfer () = ~storage:"{}" ~forges_tickets:false in - let* (operation2, incr) = + let* operation2, incr = transfer_tickets_operation ~incr ~src ~destination:destination2 [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation1; operation2] in assert_equal_ticket_token_diffs @@ -1006,14 +1006,14 @@ let test_originate_and_transfer () = (** Test originate a contract with a big-map with tickets inside. *) let test_originate_big_map_with_tickets () = - let* (baker, ticketer, block) = init () in - let* (operation, originated) = + let* baker, ticketer, block = init () in + let* operation, originated = Op.contract_origination (B block) ticketer ~script:Op.dummy_script in let* block = Block.bake ~operation block in let* incr = Incremental.begin_construction block in let ticketer_addr = Contract.to_b58check ticketer in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_int_key_big_map (Incremental.alpha_ctxt incr) originated @@ -1026,7 +1026,7 @@ let test_originate_big_map_with_tickets () = in let incr = Incremental.set_alpha_ctxt incr ctxt in let* block = Incremental.finalize_block incr in - let* (orig_contract, operation, incr) = + let* orig_contract, operation, incr = let storage = Printf.sprintf "%d" @@ Z.to_int (Big_map.Id.unparse_to_z big_map_id) in @@ -1038,7 +1038,7 @@ let test_originate_big_map_with_tickets () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -1064,14 +1064,14 @@ let test_originate_big_map_with_tickets () = (** Test transfer a big-map with tickets. *) let test_transfer_big_map_with_tickets () = - let* (baker, ticketer_contract, block) = init () in - let* (operation, originated) = + let* baker, ticketer_contract, block = init () in + let* operation, originated = Op.contract_origination (B block) ticketer_contract ~script:Op.dummy_script in let* block = Block.bake ~operation block in let* incr = Incremental.begin_construction block in let ticketer_addr = Contract.to_b58check ticketer_contract in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_int_key_big_map (Incremental.alpha_ctxt incr) originated @@ -1084,7 +1084,7 @@ let test_transfer_big_map_with_tickets () = in let incr = Incremental.set_alpha_ctxt incr ctxt in let* block = Incremental.finalize_block incr in - let* (orig_contract, incr) = + let* orig_contract, incr = originate block ~src:ticketer_contract @@ -1110,7 +1110,7 @@ let test_transfer_big_map_with_tickets () = value_type; } in - let* (operation, incr) = + let* operation, incr = transfer_operation ~incr ~src:ticketer_contract @@ -1118,7 +1118,7 @@ let test_transfer_big_map_with_tickets () = ~parameters_ty ~parameters in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -1145,10 +1145,10 @@ let test_transfer_big_map_with_tickets () = (** Test transfer a ticket to a tx_rollup. *) let test_tx_rollup_deposit_one_ticket () = let open Lwt_result_syntax in - let* (_baker, src, block) = init ~tx_rollup_enable:true () in + let* _baker, src, block = init ~tx_rollup_enable:true () in let* ticketer = one_ticketer block in let* incr = Incremental.begin_construction block in - let* (operation, tx_rollup) = + let* operation, tx_rollup = Op.tx_rollup_origination (I incr) src ~fee:(Test_tez.of_int 10) in let* incr = Incremental.add_operation incr operation in @@ -1177,7 +1177,7 @@ let test_tx_rollup_deposit_one_ticket () = (Script_typed_ir.{ticketer; contents; amount}, l2_destination) in - let* (operation, incr) = + let* operation, incr = transfer_operation_to_tx_rollup ~incr ~src @@ -1185,7 +1185,7 @@ let test_tx_rollup_deposit_one_ticket () = ~parameters_ty ~parameters in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index de826ae3b328..5853cd031c3f 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -41,7 +41,7 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult let new_ctxt () = - let* (block, _) = Context.init 1 in + let* block, _ = Context.init 1 in let* incr = Incremental.begin_construction block in return @@ Incremental.alpha_ctxt incr @@ -52,7 +52,7 @@ let string_list_of_ex_tickets ctxt tickets = let accum (xs, ctxt) (Ticket_scanner.Ex_ticket (cty, {Script_typed_ir.ticketer; contents; amount})) = - let* (x, ctxt) = + let* x, ctxt = wrap @@ Script_ir_translator.unparse_data ctxt @@ -79,16 +79,16 @@ let string_list_of_ex_tickets ctxt tickets = in return (str :: xs, ctxt) in - let* (xs, ctxt) = List.fold_left_es accum ([], ctxt) tickets in + let* xs, ctxt = List.fold_left_es accum ([], ctxt) tickets in return (List.rev xs, ctxt) let make_ex_ticket ctxt ~ticketer ~type_exp ~content_exp ~amount = - let* (Script_ir_translator.Ex_comparable_ty cty, ctxt) = + let* Script_ir_translator.Ex_comparable_ty cty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in wrap @@ Lwt.return @@ Script_ir_translator.parse_comparable_ty ctxt node in let* ticketer = wrap @@ Lwt.return @@ Contract.of_b58check ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in wrap @@ Script_ir_translator.parse_comparable_data ctxt cty node in @@ -97,10 +97,8 @@ let make_ex_ticket ctxt ~ticketer ~type_exp ~content_exp ~amount = return (Ticket_scanner.Ex_ticket (cty, ticket), ctxt) let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = - let* (str_tickets, ctxt) = string_list_of_ex_tickets ctxt ex_tickets in - let* (str_tickets_expected, _ctxt) = - string_list_of_ex_tickets ctxt expected - in + let* str_tickets, ctxt = string_list_of_ex_tickets ctxt ex_tickets in + let* str_tickets_expected, _ctxt = string_list_of_ex_tickets ctxt expected in assert_equal_string_list ~loc "Compare with expected tickets" @@ -108,14 +106,14 @@ let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = (List.sort String.compare str_tickets_expected) let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = - let (Script_ir_translator.Ex_ty ty, ctxt) = + let Script_ir_translator.Ex_ty ty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in Result.value_f ~default:(fun () -> Stdlib.failwith "Failed to parse") (Script_ir_translator.parse_any_ty ctxt ~legacy:false node) in let node = Micheline.root @@ Expr.from_string value_exp in - let* (value, ctxt) = + let* value, ctxt = wrap @@ Script_ir_translator.parse_data ctxt @@ -124,14 +122,14 @@ let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = ty node in - let* (ht, ctxt) = + let* ht, ctxt = wrap @@ Lwt.return @@ Ticket_scanner.type_has_tickets ctxt ty in wrap @@ Ticket_scanner.tickets_of_value ctxt ~include_lazy ht value let assert_contains_tickets ctxt ~loc ~include_lazy ~type_exp ~value_exp expected = - let* (ex_tickets, _) = + let* ex_tickets, _ = tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp in assert_equals_ex_tickets ctxt ~loc ex_tickets expected @@ -153,7 +151,7 @@ let assert_fail_non_empty_overlay ctxt ~loc ~include_lazy ~type_exp ~value_exp = let make_string_tickets ctxt ticketer_amounts = List.fold_right_es (fun (ticketer, content, amount) (tickets, ctxt) -> - let* (ticket, ctxt) = + let* ticket, ctxt = make_ex_ticket ctxt ~ticketer @@ -166,21 +164,21 @@ let make_string_tickets ctxt ticketer_amounts = ([], ctxt) let tickets_from_big_map_ref ~pre_populated value_exp = - let* (block, contracts) = Context.init 1 in + let* block, contracts = Context.init 1 in let source = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd contracts in - let* (operation, originated) = + let* operation, originated = Op.contract_origination (B block) source ~script:Op.dummy_script in let* block = Block.bake ~operation block in let* inc = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt inc in - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in let int_ty_expr = Expr.from_string "int" in - let* (diffs, ctxt) = - let* (updates, ctxt) = + let* diffs, ctxt = + let* updates, ctxt = List.fold_left_es (fun (kvs, ctxt) (key, value) -> - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap @@ Script_ir_translator.hash_comparable_data ctxt @@ -222,10 +220,8 @@ let tickets_from_big_map_ref ~pre_populated value_exp = let assert_big_map_int_ticket_string_ref ~loc ~pre_populated ~big_map_exp ex_tickets = - let* (value_exp, ctxt) = - tickets_from_big_map_ref ~pre_populated big_map_exp - in - let* (ex_tickets, ctxt) = make_string_tickets ctxt ex_tickets in + let* value_exp, ctxt = tickets_from_big_map_ref ~pre_populated big_map_exp in + let* ex_tickets, ctxt = make_string_tickets ctxt ex_tickets in assert_contains_tickets ctxt ~include_lazy:true @@ -236,9 +232,7 @@ let assert_big_map_int_ticket_string_ref ~loc ~pre_populated ~big_map_exp let assert_fail_non_empty_overlay_with_big_map_ref ~loc ~pre_populated ~big_map_exp = - let* (value_exp, ctxt) = - tickets_from_big_map_ref ~pre_populated big_map_exp - in + let* value_exp, ctxt = tickets_from_big_map_ref ~pre_populated big_map_exp in assert_fail_non_empty_overlay ctxt ~include_lazy:true @@ -251,7 +245,7 @@ let test_tickets_in_unit_ticket () = let* ctxt = new_ctxt () in let type_exp = "ticket(unit)" in let value_exp = {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" Unit 10|} in - let* (ex_ticket, ctxt) = + let* ex_ticket, ctxt = make_ex_ticket ctxt ~ticketer:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" @@ -269,7 +263,7 @@ let test_tickets_in_unit_ticket () = let assert_string_tickets ~loc ~include_lazy ~type_exp ~value_exp ~expected = let* ctxt = new_ctxt () in - let* (ex_tickets, ctxt) = make_string_tickets ctxt expected in + let* ex_tickets, ctxt = make_string_tickets ctxt expected in assert_contains_tickets ctxt ~include_lazy diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_storage.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_storage.ml index 6056bd184956..d1dc2f57b491 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_ticket_storage.ml @@ -40,7 +40,7 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult let make_context () = - let* (block, _) = Context.init 1 in + let* block, _ = Context.init 1 in let* incr = Incremental.begin_construction block in return (Incremental.alpha_ctxt incr) @@ -54,13 +54,13 @@ let hash_key ctxt ~ticketer ~ty ~contents ~owner = (Alpha_context.Ticket_hash.make ctxt ~ticketer ~ty ~contents ~owner) let assert_balance ctxt ~loc key expected = - let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + let* balance, _ = wrap @@ Ticket_balance.get_balance ctxt key in match balance with | Some b -> Assert.equal_int ~loc (Z.to_int b) expected | None -> failwith "Expected balance %d" expected let assert_no_balance ctxt key = - let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + let* balance, _ = wrap @@ Ticket_balance.get_balance ctxt key in match balance with | Some b -> failwith "Expected empty (none) balance but got %d" (Z.to_int b) | None -> return () @@ -71,10 +71,10 @@ let adjust_balance ctxt key delta = let assert_non_overlapping_keys ~loc ~ticketer1 ~ticketer2 ~contents1 ~contents2 ~ty1 ~ty2 ~owner1 ~owner2 = let* ctxt = make_context () in - let* (k1, ctxt) = + let* k1, ctxt = hash_key ctxt ~ticketer:ticketer1 ~ty:ty1 ~contents:contents1 ~owner:owner1 in - let* (k2, _ctxt) = + let* k2, _ctxt = hash_key ctxt ~ticketer:ticketer2 ~ty:ty2 ~contents:contents2 ~owner:owner2 in Assert.not_equal @@ -150,18 +150,18 @@ let test_non_overlapping_keys_owner () = *) let test_ticket_balance_single_update () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in assert_balance ctxt ~loc:__LOC__ alice_red 1 (** Test that updating the ticket-balance table with different keys updates both entries. *) let test_ticket_balance_different_owners () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (alice_blue, ctxt) = make_key ctxt "alice_blue" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in - let* (_, ctxt) = adjust_balance ctxt alice_blue 1 in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* alice_blue, ctxt = make_key ctxt "alice_blue" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in + let* _, ctxt = adjust_balance ctxt alice_blue 1 in let* () = assert_balance ctxt ~loc:__LOC__ alice_red 1 in let* () = assert_balance ctxt ~loc:__LOC__ alice_blue 1 in return () @@ -170,33 +170,33 @@ let test_ticket_balance_different_owners () = the net result of all balance updates *) let test_ticket_balance_multiple_updates () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in - let* (_, ctxt) = adjust_balance ctxt alice_red 2 in - let* (_, ctxt) = adjust_balance ctxt alice_red (-1) in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in + let* _, ctxt = adjust_balance ctxt alice_red 2 in + let* _, ctxt = adjust_balance ctxt alice_red (-1) in assert_balance ctxt ~loc:__LOC__ alice_red 2 (** Test that with no updates to the table, no balance is present in the table *) let test_empty_balance () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* alice_red, ctxt = make_key ctxt "alice_red" in assert_no_balance ctxt alice_red (** Test that adding one entry with positive balance and then updating with a negative balance also removes the entry *) let test_empty_balance_after_update () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in - let* (_, ctxt) = adjust_balance ctxt alice_red (-1) in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in + let* _, ctxt = adjust_balance ctxt alice_red (-1) in assert_no_balance ctxt alice_red (** Test that attempting to update an entry with a negative balance results in an error. *) let test_negative_balance () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* alice_red, ctxt = make_key ctxt "alice_red" in adjust_balance ctxt alice_red (-1) >>= fun res -> Assert.proto_error ~loc:__LOC__ res (fun _err -> true) @@ -205,20 +205,20 @@ let test_negative_balance () = *) let test_storage_space () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* alice_red, ctxt = make_key ctxt "alice_red" in (* Space for adding an entry is 65 for the key plus 1 for the value. *) - let* (space, ctxt) = adjust_balance ctxt alice_red 1 in + let* space, ctxt = adjust_balance ctxt alice_red 1 in let* () = Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) in (* Adding one does not consume additional space. *) - let* (space, ctxt) = adjust_balance ctxt alice_red 1 in + let* space, ctxt = adjust_balance ctxt alice_red 1 in let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in (* Adding a big balance costs extra. *) - let* (space, ctxt) = adjust_balance ctxt alice_red 1000 in + let* space, ctxt = adjust_balance ctxt alice_red 1000 in let* () = Assert.equal_int ~loc:__LOC__ 1 (Z.to_int space) in (* Reset balance to zero should free up space. The freed up space is 65 for the key + 2 for the value *) - let* (b, ctxt) = wrap @@ Ticket_balance.get_balance ctxt alice_red in - let* (space, ctxt) = + let* b, ctxt = wrap @@ Ticket_balance.get_balance ctxt alice_red in + let* space, ctxt = wrap (Ticket_balance.adjust_balance ctxt @@ -227,10 +227,10 @@ let test_storage_space () = in let* () = Assert.equal_int ~loc:__LOC__ (-67) (Z.to_int space) in (* Adjusting the space to 0 again should not free anything *) - let* (space, ctxt) = adjust_balance ctxt alice_red 0 in + let* space, ctxt = adjust_balance ctxt alice_red 0 in let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in (* Adding a balance requiers extra space. *) - let* (space, _) = adjust_balance ctxt alice_red 10 in + let* space, _ = adjust_balance ctxt alice_red 10 in Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) let tests = diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_timelock.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_timelock.ml index 3ef50a35a565..558a2691c42d 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_timelock.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_timelock.ml @@ -36,11 +36,11 @@ open Protocol let wrap e = Lwt.return (Environment.wrap_tzresult e) let simple_test () = - let (public, secret) = Timelock.gen_rsa_keys () in + let public, secret = Timelock.gen_rsa_keys () in let locked_value = Timelock.gen_locked_value public in let time = 1000 in let unlocked_value = Timelock.unlock_with_secret secret ~time locked_value in - let (same_unlocked, proof) = + let same_unlocked, proof = Timelock.unlock_and_prove_without_secret public ~time locked_value in assert (unlocked_value = same_unlocked) ; @@ -78,11 +78,11 @@ let contract_test () = Context.init ~consensus_threshold:0 3 >>=? fun (b, contracts) -> let src = match contracts with hd :: _ -> hd | _ -> assert false in originate_contract "contracts/timelock.tz" "0xaa" src b >>=? fun (dst, b) -> - let (public, secret) = Timelock.gen_rsa_keys () in + let public, secret = Timelock.gen_rsa_keys () in let locked_value = Timelock.gen_locked_value public in let time = 1000 in let unlocked_value = Timelock.unlock_with_secret secret ~time locked_value in - let (_same_unlocked, proof) = + let _same_unlocked, proof = Timelock.unlock_and_prove_without_secret public ~time locked_value in let sym_key = Timelock.unlocked_value_to_symmetric_key unlocked_value in @@ -139,13 +139,13 @@ let contract_test () = (Hex.show (Hex.of_bytes message)) >>=? fun () -> (* We redo an RSA parameters generation to create incorrect cipher and proof *) - let (public_bogus, secret_bogus) = Timelock.gen_rsa_keys () in + let public_bogus, secret_bogus = Timelock.gen_rsa_keys () in let locked_value_bogus = Timelock.gen_locked_value public_bogus in let time = 1000 in let unlocked_value_bogus = Timelock.unlock_with_secret secret_bogus ~time locked_value_bogus in - let (_same_unlocked, proof_bogus) = + let _same_unlocked, proof_bogus = Timelock.unlock_and_prove_without_secret public ~time locked_value_bogus in let sym_key_bogus = diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_typechecking.ml index be2a0ae79b15..91fe2fa01ad6 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -461,10 +461,10 @@ let test_parse_comb_data () = (a, ac1) Script_typed_ir.ty -> (a, ac2) Script_typed_ir.ty -> bool = fun ty1 ty2 -> match Script_typed_ir.(is_comparable ty1, is_comparable ty2) with - | (Yes, Yes) -> ty1 = ty2 - | (No, No) -> ty1 = ty2 - | (Yes, No) -> assert false - | (No, Yes) -> assert false + | Yes, Yes -> ty1 = ty2 + | No, No -> ty1 = ty2 + | Yes, No -> assert false + | No, Yes -> assert false (* These last two cases can't happen because the comparable character of a type is a function of its concrete type. @@ -628,9 +628,9 @@ let test_optimal_comb () = ty v >>=? fun (unparsed, ctxt) -> - let (unparsed_canonical, unparsed_size) = size_of_micheline unparsed in + let unparsed_canonical, unparsed_size = size_of_micheline unparsed in List.iter_es (fun other_repr -> - let (other_repr_canonical, other_repr_size) = + let other_repr_canonical, other_repr_size = size_of_micheline other_repr in if other_repr_size < unparsed_size then @@ -669,7 +669,7 @@ let test_optimal_comb () = (* Check that UNPACK on contract is forbidden. See https://gitlab.com/tezos/tezos/-/issues/301 for the motivation behind this restriction. - *) +*) let test_contract_not_packable () = let contract_unit = Prim (0, Script.T_contract, [Prim (0, T_unit, [], [])], []) diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_activation.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_activation.ml index 0304dc2ddd63..c9adbc3a4bdc 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_activation.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_activation.ml @@ -95,7 +95,7 @@ let secrets () = in List.map (fun (mnemonic, secret, amount, pkh, password, email) -> - let (pkh', pk, sk) = read_key mnemonic email password in + let pkh', pk, sk = read_key mnemonic email password in let pkh = Signature.Public_key_hash.of_b58check_exn pkh in assert (Signature.Public_key_hash.equal pkh pkh') ; let account = Account.{pkh; pk; sk} in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_combined_operations.ml index 43fc555cde62..70451a0a4892 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_combined_operations.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_combined_operations.ml @@ -53,7 +53,7 @@ let gas_limit = Alpha_context.Gas.Arith.integral_of_int_exn 3000 (** Groups ten transactions between the same parties. *) let test_multiple_transfers () = Context.init 3 >>=? fun (blk, contracts) -> - let (c1, c2, c3) = + let c1, c2, c3 = match contracts with [c1; c2; c3] -> (c1, c2, c3) | _ -> assert false in List.map_es @@ -85,7 +85,7 @@ let test_multiple_transfers () = (** Groups ten delegated originations. *) let test_multiple_origination_and_delegation () = Context.init 2 >>=? fun (blk, contracts) -> - let (c1, c2) = + let c1, c2 = match contracts with [c1; c2] -> (c1, c2) | _ -> assert false in let n = 10 in @@ -108,7 +108,7 @@ let test_multiple_origination_and_delegation () = >>=? fun originations -> (* These computed originated contracts are not the ones really created *) (* We will extract them from the tickets *) - let (originations_operations, _) = List.split originations in + let originations_operations, _ = List.split originations in Op.combine_operations ~source:c1 (B blk) originations_operations >>=? fun operation -> Incremental.begin_construction blk >>=? fun inc -> @@ -173,7 +173,7 @@ let expect_failure = function Variant without fees. *) let test_failing_operation_in_the_middle () = Context.init 2 >>=? fun (blk, contracts) -> - let (c1, c2) = + let c1, c2 = match contracts with [c1; c2] -> (c1, c2) | _ -> assert false in Op.transaction ~gas_limit ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op1 -> @@ -202,9 +202,9 @@ let test_failing_operation_in_the_middle () = (Manager_operation_result {operation_result = Backtracked _; _}) :: Contents_result (Manager_operation_result {operation_result = Failed (_, trace); _}) - :: Contents_result - (Manager_operation_result {operation_result = Skipped _; _}) - :: _ -> + :: Contents_result + (Manager_operation_result {operation_result = Skipped _; _}) + :: _ -> let trace_string = Format.asprintf "%a" Environment.Error_monad.pp_trace trace in @@ -222,7 +222,7 @@ let test_failing_operation_in_the_middle () = Variant with fees, that should be spent even in case of failure. *) let test_failing_operation_in_the_middle_with_fees () = Context.init 2 >>=? fun (blk, contracts) -> - let (c1, c2) = + let c1, c2 = match contracts with [c1; c2] -> (c1, c2) | _ -> assert false in Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> @@ -250,9 +250,9 @@ let test_failing_operation_in_the_middle_with_fees () = (Manager_operation_result {operation_result = Backtracked _; _}) :: Contents_result (Manager_operation_result {operation_result = Failed (_, trace); _}) - :: Contents_result - (Manager_operation_result {operation_result = Skipped _; _}) - :: _ -> + :: Contents_result + (Manager_operation_result {operation_result = Skipped _; _}) + :: _ -> let trace_string = Format.asprintf "%a" Environment.Error_monad.pp_trace trace in @@ -274,8 +274,8 @@ let test_failing_operation_in_the_middle_with_fees () = let test_wrong_signature_in_the_middle () = Context.init 2 >>=? function - | (_, []) | (_, [_]) -> assert false - | (blk, c1 :: c2 :: _) -> + | _, [] | _, [_] -> assert false + | blk, c1 :: c2 :: _ -> Op.transaction ~gas_limit ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~gas_limit ~fee:Tez.one (B blk) c2 c1 Tez.one @@ -340,7 +340,7 @@ let expect_inconsistent_counters list = let test_inconsistent_counters () = Context.init 2 >>=? fun (blk, contracts) -> - let (c1, c2) = + let c1, c2 = match contracts with [c1; c2] -> (c1, c2) | _ -> assert false in Op.transaction ~gas_limit ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_sc_rollup.ml index 468484621844..bb4686b8f2fb 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -57,13 +57,13 @@ let context_init n = rollup when the feature flag is deactivated and checks that it fails. *) let test_disable_feature_flag () = - let* (b, contracts) = Context.init 1 in + let* b, contracts = Context.init 1 in let contract = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth contracts 0 in let* i = Incremental.begin_construction b in let kind = Sc_rollup.Kind.Example_arith in - let* (op, _) = Op.sc_rollup_origination (I i) contract kind "" in + let* op, _ = Op.sc_rollup_origination (I i) contract kind "" in let expect_failure = function | Environment.Ecoproto_error (Apply.Sc_rollup_feature_disabled as e) :: _ -> Assert.test_error_encodings e ; @@ -109,14 +109,12 @@ let test_sc_rollups_all_well_defined () = (** Initializes the context and originates a SCORU. *) let init_and_originate n = - let* (ctxt, contracts) = context_init n in + let* ctxt, contracts = context_init n in let contract = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth contracts 0 in let kind = Sc_rollup.Kind.Example_arith in - let* (operation, rollup) = - Op.sc_rollup_origination (B ctxt) contract kind "" - in + let* operation, rollup = Op.sc_rollup_origination (B ctxt) contract kind "" in let* b = Block.bake ~operation ctxt in return (b, contracts, rollup) @@ -150,7 +148,7 @@ let dummy_commitment = (** [test_publish_and_cement] creates a rollup, publishes a commitment and then 20 blocks later cements that commitment *) let test_publish_and_cement () = - let* (ctxt, contracts, rollup) = init_and_originate 2 in + let* ctxt, contracts, rollup = init_and_originate 2 in let contract = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth contracts 1 in @@ -172,7 +170,7 @@ let test_publish_and_cement () = without waiting for the challenge period to elapse. We check that this fails with the correct error. *) let test_cement_fails_if_premature () = - let* (ctxt, contracts, rollup) = init_and_originate 2 in + let* ctxt, contracts, rollup = init_and_originate 2 in let contract = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth contracts 1 in @@ -200,7 +198,7 @@ let test_cement_fails_if_premature () = publishes two different commitments with the same staker. We check that the second publish fails. *) let test_publish_fails_on_backtrack () = - let* (ctxt, contracts, rollup) = init_and_originate 2 in + let* ctxt, contracts, rollup = init_and_originate 2 in let contract = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth contracts 1 in @@ -230,7 +228,7 @@ let test_publish_fails_on_backtrack () = cement one of the commitments; it checks that this fails because the commitment is contested. *) let test_cement_fails_on_conflict () = - let* (ctxt, contracts, rollup) = init_and_originate 3 in + let* ctxt, contracts, rollup = init_and_originate 3 in let contract1 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth contracts 1 in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml index 869705db7aae..75aa3f939b88 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -244,8 +244,8 @@ let context_init1 ?tx_rollup_max_inboxes_count ?tx_rollup_hard_size_limit_per_message 1 >|=? function - | (b, contract_1 :: _) -> (b, contract_1) - | (_, _) -> assert false + | b, contract_1 :: _ -> (b, contract_1) + | _, _ -> assert false (** [context_init2] initializes a context with no consensus rewards to not interfere with balances prediction. It returns the created @@ -258,8 +258,8 @@ let context_init2 ?tx_rollup_max_inboxes_count ?cost_per_byte 2 >|=? function - | (b, contract_1 :: contract_2 :: _) -> (b, contract_1, contract_2) - | (_, _) -> assert false + | b, contract_1 :: contract_2 :: _ -> (b, contract_1, contract_2) + | _, _ -> assert false (** [originate b contract] originates a tx_rollup from [contract], and returns the new block and the tx_rollup address. *) @@ -391,7 +391,7 @@ let make_deposit b tx_rollup l1_src addr = Block.bake ~operation b >>=? fun b -> make_unit_ticket_key (B b) ~ticketer:contract tx_rollup >>=? fun ticket_hash -> - let (deposit, cumulated_size) = + let deposit, cumulated_size = Tx_rollup_message.make_deposit (is_implicit_exn l1_src) (Tx_rollup_l2_address.Indexable.value addr) @@ -469,11 +469,11 @@ let assert_ticket_balance ~loc block token owner expected = >>=? fun (key_hash, ctxt) -> wrap_lwt (Ticket_balance.get_balance ctxt key_hash) >>=? fun (balance, _) -> match (balance, expected) with - | (Some b, Some e) -> Assert.equal_int ~loc (Z.to_int b) e - | (Some b, None) -> + | Some b, Some e -> Assert.equal_int ~loc (Z.to_int b) e + | Some b, None -> failwith "%s: Expected no balance but got some %d" loc (Z.to_int b) - | (None, Some b) -> failwith "%s: Expected balance %d but got none" loc b - | (None, None) -> return () + | None, Some b -> failwith "%s: Expected balance %d but got none" loc b + | None, None -> return () module Nat_ticket = struct let ty_str = "nat" @@ -943,7 +943,7 @@ let test_inbox_size_too_big () = (** Try to add enough batches to reach the batch count limit of an inbox. *) let test_inbox_count_too_big () = context_init1 () >>=? fun (b, contract) -> - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in Context.get_constants (B b) >>=? fun constant -> let message_count = constant.parametric.tx_rollup_max_messages_per_inbox in let contents = "some contents" in @@ -1020,7 +1020,7 @@ let test_inbox_count_too_big () = (** [test_valid_deposit] checks that a smart contract can deposit tickets to a transaction rollup. *) let test_valid_deposit () = - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> make_deposit b tx_rollup account addr @@ -1044,7 +1044,7 @@ let test_valid_deposit () = (** [test_additional_space_allocation_for_valid_deposit] originates a tx rollup with small [tx_rollup_origination_size], make a valid deposit and check additional space allocation *) let test_additional_space_allocation_for_valid_deposit () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in let tx_rollup_origination_size = 1 in context_init1 ~tx_rollup_origination_size () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> @@ -1077,7 +1077,7 @@ let test_additional_space_allocation_for_valid_deposit () = interpreter checks the existence of a transaction rollup prior to sending a deposit order. *) let test_valid_deposit_inexistant_rollup () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> Contract_helpers.originate_contract "contracts/tx_rollup_deposit.tz" @@ -1104,7 +1104,7 @@ let test_valid_deposit_inexistant_rollup () = (** [test_invalid_deposit_not_contract] checks a smart contract cannot deposit something that is not a ticket. *) let test_invalid_deposit_not_ticket () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> @@ -1137,7 +1137,7 @@ let string_ticket_of_size expected_size = let ticket_contents_ty = Tezos_micheline.Micheline.Prim (0, Michelson_v1_primitives.T_string, [], []) in - let (_, ticket_contents_ty_size) = + let _, ticket_contents_ty_size = Script_typed_ir_size.node_size ticket_contents_ty in Alcotest.( @@ -1146,7 +1146,7 @@ let string_ticket_of_size expected_size = "Expected size of ticket_contents type" (Saturation_repr.of_int_opt 40) (Some ticket_contents_ty_size)) ; - let (_, empty_string_size) = + let _, empty_string_size = Script_typed_ir_size.node_size (Expr_common.string "") in let ticket_contents = @@ -1157,7 +1157,7 @@ let string_ticket_of_size expected_size = - Saturation_repr.to_int empty_string_size) 'a') in - let (_, ticket_contents_size) = + let _, ticket_contents_size = Script_typed_ir_size.node_size ticket_contents in Alcotest.( @@ -1171,7 +1171,7 @@ let string_ticket_of_size expected_size = (** [test_invalid_deposit_too_big_ticket] tests that depositing a ticket that has a content whose size exceeds [tx_rollup_max_ticket_payload_size] fails.*) let test_invalid_deposit_too_big_ticket () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> Context.get_constants (B b) >>=? fun constant -> let tx_rollup_max_ticket_payload_size = @@ -1222,7 +1222,7 @@ let test_invalid_deposit_too_big_ticket () = ticket that has a content and type whose summed size exceeds [tx_rollup_max_ticket_payload_size] fails.*) let test_invalid_deposit_too_big_ticket_type () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> Context.get_constants (B b) >>=? fun constant -> let tx_rollup_max_ticket_payload_size = @@ -1272,7 +1272,7 @@ let test_invalid_deposit_too_big_ticket_type () = (** [test_valid_deposit_big_ticket] tests that depositing a ticket whose size is exactly [tx_rollup_max_ticket_payload_size] succeeds.*) let test_valid_deposit_big_ticket () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in (* [overhead] is the number of bytes introduced by the wrapping of a string in a ticket. This encompasses the ticketer, amount and ty fields. @@ -1322,7 +1322,7 @@ let test_valid_deposit_big_ticket () = (** [test_invalid_entrypoint] checks that a transaction to an invalid entrypoint of a transaction rollup fails. *) let test_invalid_entrypoint () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> @@ -1376,7 +1376,7 @@ let test_invalid_l2_address () = (** [test_valid_deposit_invalid_amount] checks that a transaction to a transaction rollup fails if the [amount] parameter is not null. *) let test_valid_deposit_invalid_amount () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> Contract_helpers.originate_contract @@ -1401,7 +1401,7 @@ let test_valid_deposit_invalid_amount () = too many tickets is rejected *) let test_deposit_too_many_tickets () = let too_many = Z.succ (Z.of_int64 Int64.max_int) in - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init 1 >>=? fun (block, accounts) -> let account1 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth accounts 0 @@ -1625,7 +1625,7 @@ let test_commit_current_inbox () = (* In order to have a permissible commitment, we need a transaction. *) Incremental.begin_construction b >>=? fun i -> let contents = "batch" in - let (message, _) = Tx_rollup_message.make_batch contents in + let message, _ = Tx_rollup_message.make_batch contents in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let inbox_hash = Tx_rollup_inbox.Merkle.merklize_list [message_hash] in Op.tx_rollup_submit_batch (I i) contract1 tx_rollup contents @@ -2218,7 +2218,7 @@ module Rejection = struct let run_transaction ctxt l2_parameters msg = let open Prover_context.Syntax in - let* (ctxt, _) = Prover_apply.apply_message ctxt l2_parameters msg in + let* ctxt, _ = Prover_apply.apply_message ctxt l2_parameters msg in return ctxt let time () = @@ -2282,7 +2282,7 @@ module Rejection = struct let open Context.Syntax in let index = C.index store in let* hash = hash_tree_from_store store in - let* (proof, ()) = + let* proof, () = C.produce_stream_proof index (`Node hash) (fun ctxt -> catch (run_transaction ctxt l2_parameters msg) @@ -2294,7 +2294,7 @@ module Rejection = struct let valid_empty_proof l2_parameters = let open Context.Syntax in let* l2_store = init_l2_store () in - let (message, _) = Tx_rollup_message.make_batch "bogus" in + let message, _ = Tx_rollup_message.make_batch "bogus" in make_proof l2_store l2_parameters message let invalid_proof : Tx_rollup_l2_proof.t = @@ -2310,10 +2310,10 @@ module Rejection = struct let replace_commitment ~l2_parameters ~store ~commitment messages = let open Context in let open Syntax in - let* (_, rev_results) = + let* _, rev_results = list_fold_left_m (fun (store, rev_results) msg -> - let* (store, withdraws) = + let* store, withdraws = catch (Apply.apply_message store l2_parameters msg) (fun (store, (_, withdraws)) -> return (store, withdraws)) @@ -2398,7 +2398,7 @@ module Rejection = struct l2_parameters (I i) >>=? fun l2_parameters -> make_proof store l2_parameters deposit >>= fun proof -> Incremental.begin_construction b >>=? fun i -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -2481,13 +2481,13 @@ module Rejection = struct (** Test that we can produce a simple but valid proof. *) let test_valid_proof_on_invalid_commitment () = - let (sk, pk, addr) = gen_l2_account () in + let sk, pk, addr = gen_l2_account () in init_with_deposit addr >>=? fun (b, account, tx_rollup, store, ticket_hash) -> hash_tree_from_store store >>= fun l2_context_hash -> (* Create a transfer from [pk] to a new address *) - let (_, _, addr2) = gen_l2_account () in - let (message, batch_bytes) = + let _, _, addr2 = gen_l2_account () in + let message, batch_bytes = make_message_transfer ~signers:[sk] [(bls_pk pk, None, [(addr2, ticket_hash, 1L)])] @@ -2512,7 +2512,7 @@ module Rejection = struct (* Now we produce a valid proof rejecting the commitment *) l2_parameters (I i) >>=? fun l2_parameters -> make_proof store l2_parameters message >>= fun proof -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -2538,13 +2538,13 @@ module Rejection = struct (** It is really similar to {!test_valid_proof_on_invalid_commitment} but it tries to reject a valid commitment, thus, fails. *) let test_valid_proof_on_valid_commitment () = - let (sk, pk, addr) = gen_l2_account () in + let sk, pk, addr = gen_l2_account () in init_with_deposit addr >>=? fun (b, account, tx_rollup, store, ticket_hash) -> hash_tree_from_store store >>= fun l2_context_hash -> (* Create a transfer from [pk] to a new address *) - let (_, _, addr2) = gen_l2_account () in - let (message, batch_bytes) = + let _, _, addr2 = gen_l2_account () in + let message, batch_bytes = make_message_transfer ~signers:[sk] [(bls_pk pk, None, [(addr2, ticket_hash, 1L)])] @@ -2569,7 +2569,7 @@ module Rejection = struct (* Now we produce a valid proof rejecting the commitment *) l2_parameters (B b) >>=? fun l2_parameters -> make_proof store l2_parameters message >>= fun proof -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -2604,11 +2604,11 @@ module Rejection = struct message whose l2 apply will fail in whatever specific way we wish to test. *) let do_test_proof_with_hard_fail_message make_bad_message = - let (sk, pk, addr) = gen_l2_account () in + let sk, pk, addr = gen_l2_account () in init_with_deposit addr >>=? fun (b, account, tx_rollup, store, ticket_hash) -> hash_tree_from_store store >>= fun l2_context_hash -> - let (message, batch_bytes) = make_bad_message sk pk addr ticket_hash in + let message, batch_bytes = make_bad_message sk pk addr ticket_hash in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = match Tx_rollup_inbox.Merkle.(compute_path [message_hash] 0) with @@ -2629,7 +2629,7 @@ module Rejection = struct (* Now we produce a valid proof rejecting the commitment *) l2_parameters (B b) >>=? fun l2_parameters -> make_proof store l2_parameters message >>= fun proof -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -2658,7 +2658,7 @@ module Rejection = struct do_test_proof_with_hard_fail_message (fun _sk pk addr ticket_hash -> (* We build a dummy transfer, we don't care about the content, it will hard fail on the check signature. *) - let (random_sk, _, _) = gen_l2_account () in + let random_sk, _, _ = gen_l2_account () in make_message_transfer ~signers:[random_sk] [(Bls_pk pk, None, [(addr, ticket_hash, 1L)])]) @@ -2668,14 +2668,14 @@ module Rejection = struct let test_proof_with_unparsable_batch () = do_test_proof_with_hard_fail_message (fun _sk _pk _addr _ticket_hash -> let message = "wrong" in - let (batch, _) = Tx_rollup_message.make_batch message in + let batch, _ = Tx_rollup_message.make_batch message in (batch, message)) (** Test that proof production and verification can handle an invalid counter *) let test_proof_with_invalid_counter () = do_test_proof_with_hard_fail_message (fun sk pk _addr ticket_hash -> - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in make_message_transfer ~signers:[sk] [(Bls_pk pk, Some 42L, [(addr, ticket_hash, 1L)])]) @@ -2703,7 +2703,7 @@ module Rejection = struct let test_empty_proof_on_invalid_message () = init_with_valid_commitment () >>=? fun (i, contract, tx_rollup, level, message, commitment) -> - let (msg, _) = Tx_rollup_message.make_batch message in + let msg, _ = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated msg in let message_path = match Tx_rollup_inbox.Merkle.(compute_path [message_hash] 0) with @@ -2712,7 +2712,7 @@ module Rejection = struct in l2_parameters (I i) >>=? fun l2_parameters -> valid_empty_proof l2_parameters >>= fun proof -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -2735,14 +2735,14 @@ module Rejection = struct let test_invalid_proof_on_invalid_commitment () = init_with_valid_commitment () >>=? fun (i, contract, tx_rollup, level, message, commitment) -> - let (msg, _) = Tx_rollup_message.make_batch message in + let msg, _ = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated msg in let message_path = match Tx_rollup_inbox.Merkle.(compute_path [message_hash] 0) with | Error _ -> assert false | Ok path -> path in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -2771,7 +2771,7 @@ module Rejection = struct let test_invalid_agreed () = init_with_valid_commitment () >>=? fun (i, contract, tx_rollup, level, message, commitment) -> - let (msg, _) = Tx_rollup_message.make_batch message in + let msg, _ = Tx_rollup_message.make_batch message in (* This intentionally does not match *) let previous_message_result : Tx_rollup_message_result.t = { @@ -2786,7 +2786,7 @@ module Rejection = struct | Error _ -> assert false | Ok path -> path in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -2834,7 +2834,7 @@ module Rejection = struct Block.bake ~operation b >>=? fun b -> Incremental.begin_construction b >>=? fun i -> let level = Tx_rollup_level.root in - let (message, _size) = Tx_rollup_message.make_batch message in + let message, _size = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = match Tx_rollup_inbox.Merkle.(compute_path [message_hash] 0) with @@ -2884,7 +2884,7 @@ module Rejection = struct Incremental.add_operation i op >>=? fun i -> Op.tx_rollup_finalize (I i) contract tx_rollup >>=? fun op -> Incremental.add_operation i op >>=? fun i -> - let (message, _size) = Tx_rollup_message.make_batch message in + let message, _size = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = match Tx_rollup_inbox.Merkle.(compute_path [message_hash] 0) with @@ -2893,7 +2893,7 @@ module Rejection = struct in l2_parameters (I i) >>=? fun l2_parameters -> valid_empty_proof l2_parameters >>= fun proof -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -2924,14 +2924,14 @@ module Rejection = struct let test_wrong_message_hash () = init_with_valid_commitment () >>=? fun (i, contract1, tx_rollup, level, prev_message, commitment) -> - let (prev_message, _size) = Tx_rollup_message.make_batch prev_message in + let prev_message, _size = Tx_rollup_message.make_batch prev_message in let prev_message_hash = Tx_rollup_message_hash.hash_uncarbonated prev_message in let expected_root = Tx_rollup_inbox.Merkle.merklize_list [prev_message_hash] in - let (message, _size) = Tx_rollup_message.make_batch "wrong message" in + let message, _size = Tx_rollup_message.make_batch "wrong message" in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = match Tx_rollup_inbox.Merkle.(compute_path [message_hash] 0) with @@ -2940,7 +2940,7 @@ module Rejection = struct in l2_parameters (I i) >>=? fun l2_parameters -> valid_empty_proof l2_parameters >>= fun proof -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -2970,7 +2970,7 @@ module Rejection = struct let test_wrong_message_position () = init_with_valid_commitment () >>=? fun (i, contract1, tx_rollup, level, message, _commitment) -> - let (message, _size) = Tx_rollup_message.make_batch message in + let message, _size = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = match Tx_rollup_inbox.Merkle.(compute_path [message_hash] 0) with @@ -3005,7 +3005,7 @@ module Rejection = struct (** Test rejecting a commitment to a non-trivial message -- that is, not a no-op. *) let test_nontrivial_rejection () = - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in init_l2_store () >>= fun store -> context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> @@ -3023,7 +3023,7 @@ module Rejection = struct Incremental.add_operation i op >>=? fun i -> Incremental.finalize_block i >>=? fun b -> Incremental.begin_construction b >>=? fun i -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -3075,7 +3075,7 @@ module Rejection = struct return ctxt let test_large_rejection size = - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in init_l2_store () >>= fun store -> context_init1 ~tx_rollup_rejection_max_proof_size:size () >>=? fun (b, account) -> @@ -3103,7 +3103,7 @@ module Rejection = struct l2_parameters (I i) >>=? fun l2_parameters -> make_proof store l2_parameters deposit >>= fun proof -> Incremental.begin_construction b >>=? fun i -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -3147,7 +3147,7 @@ module Rejection = struct | Nil -> assert false let test_valid_proof_truncated () = - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in init_l2_store () >>= fun store -> context_init1 ~tx_rollup_rejection_max_proof_size:100 () >>=? fun (b, account) -> @@ -3179,7 +3179,7 @@ module Rejection = struct (* We try to reject with the truncated proof which is already above the size limit. *) Incremental.begin_construction b >>=? fun i -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -3209,7 +3209,7 @@ module Rejection = struct if [n_withdraw <= tx_rollup_max_withdrawals_per_batch] but also must succeed to reject if [n_withdraw > tx_rollup_max_withdrawals_per_batch]. *) let test_reject_withdrawals_helper ?expect_failure n_withdraw = - let (sk, pk, addr) = gen_l2_account () in + let sk, pk, addr = gen_l2_account () in init_with_deposit ~tx_rollup_hard_size_limit_per_message:20_000 addr >>=? fun (b, account, tx_rollup, store, ticket_hash) -> hash_tree_from_store store >>= fun l2_context_hash -> @@ -3228,7 +3228,7 @@ module Rejection = struct contents = withdraws; } in - let (message, batch_bytes) = + let message, batch_bytes = make_and_sign_transaction ~signers:[sk] [operation] in @@ -3285,7 +3285,7 @@ module Rejection = struct withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; } in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -3385,7 +3385,7 @@ end module Single_message_inbox = struct let contents = "bogus" - let (message, _) = Tx_rollup_message.make_batch contents + let message, _ = Tx_rollup_message.make_batch contents let message_hash = Tx_rollup_message_hash.hash_uncarbonated message @@ -3408,7 +3408,7 @@ module Single_message_inbox = struct (if Option.is_some expect_failure then "x" else "√") ; l2_parameters (B b) >>=? fun l2_parameters -> Rejection.valid_empty_proof l2_parameters >>= fun proof -> - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = Rejection.make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -3673,7 +3673,7 @@ let test_state_message_storage_preallocation () = originate b account1 >>=? fun (b, tx_rollup) -> Incremental.begin_construction b >>=? fun i -> let ctxt = Incremental.alpha_ctxt i in - let (message, _) = Tx_rollup_message.make_batch "bogus" in + let message, _ = Tx_rollup_message.make_batch "bogus" in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let _inbox_hash = Tx_rollup_inbox.Merkle.merklize_list [message_hash] in let state = Tx_rollup_state.initial_state ~pre_allocated_storage:Z.zero in @@ -3945,7 +3945,7 @@ module Withdraw = struct >>=? fun storage_size_before_withdraw -> (* -- At this point, everything is in place for the user to execute the withdrawal -- *) - let (_message_result_hash, message_result_path) = + let _message_result_hash, message_result_path = Rejection.make_rejection_param commitment ~index:0 in Op.tx_rollup_dispatch_tickets @@ -4179,7 +4179,7 @@ module Withdraw = struct WithExceptions.Option.get ~loc:__LOC__ @@ List.nth context_hash_list 0 in Incremental.begin_construction block >>=? fun incr -> - let (_message_result_hash, message_result_path) = + let _message_result_hash, message_result_path = Rejection.make_rejection_param commitment ~index:0 in Op.tx_rollup_dispatch_tickets @@ -4230,7 +4230,7 @@ module Withdraw = struct in Incremental.begin_construction block >>=? fun incr -> (* Try with invalid amounts *) - let (_message_result_hash, message_result_path) = + let _message_result_hash, message_result_path = Rejection.make_rejection_param commitment ~index:0 in Op.tx_rollup_dispatch_tickets @@ -4365,7 +4365,7 @@ module Withdraw = struct ~loc:__LOC__ (List.nth context_hash_list message_index) in - let (_message_result_hash, message_result_path) = + let _message_result_hash, message_result_path = Rejection.make_rejection_param commitment ~index:0 in Op.tx_rollup_dispatch_tickets @@ -4461,10 +4461,10 @@ module Withdraw = struct ~loc:__LOC__ (List.nth context_hash_list second_message_index) in - let (_message_result_hash, path1) = + let _message_result_hash, path1 = Rejection.make_rejection_param commitment ~index:first_message_index in - let (_message_result_hash, path2) = + let _message_result_hash, path2 = Rejection.make_rejection_param commitment ~index:second_message_index in Op.tx_rollup_dispatch_tickets @@ -4589,10 +4589,10 @@ module Withdraw = struct in Incremental.begin_construction block >>=? fun incr -> (* try with wrong context hash *) - let (_message_result_hash, path1) = + let _message_result_hash, path1 = Rejection.make_rejection_param commitment ~index:valid_message_index in - let (_message_result_hash, path2) = + let _message_result_hash, path2 = Rejection.make_rejection_param commitment ~index:wrong_message_index in Op.tx_rollup_dispatch_tickets @@ -4703,7 +4703,7 @@ module Withdraw = struct Block.bake ~operation block >>=? fun block -> (* At this point, the reveal can no longer be executed *) Incremental.begin_construction block >>=? fun incr -> - let (_message_result_hash, message_result_path) = + let _message_result_hash, message_result_path = Rejection.make_rejection_param commitment ~index:message_index in Op.tx_rollup_dispatch_tickets @@ -4772,7 +4772,7 @@ module Withdraw = struct >>=? fun () -> (* Exexute with withdrawal *) Incremental.begin_construction b >>=? fun incr -> - let (_message_result_hash, message_result_path) = + let _message_result_hash, message_result_path = Rejection.make_rejection_param commitment ~index:0 in Op.tx_rollup_dispatch_tickets @@ -4849,7 +4849,7 @@ module Withdraw = struct Tx_rollup_inbox.Merkle.( compute_path [Tx_rollup_message_hash.hash_uncarbonated message] 0) in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = Rejection.make_rejection_param commitment ~index:0 in Op.tx_rollup_reject @@ -4880,7 +4880,7 @@ module Withdraw = struct withdraw is equal to the deposit, rather than the remainder after we overflow. *) let max = Int64.(sub max_int 1L) in - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init 1 >>=? fun (b, accounts) -> let account1 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth accounts 0 @@ -4907,7 +4907,7 @@ module Withdraw = struct Incremental.begin_construction b >>=? fun i -> Nat_ticket.ticket_hash (B b) ~ticketer:deposit_contract ~tx_rollup >>=? fun ticket_hash -> - let (deposit1, _) = + let deposit1, _ = Tx_rollup_message.make_deposit deposit_pkh (Tx_rollup_l2_address.Indexable.value pkh) @@ -4963,8 +4963,8 @@ module Withdraw = struct without overflowing. *) let test_deposit_multiple_destinations_at_limit () = let max = Int64.max_int in - let (_, _, pkh1) = gen_l2_account () in - let (_, _, pkh2) = gen_l2_account () in + let _, _, pkh1 = gen_l2_account () in + let _, _, pkh2 = gen_l2_account () in context_init1 () >>=? fun (b, account1) -> originate b account1 >>=? fun (b, tx_rollup) -> Nat_ticket.init_deposit_contract (Z.of_int64 max) b account1 @@ -4987,8 +4987,8 @@ module Withdraw = struct ticket_hash (Tx_rollup_l2_qty.of_int64_exn max) in - let (deposit1, _) = make_deposit pkh1 in - let (deposit2, _) = make_deposit pkh2 in + let deposit1, _ = make_deposit pkh1 in + let deposit2, _ = make_deposit pkh2 in Rejection.init_l2_store () >>= fun store -> (* For the first deposit, we have no withdraws *) make_and_check_correct_commitment diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_voting.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_voting.ml index 57bbc0be0300..cf82d8583ac8 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_voting.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_voting.ml @@ -450,15 +450,15 @@ let get_smallest_prefix_voters_for_quorum active_delegates active_power |> fun active_power_sum -> let rec loop delegates power sum selected = match (delegates, power) with - | ([], []) -> selected - | (del :: delegates, del_power :: power) -> + | [], [] -> selected + | del :: delegates, del_power :: power -> if den * sum < Float.to_int (expected_quorum *. Int64.to_float active_power_sum) then loop delegates power (sum + Int64.to_int del_power) (del :: selected) else selected - | (_, _) -> [] + | _, _ -> [] in loop active_delegates active_power 0 [] @@ -760,8 +760,8 @@ let test_supermajority_in_exploration supermajority () = (* majority/minority vote depending on the [supermajority] parameter *) let num_yays = if supermajority then num_yays else num_yays - 1 in let open Alpha_context in - let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in - let (yays_delegates, _) = List.split_n num_yays rest in + let nays_delegates, rest = List.split_n num_nays delegates_p2 in + let yays_delegates, _ = List.split_n num_yays rest in List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates >>=? fun operations_yays -> List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/test_frozen_bonds.ml index 7878b58fd5e4..c2e12cad1d39 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/test_frozen_bonds.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/test_frozen_bonds.ml @@ -74,13 +74,13 @@ let create_context () = delegate's pkh. *) let init_test ~user_is_delegate = create_context () >>=? fun (ctxt, _) -> - let (delegate, delegate_pk, _) = Signature.generate_key () in + let delegate, delegate_pk, _ = Signature.generate_key () in let delegate_contract = Contract.implicit_contract delegate in let delegate_account = `Contract (Contract.implicit_contract delegate) in let user_contract = if user_is_delegate then delegate_contract else - let (user, _, _) = Signature.generate_key () in + let user, _, _ = Signature.generate_key () in Contract.implicit_contract user in let user_account = `Contract user_contract in @@ -115,7 +115,7 @@ let test_delegate_then_freeze_deposit () = (* Fetch staking balance after delegation and before freeze. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance -> (* Freeze a tx-rollup deposit. *) - let (tx_rollup, _) = mk_tx_rollup () in + let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in let deposit_account = `Frozen_bonds (user_contract, bond_id) in @@ -163,7 +163,7 @@ let test_freeze_deposit_then_delegate () = (* Fetch user's initial balance before freeze. *) Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> (* Freeze a tx-rollup deposit. *) - let (tx_rollup, _) = mk_tx_rollup () in + let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in let deposit_account = `Frozen_bonds (user_contract, bond_id) in @@ -217,7 +217,7 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () = Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> Assert.equal_bool ~loc:__LOC__ Tez.(user_balance > zero) true >>=? fun () -> (* Freeze a tx-rollup deposit. *) - let (tx_rollup, _) = mk_tx_rollup () in + let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = user_balance in let deposit_account = `Frozen_bonds (user_contract, bond_id) in @@ -254,9 +254,9 @@ let test_total_stake ~user_is_delegate () = Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> Assert.equal_bool ~loc:__LOC__ Tez.(user_balance > zero) true >>=? fun () -> (* Freeze 2 tx-rollup deposits. *) - let (tx_rollup, nonce) = mk_tx_rollup () in + let tx_rollup, nonce = mk_tx_rollup () in let bond_id1 = Bond_id.Tx_rollup_bond_id tx_rollup in - let (tx_rollup, _) = mk_tx_rollup ~nonce () in + let tx_rollup, _ = mk_tx_rollup ~nonce () in let bond_id2 = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/test_liquidity_baking.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/test_liquidity_baking.ml index 0e1e98d69524..db5a4a525778 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/test_liquidity_baking.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/test_liquidity_baking.ml @@ -54,7 +54,6 @@ let generate_init_state () = (* The script hash of https://gitlab.com/dexter2tz/dexter2tz/-/blob/d98643881fe14996803997f1283e84ebd2067e35/dexter.liquidity_baking.mligo.tz - *) let expected_cpmm_hash = Script_expr_hash.of_b58check_exn @@ -63,7 +62,6 @@ let expected_cpmm_hash = (* The script hash of https://gitlab.com/dexter2tz/dexter2tz/-/blob/d98643881fe14996803997f1283e84ebd2067e35/lqt_fa12.mligo.tz - *) let expected_lqt_hash = Script_expr_hash.of_b58check_exn @@ -226,7 +224,7 @@ let liquidity_baking_toggle_50 n () = (* Test that the subsidy can restart if LB_on votes regain majority. Bake n_votes with LB_off, check that the subsidy is paused, bake n_votes with LB_on, check that the subsidy flows. - *) +*) let liquidity_baking_restart n_votes n () = Context.init ~consensus_threshold:0 1 >>=? fun (blk, _contracts) -> Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun liquidity_baking -> diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/test_storage_functions.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/test_storage_functions.ml index c0fa687b72a7..c5b50a5d65fe 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/test_storage_functions.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/test_storage_functions.ml @@ -99,13 +99,13 @@ let wrap m = m >|= Environment.wrap_tzresult let test_fold_keys_unaccounted () = let open Lwt_result_syntax in let* ctxt = Context.default_raw_context () in - let* (ctxt, _) = wrap (Table.init ctxt 1) in - let* (ctxt, _) = wrap (Table.init ctxt 2) in + let* ctxt, _ = wrap (Table.init ctxt 1) in + let* ctxt, _ = wrap (Table.init ctxt 2) in let*! items = Table.fold_keys_unaccounted ctxt ~order:`Undefined - ~f:(fun x acc -> Lwt.return @@ x :: acc) + ~f:(fun x acc -> Lwt.return @@ (x :: acc)) ~init:[] in let items = List.sort Compare.Int.compare items in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/test_token.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/test_token.ml index 7b4294e4fccf..6f33e53d558b 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/test_token.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/test_token.ml @@ -61,7 +61,7 @@ let test_simple_balances () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> let src = `Contract (Contract.implicit_contract pkh) in - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = `Contract (Contract.implicit_contract pkh) in let amount = Tez.one in wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) -> @@ -80,7 +80,7 @@ let test_simple_balance_updates () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> let src = Contract.implicit_contract pkh in - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.implicit_contract pkh in let amount = Tez.one in wrap (Token.transfer ctxt (`Contract src) (`Contract dest) amount) @@ -129,7 +129,7 @@ let test_allocated () = create_context () >>=? fun (ctxt, pkh) -> let dest = `Delegate_balance pkh in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = `Contract (Contract.implicit_contract pkh) in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> let dest = `Collected_commitments Blinded_public_key_hash.zero in @@ -182,7 +182,7 @@ let test_transferring_to_sink ctxt sink amount expected_bupds = Assert.proto_error_with_info ~loc:__LOC__ res "Overflowing tez addition" let test_transferring_to_contract ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.implicit_contract pkh in let amount = random_amount () in test_transferring_to_sink @@ -201,7 +201,7 @@ let test_transferring_to_collected_commitments ctxt = [(Commitments bpkh, Credited amount, Block_application)] let test_transferring_to_delegate_balance ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.implicit_contract pkh in let amount = random_amount () in test_transferring_to_sink @@ -211,7 +211,7 @@ let test_transferring_to_delegate_balance ctxt = [(Contract dest, Credited amount, Block_application)] let test_transferring_to_frozen_deposits ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in test_transferring_to_sink ctxt @@ -254,7 +254,7 @@ let test_transferring_to_burned ctxt = true >>=? fun () -> let pkh = Signature.Public_key_hash.zero in - let (p, r) = (Random.bool (), Random.bool ()) in + let p, r = (Random.bool (), Random.bool ()) in wrap (Token.transfer ctxt `Minted (`Lost_endorsing_rewards (pkh, p, r)) amount) >>=? fun (_, bupds) -> @@ -268,7 +268,7 @@ let test_transferring_to_burned ctxt = true let test_transferring_to_frozen_bonds ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let contract = Contract.implicit_contract pkh in let tx_rollup = mk_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in @@ -368,7 +368,7 @@ let test_transferring_from_bounded_source ctxt src amount expected_bupds = Assert.proto_error_with_info ~loc:__LOC__ res error_title let test_transferring_from_contract ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let src = Contract.implicit_contract pkh in let amount = random_amount () in test_transferring_from_bounded_source @@ -387,7 +387,7 @@ let test_transferring_from_collected_commitments ctxt = [(Commitments bpkh, Debited amount, Block_application)] let test_transferring_from_delegate_balance ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in let src = Contract.implicit_contract pkh in test_transferring_from_bounded_source @@ -397,7 +397,7 @@ let test_transferring_from_delegate_balance ctxt = [(Contract src, Debited amount, Block_application)] let test_transferring_from_frozen_deposits ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in test_transferring_from_bounded_source ctxt @@ -414,7 +414,7 @@ let test_transferring_from_collected_fees ctxt = [(Block_fees, Debited amount, Block_application)] let test_transferring_from_frozen_bonds ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let contract = Contract.implicit_contract pkh in let tx_rollup = mk_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in @@ -485,13 +485,13 @@ let cast_to_container_type x = let build_test_cases () = create_context () >>=? fun (ctxt, pkh) -> let origin = `Contract (Contract.implicit_contract pkh) in - let (user1, _, _) = Signature.generate_key () in + let user1, _, _ = Signature.generate_key () in let user1c = `Contract (Contract.implicit_contract user1) in - let (user2, _, _) = Signature.generate_key () in + let user2, _, _ = Signature.generate_key () in let user2c = `Contract (Contract.implicit_contract user2) in - let (baker1, baker1_pk, _) = Signature.generate_key () in + let baker1, baker1_pk, _ = Signature.generate_key () in let baker1c = `Contract (Contract.implicit_contract baker1) in - let (baker2, baker2_pk, _) = Signature.generate_key () in + let baker2, baker2_pk, _ = Signature.generate_key () in let baker2c = `Contract (Contract.implicit_contract baker2) in (* Allocate contracts for user1, user2, baker1, and baker2. *) wrap (Token.transfer ctxt origin user1c (random_amount ())) @@ -567,23 +567,23 @@ let check_sink_balances ctxt ctxt' dest amount = let rec check_balances ctxt ctxt' src dest amount = match (cast_to_container_type src, cast_to_container_type dest) with - | (None, None) -> return_unit - | (Some (`Delegate_balance d), Some (`Contract c as contract)) + | None, None -> return_unit + | Some (`Delegate_balance d), Some (`Contract c as contract) when Contract.implicit_contract d = c -> (* src and dest are in fact referring to the same contract *) check_balances ctxt ctxt' contract contract amount - | (Some (`Contract c as contract), Some (`Delegate_balance d)) + | Some (`Contract c as contract), Some (`Delegate_balance d) when Contract.implicit_contract d = c -> (* src and dest are in fact referring to the same contract *) check_balances ctxt ctxt' contract contract amount - | (Some src, Some dest) when src = dest -> + | Some src, Some dest when src = dest -> (* src and dest are the same contract *) wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> wrap (Token.balance ctxt' dest) >>=? fun (_, bal_dest') -> Assert.equal_tez ~loc:__LOC__ bal_dest bal_dest' - | (Some src, None) -> check_src_balances ctxt ctxt' src amount - | (None, Some dest) -> check_sink_balances ctxt ctxt' dest amount - | (Some src, Some dest) -> + | Some src, None -> check_src_balances ctxt ctxt' src amount + | None, Some dest -> check_sink_balances ctxt ctxt' dest amount + | Some src, Some dest -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> check_sink_balances ctxt ctxt' dest amount @@ -612,22 +612,22 @@ let test_all_combinations_of_sources_and_sinks () = if one is a credit while the other is a debit. *) let coalesce_balance_updates bu1 bu2 = match (bu1, bu2) with - | ((bu1_bal, bu1_balupd, bu1_origin), (bu2_bal, bu2_balupd, bu2_origin)) -> ( + | (bu1_bal, bu1_balupd, bu1_origin), (bu2_bal, bu2_balupd, bu2_origin) -> ( assert (bu1_bal = bu2_bal) ; assert (bu1_origin = bu2_origin) ; let open Receipt in match (bu1_balupd, bu2_balupd) with - | (Credited bu1_am, Credited bu2_am) -> + | Credited bu1_am, Credited bu2_am -> let bu_am = match bu1_am +? bu2_am with Ok am -> am | _ -> assert false in (bu1_bal, Credited bu_am, bu1_origin) - | (Debited bu1_am, Debited bu2_am) -> + | Debited bu1_am, Debited bu2_am -> let bu_am = match bu1_am +? bu2_am with Ok am -> am | _ -> assert false in (bu1_bal, Debited bu_am, bu1_origin) - | (Credited _, Debited _) | (Debited _, Credited _) -> assert false) + | Credited _, Debited _ | Debited _, Credited _ -> assert false) (** Check that elt has the same balance in ctxt1 and ctxt2. *) let check_balances_are_consistent ctxt1 ctxt2 elt = @@ -656,7 +656,7 @@ let test_transfer_n ctxt src dest = (* remove burning balance updates *) let debit_logs = List.filter - (fun b -> match b with (Receipt.Burned, _, _) -> false | _ -> true) + (fun b -> match b with Receipt.Burned, _, _ -> false | _ -> true) debit_logs in (* Credit the sink for each source. *) @@ -670,7 +670,7 @@ let test_transfer_n ctxt src dest = (* remove minting balance updates *) let credit_logs = List.filter - (fun b -> match b with (Receipt.Minted, _, _) -> false | _ -> true) + (fun b -> match b with Receipt.Minted, _, _ -> false | _ -> true) credit_logs in (* Check equivalence of balance updates. *) @@ -695,13 +695,13 @@ let test_transfer_n_with_non_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> let origin = `Contract (Contract.implicit_contract pkh) in - let (user1, _, _) = Signature.generate_key () in + let user1, _, _ = Signature.generate_key () in let user1c = `Contract (Contract.implicit_contract user1) in - let (user2, _, _) = Signature.generate_key () in + let user2, _, _ = Signature.generate_key () in let user2c = `Contract (Contract.implicit_contract user2) in - let (user3, _, _) = Signature.generate_key () in + let user3, _, _ = Signature.generate_key () in let user3c = `Contract (Contract.implicit_contract user3) in - let (user4, _, _) = Signature.generate_key () in + let user4, _, _ = Signature.generate_key () in let user4c = `Contract (Contract.implicit_contract user4) in (* Allocate contracts for user1, user2, user3, and user4. *) let amount = diff --git a/src/proto_013_PtJakart/lib_protocol/test/pbt/liquidity_baking_pbt.ml b/src/proto_013_PtJakart/lib_protocol/test/pbt/liquidity_baking_pbt.ml index 0084a8065da8..bf31e359f89e 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/pbt/liquidity_baking_pbt.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/pbt/liquidity_baking_pbt.ml @@ -92,8 +92,8 @@ let get_float_balances env state = fraction of tzbtc and xtz returned to the liquidity provider is lesser or equal than the fraction of lqt burnt. *) let is_remove_liquidity_consistent env state state' = - let (xtz, tzbtc, lqt) = get_float_balances env state in - let (xtz', tzbtc', lqt') = get_float_balances env state' in + let xtz, tzbtc, lqt = get_float_balances env state in + let xtz', tzbtc', lqt' = get_float_balances env state' in if lqt' < lqt then let flqt = (lqt -. lqt') /. lqt in let fxtz = (xtz -. xtz') /. xtz in @@ -106,8 +106,8 @@ let is_remove_liquidity_consistent env state state' = See https://blog.nomadic-labs.com/progress-report-on-the-verification-of-liquidity-baking-smart-contracts.html#evolution-of-the-product-of-supplies *) let is_share_price_increasing env state state' = - let (xtz, tzbtc, lqt) = get_float_balances env state in - let (xtz', tzbtc', lqt') = get_float_balances env state' in + let xtz, tzbtc, lqt = get_float_balances env state in + let xtz', tzbtc', lqt' = get_float_balances env state' in xtz *. tzbtc /. (lqt *. lqt) <= xtz' *. tzbtc' /. (lqt' *. lqt') (** [positive_pools env state] returns [true] iff the three pools of @@ -185,12 +185,10 @@ let validate_consistency : fun env state -> all_true (validate_cpmm_total_liquidity env state - :: - validate_balances env.cpmm_contract env state - :: - List.map - (fun account -> validate_balances account env state) - env.implicit_accounts) + :: validate_balances env.cpmm_contract env state + :: List.map + (fun account -> validate_balances account env state) + env.implicit_accounts) (** [validate_storage env blk] returns [true] iff the storage of the CPMM contract is consistent wrt. to its actual balances (tez, @@ -248,7 +246,7 @@ let machine_validation_tests = (fun (specs, scenario) -> extract_qcheck_tzresult (let invariant = positive_pools in - let (state, env) = SymbolicMachine.build ~invariant specs in + let state, env = SymbolicMachine.build ~invariant specs in let _ = SymbolicMachine.run ~invariant scenario env state in return_unit)); ] @@ -263,7 +261,7 @@ let economic_tests = ~name:"No global gain" (Liquidity_baking_generator.arb_adversary_scenario 1_000_000 1_000_000 50) (fun (specs, attacker, scenario) -> - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (one_balance_decreases attacker env) scenario env state in @@ -273,7 +271,7 @@ let economic_tests = ~name:"Remove liquidities is consistent" (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (is_remove_liquidity_consistent env) scenario env state in @@ -283,7 +281,7 @@ let economic_tests = ~name:"Share price only increases" (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (is_share_price_increasing env) scenario env state in diff --git a/src/proto_013_PtJakart/lib_protocol/test/pbt/refutation_game_pbt.ml b/src/proto_013_PtJakart/lib_protocol/test/pbt/refutation_game_pbt.ml index f548b4824d99..e76d9b05e767 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/pbt/refutation_game_pbt.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/pbt/refutation_game_pbt.ml @@ -206,11 +206,11 @@ module Strategies (P : TestPVM) = struct from initial_state. Here t0 is the last known tick smaller that t (or the intial tick if no such exits) *) let state_at history tick initial_state = - let (lower, ostate, _) = Sc_rollup_tick_repr.Map.split tick history in + let lower, ostate, _ = Sc_rollup_tick_repr.Map.split tick history in match ostate with | Some state -> Lwt.return (state, history) | None -> - let (tick0, state0) = + let tick0, state0 = match Sc_rollup_tick_repr.Map.max_binding lower with | Some (t, s) -> (t, s) | None -> (Sc_rollup_tick_repr.initial, initial_state) @@ -263,11 +263,11 @@ module Strategies (P : TestPVM) = struct ~default:Sc_rollup_tick_repr.initial (Sc_rollup_tick_repr.of_int stop_at) in - let* (starting_state, history) = + let* starting_state, history = state_at history section_start_at P.Internal_for_tests.initial_state in let* section_start_state = P.state_hash starting_state in - let* (stoping_state, history) = + let* stoping_state, history = state_at history section_stop_at P.Internal_for_tests.initial_state in let* section_stop_state = P.state_hash stoping_state in @@ -321,7 +321,7 @@ module Strategies (P : TestPVM) = struct loop game move in - let (game, move) = initial (Commit commit) refutation in + let game, move = initial (Commit commit) refutation in loop game move in outcome @@ -405,7 +405,7 @@ module Strategies (P : TestPVM) = struct let open Section in let cardinal = dissection_cardinal d in let x = Random.int cardinal in - let (_, section) = + let _, section = try fold_over_dissection (fun _ s (n, _) -> if n = x then raise (Section s) else (n + 1, None)) @@ -466,7 +466,7 @@ module Strategies (P : TestPVM) = struct checks that the stop state of a section conflicts with the one in the history. *) let conflicting_section history (section : Section.section) = - let* (new_state, _) = + let* new_state, _ = state_at history section.section_stop_at @@ -505,20 +505,20 @@ module Strategies (P : TestPVM) = struct | Some s -> Lwt.return s in Game.Section.pp_section Format.std_formatter section ; - let* (next_dissection, history) = + let* next_dissection, history = dissection_of_section history branching section in let empty_history = Sc_rollup_tick_repr.Map.empty in - let* (conflict_resolution_step, history) = + let* conflict_resolution_step, history = match next_dissection with | None -> - let* (stop_state, history) = + let* stop_state, history = state_at history (Sc_rollup_tick_repr.next section.section_start_at) P.Internal_for_tests.initial_state in - let* (start_state, _) = + let* start_state, _ = state_at history section.section_start_at @@ -529,7 +529,7 @@ module Strategies (P : TestPVM) = struct (None, P.Internal_for_tests.make_proof start_state stop_state), empty_history ) | Some next_dissection -> - let* (state, history) = + let* state, history = state_at history section.section_stop_at @@ -546,7 +546,7 @@ module Strategies (P : TestPVM) = struct let machine_directed_committer {branching; _} pred = let history = ref Sc_rollup_tick_repr.Map.empty in let initial ((section_start_at : Sc_rollup_tick_repr.t), start_state) = - let* (section_stop_at, stop_state) = + let* section_stop_at, stop_state = execute_until section_start_at start_state @@ fun tick _ -> pred tick in let* section_start_state = P.state_hash start_state in @@ -563,7 +563,7 @@ module Strategies (P : TestPVM) = struct } in let next_move dissection = - let* (move, history') = next_move !history branching dissection in + let* move, history' = next_move !history branching dissection in history := history' ; Lwt.return move in @@ -577,7 +577,7 @@ module Strategies (P : TestPVM) = struct let ({section_start_at; section_stop_at; _} : Section.section) = section in - let* (_stop_at, stop_state) = + let* _stop_at, stop_state = execute_until section_start_at section_start_state @@ fun tick _ -> tick >= section_stop_at in @@ -585,7 +585,7 @@ module Strategies (P : TestPVM) = struct let history = remember history section_start_at section_start_state in let history = remember history section_stop_at stop_state in let* section_stop_state = P.state_hash stop_state in - let* (next_dissection, history) = + let* next_dissection, history = dissection_of_section history branching @@ -594,7 +594,7 @@ module Strategies (P : TestPVM) = struct let* conflict_resolution_step = match next_dissection with | None -> - let* (state, _) = + let* state, _ = state_at history section_start_at @@ -609,7 +609,7 @@ module Strategies (P : TestPVM) = struct Lwt.return @@ RefuteByConflict conflict_resolution_step in let next_move dissection = - let* (move, _) = next_move history branching dissection in + let* move, _ = next_move history branching dissection in Lwt.return move in ({initial; next_move} : _ client) @@ -655,7 +655,7 @@ module Strategies (P : TestPVM) = struct @@ Section.(add_section section empty_dissection) | Some dissection -> Lwt.return dissection in - let (_, section) = + let _, section = Option.value ~default:(Sc_rollup_tick_repr.initial, section) (Section.last_section next_dissection) @@ -809,7 +809,7 @@ let test_random_dissection (module P : TestPVM) start_at length branching = section_stop_state; } in - let* (option_dissection, _) = + let* option_dissection, _ = let empty_history = Sc_rollup_tick_repr.Map.empty in S.dissection_of_section empty_history branching section in diff --git a/src/proto_013_PtJakart/lib_protocol/test/pbt/test_carbonated_map.ml b/src/proto_013_PtJakart/lib_protocol/test/pbt/test_carbonated_map.ml index 05ebbf38eeaa..03b2e682ea62 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/pbt/test_carbonated_map.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/pbt/test_carbonated_map.ml @@ -39,7 +39,7 @@ let wrap m = m >|= Environment.wrap_tzresult let new_ctxt () = let ( let* ) m f = m >>=? f in - let* (block, _) = Context.init 1 in + let* block, _ = Context.init 1 in let* incr = Incremental.begin_construction block in return @@ Incremental.alpha_ctxt incr @@ -74,7 +74,7 @@ let pp_int_map fmt map = Lwt_main.run (let ( let* ) m f = m >>=? f in let* ctxt = new_ctxt () in - let* (kvs, _) = wrap @@ Lwt.return @@ CM.to_list ctxt map in + let* kvs, _ = wrap @@ Lwt.return @@ CM.to_list ctxt map in return kvs) |> Result.value_f ~default:(fun () -> assert false) |> Format.fprintf fmt "%a" pp @@ -108,11 +108,11 @@ let dummy_fail = Result.error (Environment.Error_monad.trace_of_error Dummy_error) let assert_map_contains ctxt map expected = - let* (kvs, _ctxt) = CM.to_list ctxt map in + let* kvs, _ctxt = CM.to_list ctxt map in Ok (List.sort compare kvs = List.sort compare expected) let assert_equal_map ctxt map expected = - let* (kvs, ctxt) = CM.to_list ctxt expected in + let* kvs, ctxt = CM.to_list ctxt expected in assert_map_contains ctxt map kvs (** Test that the size of an empty map is 0. *) @@ -123,7 +123,7 @@ let test_empty = let test_update_add = unit_test "Update add" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) @@ -132,14 +132,14 @@ let test_update_add = let update_replace ctxt key value map = CM.update ctxt key (fun ctxt _ -> Ok (Some value, ctxt)) map in - let* (map, ctxt) = update_replace ctxt 4 4 map in + let* map, ctxt = update_replace ctxt 4 4 map in assert_map_contains ctxt map [(1, 1); (2, 2); (3, 3); (4, 4)] (** Test replacing an existing element. *) let test_update_replace = unit_test "Update replace" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) @@ -148,14 +148,14 @@ let test_update_replace = let update_replace ctxt key value map = CM.update ctxt key (fun ctxt _ -> Ok (Some value, ctxt)) map in - let* (map, ctxt) = update_replace ctxt 1 42 map in + let* map, ctxt = update_replace ctxt 1 42 map in assert_map_contains ctxt map [(1, 42); (2, 2); (3, 3)] (** Test merging when ignoring new overlapping keys. *) let test_merge_overlaps_left = unit_test "Merge overlap keep existing" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun ctxt left _ -> Ok (left, ctxt)) @@ -167,7 +167,7 @@ let test_merge_overlaps_left = let test_merge_overlaps_right = unit_test "Merge overlap replace" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun ctxt _ right -> Ok (right, ctxt)) @@ -179,7 +179,7 @@ let test_merge_overlaps_right = let test_merge_overlaps_add = unit_test "Merge overlap by adding" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun ctxt left right -> Ok (left + right, ctxt)) @@ -191,7 +191,7 @@ let test_merge_overlaps_add = let test_update_merge = unit_test "Update with merge add" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) @@ -207,27 +207,27 @@ let test_update_merge = | Some old_value -> Ok (Some (new_value + old_value), ctxt)) map in - let* (map, ctxt) = update_merge ctxt 1 1 map in - let* (map, ctxt) = update_merge ctxt 4 4 map in + let* map, ctxt = update_merge ctxt 1 1 map in + let* map, ctxt = update_merge ctxt 4 4 map in assert_map_contains ctxt map [(1, 2); (2, 2); (3, 3); (4, 4)] (** Test merging two maps when keeping the original value for overlapping keys. *) let test_merge_map_keep_existing = unit_test "Merge overlap keep existing" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map1, ctxt) = + let* map1, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) [(1, "a"); (2, "b"); (3, "c")] in - let* (map2, ctxt) = + let* map2, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) [(2, "b'"); (3, "c'"); (4, "d'")] in - let* (map, ctxt) = + let* map, ctxt = CM.merge ctxt ~merge_overlap:(fun ctxt left _ -> Ok (left, ctxt)) map1 map2 in assert_map_contains ctxt map [(1, "a"); (2, "b"); (3, "c"); (4, "d'")] @@ -236,19 +236,19 @@ let test_merge_map_keep_existing = let test_merge_map_replace_existing = unit_test "Merge overlap replace existing" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map1, ctxt) = + let* map1, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) [(1, "a"); (2, "b"); (3, "c")] in - let* (map2, ctxt) = + let* map2, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) [(2, "b'"); (3, "c'"); (4, "d'")] in - let* (map, ctxt) = + let* map, ctxt = CM.merge ctxt ~merge_overlap:(fun ctxt _ right -> Ok (right, ctxt)) @@ -261,7 +261,7 @@ let test_merge_map_replace_existing = let test_update_delete = unit_test "Update delete" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) @@ -270,15 +270,15 @@ let test_update_delete = let delete ctxt key map = CM.update ctxt key (fun ctxt _ -> Ok (None, ctxt)) map in - let* (map, ctxt) = delete ctxt 1 map in - let* (map, ctxt) = delete ctxt 4 map in + let* map, ctxt = delete ctxt 1 map in + let* map, ctxt = delete ctxt 4 map in assert_map_contains ctxt map [(2, 2); (3, 3)] (** Test that merging [empty] with a map returns the same map. *) let test_empty_left_identity_for_merge = int_map_test "Empty map is left identity for merge" @@ fun map -> let ctxt = unsafe_new_context () in - let* (map', ctxt) = + let* map', ctxt = CM.merge ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) map CM.empty in assert_equal_map ctxt map map' @@ -287,7 +287,7 @@ let test_empty_left_identity_for_merge = let test_empty_right_identity_for_merge = int_map_test "Empty map is right identity for merge" @@ fun map -> let ctxt = unsafe_new_context () in - let* (map', ctxt) = + let* map', ctxt = CM.merge ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) CM.empty map in assert_equal_map ctxt map map' @@ -296,18 +296,18 @@ let test_empty_right_identity_for_merge = let test_size = int_map_test "Size returns the number of elements" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, _) = CM.to_list ctxt map in + let* kvs, _ = CM.to_list ctxt map in Result.ok Compare.List_length_with.(kvs = CM.size map) (** Test that all keys of a map are found. *) let test_find_existing = int_map_test "Find all elements" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, _) = CM.to_list ctxt map in + let* kvs, _ = CM.to_list ctxt map in let* _ = List.fold_left_e (fun ctxt (k, v) -> - let* (v_opt, ctxt) = CM.find ctxt k map in + let* v_opt, ctxt = CM.find ctxt k map in match v_opt with Some v' when v = v' -> Ok ctxt | _ -> dummy_fail) ctxt kvs @@ -318,9 +318,9 @@ let test_find_existing = let test_find_non_existing = int_map_test "Should not find non-existing" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, _) = CM.to_list ctxt map in + let* kvs, _ = CM.to_list ctxt map in let key = 42 in - let* (v_opt, _) = CM.find ctxt key map in + let* v_opt, _ = CM.find ctxt key map in match List.find_opt (fun (k, _) -> k = key) kvs with | Some (_, value) -> Ok (Some value = v_opt) | None -> Ok (None = v_opt) @@ -330,8 +330,8 @@ let test_to_list_of_list = int_map_test "To-list/of-list roundtrip" @@ fun map -> let ctxt = unsafe_new_context () in let merge_overlap ctxt x y = Ok (x + y, ctxt) in - let* (kvs, ctxt) = CM.to_list ctxt map in - let* (map', ctxt) = CM.of_list ctxt ~merge_overlap kvs in + let* kvs, ctxt = CM.to_list ctxt map in + let* map', ctxt = CM.of_list ctxt ~merge_overlap kvs in assert_equal_map ctxt map map' (** Test that merging two maps is equivalent to merging the concatenated @@ -340,10 +340,10 @@ let test_merge_against_list = int_map_pair_test "Merge compared with list operation" @@ fun map1 map2 -> let ctxt = unsafe_new_context () in let merge_overlap ctxt x y = Ok (x + y, ctxt) in - let* (kvs1, ctxt) = CM.to_list ctxt map1 in - let* (kvs2, ctxt) = CM.to_list ctxt map2 in - let* (map_merged1, ctxt) = CM.merge ctxt ~merge_overlap map1 map2 in - let* (map_merged2, ctxt) = CM.of_list ~merge_overlap ctxt (kvs1 @ kvs2) in + let* kvs1, ctxt = CM.to_list ctxt map1 in + let* kvs2, ctxt = CM.to_list ctxt map2 in + let* map_merged1, ctxt = CM.merge ctxt ~merge_overlap map1 map2 in + let* map_merged2, ctxt = CM.of_list ~merge_overlap ctxt (kvs1 @ kvs2) in assert_equal_map ctxt map_merged1 map_merged2 (** Test that merging a map with itself does not alter its size. *) @@ -352,7 +352,7 @@ let test_size_merge_self = @@ fun map -> let ctxt = unsafe_new_context () in let size1 = CM.size map in - let* (map2, _) = + let* map2, _ = CM.merge ctxt ~merge_overlap:(fun ctxt left right -> Ok (left + right, ctxt)) @@ -378,8 +378,8 @@ let test_size_add_one = int_map_test "Add a new element increases size by one" @@ fun map -> let ctxt = unsafe_new_context () in let key = 42 in - let* (val_opt, ctxt) = CM.find ctxt key map in - let* (map', _ctxt) = + let* val_opt, ctxt = CM.find ctxt key map in + let* map', _ctxt = CM.update ctxt key @@ -409,8 +409,8 @@ let test_size_add_one = let test_map = int_map_test "Test that map commutes with mapping over list" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, ctxt) = CM.to_list ctxt map in - let* (map', ctxt) = CM.map ctxt (fun ctxt _ x -> Ok (x + 1, ctxt)) map in + let* kvs, ctxt = CM.to_list ctxt map in + let* map', ctxt = CM.map ctxt (fun ctxt _ x -> Ok (x + 1, ctxt)) map in let kvs' = List.map (fun (k, v) -> (k, v + 1)) kvs in assert_map_contains ctxt map' kvs' @@ -419,7 +419,7 @@ let test_map = let test_fold_empty = unit_test "Fold empty" @@ fun () -> let ctxt = unsafe_new_context () in - let* (x, _) = CM.fold ctxt (fun _ctxt _acc _k _v -> dummy_fail) 0 CM.empty in + let* x, _ = CM.fold ctxt (fun _ctxt _acc _k _v -> dummy_fail) 0 CM.empty in Ok (x = 0) (** Test that folding over a map is equivalent to folding over the corresponding @@ -434,9 +434,9 @@ let test_fold_empty = let test_fold = int_map_test "Test that fold commutes with folding over a list" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, ctxt) = CM.to_list ctxt map in + let* kvs, ctxt = CM.to_list ctxt map in let sum = List.fold_left (fun sum (k, v) -> k + v + sum) 0 kvs in - let* (sum', _) = + let* sum', _ = CM.fold ctxt (fun ctxt sum k v -> Ok (k + v + sum, ctxt)) 0 map in Ok (sum = sum') @@ -447,8 +447,8 @@ let test_fold_to_list = int_map_test "Test that fold collecting the elements agrees with to-list" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, ctxt) = CM.to_list ctxt map in - let* (kvs', _) = + let* kvs, ctxt = CM.to_list ctxt map in + let* kvs', _ = CM.fold ctxt (fun ctxt kvs k v -> Ok ((k, v) :: kvs, ctxt)) [] map in Ok (kvs = List.rev kvs') @@ -467,10 +467,10 @@ let test_map_fail = let test_size_remove_one = int_map_test "Remove new element decreases size by one" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, ctxt) = CM.to_list ctxt map in + let* kvs, ctxt = CM.to_list ctxt map in let key = match kvs with (k, _) :: _ -> k | _ -> 42 in - let* (val_opt, ctxt) = CM.find ctxt key map in - let* (map', _ctxt) = CM.update ctxt key (fun ctxt _ -> Ok (None, ctxt)) map in + let* val_opt, ctxt = CM.find ctxt key map in + let* map', _ctxt = CM.update ctxt key (fun ctxt _ -> Ok (None, ctxt)) map in let size = CM.size map in let size' = CM.size map' in match val_opt with diff --git a/src/proto_013_PtJakart/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_013_PtJakart/lib_protocol/test/pbt/test_script_comparison.ml index 28b83767cbc6..f1e63a281e14 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/pbt/test_script_comparison.ml @@ -50,37 +50,35 @@ let rec reference_compare_comparable : type a. a comparable_ty -> a -> a -> int = fun ty x y -> match (ty, x, y) with - | (Unit_t, (), ()) -> 0 - | (Never_t, _, _) -> . - | (Signature_t, x, y) -> normalize_compare @@ Script_signature.compare x y - | (String_t, x, y) -> normalize_compare @@ Script_string.compare x y - | (Bool_t, x, y) -> normalize_compare @@ Compare.Bool.compare x y - | (Mutez_t, x, y) -> normalize_compare @@ Tez.compare x y - | (Key_hash_t, x, y) -> + | Unit_t, (), () -> 0 + | Never_t, _, _ -> . + | Signature_t, x, y -> normalize_compare @@ Script_signature.compare x y + | String_t, x, y -> normalize_compare @@ Script_string.compare x y + | Bool_t, x, y -> normalize_compare @@ Compare.Bool.compare x y + | Mutez_t, x, y -> normalize_compare @@ Tez.compare x y + | Key_hash_t, x, y -> normalize_compare @@ Signature.Public_key_hash.compare x y - | (Key_t, x, y) -> normalize_compare @@ Signature.Public_key.compare x y - | (Int_t, x, y) -> normalize_compare @@ Script_int.compare x y - | (Nat_t, x, y) -> normalize_compare @@ Script_int.compare x y - | (Timestamp_t, x, y) -> normalize_compare @@ Script_timestamp.compare x y - | (Address_t, x, y) -> + | Key_t, x, y -> normalize_compare @@ Signature.Public_key.compare x y + | Int_t, x, y -> normalize_compare @@ Script_int.compare x y + | Nat_t, x, y -> normalize_compare @@ Script_int.compare x y + | Timestamp_t, x, y -> normalize_compare @@ Script_timestamp.compare x y + | Address_t, x, y -> normalize_compare @@ Script_comparable.compare_address x y - | (Tx_rollup_l2_address_t, x, y) -> + | Tx_rollup_l2_address_t, x, y -> normalize_compare @@ Script_comparable.compare_tx_rollup_l2_address x y - | (Bytes_t, x, y) -> normalize_compare @@ Compare.Bytes.compare x y - | (Chain_id_t, x, y) -> normalize_compare @@ Script_chain_id.compare x y - | (Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry)) -> + | Bytes_t, x, y -> normalize_compare @@ Compare.Bytes.compare x y + | Chain_id_t, x, y -> normalize_compare @@ Script_chain_id.compare x y + | Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry) -> let cl = reference_compare_comparable tl lx ly in if Compare.Int.(cl = 0) then reference_compare_comparable tr rx ry else cl - | (Union_t (tl, _, _, YesYes), L x, L y) -> - reference_compare_comparable tl x y - | (Union_t _, L _, R _) -> -1 - | (Union_t _, R _, L _) -> 1 - | (Union_t (_, tr, _, YesYes), R x, R y) -> - reference_compare_comparable tr x y - | (Option_t _, None, None) -> 0 - | (Option_t _, None, Some _) -> -1 - | (Option_t _, Some _, None) -> 1 - | (Option_t (t, _, Yes), Some x, Some y) -> reference_compare_comparable t x y + | Union_t (tl, _, _, YesYes), L x, L y -> reference_compare_comparable tl x y + | Union_t _, L _, R _ -> -1 + | Union_t _, R _, L _ -> 1 + | Union_t (_, tr, _, YesYes), R x, R y -> reference_compare_comparable tr x y + | Option_t _, None, None -> 0 + | Option_t _, None, Some _ -> -1 + | Option_t _, Some _, None -> 1 + | Option_t (t, _, Yes), Some x, Some y -> reference_compare_comparable t x y (* Generation of one to three values of the same comparable type. *) @@ -328,9 +326,9 @@ let test_transitivity = let cxy = Script_comparable.compare_comparable ty x y in let cyz = Script_comparable.compare_comparable ty y z in match (cxy, cyz) with - | (0, n) | (n, 0) -> qcheck_compare_comparable ~expected:n ty x z - | (-1, -1) -> qcheck_compare_comparable ~expected:(-1) ty x z - | (1, 1) -> qcheck_compare_comparable ~expected:1 ty x z + | 0, n | n, 0 -> qcheck_compare_comparable ~expected:n ty x z + | -1, -1 -> qcheck_compare_comparable ~expected:(-1) ty x z + | 1, 1 -> qcheck_compare_comparable ~expected:1 ty x z | _ -> QCheck.assume_fail ()) (* Test. @@ -338,8 +336,7 @@ let test_transitivity = *) let test_pack_unpack = QCheck.Test.make - ~count: - 100_000 + ~count:100_000 (* We run this test on many more cases than the default (100) because this is a very important property. Packing and then unpacking happens each time data is sent from a contract to another and also each time storage diff --git a/src/proto_013_PtJakart/lib_protocol/test/pbt/test_tez_repr.ml b/src/proto_013_PtJakart/lib_protocol/test/pbt/test_tez_repr.ml index 5d095ca59874..621511c0a4c3 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/pbt/test_tez_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/pbt/test_tez_repr.ml @@ -45,19 +45,19 @@ let z_in_mutez_bounds (z : Z.t) : bool = let compare (c' : Z.t) (c : Tez.t tzresult) : bool = match (z_in_mutez_bounds @@ c', c) with - | (true, Ok c) -> + | true, Ok c -> Lib_test.Qcheck_helpers.qcheck_eq' ~pp:Z.pp_print ~expected:c' ~actual:(tez_to_z c) () - | (true, Error _) -> + | true, Error _ -> QCheck.Test.fail_reportf "@[<h 0>Results are in Z bounds, but tez operation fails.@]" - | (false, Ok _) -> + | false, Ok _ -> QCheck.Test.fail_reportf "@[<h 0>Results are not in Z bounds, but tez operation did not fail.@]" - | (false, Error _) -> true + | false, Error _ -> true (* [prop_binop f f' (a, b)] compares the function [f] in Tez with a model function function [f'] in [Z]. diff --git a/src/proto_013_PtJakart/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml b/src/proto_013_PtJakart/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml index 7d40ce4da562..ff400821f1f4 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml @@ -83,7 +83,7 @@ let public_key_hash = let public_key_hash_gen = let open QCheck2.Gen in let+ seed = seed_gen in - let (pkh, _, _) = Tx_rollup_l2_helpers.gen_l1_address ~seed () in + let pkh, _, _ = Tx_rollup_l2_helpers.gen_l1_address ~seed () in pkh let ticket_hash : Protocol.Alpha_context.Ticket_hash.t = diff --git a/src/proto_013_PtJakart/lib_protocol/test/unit/test_gas_monad.ml b/src/proto_013_PtJakart/lib_protocol/test/unit/test_gas_monad.ml index 27a82fe49119..65d956f01464 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/unit/test_gas_monad.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/unit/test_gas_monad.ml @@ -160,7 +160,7 @@ let test_inner_error () = (* Test that no gas-exhaustion error is produced and that no gas is consumed when run in unlimited mode. - *) +*) let test_unlimited () = with_context ~limit:ten_milligas @@ fun ctxt -> let gas_monad = diff --git a/src/proto_013_PtJakart/lib_protocol/test/unit/test_round_repr.ml b/src/proto_013_PtJakart/lib_protocol/test/unit/test_round_repr.ml index 79ddd3c199ed..0774c3aabd2e 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/unit/test_round_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/unit/test_round_repr.ml @@ -600,8 +600,8 @@ let test_round_and_offset_correction = ~level_offset in match (computed, expected) with - | (Error _, Error _) -> return_unit - | (Ok {round; offset}, Ok {round = round'; offset = offset'}) -> + | Error _, Error _ -> return_unit + | Ok {round; offset}, Ok {round = round'; offset = offset'} -> Assert.equal_int32 ~loc:__LOC__ (Round_repr.to_int32 round) @@ -611,8 +611,8 @@ let test_round_and_offset_correction = ~loc:__LOC__ (Period_repr.to_seconds offset) (Period_repr.to_seconds offset') - | (Ok _, Error _) -> failwith "expected error is ok" - | (Error _, Ok _) -> failwith "expected ok is error") + | Ok _, Error _ -> failwith "expected error is ok" + | Error _, Ok _ -> failwith "expected ok is error") let tests = Tztest. diff --git a/src/proto_013_PtJakart/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_013_PtJakart/lib_protocol/test/unit/test_sc_rollup_storage.ml index 7449641f3fe8..8e3daa8996c1 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -38,7 +38,7 @@ open Lwt_result_syntax let lift k = Lwt.map Environment.wrap_tzresult k let new_context () = - let* (b, _contracts) = Context.init 1 in + let* b, _contracts = Context.init 1 in Incremental.begin_construction b >|=? fun inc -> let state = Incremental.validation_state inc in let ctxt = state.ctxt in @@ -47,7 +47,7 @@ let new_context () = Alpha_context.Internal_for_tests.to_raw ctxt let new_sc_rollup ctxt = - let+ (rollup, _size, ctxt) = + let+ rollup, _size, ctxt = Sc_rollup_storage.originate ctxt ~kind:Example_arith ~boot_sector:"" in (rollup, ctxt) @@ -55,7 +55,7 @@ let new_sc_rollup ctxt = (** Originate a rollup with one staker and make a deposit to the initial LCC *) let originate_rollup_and_deposit_with_one_staker () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -65,7 +65,7 @@ let originate_rollup_and_deposit_with_one_staker () = (** Originate a rollup with two stakers and make a deposit to the initial LCC *) let originate_rollup_and_deposit_with_two_stakers () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker1 = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -133,8 +133,8 @@ let test_deposit_to_missing_rollup () = let test_initial_state_is_pre_boot () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in - let* (lcc, ctxt) = + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in + let* lcc, ctxt = lift @@ Sc_rollup_storage.last_cemented_commitment ctxt rollup in assert_commitment_hash_equal @@ -146,7 +146,7 @@ let test_initial_state_is_pre_boot () = let test_deposit_to_existing_rollup () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -156,7 +156,7 @@ let test_deposit_to_existing_rollup () = let test_removing_staker_from_lcc_fails () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -170,7 +170,7 @@ let test_removing_staker_from_lcc_fails () = let test_deposit_then_withdraw () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -181,7 +181,7 @@ let test_deposit_then_withdraw () = let test_can_not_stake_twice () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -198,7 +198,7 @@ let test_withdrawal_from_missing_rollup () = let test_withdraw_when_not_staked () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -210,7 +210,7 @@ let test_withdraw_when_not_staked () = let test_withdrawing_twice () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -235,7 +235,7 @@ let number_of_ticks_exn n = let test_deposit_then_refine () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -251,14 +251,14 @@ let test_deposit_then_refine () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in assert_true ctxt let test_deposit_then_refine_bad_inbox () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -281,7 +281,7 @@ let test_deposit_then_refine_bad_inbox () = let test_publish () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -296,7 +296,7 @@ let test_publish () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.publish_commitment ctxt rollup staker commitment in assert_true ctxt @@ -304,7 +304,7 @@ let test_publish () = let test_deposit_then_publish () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -320,7 +320,7 @@ let test_deposit_then_publish () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.publish_commitment ctxt rollup staker commitment in assert_true ctxt @@ -348,7 +348,7 @@ let test_cement () = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -364,7 +364,7 @@ let test_cement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = @@ -379,11 +379,9 @@ let test_cement () = This is useful to catch potential issues with de-allocation of [c2], as we deallocate the old LCC when a new LCC is cemented. - *) +*) let test_cement_three_commitments () = - let* (ctxt, rollup, staker) = - originate_rollup_and_deposit_with_one_staker () - in + let* ctxt, rollup, staker = originate_rollup_and_deposit_with_one_staker () in let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in @@ -399,7 +397,7 @@ let test_cement_three_commitments () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let commitment = @@ -412,7 +410,7 @@ let test_cement_three_commitments () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let commitment = @@ -425,7 +423,7 @@ let test_cement_three_commitments () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c3, ctxt) = + let* c3, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in @@ -439,7 +437,7 @@ let test_cement_then_remove () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -454,7 +452,7 @@ let test_cement_then_remove () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in @@ -469,12 +467,12 @@ let test_cement_consumes_available_messages () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in let* ctxt = lift @@ Sc_rollup_storage.deposit_stake ctxt rollup staker in - let* (inbox, _n, ctxt) = + let* inbox, _n, ctxt = lift @@ Sc_rollup_storage.add_messages ctxt rollup ["one"; "two"; "three"] in let available_messages = @@ -490,12 +488,12 @@ let test_cement_consumes_available_messages () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in let* ctxt = lift @@ Sc_rollup_storage.cement_commitment ctxt rollup c1 in - let* (new_inbox, _ctxt) = lift @@ Sc_rollup_storage.inbox ctxt rollup in + let* new_inbox, _ctxt = lift @@ Sc_rollup_storage.inbox ctxt rollup in let new_available_messages = Sc_rollup_inbox_repr.number_of_available_messages new_inbox in @@ -516,7 +514,7 @@ let test_cement_unknown_commitment_fails () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -536,7 +534,7 @@ let test_cement_with_zero_stakers_fails () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -551,7 +549,7 @@ let test_cement_with_zero_stakers_fails () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in @@ -567,7 +565,7 @@ let test_cement_fail_too_recent () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -582,7 +580,7 @@ let test_cement_fail_too_recent () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let* () = @@ -603,7 +601,7 @@ let test_cement_fail_too_recent () = assert_true ctxt let test_cement_deadline_uses_oldest_add_time () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment = @@ -616,7 +614,7 @@ let test_cement_deadline_uses_oldest_add_time () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment in let challenge_window = @@ -624,7 +622,7 @@ let test_cement_deadline_uses_oldest_add_time () = in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment in let* ctxt = lift @@ Sc_rollup_storage.cement_commitment ctxt rollup c1 in @@ -632,7 +630,7 @@ let test_cement_deadline_uses_oldest_add_time () = let test_withdrawal_fails_when_not_staked_on_lcc () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -647,7 +645,7 @@ let test_withdrawal_fails_when_not_staked_on_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in assert_fails_with @@ -658,7 +656,7 @@ let test_withdrawal_fails_when_not_staked_on_lcc () = let test_initial_level_of_rollup () = let* ctxt = new_context () in let level_before_rollup = (Raw_context.current_level ctxt).level in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let ctxt = Raw_context.Internal_for_tests.add_level ctxt 10 in let* initial_level = lift @@ Sc_rollup_storage.initial_level ctxt rollup in Assert.equal_int32 @@ -667,7 +665,7 @@ let test_initial_level_of_rollup () = (Raw_level_repr.to_int32 initial_level) let test_stake_on_existing_node () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment = @@ -681,16 +679,16 @@ let test_stake_on_existing_node () = } in lift - @@ let* (_node, ctxt) = + @@ let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment in assert_true ctxt let test_cement_with_two_stakers () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -704,7 +702,7 @@ let test_cement_with_two_stakers () = } in lift - @@ let* (c1, ctxt) = + @@ let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -717,7 +715,7 @@ let test_cement_with_two_stakers () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let challenge_window = @@ -731,7 +729,7 @@ let test_cement_with_two_stakers () = assert_true ctxt let test_can_remove_staker () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -745,7 +743,7 @@ let test_can_remove_staker () = } in lift - @@ let* (c1, ctxt) = + @@ let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -758,7 +756,7 @@ let test_can_remove_staker () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let* ctxt = Sc_rollup_storage.remove_staker ctxt rollup staker1 in @@ -772,7 +770,7 @@ let test_can_remove_staker () = assert_true ctxt let test_can_remove_staker2 () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -786,7 +784,7 @@ let test_can_remove_staker2 () = } in lift - @@ let* (c1, ctxt) = + @@ let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -799,7 +797,7 @@ let test_can_remove_staker2 () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let* ctxt = Sc_rollup_storage.remove_staker ctxt rollup staker2 in @@ -814,7 +812,7 @@ let test_can_remove_staker2 () = assert_true ctxt let test_removed_staker_can_not_withdraw () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -827,7 +825,7 @@ let test_removed_staker_can_not_withdraw () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -840,7 +838,7 @@ let test_removed_staker_can_not_withdraw () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let* ctxt = lift @@ Sc_rollup_storage.remove_staker ctxt rollup staker2 in @@ -850,7 +848,7 @@ let test_removed_staker_can_not_withdraw () = "Unknown staker." let test_no_cement_on_conflict () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -863,7 +861,7 @@ let test_no_cement_on_conflict () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -876,7 +874,7 @@ let test_no_cement_on_conflict () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let ctxt = Raw_context.Internal_for_tests.add_level ctxt 5000 in @@ -892,7 +890,7 @@ let test_no_cement_on_conflict () = LCC <- [c1] *) let test_no_cement_with_one_staker_at_zero_commitment () = - let* (ctxt, rollup, staker1, _staker2) = + let* ctxt, rollup, staker1, _staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -905,7 +903,7 @@ let test_no_cement_with_one_staker_at_zero_commitment () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let challenge_window = @@ -918,7 +916,7 @@ let test_no_cement_with_one_staker_at_zero_commitment () = "Attempted to cement a disputed commitment." let test_non_cemented_parent () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -931,7 +929,7 @@ let test_non_cemented_parent () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -944,7 +942,7 @@ let test_non_cemented_parent () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let challenge_window = @@ -957,7 +955,7 @@ let test_non_cemented_parent () = "Parent is not cemented." let test_finds_conflict_point_at_lcc () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -970,7 +968,7 @@ let test_finds_conflict_point_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -983,16 +981,16 @@ let test_finds_conflict_point_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_c2, ctxt) = + let* _c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in - let* ((left, _right), ctxt) = + let* (left, _right), ctxt = lift @@ Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 in assert_commitment_hash_equal ~loc:__LOC__ ctxt left c1 let test_finds_conflict_point_beneath_lcc () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -1005,7 +1003,7 @@ let test_finds_conflict_point_beneath_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1018,7 +1016,7 @@ let test_finds_conflict_point_beneath_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment2 in let commitment3 = @@ -1031,17 +1029,17 @@ let test_finds_conflict_point_beneath_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c3, ctxt) = + let* c3, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment3 in - let* ((left, right), ctxt) = + let* (left, right), ctxt = lift @@ Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 in let* () = assert_commitment_hash_equal ~loc:__LOC__ ctxt left c2 in assert_commitment_hash_equal ~loc:__LOC__ ctxt right c3 let test_conflict_point_is_first_point_of_disagreement () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -1054,7 +1052,7 @@ let test_conflict_point_is_first_point_of_disagreement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1067,7 +1065,7 @@ let test_conflict_point_is_first_point_of_disagreement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment2 in let commitment3 = @@ -1080,7 +1078,7 @@ let test_conflict_point_is_first_point_of_disagreement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c3, ctxt) = + let* c3, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment3 in let commitment4 = @@ -1093,17 +1091,17 @@ let test_conflict_point_is_first_point_of_disagreement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_c4, ctxt) = + let* _c4, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment4 in - let* ((left, right), ctxt) = + let* (left, right), ctxt = lift @@ Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 in let* () = assert_commitment_hash_equal ~loc:__LOC__ ctxt left c2 in assert_commitment_hash_equal ~loc:__LOC__ ctxt right c3 let test_no_conflict_point_one_staker_at_lcc_preboot () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment = @@ -1116,7 +1114,7 @@ let test_no_conflict_point_one_staker_at_lcc_preboot () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_, ctxt) = + let* _, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment in assert_fails_with @@ -1125,7 +1123,7 @@ let test_no_conflict_point_one_staker_at_lcc_preboot () = "No conflict." let test_no_conflict_point_both_stakers_at_lcc_preboot () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in assert_fails_with @@ -1134,7 +1132,7 @@ let test_no_conflict_point_both_stakers_at_lcc_preboot () = "No conflict." let test_no_conflict_point_one_staker_at_lcc () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -1147,7 +1145,7 @@ let test_no_conflict_point_one_staker_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1160,7 +1158,7 @@ let test_no_conflict_point_one_staker_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let challenge_window = @@ -1174,7 +1172,7 @@ let test_no_conflict_point_one_staker_at_lcc () = "No conflict." let test_no_conflict_point_both_stakers_at_lcc () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -1187,10 +1185,10 @@ let test_no_conflict_point_both_stakers_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment1 in let challenge_window = @@ -1205,7 +1203,7 @@ let test_no_conflict_point_both_stakers_at_lcc () = let test_staker_cannot_backtrack () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -1220,7 +1218,7 @@ let test_staker_cannot_backtrack () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment1 in let commitment2 = @@ -1233,7 +1231,7 @@ let test_staker_cannot_backtrack () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_, ctxt) = + let* _, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment2 in assert_fails_with @@ -1242,7 +1240,7 @@ let test_staker_cannot_backtrack () = "Staker backtracked." let test_staker_cannot_change_branch () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -1255,7 +1253,7 @@ let test_staker_cannot_change_branch () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1268,7 +1266,7 @@ let test_staker_cannot_change_branch () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment2 in let commitment3 = @@ -1282,7 +1280,7 @@ let test_staker_cannot_change_branch () = } in - let* (_c3, ctxt) = + let* _c3, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment3 in let commitment4 = @@ -1295,7 +1293,7 @@ let test_staker_cannot_change_branch () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_c4, ctxt) = + let* _c4, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment4 in assert_fails_with @@ -1360,7 +1358,7 @@ let test_get_commitment_of_missing_rollup () = let test_get_missing_commitment () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let commitment_hash = Sc_rollup_repr.Commitment_hash.zero in assert_fails_with ~loc:__LOC__ @@ -1376,7 +1374,7 @@ let test_initial_level_of_missing_rollup () = assert_fails_with_missing_rollup ~loc:__LOC__ Sc_rollup_storage.initial_level let test_concurrent_refinement_point_of_conflict () = - let* (before_ctxt, rollup, staker1, staker2) = + let* before_ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -1399,22 +1397,22 @@ let test_concurrent_refinement_point_of_conflict () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* ((c1, c2), _ctxt) = + let* (c1, c2), _ctxt = lift - @@ let* (_c1, ctxt) = + @@ let* _c1, ctxt = Sc_rollup_storage.refine_stake before_ctxt rollup staker1 commitment1 in - let* (_c2, ctxt) = + let* _c2, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 in - let* ((c1', c2'), ctxt) = + let* (c1', c2'), ctxt = lift - @@ let* (_c2, ctxt) = + @@ let* _c2, ctxt = Sc_rollup_storage.refine_stake before_ctxt rollup staker2 commitment2 in - let* (_c1, ctxt) = + let* _c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 @@ -1423,7 +1421,7 @@ let test_concurrent_refinement_point_of_conflict () = assert_commitment_hash_equal ~loc:__LOC__ ctxt c2 c2' let test_concurrent_refinement_cement () = - let* (before_ctxt, rollup, staker1, staker2) = + let* before_ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment = @@ -1436,12 +1434,12 @@ let test_concurrent_refinement_cement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, _ctxt) = + let* c1, _ctxt = lift - @@ let* (c1, ctxt) = + @@ let* c1, ctxt = Sc_rollup_storage.refine_stake before_ctxt rollup staker1 commitment in - let* (_c2, ctxt) = + let* _c2, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment in let challenge_window = @@ -1453,12 +1451,12 @@ let test_concurrent_refinement_cement () = let* ctxt = Sc_rollup_storage.cement_commitment ctxt rollup c1 in Sc_rollup_storage.last_cemented_commitment ctxt rollup in - let* (c2, ctxt) = + let* c2, ctxt = lift - @@ let* (c2, ctxt) = + @@ let* c2, ctxt = Sc_rollup_storage.refine_stake before_ctxt rollup staker2 commitment in - let* (_c1, ctxt) = + let* _c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment in let challenge_window = @@ -1650,4 +1648,4 @@ let tests = (* FIXME: https://gitlab.com/tezos/tezos/-/issues/2460 Further tests to be added. - *) +*) diff --git a/src/proto_013_PtJakart/lib_protocol/test/unit/test_skip_list_repr.ml b/src/proto_013_PtJakart/lib_protocol/test/unit/test_skip_list_repr.ml index e250076548c8..3e6cc803b0e0 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/unit/test_skip_list_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/unit/test_skip_list_repr.ml @@ -75,7 +75,7 @@ struct let zero = {size = 1; cells = [(0, genesis ())]} let succ list = - let (prev_cell_ptr, prev_cell) = head list in + let prev_cell_ptr, prev_cell = head list in let cell = next ~prev_cell ~prev_cell_ptr () in {size = list.size + 1; cells = (list.size, cell) :: list.cells} diff --git a/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2.ml b/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2.ml index b5d9787447e1..da13b983e01a 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2.ml @@ -102,8 +102,8 @@ let context_with_one_addr = let open Context_l2 in let open Syntax in let ctxt = empty_context in - let (_, _, addr1) = gen_l2_address () in - let+ (ctxt, _, idx1) = Address_index.get_or_associate_index ctxt addr1 in + let _, _, addr1 = gen_l2_address () in + let+ ctxt, _, idx1 = Address_index.get_or_associate_index ctxt addr1 in (ctxt, idx1) let ((_, pk, addr) as l2_addr1) = gen_l2_address () @@ -118,7 +118,7 @@ module Test_Address_medata = struct (** Test that an initilized metadata has a counter of zero and is correctly incremented. *) let test_init_and_incr () = - let* (ctxt, idx) = context_with_one_addr in + let* ctxt, idx = context_with_one_addr in let* metadata = get ctxt idx in assert (metadata = None) ; @@ -136,7 +136,7 @@ module Test_Address_medata = struct (** Test that initializing an index to a public key fails if the index has already been initialized. *) let test_init_twice_fails () = - let* (ctxt, idx) = context_with_one_addr in + let* ctxt, idx = context_with_one_addr in let* ctxt = init_with_public_key ctxt idx pk in @@ -164,7 +164,7 @@ module Test_Address_medata = struct (** Test that crediting more than {!Int64.max_int} causes an overflow. *) let test_counter_overflow () = - let* (ctxt, idx) = context_with_one_addr in + let* ctxt, idx = context_with_one_addr in let* ctxt = init_with_public_key ctxt idx pk in let* ctxt = @@ -213,7 +213,7 @@ end module Test_index (Index : S) = struct let init_context_1 () = let open Context_l2.Syntax in - let* (ctxt, values) = Index.init_context_n 1 in + let* ctxt, values = Index.init_context_n 1 in let value = nth_exn values 0 in return (ctxt, value) @@ -221,9 +221,9 @@ module Test_index (Index : S) = struct from the value gives the same index. *) let test_set_and_get () = let open Context_l2.Syntax in - let* (ctxt, value) = init_context_1 () in + let* ctxt, value = init_context_1 () in - let* (ctxt, created, idx1) = Index.get_or_associate_index ctxt value in + let* ctxt, created, idx1 = Index.get_or_associate_index ctxt value in assert (created = `Created) ; let* idx2 = Index.get ctxt value in @@ -235,7 +235,7 @@ module Test_index (Index : S) = struct address increments the count. *) let test_associate_fresh_index () = let open Context_l2.Syntax in - let* (ctxt, value) = init_context_1 () in + let* ctxt, value = init_context_1 () in let* count = Index.count ctxt in assert (count = 0l) ; @@ -243,7 +243,7 @@ module Test_index (Index : S) = struct let* idx = Index.get ctxt value in assert (idx = None) ; - let* (ctxt, created, idx) = Index.get_or_associate_index ctxt value in + let* ctxt, created, idx = Index.get_or_associate_index ctxt value in assert (created = `Created) ; let* count = Index.count ctxt in @@ -255,18 +255,18 @@ module Test_index (Index : S) = struct (** Test that associating twice the same value give the same index. *) let test_associate_value_twice () = let open Context_l2.Syntax in - let* (ctxt, value) = init_context_1 () in + let* ctxt, value = init_context_1 () in let expected = Indexable.index_exn 0l in - let* (ctxt, created, idx) = Index.get_or_associate_index ctxt value in + let* ctxt, created, idx = Index.get_or_associate_index ctxt value in assert (created = `Created) ; assert (idx = expected) ; let* idx = Index.get ctxt value in assert (idx = Some (Indexable.index_exn 0l)) ; - let* (ctxt, existed, idx) = Index.get_or_associate_index ctxt value in + let* ctxt, existed, idx = Index.get_or_associate_index ctxt value in assert (existed = `Existed) ; assert (idx = expected) ; @@ -277,7 +277,7 @@ module Test_index (Index : S) = struct let test_reach_too_many_l2 () = let open Context_l2.Syntax in - let* (ctxt, value) = init_context_1 () in + let* ctxt, value = init_context_1 () in let* ctxt = Index.set_count ctxt Int32.max_int in let* () = @@ -397,7 +397,7 @@ module Test_Ticket_ledger = struct (** Test that crediting a ticket index to an index behaves correctly. *) let test_credit () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* amount = get ctxt ticket_idx1 idx1 in assert (Tx_rollup_l2_qty.(amount = zero)) ; @@ -411,7 +411,7 @@ module Test_Ticket_ledger = struct (** Test that crediting more than {!Int64.max_int} causes an overflow. *) let test_credit_too_much () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* ctxt = credit ctxt ticket_idx1 idx1 (Tx_rollup_l2_qty.of_int64_exn Int64.max_int) @@ -442,7 +442,7 @@ module Test_Ticket_ledger = struct (** Test that spending a ticket from an index to another one behaves correctly *) let test_spend_valid () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* ctxt = credit ctxt ticket_idx1 idx1 (Tx_rollup_l2_qty.of_int64_exn 10L) @@ -462,7 +462,7 @@ module Test_Ticket_ledger = struct (** Test that spending a ticket without the required balance fails. *) let test_spend_without_balance () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* () = expect_error @@ -473,7 +473,7 @@ module Test_Ticket_ledger = struct return_unit let test_remove_empty_balance () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* ctxt = credit ctxt ticket_idx1 idx1 Tx_rollup_l2_qty.one in let* qty = Internal_for_tests.get_opt ctxt ticket_idx1 idx1 in diff --git a/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml b/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml index 36e8346f513f..93e681e7246d 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml @@ -88,7 +88,7 @@ let aggregate_signature_exn : signature list -> signature = | Some res -> res | None -> raise (Invalid_argument "aggregate_signature_exn") -let (ticket1, ticket2) = +let ticket1, ticket2 = match gen_n_ticket_hash 2 with [x; y] -> (x, y) | _ -> assert false let empty_indexes = {address_indexes = []; ticket_indexes = []} @@ -135,7 +135,7 @@ let check_metadata ctxt name_account description counter pk = let open Syntax in let addr = Tx_rollup_l2_address.of_bls_pk pk in (* We ignore the created [ctxt] because it should be a get only. *) - let* (_ctxt, _, aidx) = Address_index.get_or_associate_index ctxt addr in + let* _ctxt, _, aidx = Address_index.get_or_associate_index ctxt addr in let* metadata = Address_metadata.get ctxt aidx in Alcotest.( check @@ -189,30 +189,28 @@ let with_initial_setup tickets contracts = let open Context_l2.Syntax in let ctxt = empty_context in - let* (ctxt, rev_tidxs) = + let* ctxt, rev_tidxs = list_fold_left_m (fun (ctxt, rev_tidxs) ticket -> - let* (ctxt, _, tidx) = - Ticket_index.get_or_associate_index ctxt ticket - in + let* ctxt, _, tidx = Ticket_index.get_or_associate_index ctxt ticket in return (ctxt, tidx :: rev_tidxs)) (ctxt, []) tickets in let tidxs = List.rev rev_tidxs in - let* (ctxt, rev_contracts) = + let* ctxt, rev_contracts = list_fold_left_m (fun (ctxt, rev_contracts) balances -> - let (pkh, _, _) = gen_l1_address () in - let (sk, pk, addr) = gen_l2_address () in - let* (ctxt, _, idx) = Address_index.get_or_associate_index ctxt addr in + let pkh, _, _ = gen_l1_address () in + let sk, pk, addr = gen_l2_address () in + let* ctxt, _, idx = Address_index.get_or_associate_index ctxt addr in let* ctxt = list_fold_left_m (fun ctxt (ticket, qty) -> let qty = Tx_rollup_l2_qty.of_int64_exn qty in - let* (ctxt, _, tidx) = + let* ctxt, _, tidx = Ticket_index.get_or_associate_index ctxt ticket in Ticket_ledger.credit ctxt tidx idx qty) @@ -325,11 +323,11 @@ let test_simple_deposit () = let deposit = {sender = pkh; destination = value addr1; ticket_hash = ticket1; amount} in - let* (ctxt, result, withdrawal_opt) = apply_deposit ctxt deposit in + let* ctxt, result, withdrawal_opt = apply_deposit ctxt deposit in (* Applying the deposit should create an idx for both [addr1] and [ticket]. *) match (result, withdrawal_opt) with - | (Deposit_success indexes, None) -> + | Deposit_success indexes, None -> let* () = check_indexes [(addr1, 0l)] [(ticket1, 0l)] indexes in let* aidx_opt = Address_index.get ctxt addr1 in let* aidx = get_opt aidx_opt in @@ -347,23 +345,23 @@ let test_simple_deposit () = let test_returned_deposit () = let open Context_l2.Syntax in let balance = Int64.max_int in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1] [[(ticket1, balance)]] in let tidx1 = nth_exn tidxs 0 in - let (_sk1, _pk1, addr1, idx1, pkh) = nth_exn accounts 0 in + let _sk1, _pk1, addr1, idx1, pkh = nth_exn accounts 0 in (* my cup runneth over *) let amount = Tx_rollup_l2_qty.one in let deposit = {sender = pkh; destination = value addr1; ticket_hash = ticket1; amount} in - let* (ctxt, result, withdrawal_opt) = apply_deposit ctxt deposit in + let* ctxt, result, withdrawal_opt = apply_deposit ctxt deposit in (* Applying the deposit will result in a Deposit_failure, an unchanged context and a withdrawal of the deposit *) match (result, withdrawal_opt) with - | (Deposit_failure Tx_rollup_l2_context_sig.Balance_overflow, Some withdrawal) + | Deposit_failure Tx_rollup_l2_context_sig.Balance_overflow, Some withdrawal -> (* balance is unchanged *) let* balance' = Context_l2.Ticket_ledger.get ctxt tidx1 idx1 in @@ -380,7 +378,7 @@ let test_returned_deposit () = withdrawal {claimer = pkh; ticket_hash = ticket1; amount}) ; return_unit - | (Deposit_failure reason, _) -> + | Deposit_failure reason, _ -> let msg = Format.asprintf "Unexpected failure for overflowing deposit: %a" @@ -388,7 +386,7 @@ let test_returned_deposit () = reason in fail_msg msg - | (Deposit_success _result, _) -> + | Deposit_success _result, _ -> fail_msg "Did not expect overflowing deposit to be succesful" let apply_l2_parameters : Protocol.Tx_rollup_l2_apply.parameters = @@ -404,9 +402,9 @@ let test_indexes_creation_bad () = let ctxt = empty_context in let contracts = gen_n_address 3 in - let (sk1, pk1, addr1) = nth_exn contracts 0 in - let (_, _, addr2) = nth_exn contracts 1 in - let (_, _, addr3) = nth_exn contracts 2 in + let sk1, pk1, addr1 = nth_exn contracts 0 in + let _, _, addr2 = nth_exn contracts 1 in + let _, _, addr3 = nth_exn contracts 2 in let deposit = { @@ -416,7 +414,7 @@ let test_indexes_creation_bad () = amount = Tx_rollup_l2_qty.of_int64_exn 20L; } in - let* (ctxt, _, _withdrawal_opt) = apply_deposit ctxt deposit in + let* ctxt, _, _withdrawal_opt = apply_deposit ctxt deposit in let transaction1 = (* This transaction will fail because the number of tickets required is @@ -443,7 +441,7 @@ let test_indexes_creation_bad () = batch (List.concat [signature1; signature2]) [transaction1; transaction2] in - let* (ctxt, Batch_result {results; indexes}, _withdrawals) = + let* ctxt, Batch_result {results; indexes}, _withdrawals = apply_l2_batch ctxt batch in @@ -470,15 +468,15 @@ let test_indexes_creation_bad () = the transaction's status and the balances afterwards. *) let test_simple_l2_transaction () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in - let (sk1, pk1, addr1, idx1, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, idx2, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, idx1, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, idx2, _ = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [addr2] & [addr2] -> [addr1]. *) @@ -491,14 +489,14 @@ let test_simple_l2_transaction () = in let batch = create_batch_v1 [transaction] [[sk1; sk2]] in - let* (ctxt, Batch_result {results; _}, _withdrawals) = + let* ctxt, Batch_result {results; _}, _withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 |> snd in match (status, _withdrawals) with - | (Transaction_success, []) -> + | Transaction_success, [] -> (* Check the balance after the transaction has been applied, we omit the check the indexes to not pollute this test. *) let* () = @@ -543,39 +541,37 @@ let test_simple_l2_transaction () = 20L in return_unit - | (Transaction_success, _) -> fail_msg "Did not expect any withdrawals" - | (Transaction_failure _, _) -> fail_msg "The transaction should be a success" + | Transaction_success, _ -> fail_msg "Did not expect any withdrawals" + | Transaction_failure _, _ -> fail_msg "The transaction should be a success" (** Test that a signer can be layer2 address. *) let test_l2_transaction_l2_addr_signer_good () = let open Context_l2 in let open Syntax in - let* (ctxt, _tidxs, accounts) = - with_initial_setup [] [[(ticket1, 10L)]; []] - in - let (sk1, pk1, addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, addr2, _idx2, _pkh2) = nth_exn accounts 1 in + let* ctxt, _tidxs, accounts = with_initial_setup [] [[(ticket1, 10L)]; []] in + let sk1, pk1, addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, addr2, _idx2, _pkh2 = nth_exn accounts 1 in let* ctxt = Address_metadata.init_with_public_key ctxt idx1 pk1 in let transfer = [transfer ~signer:(signer_addr addr1) ~dest:addr2 ~ticket:ticket1 10L] in let signature = sign_transaction [sk1] transfer in let batch = batch signature [transfer] in - let* (_ctxt, Batch_result {results; indexes = _}, _withdrawals) = + let* _ctxt, Batch_result {results; indexes = _}, _withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 in match status with - | (_, Transaction_success) -> return_unit - | (_, Transaction_failure _) -> fail_msg "The transaction should be a success" + | _, Transaction_success -> return_unit + | _, Transaction_failure _ -> fail_msg "The transaction should be a success" (** Test that signing with a layer2 address needs a proper context. *) let test_l2_transaction_l2_addr_signer_bad () = let open Context_l2 in let open Syntax in let ctxt = empty_context in - let (sk1, pk1, addr1) = gen_l2_address () in - let (_sk2, _pk2, addr2) = gen_l2_address () in + let sk1, pk1, addr1 = gen_l2_address () in + let _sk2, _pk2, addr2 = gen_l2_address () in (* The address has no index in the context *) let transfer = [transfer ~signer:(signer_addr addr1) ~dest:addr2 ~ticket:ticket1 10L] @@ -589,7 +585,7 @@ let test_l2_transaction_l2_addr_signer_bad () = (Tx_rollup_l2_apply.Unknown_address addr1) in (* Now we add the index but the metadata is still missing *) - let* (ctxt, _, idx1) = Address_index.get_or_associate_index ctxt addr1 in + let* ctxt, _, idx1 = Address_index.get_or_associate_index ctxt addr1 in let* () = expect_error ~msg_if_valid:"The check should fail with unknown metadata" @@ -598,30 +594,30 @@ let test_l2_transaction_l2_addr_signer_bad () = in (* Finally we add the metadata and the test pass *) let* ctxt = Address_metadata.init_with_public_key ctxt idx1 pk1 in - let* (ctxt, _, tidx) = Ticket_index.get_or_associate_index ctxt ticket1 in + let* ctxt, _, tidx = Ticket_index.get_or_associate_index ctxt ticket1 in let* ctxt = Ticket_ledger.credit ctxt tidx idx1 (Tx_rollup_l2_qty.of_int64_exn 100L) in - let* (_ctxt, Batch_result {results; indexes = _}, _withdrawals) = + let* _ctxt, Batch_result {results; indexes = _}, _withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 in match status with - | (_, Transaction_success) -> return_unit - | (_, Transaction_failure _) -> fail_msg "The transaction should succeed" + | _, Transaction_success -> return_unit + | _, Transaction_failure _ -> fail_msg "The transaction should succeed" (** The test consists of [pk1] sending [ticket1] to [pkh2]. This results in a withdrawal. *) let test_simple_l1_transaction () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1] [[(ticket1, 10L)]; []] in let tidx1 = nth_exn tidxs 0 in - let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, _idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, _idx2, pkh2 = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [pkh2] *) @@ -631,14 +627,14 @@ let test_simple_l1_transaction () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 |> snd in match (status, withdrawals) with - | (Transaction_success, [withdrawal]) -> + | Transaction_success, [withdrawal] -> (* Check the balance after the transaction has been applied, we omit the check the indexes to not pollute this test. *) let* () = @@ -662,8 +658,8 @@ let test_simple_l1_transaction () = amount = Tx_rollup_l2_qty.of_int64_exn 10L; }) ; return_unit - | (Transaction_success, _) -> fail_msg "Expected exactly one withdrawal" - | (Transaction_failure _, _) -> fail_msg "The transaction should be a success" + | Transaction_success, _ -> fail_msg "Expected exactly one withdrawal" + | Transaction_failure _, _ -> fail_msg "The transaction should be a success" let rec repeat n f acc = if n <= 0 then acc else repeat (n - 1) f (f n acc) @@ -674,17 +670,15 @@ let helper_test_withdrawal_limits_per_batch nb_withdraws ~should_succeed = let open Context_l2.Syntax in (* create sufficiently many accounts *) let accounts = repeat nb_withdraws (fun _i l -> [(ticket1, 2L)] :: l) [] in - let* (ctxt, _tidxs, accounts) = - with_initial_setup [ticket1] ([] :: accounts) - in + let* ctxt, _tidxs, accounts = with_initial_setup [ticket1] ([] :: accounts) in (* destination of withdrawals *) - let (_skD, _pkD, _addrD, _idxD, pkhD) = nth_exn accounts 0 in + let _skD, _pkD, _addrD, _idxD, pkhD = nth_exn accounts 0 in (* transfer 1 ticket from [nb_withdraws] accounts to the dest *) - let (transactions, sks) = + let transactions, sks = repeat nb_withdraws (fun i (transactions, sks) -> - let (sk, pk, _addr, _idx, _pkh) = nth_exn accounts i in + let sk, pk, _addr, _idx, _pkh = nth_exn accounts i in let withdraw = withdraw ~signer:(signer_pk pk) ~dest:pkhD ~ticket:ticket1 1L in @@ -735,10 +729,10 @@ let nb_withdrawals_per_batch_above_limit () = let test_l1_transaction_inexistant_ticket () = let open Context_l2.Syntax in (* empty context *) - let* (ctxt, _tidxs, accounts) = with_initial_setup [] [[]; []] in + let* ctxt, _tidxs, accounts = with_initial_setup [] [[]; []] in - let (sk1, pk1, _addr1, _idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, _idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, _idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, _idx2, pkh2 = nth_exn accounts 1 in (* We build an invalid transaction with: [addr1] -> [pkh2] *) let withdraw = @@ -747,7 +741,7 @@ let test_l1_transaction_inexistant_ticket () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (_ctxt, Batch_result {results; _}, withdrawals) = + let* _ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -771,13 +765,13 @@ let test_l1_transaction_inexistant_ticket () = then batch application fails with Balance_too_low. *) let test_l1_transaction_inexistant_signer () = let open Context_l2.Syntax in - let* (ctxt, _tidxs, accounts) = + let* ctxt, _tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (_sk1, _pk1, _addr1, _idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, _idx2, pkh2) = nth_exn accounts 1 in - let (sk_unknown, pk_unknown, _) = gen_l2_address () in + let _sk1, _pk1, _addr1, _idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, _idx2, pkh2 = nth_exn accounts 1 in + let sk_unknown, pk_unknown, _ = gen_l2_address () in (* Then, we build an invalid transaction with: [pk_unknown] -> [pkh2] *) @@ -787,7 +781,7 @@ let test_l1_transaction_inexistant_signer () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk_unknown]] in - let* (_ctxt, Batch_result {results; _}, withdrawals) = + let* _ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -812,12 +806,12 @@ let test_l1_transaction_inexistant_signer () = let test_l1_transaction_overdraft () = let open Context_l2.Syntax in let initial_balances = [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] initial_balances in - let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, idx2, pkh2 = nth_exn accounts 1 in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in @@ -829,7 +823,7 @@ let test_l1_transaction_overdraft () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -894,12 +888,12 @@ let test_l1_transaction_overdraft () = let test_l1_transaction_zero () = let open Context_l2.Syntax in let initial_balances = [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] initial_balances in - let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, idx2, pkh2 = nth_exn accounts 1 in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in @@ -911,7 +905,7 @@ let test_l1_transaction_zero () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -978,12 +972,12 @@ let test_l1_transaction_zero () = account. *) let test_l1_transaction_partial () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, idx2, pkh2 = nth_exn accounts 1 in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in @@ -995,7 +989,7 @@ let test_l1_transaction_partial () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -1064,15 +1058,15 @@ let test_l1_transaction_partial () = let test_transaction_with_unknown_indexable () = let open Context_l2.Syntax in let open Tx_rollup_l2_batch.V1 in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in - let (sk1, pk1, addr1, aidx1, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, aidx2, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, aidx1, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, aidx2, _ = nth_exn accounts 1 in (* Note that {!with_initial_setup} does not initialize metadatas for the public keys. If it was the case, we could not use this function @@ -1129,14 +1123,14 @@ let test_transaction_with_unknown_indexable () = let signatures = sign_transaction [sk1; sk2] transaction in let batch = batch signatures [transaction] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 |> snd in match (status, withdrawals) with - | (Transaction_success, []) -> + | Transaction_success, [] -> (* Check the balance after the transaction has been applied, we omit the check the indexes to not pollute this test. *) let* () = @@ -1181,8 +1175,8 @@ let test_transaction_with_unknown_indexable () = 20L in return_unit - | (Transaction_success, _) -> fail_msg "Did not expect any withdrawals" - | (Transaction_failure _, _) -> fail_msg "The transaction should be a success" + | Transaction_success, _ -> fail_msg "Did not expect any withdrawals" + | Transaction_failure _, _ -> fail_msg "The transaction should be a success" (** Test that a transaction containing at least one invalid operation fails and does not change the context. It is similar to @@ -1190,14 +1184,14 @@ let test_transaction_with_unknown_indexable () = possess the tickets. *) let test_invalid_transaction () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; []] in let tidx1 = nth_exn tidxs 0 in - let (sk1, pk1, addr1, idx1, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, idx2, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, idx1, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, idx2, _ = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [addr2] & [addr2] -> [addr1]. *) @@ -1210,7 +1204,7 @@ let test_invalid_transaction () = in let batch = create_batch_v1 [transaction] [[sk1; sk2]] in - let* (ctxt, Batch_result {results; _}, _withdrawals) = + let* ctxt, Batch_result {results; _}, _withdrawals = apply_l2_batch ctxt batch in @@ -1249,9 +1243,9 @@ let test_invalid_transaction () = (** Test that submitting an invalid counter fails. *) let test_invalid_counter () = let open Context_l2.Syntax in - let* (ctxt, _, accounts) = with_initial_setup [ticket1] [[]] in + let* ctxt, _, accounts = with_initial_setup [ticket1] [[]] in - let (sk1, pk1, addr1, _idx1, _) = nth_exn accounts 0 in + let sk1, pk1, addr1, _idx1, _ = nth_exn accounts 0 in let counter = 10L in let transaction = @@ -1259,7 +1253,7 @@ let test_invalid_counter () = in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (_ctxt, Batch_result {results; _}, _withdrawals) = + let* _ctxt, Batch_result {results; _}, _withdrawals = apply_l2_batch ctxt batch in @@ -1279,9 +1273,9 @@ let test_invalid_counter () = the batch is incorrectly signed). *) let test_update_counter () = let open Context_l2.Syntax in - let* (ctxt, _, accounts) = with_initial_setup [ticket1] [[]] in + let* ctxt, _, accounts = with_initial_setup [ticket1] [[]] in - let (sk1, pk1, _addr1, _idx1, _) = nth_exn accounts 0 in + let sk1, pk1, _addr1, _idx1, _ = nth_exn accounts 0 in let transactions = transfers @@ -1299,7 +1293,7 @@ let test_update_counter () = create_batch_v1 transactions [[sk1]; [sk1]; [sk1]; [sk1]; [sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -1323,12 +1317,12 @@ let test_update_counter () = let test_pre_apply_batch () = let open Context_l2.Syntax in - let* (ctxt, _tidxs, accounts) = + let* ctxt, _tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, addr1, _idx1, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, _idx2, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, _idx1, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, _idx2, _ = nth_exn accounts 1 in let transaction = transfers @@ -1338,7 +1332,7 @@ let test_pre_apply_batch () = ] in let batch1 = create_batch_v1 [transaction] [[sk1; sk2]] in - let* (ctxt, _indexes, _) = Batch_V1.check_signature ctxt batch1 in + let* ctxt, _indexes, _ = Batch_V1.check_signature ctxt batch1 in let* () = check_metadata @@ -1374,12 +1368,12 @@ let test_pre_apply_batch () = let test_apply_message_batch () = let open Context_l2.Syntax in - let* (ctxt, _, accounts) = + let* ctxt, _, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, addr1, _, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, _, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, _, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, _, _ = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [addr2] & [addr2] -> [addr1]. *) @@ -1391,17 +1385,17 @@ let test_apply_message_batch () = ] in let batch = create_batch_v1 [transaction] [[sk1; sk2]] in - let (msg, _) = + let msg, _ = Tx_rollup_message.make_batch (Data_encoding.Binary.to_string_exn Tx_rollup_l2_batch.encoding (V1 batch)) in - let* (_ctxt, result) = apply_l2_message ctxt msg in + let* _ctxt, result = apply_l2_message ctxt msg in match result with - | (Message_result.Batch_V1_result _, []) -> + | Message_result.Batch_V1_result _, [] -> (* We do not check the result inside as we consider it is covered by other tests. *) return_unit @@ -1411,12 +1405,12 @@ let test_apply_message_batch () = withdrawals. *) let test_apply_message_batch_withdrawals () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, addr1, idx1, pkh1) = nth_exn accounts 0 in - let (sk2, pk2, addr2, idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, addr1, idx1, pkh1 = nth_exn accounts 0 in + let sk2, pk2, addr2, idx2, pkh2 = nth_exn accounts 1 in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in @@ -1464,14 +1458,14 @@ let test_apply_message_batch_withdrawals () = ] in let batch = create_batch_v1 transactions [[sk1]; [sk1]; [sk2]; [sk2]] in - let (msg, _) = + let msg, _ = Tx_rollup_message.make_batch (Data_encoding.Binary.to_string_exn Tx_rollup_l2_batch.encoding (V1 batch)) in - let* (ctxt, result) = apply_l2_message ctxt msg in + let* ctxt, result = apply_l2_message ctxt msg in match result with | ( Message_result.Batch_V1_result @@ -1558,8 +1552,8 @@ let test_apply_message_batch_withdrawals () = List.iter_es (fun res -> match res with - | (_, Message_result.Transaction_success) -> return_unit - | (_, Transaction_failure {index; reason}) -> + | _, Message_result.Transaction_success -> return_unit + | _, Transaction_failure {index; reason} -> let msg = Format.asprintf "Result at position %d unexpectedly failed: %a" @@ -1576,7 +1570,7 @@ let test_apply_message_deposit () = let ctxt = empty_context in let amount = 50L in - let (msg, _) = + let msg, _ = Tx_rollup_message.make_deposit pkh (value addr1) @@ -1584,10 +1578,10 @@ let test_apply_message_deposit () = (Tx_rollup_l2_qty.of_int64_exn amount) in - let* (_ctxt, result) = apply_l2_message ctxt msg in + let* _ctxt, result = apply_l2_message ctxt msg in match result with - | (Message_result.Deposit_result _, []) -> + | Message_result.Deposit_result _, [] -> (* We do not check the result inside as we consider it is covered by other tests. *) return_unit @@ -1596,10 +1590,10 @@ let test_apply_message_deposit () = (** Test an unparsable message. *) let test_apply_message_unparsable () = let open Context_l2.Syntax in - let* (ctxt, _tidxs, _accounts) = + let* ctxt, _tidxs, _accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (msg, _) = + let msg, _ = Tx_rollup_message.make_batch "Yo, let me bust the funky lyrics (You can't parse this)!" in @@ -1610,14 +1604,14 @@ let test_apply_message_unparsable () = let test_transfer_to_self () = let open Context_l2.Syntax in - let* (ctxt, _, accounts) = with_initial_setup [ticket1] [[(ticket1, 10L)]] in - let (sk1, pk1, addr1, _idx1, _) = nth_exn accounts 0 in + let* ctxt, _, accounts = with_initial_setup [ticket1] [[(ticket1, 10L)]] in + let sk1, pk1, addr1, _idx1, _ = nth_exn accounts 0 in let transaction = [transfer ~signer:(signer_pk pk1) ~dest:addr1 ~ticket:ticket1 1L] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (_ctxt, Batch_result {results; _}, _withdrawals) = + let* _ctxt, Batch_result {results; _}, _withdrawals = apply_l2_batch ctxt batch in @@ -1628,28 +1622,28 @@ let test_transfer_to_self () = Transaction_failure {index = 0; reason = Tx_rollup_l2_apply.Invalid_self_transfer} ) -> return_unit - | (_, _) -> fail_msg "The transaction should faild with [Invalid_destination]" + | _, _ -> fail_msg "The transaction should faild with [Invalid_destination]" module Indexes = struct (** The context should be dropped during an invalid deposit, as the indexes should be. *) let test_drop_on_wrong_deposit () = let open Context_l2.Syntax in - let (deposit, _) = + let deposit, _ = make_deposit pkh (value addr1) ticket1 Tx_rollup_l2_qty.one in (* We make the apply fail with an enormous address count *) let* ctxt = Address_index.Internal_for_tests.set_count empty_context Int32.max_int in - let* (ctxt, _) = apply_l2_message ctxt deposit in + let* ctxt, _ = apply_l2_message ctxt deposit in let* ticket_count = Ticket_index.count ctxt in Alcotest.(check int32) "Ticket count should not change" 0l ticket_count ; (* We make the apply fail with an enormous ticket count *) let* ctxt = Ticket_index.Internal_for_tests.set_count empty_context Int32.max_int in - let* (ctxt, _) = apply_l2_message ctxt deposit in + let* ctxt, _ = apply_l2_message ctxt deposit in let* address_count = Address_index.count ctxt in Alcotest.(check int32) "Address count should not change" 0l address_count ; return_unit @@ -1658,10 +1652,10 @@ module Indexes = struct and the destination. *) let test_creation_on_deposit () = let open Context_l2.Syntax in - let (deposit, _) = + let deposit, _ = make_deposit pkh (value addr1) ticket1 Tx_rollup_l2_qty.one in - let* (ctxt, (result, _)) = apply_l2_message empty_context deposit in + let* ctxt, (result, _) = apply_l2_message empty_context deposit in let* ticket_count = Ticket_index.count ctxt in Alcotest.(check int32) "Ticket count should change" 1l ticket_count ; let* address_count = Address_index.count ctxt in @@ -1675,14 +1669,14 @@ module Indexes = struct existed. *) let test_deposit_with_existing_indexes () = let open Context_l2.Syntax in - let* (ctxt, _, _) = + let* ctxt, _, _ = Address_index.get_or_associate_index empty_context addr1 in - let* (ctxt, _, _) = Ticket_index.get_or_associate_index ctxt ticket1 in - let (deposit, _) = + let* ctxt, _, _ = Ticket_index.get_or_associate_index ctxt ticket1 in + let deposit, _ = make_deposit pkh (value addr1) ticket1 Tx_rollup_l2_qty.one in - let* (_, (result, _)) = apply_l2_message ctxt deposit in + let* _, (result, _) = apply_l2_message ctxt deposit in match result with | Deposit_result (Deposit_success indexes) -> check_indexes [] [] indexes | _ -> fail_msg "Should be a success" @@ -1690,17 +1684,17 @@ module Indexes = struct let test_creation_on_valid_batch () = let open Context_l2.Syntax in let contracts = gen_n_address 3 in - let (sk1, pk1, addr1) = nth_exn contracts 0 in - let (_, _, addr2) = nth_exn contracts 1 in - let (_, _, addr3) = nth_exn contracts 2 in - let (deposit, _) = + let sk1, pk1, addr1 = nth_exn contracts 0 in + let _, _, addr2 = nth_exn contracts 1 in + let _, _, addr3 = nth_exn contracts 2 in + let deposit, _ = make_deposit (Obj.magic pk1) (value addr1) ticket1 (Tx_rollup_l2_qty.of_int64_exn 10L) in - let* (ctxt, _) = apply_l2_message empty_context deposit in + let* ctxt, _ = apply_l2_message empty_context deposit in let batch = batch_from_transfers [ @@ -1708,7 +1702,7 @@ module Indexes = struct [(sk1, pk1, addr3, ticket1, 1L, Some 2L)]; ] in - let* (_, (result, _)) = apply_l2_message ctxt batch in + let* _, (result, _) = apply_l2_message ctxt batch in match result with | Batch_V1_result (Batch_result {indexes; _}) -> check_indexes [(addr2, 1l); (addr3, 2l)] [] indexes @@ -1717,18 +1711,18 @@ module Indexes = struct let test_drop_on_wrong_batch () = let open Context_l2.Syntax in let contracts = gen_n_address 4 in - let (sk1, pk1, addr1) = nth_exn contracts 0 in - let (sk2, pk2, addr2) = nth_exn contracts 1 in - let (_, _, addr3) = nth_exn contracts 2 in - let (_, _, addr4) = nth_exn contracts 3 in - let (deposit, _) = + let sk1, pk1, addr1 = nth_exn contracts 0 in + let sk2, pk2, addr2 = nth_exn contracts 1 in + let _, _, addr3 = nth_exn contracts 2 in + let _, _, addr4 = nth_exn contracts 3 in + let deposit, _ = make_deposit (Obj.magic pk1) (value addr1) ticket1 (Tx_rollup_l2_qty.of_int64_exn 10L) in - let* (ctxt, _) = apply_l2_message empty_context deposit in + let* ctxt, _ = apply_l2_message empty_context deposit in let batch = batch_from_transfers [ @@ -1744,7 +1738,7 @@ module Indexes = struct ]; ] in - let* (_ctxt, (result, _)) = apply_l2_message ctxt batch in + let* _ctxt, (result, _) = apply_l2_message ctxt batch in match result with | Batch_V1_result (Batch_result {indexes; _}) -> check_indexes [(addr2, 1l)] [] indexes diff --git a/src/proto_013_PtJakart/lib_tx_rollup/RPC.ml b/src/proto_013_PtJakart/lib_tx_rollup/RPC.ml index 66ffe91ca622..39df99caa42f 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/RPC.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/RPC.ml @@ -258,7 +258,7 @@ module Block = struct let open Inbox in let inbox = block.inbox in let index = state.context_index in - let* (prev_ctxt, message) = + let* prev_ctxt, message = if message_pos = 0 then (* We must take the block predecessor context *) let*? message = @@ -290,7 +290,7 @@ module Block = struct L2block.Hash.pp hash) else - let*? (pred_message, message) = + let*? pred_message, message = match List.drop_n (message_pos - 1) inbox.contents with | pred_message :: message :: _ -> ok (pred_message, message) | _ -> @@ -310,7 +310,7 @@ module Block = struct .tx_rollup_max_withdrawals_per_batch; } in - let* (proof, _) = + let* proof, _ = Prover_apply.apply_message prev_ctxt l2_parameters message.message in return_some proof) @@ -474,8 +474,8 @@ module Context_RPC = struct let* ticket_id = get_ticket_index c ticket in let* address_id = get_address_index c address in match (ticket_id, address_id) with - | (None, _) | (_, None) -> return Tx_rollup_l2_qty.zero - | (Some ticket_id, Some address_id) -> + | None, _ | _, None -> return Tx_rollup_l2_qty.zero + | Some ticket_id, Some address_id -> Context.Ticket_ledger.get c ticket_id address_id let () = @@ -627,7 +627,7 @@ let launch ~host ~acl ~node ~dir () = let start configuration state = let open Lwt_result_syntax in let Configuration.{rpc_addr; _} = configuration in - let (host, rpc_port) = rpc_addr in + let host, rpc_port = rpc_addr in let host = P2p_addr.to_string host in let dir = register state in let node = `TCP (`Port rpc_port) in diff --git a/src/proto_013_PtJakart/lib_tx_rollup/batcher.ml b/src/proto_013_PtJakart/lib_tx_rollup/batcher.ml index dfe644b2689c..7afbe5aa6e10 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/batcher.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/batcher.ml @@ -120,7 +120,7 @@ let get_batches ctxt constants queue = } in try - let* (rev_batches, rev_current_trs, to_remove) = + let* rev_batches, rev_current_trs, to_remove = Tx_queue.fold_es (fun tr_hash tr (batches, rev_current_trs, to_remove) -> let new_trs = tr :: rev_current_trs in @@ -168,7 +168,7 @@ let get_batches ctxt constants queue = let on_batch state = let open Lwt_result_syntax in - let* (batches, to_remove) = + let* batches, to_remove = get_batches state.incr_context state.constants state.transactions in match batches with @@ -195,7 +195,7 @@ let on_register state ~apply (tr : L2_transaction.t) = let prev_context = context in let* context = if apply then - let* (new_context, result, _withdrawals) = + let* new_context, result, _withdrawals = let parameters = Tx_rollup_l2_apply. { diff --git a/src/proto_013_PtJakart/lib_tx_rollup/common.ml b/src/proto_013_PtJakart/lib_tx_rollup/common.ml index 491478b2c1c7..298419e40eba 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/common.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/common.ml @@ -32,7 +32,7 @@ type signer = { let get_signer cctxt pkh = let open Lwt_result_syntax in - let* (alias, pk, sk) = Client_keys.get_key cctxt pkh in + let* alias, pk, sk = Client_keys.get_key cctxt pkh in return {alias; pkh; pk; sk} type 'block reorg = { diff --git a/src/proto_013_PtJakart/lib_tx_rollup/context.ml b/src/proto_013_PtJakart/lib_tx_rollup/context.ml index 8ede5d302a49..42c449f7732e 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/context.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/context.ml @@ -176,7 +176,7 @@ let produce_proof ctxt f = | Some kinded_key -> return kinded_key | None -> fail [Error.Tx_rollup_tree_kinded_key_not_found] in - let*! (proof, result) = + let*! proof, result = produce_stream_proof index kinded_key (fun tree -> let*! res = f tree in Lwt.return (res.tree, res)) @@ -213,5 +213,5 @@ let init_context index = assert ( Context_hash.( tree_hash = Protocol.Tx_rollup_message_result_repr.empty_l2_context_hash)) ; - let* (ctxt, _) = add_tree ctxt tree in + let* ctxt, _ = add_tree ctxt tree in return ctxt diff --git a/src/proto_013_PtJakart/lib_tx_rollup/daemon.ml b/src/proto_013_PtJakart/lib_tx_rollup/daemon.ml index 4806d496c8bb..848a3ae64584 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/daemon.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/daemon.ml @@ -128,7 +128,7 @@ let extract_messages_from_block block_info rollup_id = destination ticket_hash amount - | (_, _) -> None + | _, _ -> None in let acc = match message_and_size with @@ -188,14 +188,14 @@ let extract_messages_from_block block_info rollup_id = | None -> (* Should not happen *) ok acc) - | (_, Receipt No_operation_metadata) | (_, Empty) | (_, Too_large) -> + | _, Receipt No_operation_metadata | _, Empty | _, Too_large -> error (Tx_rollup_no_operation_metadata operation.hash) in match managed_operation with | None -> ok ([], 0) | Some managed_operations -> let open Result_syntax in - let+ (rev_messages, cumulated_size) = + let+ rev_messages, cumulated_size = List.fold_left_e finalize_receipt ([], 0) managed_operations in (List.rev rev_messages, cumulated_size) @@ -213,7 +213,7 @@ let process_messages_and_inboxes (state : State.t) ~(predecessor : L2block.t) ?predecessor_context block_info rollup_id = let open Lwt_result_syntax in let current_hash = block_info.Alpha_block_services.hash in - let*? (messages, cumulated_size) = + let*? messages, cumulated_size = extract_messages_from_block block_info rollup_id in let*! () = Event.(emit messages_application) (List.length messages) in @@ -229,7 +229,7 @@ let process_messages_and_inboxes (state : State.t) ~(predecessor : L2block.t) state.constants.parametric.tx_rollup_max_withdrawals_per_batch; } in - let* (context, contents) = + let* context, contents = Interpreter.interpret_messages predecessor_context parameters @@ -271,7 +271,7 @@ let rec process_block state current_hash rollup_id : if Block_hash.equal state.State.rollup_info.origination_block current_hash then (* This is the rollup origination block, create L2 genesis block *) - let*! (genesis_block, genesis_ctxt) = + let*! genesis_block, genesis_ctxt = create_genesis_block state current_hash in return (genesis_block, Some genesis_ctxt) @@ -294,13 +294,13 @@ let rec process_block state current_hash rollup_id : in (* Handle predecessor Tezos block first *) let*! () = Event.(emit processing_block_predecessor) predecessor_hash in - let* (l2_predecessor_header, predecessor_context) = + let* l2_predecessor_header, predecessor_context = process_block state predecessor_hash rollup_id in let*! () = Event.(emit processing_block) (current_hash, predecessor_hash) in - let* (l2_block, context) = + let* l2_block, context = process_messages_and_inboxes state ~predecessor:l2_predecessor_header @@ -469,7 +469,7 @@ let run configuration cctxt = let* () = Lwt.catch (fun () -> - let* (block_stream, interupt) = + let* block_stream, interupt = connect ~delay:reconnection_delay cctxt in let*! () = diff --git a/src/proto_013_PtJakart/lib_tx_rollup/injector.ml b/src/proto_013_PtJakart/lib_tx_rollup/injector.ml index 9b5d91b0df87..5742366e204a 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/injector.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/injector.ml @@ -289,7 +289,7 @@ let simulate_operations ~must_succeed state signer let (Manager_list annot_op) = Annotated_manager_operation.manager_of_list operations in - let* (oph, op, result) = + let* oph, op, result = Injection.inject_manager_operation state.cctxt ~simulation:true (* Only simulation here *) @@ -299,8 +299,8 @@ let simulate_operations ~must_succeed state signer ~source:signer.pkh ~src_pk:signer.pk ~src_sk:signer.sk - ~successor_level: - true (* Needed to simulate tx_rollup operations in the next block *) + ~successor_level:true + (* Needed to simulate tx_rollup operations in the next block *) ~fee:Limit.unknown ~gas_limit:Limit.unknown ~storage_limit:Limit.unknown @@ -368,7 +368,7 @@ let inject_on_node state packed_contents = let rec inject_operations ~must_succeed state (operations : L1_operation.t list) = let open Lwt_result_syntax in - let* (_oph, packed_contents, result) = + let* _oph, packed_contents, result = simulate_operations ~must_succeed state state.signer operations in let results = Apply_results.to_list result in @@ -705,14 +705,14 @@ let init cctxt ~signers = List.fold_left (fun acc (signer, strategy, tags) -> let tags = Tags.of_list tags in - let (strategy, tags) = + let strategy, tags = match Signature.Public_key_hash.Map.find_opt signer acc with | None -> (strategy, tags) | Some (other_strategy, other_tags) -> let strategy = match (strategy, other_strategy) with - | (Each_block, Each_block) -> Each_block - | (Delay_block, _) | (_, Delay_block) -> + | Each_block, Each_block -> Each_block + | Delay_block, _ | _, Delay_block -> (* Delay_block strategy takes over because we can always wait a little bit more to inject operation which are to be injected "each block". *) diff --git a/src/proto_013_PtJakart/lib_tx_rollup/interpreter.ml b/src/proto_013_PtJakart/lib_tx_rollup/interpreter.ml index 797da4adff83..fae917c5f5e8 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/interpreter.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/interpreter.ml @@ -50,7 +50,7 @@ let () = the proof size boundaries. *) let interpret_message ~rejection_max_proof_size ctxt l2_parameters message = let open Lwt_result_syntax in - let* (proof, res) = Prover_apply.apply_message ctxt l2_parameters message in + let* proof, res = Prover_apply.apply_message ctxt l2_parameters message in let proof_size = Prover_apply.proof_size proof in let result = if proof_size > rejection_max_proof_size then @@ -69,20 +69,20 @@ let interpret_messages ~rejection_max_proof_size ctxt l2_parameters messages = let open Lwt_result_syntax in let ctxt_hash = Context.hash ctxt in let* tree_hash = Context.tree_hash_of_context ctxt in - let+ (ctxt, _ctxt_hash, _tree_hash, rev_contents) = + let+ ctxt, _ctxt_hash, _tree_hash, rev_contents = List.fold_left_es (fun (ctxt, ctxt_hash, tree_hash, acc) message -> - let* (tree, result) = + let* tree, result = interpret_message ~rejection_max_proof_size ctxt l2_parameters message in - let* (ctxt, ctxt_hash, tree_hash) = + let* ctxt, ctxt_hash, tree_hash = match result with | Inbox.Interpreted _ -> (* The message was successfully interpreted but the status in [result] may indicate that the application failed. The context may have been modified with e.g. updated counters. *) let tree_hash = Context.hash_tree tree in - let*! (ctxt, ctxt_hash) = Context.add_tree ctxt tree in + let*! ctxt, ctxt_hash = Context.add_tree ctxt tree in return (ctxt, ctxt_hash, tree_hash) | Inbox.Discarded _ -> (* The message was discarded before attempting to interpret it. The @@ -115,10 +115,10 @@ let interpret_batch ~rejection_max_proof_size ctxt l2_parameters batch = Protocol.Tx_rollup_l2_batch.encoding batch in - let (message, _) = + let message, _ = Protocol.Alpha_context.Tx_rollup_message.make_batch batch_bytes in - let* (_tree, result) = + let* _tree, result = interpret_message ~rejection_max_proof_size ctxt l2_parameters message in match result with Inbox.Discarded trace -> fail trace | _ -> return () diff --git a/src/proto_013_PtJakart/lib_tx_rollup/prover_apply.ml b/src/proto_013_PtJakart/lib_tx_rollup/prover_apply.ml index 51e49fdb133b..a4dc4136f5de 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/prover_apply.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/prover_apply.ml @@ -42,5 +42,5 @@ let apply_message ctxt parameters message = Context. {tree; result = Inbox.Discarded [Environment.wrap_tzerror err]}) in - let* (proof, result) = Context.produce_proof ctxt f in + let* proof, result = Context.produce_proof ctxt f in return (proof, result) diff --git a/src/proto_013_PtJakart/lib_tx_rollup/state.ml b/src/proto_013_PtJakart/lib_tx_rollup/state.ml index 2413dd4ef64e..7cffb3edaedf 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/state.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/state.ml @@ -96,7 +96,7 @@ let tezos_reorg state ~old_head_hash ~new_head_hash = let old_level = old_head.header.shell.level in let new_level = new_head.header.shell.level in let diff = Int32.sub new_level old_level in - let (old_chain, new_chain, old, new_) = + let old_chain, new_chain, old, new_ = if diff = 0l then (* Heads at same level *) let new_chain = new_head :: new_chain in @@ -201,14 +201,14 @@ let rollup_reorg state ~old_head ~new_head = let open Lwt_syntax in let rec loop old_chain new_chain old_head new_head = match (old_head, new_head) with - | (None, _) | (_, None) -> + | None, _ | _, None -> return { ancestor = None; old_chain = List.rev old_chain; new_chain = List.rev new_chain; } - | (Some old_head, Some new_head) -> + | Some old_head, Some new_head -> if L2block.Hash.(old_head.L2block.hash = new_head.L2block.hash) then return { @@ -222,7 +222,7 @@ let rollup_reorg state ~old_head ~new_head = old_head.L2block.header.level new_head.L2block.header.level in - let* (old_chain, new_chain, old, new_) = + let* old_chain, new_chain, old, new_ = if diff = 0l then (* Heads at same level *) let new_chain = new_head :: new_chain in @@ -334,12 +334,12 @@ let init_rollup_info cctxt stores ?rollup_genesis rollup = let*! rollup_info = Stores.Rollup_info_store.read stores.Stores.rollup_info in let* rollup_info = match (rollup_info, rollup_genesis) with - | (None, None) -> + | None, None -> fail [Error.Tx_rollup_no_rollup_info_on_disk_and_no_rollup_genesis_given] - | (Some stored, __) when Tx_rollup.(stored.rollup_id <> rollup) -> + | Some stored, __ when Tx_rollup.(stored.rollup_id <> rollup) -> fail [Error.Tx_rollup_mismatch] - | (Some stored, Some genesis) + | Some stored, Some genesis when Block_hash.(stored.origination_block <> genesis) -> fail [ @@ -350,8 +350,8 @@ let init_rollup_info cctxt stores ?rollup_genesis rollup = given_rollup_genesis = genesis; }; ] - | (Some stored, _) -> return stored - | (None, Some rollup_genesis) -> + | Some stored, _ -> return stored + | None, Some rollup_genesis -> let block = `Hash (rollup_genesis, 0) in let* block_info = Alpha_block_services.info cctxt ~chain:cctxt#chain ~block () @@ -399,7 +399,7 @@ let init cctxt ~data_dir ?(readonly = false) ?rollup_genesis let*! stores = Stores.init ~data_dir ~readonly ~blocks_cache_size:l2_blocks_cache_size in - let* (rollup_info, context_index) = + let* rollup_info, context_index = both (init_rollup_info cctxt stores ?rollup_genesis rollup) (init_context ~data_dir) @@ -413,8 +413,8 @@ let init cctxt ~data_dir ?(readonly = false) ?rollup_genesis ~signers: (List.filter_map (function - | (None, _, _) -> None - | (Some x, strategy, tags) -> Some (x, strategy, tags)) + | None, _, _ -> None + | Some x, strategy, tags -> Some (x, strategy, tags)) [ (operator, Injector.Each_block, [`Commitment]); (* Batches of L2 operations are submitted with a delay after each diff --git a/src/proto_013_PtJakart/lib_tx_rollup/stores.ml b/src/proto_013_PtJakart/lib_tx_rollup/stores.ml index 5a46f0cb0ea0..30bc1967b104 100644 --- a/src/proto_013_PtJakart/lib_tx_rollup/stores.ml +++ b/src/proto_013_PtJakart/lib_tx_rollup/stores.ml @@ -211,11 +211,11 @@ module L2_block_info = struct Bytes.unsafe_to_string dst let decode str offset = - let (file_offset, offset) = read_int64 str offset in - let (predecessor, offset) = + let file_offset, offset = read_int64 str offset in + let predecessor, offset = read_str str ~offset ~len:L2block.Hash.size L2block.Hash.of_string_exn in - let (context, _) = + let context, _ = read_str str ~offset @@ -247,11 +247,11 @@ module Tezos_block_info = struct Bytes.unsafe_to_string dst let decode str offset = - let (l2_block, offset) = + let l2_block, offset = read_str str ~offset ~len:L2block.Hash.size L2block.Hash.of_string_exn in - let (level, offset) = read_int32 str offset in - let (predecessor, _) = + let level, offset = read_int32 str offset in + let predecessor, _ = read_str str ~offset ~len:Block_hash.size Block_hash.of_string_exn in {l2_block; level; predecessor} @@ -275,7 +275,7 @@ module L2_level_info = struct let encode bh = let dst = Bytes.create encoded_size in - let (tag, l2_block_bytes) = + let tag, l2_block_bytes = match bh with | None -> (0, Bytes.make L2block.Hash.size '\000') | Some l2_block -> (1, L2block.Hash.to_bytes l2_block) @@ -285,11 +285,11 @@ module L2_level_info = struct Bytes.unsafe_to_string dst let decode str offset = - let (tag, offset) = read_int8 str offset in + let tag, offset = read_int8 str offset in match tag with | 0 -> None | 1 -> - let (l2block_hash, _) = + let l2block_hash, _ = read_str str ~offset ~len:L2block.Hash.size L2block.Hash.of_string_exn in @@ -419,7 +419,7 @@ module L2_block_store = struct let init ~data_dir ~readonly ~cache_size = let open Lwt_syntax in - let (flag, perms) = + let flag, perms = if readonly then (Unix.O_RDONLY, 0o444) else (Unix.O_RDWR, 0o644) in let* fd = diff --git a/src/proto_alpha/bin_sc_rollup_client/configuration.ml b/src/proto_alpha/bin_sc_rollup_client/configuration.ml index e5cd10551cee..0de3f0b092ae 100644 --- a/src/proto_alpha/bin_sc_rollup_client/configuration.ml +++ b/src/proto_alpha/bin_sc_rollup_client/configuration.ml @@ -40,7 +40,7 @@ let default = let valid_endpoint _configuration s = let endpoint = Uri.of_string s in match (Uri.scheme endpoint, Uri.query endpoint, Uri.fragment endpoint) with - | (Some ("http" | "https"), [], None) -> return endpoint + | Some ("http" | "https"), [], None -> return endpoint | _ -> failwith "Endpoint should be of the form http[s]://address:port" let endpoint_arg () = @@ -82,7 +82,7 @@ let make (base_dir, endpoint) = } let parse argv = - let* (opts, argv) = + let* opts, argv = Clic.parse_global_options (global_options ()) default argv in return (make opts, argv) diff --git a/src/proto_alpha/bin_sc_rollup_node/commitment.ml b/src/proto_alpha/bin_sc_rollup_node/commitment.ml index 5e40a40ca9af..adfdad2fc6f8 100644 --- a/src/proto_alpha/bin_sc_rollup_node/commitment.ml +++ b/src/proto_alpha/bin_sc_rollup_node/commitment.ml @@ -45,9 +45,9 @@ open Alpha_context module type Mutable_level_store = Store.Mutable_value with type value = Raw_level.t -(* We keep the number of messages and ticks to be included in the - next commitment in memory. Note that we do not risk to increase - these counters when the wrong branch is tracked by the rollup +(* We keep the number of messages and ticks to be included in the + next commitment in memory. Note that we do not risk to increase + these counters when the wrong branch is tracked by the rollup node, as only finalized heads are processed to build commitments. *) @@ -265,10 +265,8 @@ module Make (PVM : Pvm.S) : S with module PVM = PVM = struct let cctxt = node_ctxt.cctxt in let sc_rollup_address = node_ctxt.rollup_address in let fee_parameter = node_ctxt.fee_parameter in - let* (source, src_pk, src_sk) = - Node_context.get_operator_keys node_ctxt - in - let* (_, _, Manager_operation_result {operation_result; _}) = + let* source, src_pk, src_sk = Node_context.get_operator_keys node_ctxt in + let* _, _, Manager_operation_result {operation_result; _} = Client_proto_context.sc_rollup_publish cctxt ~chain:cctxt#chain diff --git a/src/proto_alpha/bin_sc_rollup_node/commitment_event.ml b/src/proto_alpha/bin_sc_rollup_node/commitment_event.ml index e5dfda80717f..058432de36ef 100644 --- a/src/proto_alpha/bin_sc_rollup_node/commitment_event.ml +++ b/src/proto_alpha/bin_sc_rollup_node/commitment_event.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 +(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 Add corresponding .mli file. *) open Protocol diff --git a/src/proto_alpha/bin_sc_rollup_node/configuration.ml b/src/proto_alpha/bin_sc_rollup_node/configuration.ml index 504aca0da28f..af7f25564bbd 100644 --- a/src/proto_alpha/bin_sc_rollup_node/configuration.ml +++ b/src/proto_alpha/bin_sc_rollup_node/configuration.ml @@ -46,10 +46,10 @@ let default_rpc_addr = "127.0.0.1" let default_rpc_port = 8932 -(* TODO: https://gitlab.com/tezos/tezos/-/issues/2794 - the below default values have been copied from - `src/proto_alpha/lib_client/client_proto_args.ml`, but - we need to check whether these values are sensible for the rollup +(* TODO: https://gitlab.com/tezos/tezos/-/issues/2794 + the below default values have been copied from + `src/proto_alpha/lib_client/client_proto_args.ml`, but + we need to check whether these values are sensible for the rollup node. *) let default_minimal_fees = diff --git a/src/proto_alpha/bin_sc_rollup_node/daemon.ml b/src/proto_alpha/bin_sc_rollup_node/daemon.ml index cb55f4b33aae..ff8effe6ec43 100644 --- a/src/proto_alpha/bin_sc_rollup_node/daemon.ml +++ b/src/proto_alpha/bin_sc_rollup_node/daemon.ml @@ -51,7 +51,7 @@ let categorise_heads (node_ctxt : Node_context.t) old_heads new_heads = let number_of_new_heads = List.length new_heads in - let (head_states, _, _) = + let head_states, _, _ = List.fold_right (fun head (heads, n, m) -> ({head; finalized = n <= 0; seen_before = m <= 0} :: heads, n - 1, m - 1)) @@ -136,7 +136,7 @@ module Make (PVM : Pvm.S) = struct as such. Heads in `old_heads` whose level is greater than `new_level` can be safely discarded. *) - let (final_heads, _non_final_heads) = + let final_heads, _non_final_heads = List.partition (fun head -> let (Layer1.Head {level; _}) = head in @@ -220,7 +220,7 @@ let run ~data_dir (cctxt : Protocol_client_context.full) = sc_rollup_node_operator fee_parameter in - let* (_pkh, _pk, _skh) = Node_context.get_operator_keys node_ctxt in + let* _pkh, _pk, _skh = Node_context.get_operator_keys node_ctxt in (* Check that the public key hash is valid. *) let module Daemon = Make ((val Components.pvm_of_kind node_ctxt.kind)) in Daemon.run node_ctxt configuration store diff --git a/src/proto_alpha/bin_sc_rollup_node/daemon_event.ml b/src/proto_alpha/bin_sc_rollup_node/daemon_event.ml index 658d2c28fe9c..ac3c104fc8e9 100644 --- a/src/proto_alpha/bin_sc_rollup_node/daemon_event.ml +++ b/src/proto_alpha/bin_sc_rollup_node/daemon_event.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 +(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 Add corresponding .mli file. *) module Simple = struct diff --git a/src/proto_alpha/bin_sc_rollup_node/event.ml b/src/proto_alpha/bin_sc_rollup_node/event.ml index 12511fa90e97..7889d98d9fcb 100644 --- a/src/proto_alpha/bin_sc_rollup_node/event.ml +++ b/src/proto_alpha/bin_sc_rollup_node/event.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 +(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 Add corresponding .mli file. *) module Simple = struct include Internal_event.Simple diff --git a/src/proto_alpha/bin_sc_rollup_node/inbox.ml b/src/proto_alpha/bin_sc_rollup_node/inbox.ml index 2518f3272cac..0d5a5f2fd3ab 100644 --- a/src/proto_alpha/bin_sc_rollup_node/inbox.ml +++ b/src/proto_alpha/bin_sc_rollup_node/inbox.ml @@ -115,7 +115,7 @@ let process_head Node_context.({cctxt; rollup_address; _} as node_ctxt) store @@ let*! history = State.history_of_hash store predecessor in let*! messages_tree = State.get_message_tree store predecessor in let*? level = Raw_level.of_int32 level in - let* (messages_tree, history, inbox) = + let* messages_tree, history, inbox = Store.Inbox.add_messages history inbox level messages messages_tree in let*! () = State.set_message_tree store head_hash messages_tree in diff --git a/src/proto_alpha/bin_sc_rollup_node/inbox_event.ml b/src/proto_alpha/bin_sc_rollup_node/inbox_event.ml index bd284969d7a6..dd68d1af4d03 100644 --- a/src/proto_alpha/bin_sc_rollup_node/inbox_event.ml +++ b/src/proto_alpha/bin_sc_rollup_node/inbox_event.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 +(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 Add corresponding .mli file. *) module Simple = struct include Internal_event.Simple diff --git a/src/proto_alpha/bin_sc_rollup_node/interpreter_event.ml b/src/proto_alpha/bin_sc_rollup_node/interpreter_event.ml index bbabf0172a8a..b78679af8ba6 100644 --- a/src/proto_alpha/bin_sc_rollup_node/interpreter_event.ml +++ b/src/proto_alpha/bin_sc_rollup_node/interpreter_event.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 +(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 Add corresponding .mli file. *) open Protocol.Alpha_context.Sc_rollup diff --git a/src/proto_alpha/bin_sc_rollup_node/layer1.ml b/src/proto_alpha/bin_sc_rollup_node/layer1.ml index 4431df47a204..2135646ea62b 100644 --- a/src/proto_alpha/bin_sc_rollup_node/layer1.ml +++ b/src/proto_alpha/bin_sc_rollup_node/layer1.ml @@ -270,11 +270,11 @@ let chain_events cctxt store chain = | None -> Head {hash = genesis_hash; level = 0l} | Some last_seen_head -> last_seen_head in - let*! (base, events) = catch_up cctxt store chain last_seen_head new_head in + let*! base, events = catch_up cctxt store chain last_seen_head new_head in let*! () = List.iter_s (store_chain_event store base) events in Lwt.return events in - let+ (heads, _) = Tezos_shell_services.Monitor_services.heads cctxt chain in + let+ heads, _ = Tezos_shell_services.Monitor_services.heads cctxt chain in Lwt_stream.map_list_s on_head heads let check_sc_rollup_address_exists sc_rollup_address diff --git a/src/proto_alpha/bin_sc_rollup_node/layer1_event.ml b/src/proto_alpha/bin_sc_rollup_node/layer1_event.ml index 3f88318a5ec3..fd7cd99dc2b5 100644 --- a/src/proto_alpha/bin_sc_rollup_node/layer1_event.ml +++ b/src/proto_alpha/bin_sc_rollup_node/layer1_event.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 +(* TODO: https://gitlab.com/tezos/tezos/-/issues/2880 Add corresponding .mli file. *) module Simple = struct diff --git a/src/proto_alpha/bin_sc_rollup_node/node_context.ml b/src/proto_alpha/bin_sc_rollup_node/node_context.ml index bef4b0e7f405..d60f9947fecb 100644 --- a/src/proto_alpha/bin_sc_rollup_node/node_context.ml +++ b/src/proto_alpha/bin_sc_rollup_node/node_context.ml @@ -38,7 +38,7 @@ type t = { let get_operator_keys node_ctxt = let open Lwt_result_syntax in - let+ (_, pk, sk) = Client_keys.get_key node_ctxt.cctxt node_ctxt.operator in + let+ _, pk, sk = Client_keys.get_key node_ctxt.cctxt node_ctxt.operator in (node_ctxt.operator, pk, sk) let init (cctxt : Protocol_client_context.full) rollup_address operator diff --git a/src/proto_alpha/bin_tx_rollup_client/commands.ml b/src/proto_alpha/bin_tx_rollup_client/commands.ml index 4d2176425cd6..9fabf7aaa959 100644 --- a/src/proto_alpha/bin_tx_rollup_client/commands.ml +++ b/src/proto_alpha/bin_tx_rollup_client/commands.ml @@ -79,7 +79,7 @@ let wallet_parameter () = let* (Bls12_381 public_key_hash) = Client_keys.Aggregate_alias.Public_key_hash.find cctxt alias in - let* (_, pk_opt) = + let* _, pk_opt = Client_keys.Aggregate_alias.Public_key.find cctxt alias in let public_key = @@ -317,7 +317,7 @@ let aggregate_signature signatures = let craft_batch ~transactions = let open Result_syntax in - let (transactions, signatures) = + let transactions, signatures = List.split (List.map (fun L2_transaction.{transaction; signatures} -> @@ -641,7 +641,7 @@ let transfer () = (fun counter qty ticket_hash signer destination cctxt -> let open Lwt_result_syntax in let open Tx_rollup_l2_batch.V1 in - let* (signer, sk_uri, counter) = + let* signer, sk_uri, counter = prepare_operation_parameters cctxt signer counter in (* TODO/TORU: https://gitlab.com/tezos/tezos/-/issues/2903 @@ -687,7 +687,7 @@ let withdraw () = (fun counter qty ticket_hash signer destination cctxt -> let open Lwt_result_syntax in let open Tx_rollup_l2_batch.V1 in - let* (signer, sk_uri, counter) = + let* signer, sk_uri, counter = prepare_operation_parameters cctxt signer counter in let contents = [Withdraw {destination; ticket_hash; qty}] in @@ -781,9 +781,9 @@ let call ?body meth raw_url (cctxt : #Configuration.tx_client_context) = body is not given. In that case, the body should be an empty JSON object. *) match (meth, body) with - | (_, Some _) -> body - | (`DELETE, None) | (`GET, None) -> None - | (`PATCH, None) | (`PUT, None) | (`POST, None) -> Some (`O []) + | _, Some _ -> body + | `DELETE, None | `GET, None -> None + | `PATCH, None | `PUT, None | `POST, None -> Some (`O []) in let* answer = cctxt#generic_media_type_call ?body meth uri in let*! () = display_answer cctxt answer in diff --git a/src/proto_alpha/bin_tx_rollup_client/configuration.ml b/src/proto_alpha/bin_tx_rollup_client/configuration.ml index 241d2f871c3a..a3b8d67ae26b 100644 --- a/src/proto_alpha/bin_tx_rollup_client/configuration.ml +++ b/src/proto_alpha/bin_tx_rollup_client/configuration.ml @@ -46,7 +46,7 @@ let default = let valid_endpoint _configuration s = let endpoint = Uri.of_string s in match (Uri.scheme endpoint, Uri.query endpoint, Uri.fragment endpoint) with - | (Some ("http" | "https"), [], None) -> return endpoint + | Some ("http" | "https"), [], None -> return endpoint | _ -> failwith "Endpoint should be of the form http[s]://address:port" let endpoint_arg () = @@ -104,7 +104,7 @@ let make (base_dir, wallet_dir, endpoint) = } let parse argv = - let* (opts, argv) = + let* opts, argv = Clic.parse_global_options (global_options ()) default argv in return (make opts, argv) diff --git a/src/proto_alpha/lib_benchmark/autocomp.ml b/src/proto_alpha/lib_benchmark/autocomp.ml index e45662a9c1f1..a5ffb8cf0e8b 100644 --- a/src/proto_alpha/lib_benchmark/autocomp.ml +++ b/src/proto_alpha/lib_benchmark/autocomp.ml @@ -141,7 +141,7 @@ module SM = struct let ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t = fun m f rng_state s -> - let (x, s) = m rng_state s in + let x, s = m rng_state s in f x rng_state s [@@inline] @@ -294,14 +294,12 @@ struct complete_data_list path (i + 1) tl (term :: acc) let complete_data typing node rng_state = - let (root_type_opt, _) = - Inference.M.get_data_annot Kernel.Path.root typing - in + let root_type_opt, _ = Inference.M.get_data_annot Kernel.Path.root typing in match root_type_opt with | None -> Stdlib.failwith "Autocomp.complete_data: cannot get type of expr" | Some ty -> - let (_, typing) = Inference.instantiate_base ty typing in - let (result, _) = + let _, typing = Inference.instantiate_base ty typing in + let result, _ = try complete_data node Kernel.Path.root rng_state typing with Autocompletion_error (Cannot_complete_data (subterm, path)) -> Format.eprintf "Cannot complete data@." ; @@ -309,7 +307,7 @@ struct Format.eprintf "%a@." Mikhailsky.pp subterm ; Stdlib.failwith "in autocomp.ml: unrecoverable failure" in - let (typ, _typing) = + let typ, _typing = try Inference.infer_data_with_state result with Inference.Ill_typed_script error -> Format.eprintf "%a@." Inference.pp_inference_error error ; @@ -352,15 +350,15 @@ struct complete_code_list path (i + 1) tl (term :: acc) let complete_code typing node rng_state = - let (root_type_opt, _) = + let root_type_opt, _ = Inference.M.get_instr_annot Kernel.Path.root typing in match root_type_opt with | None -> Stdlib.failwith "Autocomp.complete_code: cannot get type of expr" | Some {bef; aft} -> - let (_, typing) = Inference.instantiate bef typing in - let (_, typing) = Inference.instantiate aft typing in - let (result, _) = + let _, typing = Inference.instantiate bef typing in + let _, typing = Inference.instantiate aft typing in + let result, _ = try complete_code node Kernel.Path.root rng_state typing with | Autocompletion_error (Cannot_complete_code (subterm, path)) -> Format.eprintf "Cannot complete code@." ; @@ -369,14 +367,14 @@ struct Stdlib.failwith "in autocomp.ml: unrecoverable failure" | _ -> assert false in - let ((bef, aft), typing) = + let (bef, aft), typing = try Inference.infer_with_state result with Inference.Ill_typed_script error -> Format.eprintf "%a@." Inference.pp_inference_error error ; Format.eprintf "%a@." Mikhailsky.pp result ; assert false in - let (bef, typing) = instantiate_and_set_stack bef typing in - let (aft, typing) = instantiate_and_set_stack aft typing in + let bef, typing = instantiate_and_set_stack bef typing in + let aft, typing = instantiate_and_set_stack aft typing in (result, (bef, aft), typing) end diff --git a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/inference.ml b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/inference.ml index 72dc6c1ef4be..88ba95c8db0f 100644 --- a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/inference.ml +++ b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/inference.ml @@ -48,10 +48,10 @@ let pp_comparability fmtr (cmp : comparability) = let sup_comparability (c1 : comparability) (c2 : comparability) = match (c1, c2) with - | (Unconstrained, c) | (c, Unconstrained) -> Some c - | (Comparable, Comparable) -> Some Comparable - | (Not_comparable, Not_comparable) -> Some Not_comparable - | (Comparable, Not_comparable) | (Not_comparable, Comparable) -> None + | Unconstrained, c | c, Unconstrained -> Some c + | Comparable, Comparable -> Some Comparable + | Not_comparable, Not_comparable -> Some Not_comparable + | Comparable, Not_comparable | Not_comparable, Comparable -> None type michelson_type = | Base_type of {repr : Type.Base.t option; comparable : comparability} @@ -247,7 +247,7 @@ module M = struct } let ( >>= ) m f s = - let (x, s) = m s in + let x, s = m s in f x s [@@inline] @@ -257,25 +257,25 @@ module M = struct let uf_lift : 'a UF.M.t -> 'a t = fun computation state -> - let (res, uf) = computation state.uf in + let res, uf = computation state.uf in (res, {state with uf}) [@@inline] let repr_lift : 'a Repr_sm.t -> 'a t = fun computation state -> - let (res, repr) = computation state.repr in + let res, repr = computation state.repr in (res, {state with repr}) [@@inline] let annot_instr_lift : 'a Annot_instr_sm.t -> 'a t = fun computation state -> - let (res, annot_instr) = computation state.annot_instr in + let res, annot_instr = computation state.annot_instr in (res, {state with annot_instr}) [@@inline] let annot_data_lift : 'a Annot_data_sm.t -> 'a t = fun computation state -> - let (res, annot_data) = computation state.annot_data in + let res, annot_data = computation state.annot_data in (res, {state with annot_data}) [@@inline] @@ -380,17 +380,17 @@ let rec unify (x : Type.Stack.t) (y : Type.Stack.t) : unit M.t = if x.tag = y.tag then return () else match (x.node, y.node) with - | (Empty_t, Empty_t) -> return () - | (Stack_var_t x, Stack_var_t y) -> + | Empty_t, Empty_t -> return () + | Stack_var_t x, Stack_var_t y -> M.uf_lift (UF.find x) >>= fun root_x -> M.uf_lift (UF.find y) >>= fun root_y -> get_repr_exn root_x >>= fun repr_x -> get_repr_exn root_y >>= fun repr_y -> M.uf_lift (UF.union x y) >>= fun root -> merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | (Stack_var_t v, _) -> unify_single_stack v y - | (_, Stack_var_t v) -> unify_single_stack v x - | (Item_t (ty1, tail1), Item_t (ty2, tail2)) -> + | Stack_var_t v, _ -> unify_single_stack v y + | _, Stack_var_t v -> unify_single_stack v x + | Item_t (ty1, tail1), Item_t (ty2, tail2) -> unify_base ty1 ty2 >>= fun () -> unify tail1 tail2 >>= fun () -> return () | _ -> raise (Ill_typed_script (Stack_types_incompatible (x, y))) @@ -412,37 +412,37 @@ and unify_base (x : Type.Base.t) (y : Type.Base.t) : unit M.t = if x.tag = y.tag then return () else match (x.node, y.node) with - | (Unit_t, Unit_t) - | (Int_t, Int_t) - | (Nat_t, Nat_t) - | (Bool_t, Bool_t) - | (String_t, String_t) - | (Bytes_t, Bytes_t) - | (Key_hash_t, Key_hash_t) - | (Timestamp_t, Timestamp_t) - | (Mutez_t, Mutez_t) - | (Key_t, Key_t) -> + | Unit_t, Unit_t + | Int_t, Int_t + | Nat_t, Nat_t + | Bool_t, Bool_t + | String_t, String_t + | Bytes_t, Bytes_t + | Key_hash_t, Key_hash_t + | Timestamp_t, Timestamp_t + | Mutez_t, Mutez_t + | Key_t, Key_t -> return () - | (Option_t x, Option_t y) -> unify_base x y - | (List_t x, List_t y) -> unify_base x y - | (Set_t x, Set_t y) -> unify_base x y - | (Map_t (kx, vx), Map_t (ky, vy)) -> + | Option_t x, Option_t y -> unify_base x y + | List_t x, List_t y -> unify_base x y + | Set_t x, Set_t y -> unify_base x y + | Map_t (kx, vx), Map_t (ky, vy) -> unify_base kx ky >>= fun () -> unify_base vx vy - | (Pair_t (x, x'), Pair_t (y, y')) -> + | Pair_t (x, x'), Pair_t (y, y') -> unify_base x y >>= fun () -> unify_base x' y' - | (Union_t (x, x'), Union_t (y, y')) -> + | Union_t (x, x'), Union_t (y, y') -> unify_base x y >>= fun () -> unify_base x' y' - | (Lambda_t (x, x'), Lambda_t (y, y')) -> + | Lambda_t (x, x'), Lambda_t (y, y') -> unify_base x y >>= fun () -> unify_base x' y' - | (Var_t x, Var_t y) -> + | Var_t x, Var_t y -> M.uf_lift (UF.find x) >>= fun root_x -> M.uf_lift (UF.find y) >>= fun root_y -> get_repr_exn root_x >>= fun repr_x -> get_repr_exn root_y >>= fun repr_y -> M.uf_lift (UF.union x y) >>= fun root -> merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | (Var_t v, _) -> unify_single_var v y - | (_, Var_t v) -> unify_single_var v x + | Var_t v, _ -> unify_single_var v y + | _, Var_t v -> unify_single_var v x | _ -> instantiate_base x >>= fun x -> instantiate_base y >>= fun y -> @@ -452,11 +452,11 @@ and merge_reprs (repr1 : michelson_type) (repr2 : michelson_type) : michelson_type M.t = let open M in match (repr1, repr2) with - | ((Stack_type None as repr), Stack_type None) - | ((Stack_type (Some _) as repr), Stack_type None) - | (Stack_type None, (Stack_type (Some _) as repr)) -> + | (Stack_type None as repr), Stack_type None + | (Stack_type (Some _) as repr), Stack_type None + | Stack_type None, (Stack_type (Some _) as repr) -> return repr - | ((Stack_type (Some sty1) as repr), Stack_type (Some sty2)) -> + | (Stack_type (Some sty1) as repr), Stack_type (Some sty2) -> unify sty1 sty2 >>= fun () -> return repr | ( Base_type {repr = opt1; comparable = cmp1}, Base_type {repr = opt2; comparable = cmp2} ) -> ( @@ -469,14 +469,14 @@ and merge_reprs (repr1 : michelson_type) (repr2 : michelson_type) : (Comparability_error_types (repr1, repr2)))) | Some comparable -> ( match (opt1, opt2) with - | (None, None) -> return (Base_type {repr = None; comparable}) - | ((Some ty as repr), None) -> + | None, None -> return (Base_type {repr = None; comparable}) + | (Some ty as repr), None -> assert_comparability comparable ty >>= fun () -> return (Base_type {repr; comparable}) - | (None, (Some ty as repr)) -> + | None, (Some ty as repr) -> assert_comparability comparable ty >>= fun () -> return (Base_type {repr; comparable}) - | (Some ty1, Some ty2) -> + | Some ty1, Some ty2 -> unify_base ty1 ty2 >>= fun () -> assert_comparability comparable ty1 >>= fun () -> assert_comparability comparable ty2 >>= fun () -> @@ -555,7 +555,7 @@ and get_comparability (ty : Type.Base.t) : comparability M.t = get_comparability lt >>= fun lc -> get_comparability rt >>= fun rc -> match (lc, rc) with - | (Comparable, Comparable) -> return Comparable + | Comparable, Comparable -> return Comparable | _ -> return Unconstrained) let fresh = @@ -601,35 +601,35 @@ let parse_uint30 n : int = let arith_type (instr : Mikhailsky_prim.prim) (ty1 : Type.Base.t) (ty2 : Type.Base.t) : Type.Base.t option = match (instr, ty1.node, ty2.node) with - | ((I_ADD | I_MUL), Int_t, Int_t) - | ((I_ADD | I_MUL), Int_t, Nat_t) - | ((I_ADD | I_MUL), Nat_t, Int_t) -> + | (I_ADD | I_MUL), Int_t, Int_t + | (I_ADD | I_MUL), Int_t, Nat_t + | (I_ADD | I_MUL), Nat_t, Int_t -> Some Type.int - | ((I_ADD | I_MUL), Nat_t, Nat_t) -> Some Type.nat - | (I_SUB, Int_t, Int_t) - | (I_SUB, Int_t, Nat_t) - | (I_SUB, Nat_t, Int_t) - | (I_SUB, Nat_t, Nat_t) - | (I_SUB, Timestamp_t, Timestamp_t) -> + | (I_ADD | I_MUL), Nat_t, Nat_t -> Some Type.nat + | I_SUB, Int_t, Int_t + | I_SUB, Int_t, Nat_t + | I_SUB, Nat_t, Int_t + | I_SUB, Nat_t, Nat_t + | I_SUB, Timestamp_t, Timestamp_t -> Some Type.int - | (I_EDIV, Int_t, Int_t) - | (I_EDIV, Int_t, Nat_t) - | (I_EDIV, Nat_t, Int_t) - | (I_EDIV, Nat_t, Nat_t) -> + | I_EDIV, Int_t, Int_t + | I_EDIV, Int_t, Nat_t + | I_EDIV, Nat_t, Int_t + | I_EDIV, Nat_t, Nat_t -> Some Type.(option (pair nat nat)) (* Timestamp *) - | (I_ADD, Timestamp_t, Int_t) - | (I_ADD, Int_t, Timestamp_t) - | (I_SUB, Timestamp_t, Int_t) -> + | I_ADD, Timestamp_t, Int_t + | I_ADD, Int_t, Timestamp_t + | I_SUB, Timestamp_t, Int_t -> Some Type.timestamp (* Mutez *) - | (I_ADD, Mutez_t, Mutez_t) - | (I_SUB, Mutez_t, Mutez_t) - | (I_MUL, Mutez_t, Nat_t) - | (I_MUL, Nat_t, Mutez_t) -> + | I_ADD, Mutez_t, Mutez_t + | I_SUB, Mutez_t, Mutez_t + | I_MUL, Mutez_t, Nat_t + | I_MUL, Nat_t, Mutez_t -> Some Type.mutez - | (I_EDIV, Mutez_t, Nat_t) -> Some Type.(option (pair mutez mutez)) - | (I_EDIV, Mutez_t, Mutez_t) -> Some Type.(option (pair nat mutez)) + | I_EDIV, Mutez_t, Nat_t -> Some Type.(option (pair mutez mutez)) + | I_EDIV, Mutez_t, Mutez_t -> Some Type.(option (pair nat mutez)) | _ -> None let rec generate_constraints (path : Mikhailsky.Path.t) (node : Mikhailsky.node) diff --git a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/monads.ml b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/monads.ml index d0939011cb5e..47273406af50 100644 --- a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/monads.ml +++ b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/monads.ml @@ -65,7 +65,7 @@ module Make_state_monad (X : Stores.S) : type 'a t = state -> 'a * state let ( >>= ) m f s = - let (x, s) = m s in + let x, s = m s in f x s let return x s = (x, s) diff --git a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml index 93aa25022308..4b702dd05667 100644 --- a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml +++ b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml @@ -50,7 +50,7 @@ module Test1 = struct let program = seq [add_ii; push bool_ty false_; dip instr_hole; dip swap] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -121,7 +121,7 @@ module Test3 = struct module Rewriter = Rewrite.Make (Mikhailsky.Mikhailsky_signature) (Lang) (Path) (Patt) - let (timing, ((bef, aft), state)) = + let timing, ((bef, aft), state) = try time @@ fun () -> Inference.infer_with_state program with Inference.Ill_typed_script error -> let s = Mikhailsky.to_string program in @@ -195,7 +195,7 @@ module Test4 = struct update_set; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -224,7 +224,7 @@ module Test5 = struct update_map; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -253,7 +253,7 @@ module Test5 = struct ]); ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -325,7 +325,7 @@ module Test7 = struct left; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -370,7 +370,7 @@ module Test8 = struct push_int; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -388,7 +388,7 @@ module Test9 = struct let program = seq [car; if_none hole hole] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -406,7 +406,7 @@ module Test10 = struct let program = seq [hash_key] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -425,7 +425,7 @@ module Test11 = struct let program = seq [lambda [dup; car; dip cdr; add_in]; push_int; apply; push_nat; exec] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -443,7 +443,7 @@ module Test12 = struct let program = seq [dup; dup; if_none hole (seq [drop]); dup; compare] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -462,7 +462,7 @@ module Test13 = struct let program = seq [push Type.(unparse_ty_exn (lambda int int)) (Data.lambda [])] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -480,7 +480,7 @@ module Test14 = struct let program = seq [nil; push_int; cons] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -498,7 +498,7 @@ module Test15 = struct let program = seq [empty_set; size_set; empty_map; size_map; nil; size_list] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -524,7 +524,7 @@ module Test16 = struct iter_set [dup; add_ii; add_ii]; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -559,7 +559,7 @@ module Test17 = struct ]; ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; @@ -601,7 +601,7 @@ module Test18 = struct (seq [drop; drop; push (option_ty (list_ty bool_ty)) Data.none]); ] - let (timing, (bef, aft)) = time @@ fun () -> Inference.infer program + let timing, (bef, aft) = time @@ fun () -> Inference.infer program let _ = Format.printf "Testing type inference\n" ; diff --git a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/type.ml b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/type.ml index dacd2ac7f8fd..5f66f6ff5e7d 100644 --- a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/type.ml +++ b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/type.ml @@ -55,27 +55,26 @@ module Base = struct let equal (t1 : t) (t2 : t) = match (t1, t2) with - | (Var_t v1, Var_t v2) -> v1 = v2 - | (Unit_t, Unit_t) - | (Int_t, Int_t) - | (Nat_t, Nat_t) - | (Bool_t, Bool_t) - | (String_t, String_t) - | (Bytes_t, Bytes_t) - | (Key_hash_t, Key_hash_t) - | (Timestamp_t, Timestamp_t) - | (Mutez_t, Mutez_t) - | (Key_t, Key_t) -> + | Var_t v1, Var_t v2 -> v1 = v2 + | Unit_t, Unit_t + | Int_t, Int_t + | Nat_t, Nat_t + | Bool_t, Bool_t + | String_t, String_t + | Bytes_t, Bytes_t + | Key_hash_t, Key_hash_t + | Timestamp_t, Timestamp_t + | Mutez_t, Mutez_t + | Key_t, Key_t -> true - | (Option_t ty1, Option_t ty2) -> ty1.tag = ty2.tag - | (Pair_t (l1, r1), Pair_t (l2, r2)) -> l1.tag = l2.tag && r1.tag = r2.tag - | (Union_t (l1, r1), Union_t (l2, r2)) -> - l1.tag = l2.tag && r1.tag = r2.tag - | (List_t ty1, List_t ty2) -> ty1.tag = ty2.tag - | (Set_t ty1, Set_t ty2) -> ty1.tag = ty2.tag - | (Map_t (kty1, vty1), Map_t (kty2, vty2)) -> + | Option_t ty1, Option_t ty2 -> ty1.tag = ty2.tag + | Pair_t (l1, r1), Pair_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag + | Union_t (l1, r1), Union_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag + | List_t ty1, List_t ty2 -> ty1.tag = ty2.tag + | Set_t ty1, Set_t ty2 -> ty1.tag = ty2.tag + | Map_t (kty1, vty1), Map_t (kty2, vty2) -> kty1.tag = kty2.tag && vty1.tag = vty2.tag - | (Lambda_t (dom1, range1), Lambda_t (dom2, range2)) -> + | Lambda_t (dom1, range1), Lambda_t (dom2, range2) -> dom1.tag = dom2.tag && range1.tag = range2.tag | _ -> false @@ -132,9 +131,9 @@ module Stack = struct let equal (t1 : t) (t2 : t) = match (t1, t2) with - | (Empty_t, Empty_t) -> true - | (Stack_var_t v1, Stack_var_t v2) -> v1 = v2 - | (Item_t (h1, tl1), Item_t (h2, tl2)) -> h1 == h2 && tl1 == tl2 + | Empty_t, Empty_t -> true + | Stack_var_t v1, Stack_var_t v2 -> v1 = v2 + | Item_t (h1, tl1), Item_t (h2, tl2) -> h1 == h2 && tl1 == tl2 | _ -> false let hash (t : t) = Hashtbl.hash t diff --git a/src/proto_alpha/lib_benchmark/michelson_mcmc_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_mcmc_samplers.ml index 5926dc38fe01..7dc0f4edd716 100644 --- a/src/proto_alpha/lib_benchmark/michelson_mcmc_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_mcmc_samplers.ml @@ -248,7 +248,7 @@ struct let to_michelson {state = ({typing; term} : State_space.t); jump = _} = let typing = Lazy.force typing in - let (node, (bef, aft), state) = + let node, (bef, aft), state = Autocomp.complete_code typing term X.rng_state in let node = @@ -316,8 +316,8 @@ struct let to_michelson {state = ({typing; term} : State_space.t); jump = _} = let typing = Lazy.force typing in - let (node, _) = Autocomp.complete_data typing term X.rng_state in - let (typ, state) = + let node, _ = Autocomp.complete_data typing term X.rng_state in + let typ, state = try Inference.infer_data_with_state node with _ -> Format.eprintf "Bug found!@." ; diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index 87ae02a42baa..2cd5e55bd56a 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -372,21 +372,21 @@ end) else bind (uniform all_non_atomic_type_names) @@ function | `TPair -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_ty left) = m_type ~size:lsize in let* (Ex_ty right) = m_type ~size:rsize in match pair_t (-1) left right with | Error _ -> assert false | Ok (Ty_ex_c res_ty) -> return @@ Ex_ty res_ty) | `TLambda -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_ty domain) = m_type ~size:lsize in let* (Ex_ty range) = m_type ~size:rsize in match lambda_t (-1) domain range with | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TUnion -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_ty left) = m_type ~size:lsize in let* (Ex_ty right) = m_type ~size:rsize in match union_t (-1) left right with @@ -398,7 +398,7 @@ end) | Error _ -> assert false | Ok res_ty -> return @@ Ex_ty res_ty) | `TMap -> ( - let* (lsize, rsize) = pick_split (size - 1) in + let* lsize, rsize = pick_split (size - 1) in let* (Ex_comparable_ty key) = m_comparable_type ~size:lsize in let* (Ex_ty elt) = m_type ~size:rsize in match map_t (-1) key elt with @@ -520,7 +520,7 @@ end) let seed = Bytes.init 32 (fun _ -> char_of_int @@ Random.State.int rng_state 255) in - let (_pkh, public_key, _secret_key) = Bls.generate_key ~seed () in + let _pkh, public_key, _secret_key = Bls.generate_key ~seed () in Tx_rollup_l2_address.Indexable.value (Tx_rollup_l2_address.of_bls_pk public_key) @@ -601,7 +601,7 @@ end) = fun elt_type -> let open M in - let* (length, elements) = + let* length, elements = Structure_samplers.list ~range:P.parameters.list_size ~sampler:(value elt_type) @@ -615,7 +615,7 @@ end) elt Script_typed_ir.comparable_ty -> elt Script_typed_ir.set sampler = fun elt_ty -> let open M in - let* (_, elements) = + let* _, elements = Structure_samplers.list ~range:P.parameters.set_size ~sampler:(value elt_ty) diff --git a/src/proto_alpha/lib_benchmark/mikhailsky_to_michelson.ml b/src/proto_alpha/lib_benchmark/mikhailsky_to_michelson.ml index dbe7dd24789f..89741cd4ca0a 100644 --- a/src/proto_alpha/lib_benchmark/mikhailsky_to_michelson.ml +++ b/src/proto_alpha/lib_benchmark/mikhailsky_to_michelson.ml @@ -107,7 +107,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (_, r) = project_union aft in + let _, r = project_union aft in Inference.instantiate_base r >>= fun r -> Autocomp.replace_vars r >>= fun r -> let r = unparse_type r in @@ -119,7 +119,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (l, _) = project_union aft in + let l, _ = project_union aft in Inference.instantiate_base l >>= fun l -> Autocomp.replace_vars l >>= fun l -> let l = unparse_type l in @@ -135,7 +135,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (dom, range) = project_lambda aft in + let dom, range = project_lambda aft in Inference.instantiate_base dom >>= fun dom -> Autocomp.replace_vars dom >>= fun dom -> Inference.instantiate_base range >>= fun range -> @@ -165,7 +165,7 @@ let rec convert : | None -> raise (Cannot_get_type (node, path)) | Some {aft; _} -> Inference.instantiate aft >>= fun aft -> - let (k, v) = project_map aft in + let k, v = project_map aft in Inference.instantiate_base k >>= fun k -> Autocomp.replace_vars k >>= fun k -> Inference.instantiate_base v >>= fun v -> diff --git a/src/proto_alpha/lib_benchmark/rules.ml b/src/proto_alpha/lib_benchmark/rules.ml index 135a4006fb60..ce35900d5a20 100644 --- a/src/proto_alpha/lib_benchmark/rules.ml +++ b/src/proto_alpha/lib_benchmark/rules.ml @@ -673,7 +673,7 @@ struct (* rules *) (* fresh type variables *) - let (alpha, beta) = (-1, -2) + let alpha, beta = (-1, -2) let replacement ~fresh ~typ ~replacement = { diff --git a/src/proto_alpha/lib_benchmark/test/test_autocompletion.ml b/src/proto_alpha/lib_benchmark/test/test_autocompletion.ml index 5d5d65fdee01..c2f3e6c74295 100644 --- a/src/proto_alpha/lib_benchmark/test/test_autocompletion.ml +++ b/src/proto_alpha/lib_benchmark/test/test_autocompletion.ml @@ -50,7 +50,7 @@ let () = Format.eprintf "Testing dummy program generator@.%!" let run x = x rng_state (Inference.M.empty ()) let invent_term bef aft = - let (term, _state) = run (Autocomp.invent_term bef aft) in + let term, _state = run (Autocomp.invent_term bef aft) in Mikhailsky.seq term let invent_term bef aft = @@ -61,7 +61,7 @@ let invent_term bef aft = Type.Stack.pp aft ; let term = invent_term bef aft in - let (bef', aft') = Inference.infer term in + let bef', aft' = Inference.infer term in Format.eprintf "generated type: %a => %a@." Type.Stack.pp @@ -88,9 +88,9 @@ let () = Format.eprintf "Testing completion@.%!" let complete term = Format.eprintf "term: %a@." Mikhailsky.pp term ; - let ((bef, aft), state) = Inference.infer_with_state term in + let (bef, aft), state = Inference.infer_with_state term in Format.eprintf "Inferred type: %a => %a@." Type.Stack.pp bef Type.Stack.pp aft ; - let (term, (bef', aft'), _state) = + let term, (bef', aft'), _state = Autocomp.complete_code state term rng_state in Format.eprintf "completed: %a@." Mikhailsky.pp term ; diff --git a/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml index a80889bcbe88..875d80b6897a 100644 --- a/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml @@ -51,15 +51,15 @@ let throwaway_context = let dummy_script : Cache.cached_contract = let str = "{ parameter unit; storage unit; code FAILWITH }" in let storage = - let (parsed, _) = Michelson_v1_parser.parse_expression "Unit" in + let parsed, _ = Michelson_v1_parser.parse_expression "Unit" in Alpha_context.Script.lazy_expr parsed.expanded in let code = - let (parsed, _) = Michelson_v1_parser.parse_expression ~check:false str in + let parsed, _ = Michelson_v1_parser.parse_expression ~check:false str in Alpha_context.Script.lazy_expr parsed.expanded in let script = Alpha_context.Script.{code; storage} in - let (ex_script, _) = + let ex_script, _ = Script_ir_translator.parse_script throwaway_context ~legacy:true @@ -96,7 +96,7 @@ end (* We can't produce a Script_cache.identifier without calling [Script_cache.find]. *) let identifier_of_contract (c : Alpha_context.Contract.t) : Cache.identifier = - let (_, id, _) = Cache.find throwaway_context c |> assert_ok_lwt in + let _, id, _ = Cache.find throwaway_context c |> assert_ok_lwt in id let contract_of_int i : Alpha_context.Contract.t = @@ -185,7 +185,7 @@ module Cache_update_benchmark : Benchmark.S = struct let cache_cardinal = Base_samplers.sample_in_interval ~range:{min = 1; max = 100_000} rng_state in - let (ctxt, some_key_in_domain) = prepare_context rng_state cache_cardinal in + let ctxt, some_key_in_domain = prepare_context rng_state cache_cardinal in cache_update_benchmark ctxt some_key_in_domain cache_cardinal let create_benchmarks ~rng_state ~bench_num config = diff --git a/src/proto_alpha/lib_benchmarks_proto/carbonated_map_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/carbonated_map_benchmarks.ml index a4788a34a9fa..013333abbd20 100644 --- a/src/proto_alpha/lib_benchmarks_proto/carbonated_map_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/carbonated_map_benchmarks.ml @@ -96,7 +96,7 @@ module Fold_benchmark : Benchmark.S = struct let benchmark rng_state config () = let module M = Carbonated_map.Make (Alpha_context_gas) (Int) in - let (_, list) = + let _, list = let sampler rng_state = let key = Base_samplers.int rng_state ~size:{min = 1; max = 5} in (* Value should not be important *) @@ -248,7 +248,7 @@ module Make (CS : COMPARABLE_SAMPLER) = struct ] let benchmark rng_state (config : config) () = - let (_, list) = + let _, list = let sampler rng_state = (CS.sampler rng_state, ()) in Structure_samplers.list rng_state diff --git a/src/proto_alpha/lib_benchmarks_proto/encodings_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/encodings_benchmarks.ml index 9684756a3421..1bea188c7980 100644 --- a/src/proto_alpha/lib_benchmarks_proto/encodings_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/encodings_benchmarks.ml @@ -379,7 +379,7 @@ module Timelock = struct let plaintext_size = Base_samplers.sample_in_interval ~range:{min = 1; max = 10000} rng_state in - let (chest, chest_key) = + let chest, chest_key = Timelock.chest_sampler ~plaintext_size ~time ~rng_state in ((chest, chest_key), plaintext_size) @@ -390,7 +390,7 @@ module Timelock = struct ~name:"ENCODING_Chest" ~to_string:(Data_encoding.Binary.to_string_exn Timelock.chest_encoding) ~generator:(fun rng_state -> - let ((chest, _), plaintext_size) = generator rng_state in + let (chest, _), plaintext_size = generator rng_state in (chest, {bytes = plaintext_size})) let () = @@ -400,7 +400,7 @@ module Timelock = struct ~to_string: (Data_encoding.Binary.to_string_exn Timelock.chest_key_encoding) ~generator:(fun rng_state -> - let ((_, chest_key), _w) = generator rng_state in + let (_, chest_key), _w = generator rng_state in chest_key) let () = @@ -410,7 +410,7 @@ module Timelock = struct ~to_bytes:(Data_encoding.Binary.to_bytes_exn Timelock.chest_encoding) ~from_bytes:(Data_encoding.Binary.of_bytes_exn Timelock.chest_encoding) ~generator:(fun rng_state -> - let ((chest, _), _) = generator rng_state in + let (chest, _), _ = generator rng_state in let b = Data_encoding.Binary.to_bytes_exn Timelock.chest_encoding chest in @@ -425,6 +425,6 @@ module Timelock = struct ~from_bytes: (Data_encoding.Binary.of_bytes_exn Timelock.chest_key_encoding) ~generator:(fun rng_state -> - let ((_, chest_key), _w) = generator rng_state in + let (_, chest_key), _w = generator rng_state in chest_key) end diff --git a/src/proto_alpha/lib_benchmarks_proto/global_constants_storage_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/global_constants_storage_benchmarks.ml index b378451fc566..665a450488a4 100644 --- a/src/proto_alpha/lib_benchmarks_proto/global_constants_storage_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/global_constants_storage_benchmarks.ml @@ -612,8 +612,8 @@ module Global_constants_storage_expand_models = struct let size = (Micheline_sampler.micheline_size node).nodes in let registered_constant = Int (-1, Z.of_int 1) in let hash = registered_constant |> node_to_hash in - let (context, _) = Execution_context.make ~rng_state |> assert_ok_lwt in - let (context, _, _) = + let context, _ = Execution_context.make ~rng_state |> assert_ok_lwt in + let context, _, _ = Alpha_context.Global_constants_storage.register context (strip_locations registered_constant) @@ -700,7 +700,7 @@ module Global_constants_storage_expand_models = struct let open Micheline in let node = Micheline_sampler.sample rng_state in let size = (Micheline_sampler.micheline_size node).nodes in - let (context, _) = Execution_context.make ~rng_state |> assert_ok_lwt in + let context, _ = Execution_context.make ~rng_state |> assert_ok_lwt in let expr = strip_locations node in let closure () = ignore diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index 0d6add9c5bc7..81187791c549 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -170,8 +170,8 @@ let benchmark_from_kinstr_and_stack : fun ?amplification ctxt step_constants stack_kinstr -> let ctxt = Gas_helpers.set_limit ctxt in match stack_kinstr with - | Ex_stack_and_kinstr {stack = (bef_top, bef); kinstr} -> - let (workload, closure) = + | Ex_stack_and_kinstr {stack = bef_top, bef; kinstr} -> + let workload, closure = match amplification with | None -> let workload = @@ -181,7 +181,7 @@ let benchmark_from_kinstr_and_stack : kinstr (bef_top, bef) in - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in let closure () = @@ -207,7 +207,7 @@ let benchmark_from_kinstr_and_stack : let workload = List.repeat amplification_factor workload |> List.flatten in - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in let closure () = @@ -256,7 +256,7 @@ let make_benchmark : ?amplification (if intercept then None else Some (Instr_name name)) - let (info, name) = + let info, name = info_and_name ~intercept ?salt @@ -297,7 +297,7 @@ let make_simple_benchmark : let kinfo = Script_typed_ir.kinfo_of_kinstr kinstr in let stack_ty = kinfo.kstack_ty in let kinstr_and_stack_sampler config rng_state = - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -419,8 +419,8 @@ let benchmark_from_continuation : fun ?amplification ctxt step_constants stack_cont -> let ctxt = Gas_helpers.set_limit ctxt in match stack_cont with - | Ex_stack_and_cont {stack = (bef_top, bef); cont} -> - let (workload, closure) = + | Ex_stack_and_cont {stack = bef_top, bef; cont} -> + let workload, closure = match amplification with | None -> let workload = @@ -430,7 +430,7 @@ let benchmark_from_continuation : cont (bef_top, bef) in - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in let closure () = @@ -457,7 +457,7 @@ let benchmark_from_continuation : let workload = List.repeat amplification_factor workload |> List.flatten in - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in let closure () = @@ -508,7 +508,7 @@ let make_continuation_benchmark : ?amplification (if intercept then None else Some (Cont_name name)) - let (info, name) = + let info, name = info_and_name ~intercept ?salt @@ -553,7 +553,7 @@ let nat_of_positive_int (i : int) = match is_nat (of_int i) with None -> assert false | Some x -> x let adversarial_ints rng_state (cfg : Default_config.config) n = - let (_common_prefix, ls) = + let _common_prefix, ls = Base_samplers.Adversarial.integers ~prefix_size:cfg.sampler.base_parameters.int_size ~card:n @@ -1187,7 +1187,7 @@ module Registration_section = struct ~range:cfg.sampler.set_size in let elts = adversarial_ints rng_state cfg (n + 1) in - let (out_of_set, in_set) = + let out_of_set, in_set = match elts with [] -> assert false | hd :: tl -> (hd, tl) in let set = @@ -1309,7 +1309,7 @@ module Registration_section = struct (let map = Script_map.empty int in (Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1329,7 +1329,7 @@ module Registration_section = struct (let map = Script_map.empty int in (Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1349,7 +1349,7 @@ module Registration_section = struct (let map = Script_map.empty int in (Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () @@ -1370,7 +1370,7 @@ module Registration_section = struct (let map = Script_map.empty int in (Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_map_and_key_in_map cfg rng_state in + let key, map = generate_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () @@ -1446,7 +1446,7 @@ module Registration_section = struct ( kinfo (int @$ big_map int unit @$ unit @$ bot), halt (bool @$ unit @$ bot) )) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1466,7 +1466,7 @@ module Registration_section = struct (let map = Script_ir_translator.empty_big_map int unit in (Script_int.zero, (map, ((), eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (map, ((), eos)))) () @@ -1486,7 +1486,7 @@ module Registration_section = struct (let map = Script_ir_translator.empty_big_map int unit in (Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () @@ -1507,7 +1507,7 @@ module Registration_section = struct (let map = Script_ir_translator.empty_big_map int unit in (Script_int.zero, (None, (map, eos)))) ~stack_sampler:(fun cfg rng_state () -> - let (key, map) = generate_big_map_and_key_in_map cfg rng_state in + let key, map = generate_big_map_and_key_in_map cfg rng_state in (key, (Some (), (map, eos)))) () end @@ -1542,7 +1542,7 @@ module Registration_section = struct (let z = Script_int.zero_n in (z, (z, (empty, eos)))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let string = Samplers.Random_value.value Script_typed_ir.string_t rng_state @@ -1588,7 +1588,7 @@ module Registration_section = struct (let z = Script_int.zero_n in (z, (z, (Bytes.empty, eos)))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let bytes = Samplers.Random_value.value Script_typed_ir.bytes_t rng_state @@ -1660,7 +1660,7 @@ module Registration_section = struct ~kinstr: (ISub_tez (kinfo (mutez @$ mutez @$ bot), halt (option mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers cfg.Default_config.sampler in fun () -> @@ -1679,7 +1679,7 @@ module Registration_section = struct ~kinstr: (ISub_tez_legacy (kinfo (mutez @$ mutez @$ bot), halt (mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers cfg.Default_config.sampler in fun () -> @@ -1708,9 +1708,9 @@ module Registration_section = struct ~name:Interpreter_workload.N_IMul_teznat ~kinstr:(IMul_teznat (kinfo (mutez @$ nat @$ bot), halt (mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, samplers) = make_default_samplers cfg.sampler in + let _, samplers = make_default_samplers cfg.sampler in fun () -> - let (mutez, nat) = sample_tez_nat samplers rng_state in + let mutez, nat = sample_tez_nat samplers rng_state in (mutez, (nat, eos))) () @@ -1719,9 +1719,9 @@ module Registration_section = struct ~name:Interpreter_workload.N_IMul_nattez ~kinstr:(IMul_nattez (kinfo (nat @$ mutez @$ bot), halt (mutez @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, samplers) = make_default_samplers cfg.sampler in + let _, samplers = make_default_samplers cfg.sampler in fun () -> - let (mutez, nat) = sample_tez_nat samplers rng_state in + let mutez, nat = sample_tez_nat samplers rng_state in (nat, (mutez, eos))) () @@ -1734,9 +1734,9 @@ module Registration_section = struct ( kinfo (mutez @$ nat @$ bot), halt (option (cpair mutez mutez) @$ bot) )) ~stack_sampler:(fun cfg rng_state -> - let (_, samplers) = make_default_samplers cfg.sampler in + let _, samplers = make_default_samplers cfg.sampler in fun () -> - let (mutez, nat) = sample_tez_nat samplers rng_state in + let mutez, nat = sample_tez_nat samplers rng_state in (mutez, (nat, eos))) () @@ -1802,7 +1802,7 @@ module Registration_section = struct ~kinstr:(IAbs_int (kinfo (int @$ bot), halt (nat @$ bot))) ~intercept_stack:(zero, eos) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let x = Samplers.Michelson_base.nat rng_state in let neg_x = Script_int.neg x in @@ -1875,7 +1875,7 @@ module Registration_section = struct ~intercept_stack:(zero_n, (zero_n, eos)) ~kinstr:(ILsl_nat (kinfo (nat @$ nat @$ bot), halt (nat @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let x = Samplers.Michelson_base.nat rng_state in (* shift must be in [0;256]: 1 byte max *) @@ -1891,7 +1891,7 @@ module Registration_section = struct ~intercept_stack:(zero_n, (zero_n, eos)) ~kinstr:(ILsr_nat (kinfo (nat @$ nat @$ bot), halt (nat @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let x = Samplers.Michelson_base.nat rng_state in (* shift must be in [0;256]: 1 byte max *) @@ -2070,7 +2070,7 @@ module Registration_section = struct benchmark ~name:Interpreter_workload.N_ICompare ~kinstr_and_stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in fun () -> let size = Base_samplers.sample_in_interval @@ -2237,11 +2237,11 @@ module Registration_section = struct ( kinfo (public_key @$ signature @$ bytes @$ bot), halt (bool @$ bot) )) ~stack_sampler:(fun cfg rng_state -> - let ((module Crypto_samplers), (module Samplers)) = + let (module Crypto_samplers), (module Samplers) = make_default_samplers ~algo:(`Algo algo) cfg.Default_config.sampler in fun () -> - let (_pkh, pk, sk) = Crypto_samplers.all rng_state in + let _pkh, pk, sk = Crypto_samplers.all rng_state in let unsigned_message = if for_intercept then Environment.Bytes.empty else Samplers.Random_value.value Script_typed_ir.bytes_t rng_state @@ -2407,7 +2407,7 @@ module Registration_section = struct | Error _ -> assert false | Ok sz -> sz in - let (info, name) = + let info, name = info_and_name ~intercept:false "ISapling_verify_update" in let module B : Benchmark.S = struct @@ -2483,7 +2483,7 @@ module Registration_section = struct in List.map (fun (_, transition) () -> - let (ctxt, state, step_constants) = + let ctxt, state, step_constants = prepare_sapling_execution_environment seed transition in let stack_instr = @@ -2573,7 +2573,7 @@ module Registration_section = struct (IMul_bls12_381_z_fr (kinfo (bls12_381_fr @$ int @$ bot), halt (bls12_381_fr @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in let fr_sampler = Samplers.Random_value.value bls12_381_fr in let zero = Script_int.zero in fun () -> (fr_sampler rng_state, (zero, eos))) @@ -2595,7 +2595,7 @@ module Registration_section = struct (IMul_bls12_381_fr_z (kinfo (int @$ bls12_381_fr @$ bot), halt (bls12_381_fr @$ bot))) ~stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in let fr_sampler = Samplers.Random_value.value bls12_381_fr in let zero = Script_int.zero in fun () -> (zero, (fr_sampler rng_state, eos))) @@ -2690,7 +2690,7 @@ module Registration_section = struct benchmark ~name:Interpreter_workload.N_ISplit_ticket ~kinstr_and_stack_sampler:(fun config rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -2718,7 +2718,7 @@ module Registration_section = struct ~intercept:true ~name:Interpreter_workload.N_IJoin_tickets ~kinstr_and_stack_sampler:(fun config rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -2740,7 +2740,7 @@ module Registration_section = struct benchmark ~name:Interpreter_workload.N_IJoin_tickets ~kinstr_and_stack_sampler:(fun config rng_state -> - let (_, (module Samplers)) = + let _, (module Samplers) = make_default_samplers config.Default_config.sampler in fun () -> @@ -2778,7 +2778,7 @@ module Registration_section = struct ~name ~kinstr ~stack_sampler:(fun _ rng_state () -> - let (chest, chest_key) = + let chest, chest_key = Timelock_samplers.chest_sampler ~plaintext_size:1 ~time:0 ~rng_state in resulting_stack chest chest_key 0) @@ -2801,7 +2801,7 @@ module Registration_section = struct rng_state in - let (chest, chest_key) = + let chest, chest_key = Timelock_samplers.chest_sampler ~plaintext_size ~time ~rng_state in resulting_stack chest chest_key time) @@ -2992,7 +2992,7 @@ module Registration_section = struct ~name:Interpreter_workload.N_KList_enter_body ~salt:"_terminal" ~cont_and_stack_sampler:(fun cfg rng_state -> - let (_, (module Samplers)) = make_default_samplers cfg.sampler in + let _, (module Samplers) = make_default_samplers cfg.sampler in let kbody = halt_unitunit in fun () -> let ys = Samplers.Random_value.value (list unit) rng_state in @@ -3092,7 +3092,7 @@ module Registration_section = struct ICdr (kinfo (cpair int unit @$ unit @$ bot), halt_unitunit) in fun () -> - let (key, map) = Maps.generate_map_and_key_in_map cfg rng_state in + let key, map = Maps.generate_map_and_key_in_map cfg rng_state in let cont = KMap_exit_body (kbody, [], map, key, KNil) in Ex_stack_and_cont {stack = ((), ((), eos)); cont}) () diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml index 52a91b76e7d9..1e2d586cf2f7 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml @@ -1150,63 +1150,63 @@ let extract_ir_sized_step : fun ctxt instr stack -> let open Script_typed_ir in match (instr, stack) with - | (IDrop (_, _), _) -> Instructions.drop - | (IDup (_, _), _) -> Instructions.dup - | (ISwap (_, _), _) -> Instructions.swap - | (IConst (_, _, _), _) -> Instructions.const - | (ICons_pair (_, _), _) -> Instructions.cons_pair - | (ICar (_, _), _) -> Instructions.car - | (ICdr (_, _), _) -> Instructions.cdr - | (IUnpair (_, _), _) -> Instructions.unpair - | (ICons_some (_, _), _) -> Instructions.cons_some - | (ICons_none (_, _), _) -> Instructions.cons_none - | (IIf_none _, _) -> Instructions.if_none - | (IOpt_map _, _) -> Instructions.opt_map - | (ICons_left (_, _), _) -> Instructions.left - | (ICons_right (_, _), _) -> Instructions.right - | (IIf_left _, _) -> Instructions.if_left - | (ICons_list (_, _), _) -> Instructions.cons_list - | (INil (_, _), _) -> Instructions.nil - | (IIf_cons _, _) -> Instructions.if_cons - | (IList_iter (_, _, _), _) -> Instructions.list_iter - | (IList_map (_, _, _), _) -> Instructions.list_map - | (IList_size (_, _), (list, _)) -> Instructions.list_size (Size.list list) - | (IEmpty_set (_, _, _), _) -> Instructions.empty_set - | (ISet_iter _, (set, _)) -> Instructions.set_iter (Size.set set) - | (ISet_mem (_, _), (v, (set, _))) -> + | IDrop (_, _), _ -> Instructions.drop + | IDup (_, _), _ -> Instructions.dup + | ISwap (_, _), _ -> Instructions.swap + | IConst (_, _, _), _ -> Instructions.const + | ICons_pair (_, _), _ -> Instructions.cons_pair + | ICar (_, _), _ -> Instructions.car + | ICdr (_, _), _ -> Instructions.cdr + | IUnpair (_, _), _ -> Instructions.unpair + | ICons_some (_, _), _ -> Instructions.cons_some + | ICons_none (_, _), _ -> Instructions.cons_none + | IIf_none _, _ -> Instructions.if_none + | IOpt_map _, _ -> Instructions.opt_map + | ICons_left (_, _), _ -> Instructions.left + | ICons_right (_, _), _ -> Instructions.right + | IIf_left _, _ -> Instructions.if_left + | ICons_list (_, _), _ -> Instructions.cons_list + | INil (_, _), _ -> Instructions.nil + | IIf_cons _, _ -> Instructions.if_cons + | IList_iter (_, _, _), _ -> Instructions.list_iter + | IList_map (_, _, _), _ -> Instructions.list_map + | IList_size (_, _), (list, _) -> Instructions.list_size (Size.list list) + | IEmpty_set (_, _, _), _ -> Instructions.empty_set + | ISet_iter _, (set, _) -> Instructions.set_iter (Size.set set) + | ISet_mem (_, _), (v, (set, _)) -> let (module S) = Script_set.get set in let sz = S.OPS.elt_size v in Instructions.set_mem sz (Size.set set) - | (ISet_update (_, _), (v, (_flag, (set, _)))) -> + | ISet_update (_, _), (v, (_flag, (set, _))) -> let (module S) = Script_set.get set in let sz = S.OPS.elt_size v in Instructions.set_update sz (Size.set set) - | (ISet_size (_, _), (set, _)) -> Instructions.set_size (Size.set set) - | (IEmpty_map (_, _, _), _) -> Instructions.empty_map - | (IMap_map _, (map, _)) -> Instructions.map_map (Size.map map) - | (IMap_iter _, (map, _)) -> Instructions.map_iter (Size.map map) - | (IMap_mem (_, _), (v, (map, _))) -> + | ISet_size (_, _), (set, _) -> Instructions.set_size (Size.set set) + | IEmpty_map (_, _, _), _ -> Instructions.empty_map + | IMap_map _, (map, _) -> Instructions.map_map (Size.map map) + | IMap_iter _, (map, _) -> Instructions.map_iter (Size.map map) + | IMap_mem (_, _), (v, (map, _)) -> let (module Map) = Script_map.get_module map in let key_size = Map.OPS.key_size v in Instructions.map_mem key_size (Size.map map) - | (IMap_get (_, _), (v, (map, _))) -> + | IMap_get (_, _), (v, (map, _)) -> let (module Map) = Script_map.get_module map in let key_size = Map.OPS.key_size v in Instructions.map_get key_size (Size.map map) - | (IMap_update (_, _), (v, (_elt_opt, (map, _)))) -> + | IMap_update (_, _), (v, (_elt_opt, (map, _))) -> let (module Map) = Script_map.get_module map in let key_size = Map.OPS.key_size v in Instructions.map_update key_size (Size.map map) - | (IMap_get_and_update (_, _), (v, (_elt_opt, (map, _)))) -> + | IMap_get_and_update (_, _), (v, (_elt_opt, (map, _))) -> let (module Map) = Script_map.get_module map in let key_size = Map.OPS.key_size v in Instructions.map_get_and_update key_size (Size.map map) - | (IMap_size (_, _), (map, _)) -> Instructions.map_size (Size.map map) - | (IEmpty_big_map (_, _, _, _), _) -> Instructions.empty_big_map - | (IBig_map_mem (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _))) -> + | IMap_size (_, _), (map, _) -> Instructions.map_size (Size.map map) + | IEmpty_big_map (_, _, _, _), _ -> Instructions.empty_big_map + | IBig_map_mem (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _)) -> let key_size = Size.size_of_comparable_value key_type v in Instructions.big_map_mem key_size (Size.of_int size) - | (IBig_map_get (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _))) -> + | IBig_map_get (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _)) -> let key_size = Size.size_of_comparable_value key_type v in Instructions.big_map_get key_size (Size.of_int size) | ( IBig_map_update (_, _), @@ -1217,7 +1217,7 @@ let extract_ir_sized_step : (v, (_, (Big_map {diff = {size; _}; key_type; _}, _))) ) -> let key_size = Size.size_of_comparable_value key_type v in Instructions.big_map_get_and_update key_size (Size.of_int size) - | (IConcat_string (_, _), (ss, _)) -> + | IConcat_string (_, _), (ss, _) -> let list_size = Size.list ss in let total_bytes = List.fold_left @@ -1226,109 +1226,109 @@ let extract_ir_sized_step : ss.elements in Instructions.concat_string list_size total_bytes - | (IConcat_string_pair (_, _), (s1, (s2, _))) -> + | IConcat_string_pair (_, _), (s1, (s2, _)) -> Instructions.concat_string_pair (Size.script_string s1) (Size.script_string s2) - | (ISlice_string (_, _), (_off, (_len, (s, _)))) -> + | ISlice_string (_, _), (_off, (_len, (s, _))) -> Instructions.slice_string (Size.script_string s) - | (IString_size (_, _), (s, _)) -> + | IString_size (_, _), (s, _) -> Instructions.string_size (Size.script_string s) - | (IConcat_bytes (_, _), (ss, _)) -> + | IConcat_bytes (_, _), (ss, _) -> let list_size = Size.list ss in let total_bytes = List.fold_left (fun x s -> Size.(add x (bytes s))) Size.zero ss.elements in Instructions.concat_bytes list_size total_bytes - | (IConcat_bytes_pair (_, _), (s1, (s2, _))) -> + | IConcat_bytes_pair (_, _), (s1, (s2, _)) -> Instructions.concat_bytes_pair (Size.bytes s1) (Size.bytes s2) - | (ISlice_bytes (_, _), (_off, (_len, (s, _)))) -> + | ISlice_bytes (_, _), (_off, (_len, (s, _))) -> Instructions.slice_bytes (Size.bytes s) - | (IBytes_size (_, _), _) -> Instructions.bytes_size - | (IAdd_seconds_to_timestamp (_, _), (s, (t, _))) -> + | IBytes_size (_, _), _ -> Instructions.bytes_size + | IAdd_seconds_to_timestamp (_, _), (s, (t, _)) -> Instructions.add_seconds_to_timestamp (Size.timestamp t) (Size.integer s) - | (IAdd_timestamp_to_seconds (_, _), (t, (s, _))) -> + | IAdd_timestamp_to_seconds (_, _), (t, (s, _)) -> Instructions.add_timestamp_to_seconds (Size.timestamp t) (Size.integer s) - | (ISub_timestamp_seconds (_, _), (t, (s, _))) -> + | ISub_timestamp_seconds (_, _), (t, (s, _)) -> Instructions.sub_timestamp_seconds (Size.timestamp t) (Size.integer s) - | (IDiff_timestamps (_, _), (t1, (t2, _))) -> + | IDiff_timestamps (_, _), (t1, (t2, _)) -> Instructions.diff_timestamps (Size.timestamp t1) (Size.timestamp t2) - | (IAdd_tez (_, _), (x, (y, _))) -> + | IAdd_tez (_, _), (x, (y, _)) -> Instructions.add_tez (Size.mutez x) (Size.mutez y) - | (ISub_tez (_, _), (x, (y, _))) -> + | ISub_tez (_, _), (x, (y, _)) -> Instructions.sub_tez (Size.mutez x) (Size.mutez y) - | (ISub_tez_legacy (_, _), (x, (y, _))) -> + | ISub_tez_legacy (_, _), (x, (y, _)) -> Instructions.sub_tez_legacy (Size.mutez x) (Size.mutez y) - | (IMul_teznat (_, _), (x, (y, _))) -> + | IMul_teznat (_, _), (x, (y, _)) -> Instructions.mul_teznat (Size.mutez x) (Size.integer y) - | (IMul_nattez (_, _), (x, (y, _))) -> + | IMul_nattez (_, _), (x, (y, _)) -> Instructions.mul_nattez (Size.integer x) (Size.mutez y) - | (IEdiv_teznat (_, _), (x, (y, _))) -> + | IEdiv_teznat (_, _), (x, (y, _)) -> Instructions.ediv_teznat (Size.mutez x) (Size.integer y) - | (IEdiv_tez (_, _), (x, (y, _))) -> + | IEdiv_tez (_, _), (x, (y, _)) -> Instructions.ediv_tez (Size.mutez x) (Size.mutez y) - | (IOr (_, _), _) -> Instructions.or_ - | (IAnd (_, _), _) -> Instructions.and_ - | (IXor (_, _), _) -> Instructions.xor_ - | (INot (_, _), _) -> Instructions.not_ - | (IIs_nat (_, _), (x, _)) -> Instructions.is_nat (Size.integer x) - | (INeg (_, _), (x, _)) -> Instructions.neg (Size.integer x) - | (IAbs_int (_, _), (x, _)) -> Instructions.abs_int (Size.integer x) - | (IInt_nat (_, _), (x, _)) -> Instructions.int_nat (Size.integer x) - | (IAdd_int (_, _), (x, (y, _))) -> + | IOr (_, _), _ -> Instructions.or_ + | IAnd (_, _), _ -> Instructions.and_ + | IXor (_, _), _ -> Instructions.xor_ + | INot (_, _), _ -> Instructions.not_ + | IIs_nat (_, _), (x, _) -> Instructions.is_nat (Size.integer x) + | INeg (_, _), (x, _) -> Instructions.neg (Size.integer x) + | IAbs_int (_, _), (x, _) -> Instructions.abs_int (Size.integer x) + | IInt_nat (_, _), (x, _) -> Instructions.int_nat (Size.integer x) + | IAdd_int (_, _), (x, (y, _)) -> Instructions.add_int (Size.integer x) (Size.integer y) - | (IAdd_nat (_, _), (x, (y, _))) -> + | IAdd_nat (_, _), (x, (y, _)) -> Instructions.add_nat (Size.integer x) (Size.integer y) - | (ISub_int (_, _), (x, (y, _))) -> + | ISub_int (_, _), (x, (y, _)) -> Instructions.sub_int (Size.integer x) (Size.integer y) - | (IMul_int (_, _), (x, (y, _))) -> + | IMul_int (_, _), (x, (y, _)) -> Instructions.mul_int (Size.integer x) (Size.integer y) - | (IMul_nat (_, _), (x, (y, _))) -> + | IMul_nat (_, _), (x, (y, _)) -> Instructions.mul_nat (Size.integer x) (Size.integer y) - | (IEdiv_int (_, _), (x, (y, _))) -> + | IEdiv_int (_, _), (x, (y, _)) -> Instructions.ediv_int (Size.integer x) (Size.integer y) - | (IEdiv_nat (_, _), (x, (y, _))) -> + | IEdiv_nat (_, _), (x, (y, _)) -> Instructions.ediv_nat (Size.integer x) (Size.integer y) - | (ILsl_nat (_, _), (x, (y, _))) -> + | ILsl_nat (_, _), (x, (y, _)) -> Instructions.lsl_nat (Size.integer x) (Size.integer y) - | (ILsr_nat (_, _), (x, (y, _))) -> + | ILsr_nat (_, _), (x, (y, _)) -> Instructions.lsr_nat (Size.integer x) (Size.integer y) - | (IOr_nat (_, _), (x, (y, _))) -> + | IOr_nat (_, _), (x, (y, _)) -> Instructions.or_nat (Size.integer x) (Size.integer y) - | (IAnd_nat (_, _), (x, (y, _))) -> + | IAnd_nat (_, _), (x, (y, _)) -> Instructions.and_nat (Size.integer x) (Size.integer y) - | (IAnd_int_nat (_, _), (x, (y, _))) -> + | IAnd_int_nat (_, _), (x, (y, _)) -> Instructions.and_int_nat (Size.integer x) (Size.integer y) - | (IXor_nat (_, _), (x, (y, _))) -> + | IXor_nat (_, _), (x, (y, _)) -> Instructions.xor_nat (Size.integer x) (Size.integer y) - | (INot_int (_, _), (x, _)) -> Instructions.not_int (Size.integer x) - | (IIf _, _) -> Instructions.if_ - | (ILoop (_, _, _), _) -> Instructions.loop - | (ILoop_left (_, _, _), _) -> Instructions.loop_left - | (IDip (_, _, _), _) -> Instructions.dip - | (IExec (_, _), _) -> Instructions.exec - | (IApply (_, _, _), _) -> Instructions.apply - | (ILambda (_, _, _), _) -> Instructions.lambda - | (IFailwith (_, _, _), _) -> Instructions.failwith_ - | (ICompare (_, cmp_ty, _), (a, (b, _))) -> + | INot_int (_, _), (x, _) -> Instructions.not_int (Size.integer x) + | IIf _, _ -> Instructions.if_ + | ILoop (_, _, _), _ -> Instructions.loop + | ILoop_left (_, _, _), _ -> Instructions.loop_left + | IDip (_, _, _), _ -> Instructions.dip + | IExec (_, _), _ -> Instructions.exec + | IApply (_, _, _), _ -> Instructions.apply + | ILambda (_, _, _), _ -> Instructions.lambda + | IFailwith (_, _, _), _ -> Instructions.failwith_ + | ICompare (_, cmp_ty, _), (a, (b, _)) -> extract_compare_sized_step cmp_ty a b - | (IEq (_, _), _) -> Instructions.eq - | (INeq (_, _), _) -> Instructions.neq - | (ILt (_, _), _) -> Instructions.lt - | (IGt (_, _), _) -> Instructions.gt - | (ILe (_, _), _) -> Instructions.le - | (IGe (_, _), _) -> Instructions.ge - | (IAddress (_, _), _) -> Instructions.address - | (IContract (_, _, _, _), _) -> Instructions.contract - | (ITransfer_tokens (_, _), _) -> Instructions.transfer_tokens - | (IView (_, _, _), _) -> Instructions.view - | (IImplicit_account (_, _), _) -> Instructions.implicit_account - | (ICreate_contract _, _) -> Instructions.create_contract - | (ISet_delegate (_, _), _) -> Instructions.set_delegate - | (INow (_, _), _) -> Instructions.now - | (IBalance (_, _), _) -> Instructions.balance - | (ILevel (_, _), _) -> Instructions.level - | (ICheck_signature (_, _), (public_key, (_signature, (message, _)))) -> ( + | IEq (_, _), _ -> Instructions.eq + | INeq (_, _), _ -> Instructions.neq + | ILt (_, _), _ -> Instructions.lt + | IGt (_, _), _ -> Instructions.gt + | ILe (_, _), _ -> Instructions.le + | IGe (_, _), _ -> Instructions.ge + | IAddress (_, _), _ -> Instructions.address + | IContract (_, _, _, _), _ -> Instructions.contract + | ITransfer_tokens (_, _), _ -> Instructions.transfer_tokens + | IView (_, _, _), _ -> Instructions.view + | IImplicit_account (_, _), _ -> Instructions.implicit_account + | ICreate_contract _, _ -> Instructions.create_contract + | ISet_delegate (_, _), _ -> Instructions.set_delegate + | INow (_, _), _ -> Instructions.now + | IBalance (_, _), _ -> Instructions.balance + | ILevel (_, _), _ -> Instructions.level + | ICheck_signature (_, _), (public_key, (_signature, (message, _))) -> ( match public_key with | Signature.Ed25519 _pk -> let pk = Size.of_int Ed25519.size in @@ -1345,86 +1345,86 @@ let extract_ir_sized_step : let signature = Size.of_int Signature.size in let message = Size.bytes message in Instructions.check_signature_p256 pk signature message) - | (IHash_key (_, _), _) -> Instructions.hash_key - | (IPack (_, ty, _), (v, _)) -> ( + | IHash_key (_, _), _ -> Instructions.hash_key + | IPack (_, ty, _), (v, _) -> ( let script_res = Lwt_main.run (Script_ir_translator.unparse_data ctxt Optimized ty v) in match script_res with | Ok (node, _ctxt) -> Instructions.pack (Size.of_micheline node) | Error _ -> Stdlib.failwith "IPack workload: could not unparse") - | (IUnpack (_, _, _), _) -> Instructions.unpack - | (IBlake2b (_, _), (bytes, _)) -> Instructions.blake2b (Size.bytes bytes) - | (ISha256 (_, _), (bytes, _)) -> Instructions.sha256 (Size.bytes bytes) - | (ISha512 (_, _), (bytes, _)) -> Instructions.sha512 (Size.bytes bytes) - | (ISource (_, _), _) -> Instructions.source - | (ISender (_, _), _) -> Instructions.sender - | (ISelf (_, _, _, _), _) -> Instructions.self - | (ISelf_address (_, _), _) -> Instructions.self_address - | (IAmount (_, _), _) -> Instructions.amount - | (ISapling_empty_state (_, _, _), _) -> Instructions.sapling_empty_state - | (ISapling_verify_update (_, _), (transaction, (_state, _))) -> + | IUnpack (_, _, _), _ -> Instructions.unpack + | IBlake2b (_, _), (bytes, _) -> Instructions.blake2b (Size.bytes bytes) + | ISha256 (_, _), (bytes, _) -> Instructions.sha256 (Size.bytes bytes) + | ISha512 (_, _), (bytes, _) -> Instructions.sha512 (Size.bytes bytes) + | ISource (_, _), _ -> Instructions.source + | ISender (_, _), _ -> Instructions.sender + | ISelf (_, _, _, _), _ -> Instructions.self + | ISelf_address (_, _), _ -> Instructions.self_address + | IAmount (_, _), _ -> Instructions.amount + | ISapling_empty_state (_, _, _), _ -> Instructions.sapling_empty_state + | ISapling_verify_update (_, _), (transaction, (_state, _)) -> let inputs = Size.sapling_transaction_inputs transaction in let outputs = Size.sapling_transaction_outputs transaction in let bound_data = Size.sapling_transaction_bound_data transaction in let state = Size.zero in Instructions.sapling_verify_update inputs outputs bound_data state - | (ISapling_verify_update_deprecated (_, _), (transaction, (_state, _))) -> + | ISapling_verify_update_deprecated (_, _), (transaction, (_state, _)) -> let inputs = List.length transaction.inputs in let outputs = List.length transaction.outputs in let bound_data = Size.zero in let state = Size.zero in Instructions.sapling_verify_update inputs outputs bound_data state - | (IDig (_, n, _, _), _) -> Instructions.dig (Size.of_int n) - | (IDug (_, n, _, _), _) -> Instructions.dug (Size.of_int n) - | (IDipn (_, n, _, _, _), _) -> Instructions.dipn (Size.of_int n) - | (IDropn (_, n, _, _), _) -> Instructions.dropn (Size.of_int n) - | (IChainId (_, _), _) -> Instructions.chain_id - | (INever _, _) -> . - | (IVoting_power (_, _), _) -> Instructions.voting_power - | (ITotal_voting_power (_, _), _) -> Instructions.total_voting_power - | (IKeccak (_, _), (bytes, _)) -> Instructions.keccak (Size.bytes bytes) - | (ISha3 (_, _), (bytes, _)) -> Instructions.sha3 (Size.bytes bytes) - | (IAdd_bls12_381_g1 (_, _), _) -> Instructions.add_bls12_381_g1 - | (IAdd_bls12_381_g2 (_, _), _) -> Instructions.add_bls12_381_g2 - | (IAdd_bls12_381_fr (_, _), _) -> Instructions.add_bls12_381_fr - | (IMul_bls12_381_g1 (_, _), _) -> Instructions.mul_bls12_381_g1 - | (IMul_bls12_381_g2 (_, _), _) -> Instructions.mul_bls12_381_g2 - | (IMul_bls12_381_fr (_, _), _) -> Instructions.mul_bls12_381_fr - | (IMul_bls12_381_z_fr (_, _), (_fr, (z, _))) -> + | IDig (_, n, _, _), _ -> Instructions.dig (Size.of_int n) + | IDug (_, n, _, _), _ -> Instructions.dug (Size.of_int n) + | IDipn (_, n, _, _, _), _ -> Instructions.dipn (Size.of_int n) + | IDropn (_, n, _, _), _ -> Instructions.dropn (Size.of_int n) + | IChainId (_, _), _ -> Instructions.chain_id + | INever _, _ -> . + | IVoting_power (_, _), _ -> Instructions.voting_power + | ITotal_voting_power (_, _), _ -> Instructions.total_voting_power + | IKeccak (_, _), (bytes, _) -> Instructions.keccak (Size.bytes bytes) + | ISha3 (_, _), (bytes, _) -> Instructions.sha3 (Size.bytes bytes) + | IAdd_bls12_381_g1 (_, _), _ -> Instructions.add_bls12_381_g1 + | IAdd_bls12_381_g2 (_, _), _ -> Instructions.add_bls12_381_g2 + | IAdd_bls12_381_fr (_, _), _ -> Instructions.add_bls12_381_fr + | IMul_bls12_381_g1 (_, _), _ -> Instructions.mul_bls12_381_g1 + | IMul_bls12_381_g2 (_, _), _ -> Instructions.mul_bls12_381_g2 + | IMul_bls12_381_fr (_, _), _ -> Instructions.mul_bls12_381_fr + | IMul_bls12_381_z_fr (_, _), (_fr, (z, _)) -> Instructions.mul_bls12_381_z_fr (Size.integer z) - | (IMul_bls12_381_fr_z (_, _), (z, _)) -> + | IMul_bls12_381_fr_z (_, _), (z, _) -> Instructions.mul_bls12_381_fr_z (Size.integer z) - | (IInt_bls12_381_fr (_, _), _) -> Instructions.int_bls12_381_z_fr - | (INeg_bls12_381_g1 (_, _), _) -> Instructions.neg_bls12_381_g1 - | (INeg_bls12_381_g2 (_, _), _) -> Instructions.neg_bls12_381_g2 - | (INeg_bls12_381_fr (_, _), _) -> Instructions.neg_bls12_381_fr - | (IPairing_check_bls12_381 (_, _), (list, _)) -> + | IInt_bls12_381_fr (_, _), _ -> Instructions.int_bls12_381_z_fr + | INeg_bls12_381_g1 (_, _), _ -> Instructions.neg_bls12_381_g1 + | INeg_bls12_381_g2 (_, _), _ -> Instructions.neg_bls12_381_g2 + | INeg_bls12_381_fr (_, _), _ -> Instructions.neg_bls12_381_fr + | IPairing_check_bls12_381 (_, _), (list, _) -> Instructions.pairing_check_bls12_381 (Size.list list) - | (IComb (_, n, _, _), _) -> Instructions.comb (Size.of_int n) - | (IUncomb (_, n, _, _), _) -> Instructions.uncomb (Size.of_int n) - | (IComb_get (_, n, _, _), _) -> Instructions.comb_get (Size.of_int n) - | (IComb_set (_, n, _, _), _) -> Instructions.comb_set (Size.of_int n) - | (IDup_n (_, n, _, _), _) -> Instructions.dupn (Size.of_int n) - | (ITicket (_, _), _) -> Instructions.ticket - | (IRead_ticket (_, _), _) -> Instructions.read_ticket - | (ISplit_ticket (_, _), (_ticket, ((amount_a, amount_b), _))) -> + | IComb (_, n, _, _), _ -> Instructions.comb (Size.of_int n) + | IUncomb (_, n, _, _), _ -> Instructions.uncomb (Size.of_int n) + | IComb_get (_, n, _, _), _ -> Instructions.comb_get (Size.of_int n) + | IComb_set (_, n, _, _), _ -> Instructions.comb_set (Size.of_int n) + | IDup_n (_, n, _, _), _ -> Instructions.dupn (Size.of_int n) + | ITicket (_, _), _ -> Instructions.ticket + | IRead_ticket (_, _), _ -> Instructions.read_ticket + | ISplit_ticket (_, _), (_ticket, ((amount_a, amount_b), _)) -> Instructions.split_ticket (Size.integer amount_a) (Size.integer amount_b) - | (IJoin_tickets (_, cmp_ty, _), ((ticket1, ticket2), _)) -> + | IJoin_tickets (_, cmp_ty, _), ((ticket1, ticket2), _) -> let size1 = Size.size_of_comparable_value cmp_ty ticket1.contents in let size2 = Size.size_of_comparable_value cmp_ty ticket2.contents in let tez1 = Size.integer ticket1.amount in let tez2 = Size.integer ticket2.amount in Instructions.join_tickets size1 size2 tez1 tez2 - | (IHalt _, _) -> Instructions.halt - | (ILog _, _) -> Instructions.log - | (IOpen_chest (_, _), (_, (chest, (time, _)))) -> + | IHalt _, _ -> Instructions.halt + | ILog _, _ -> Instructions.log + | IOpen_chest (_, _), (_, (chest, (time, _))) -> let plaintext_size = Script_timelock.get_plaintext_size chest - 1 |> Size.of_int in let log_time = Z.log2 Z.(one + Script_int.to_zint time) |> Size.of_int in Instructions.open_chest log_time plaintext_size - | (IMin_block_time _, _) -> Instructions.min_block_time + | IMin_block_time _, _ -> Instructions.min_block_time let extract_control_trace (type bef_top bef aft_top aft) (cont : (bef_top, bef, aft_top, aft) Script_typed_ir.continuation) = @@ -1516,7 +1516,7 @@ let extract_deps_continuation (type bef_top bef aft_top aft) ctxt step_constants let logger = {log_interp; log_entry; log_control; log_exit; get_log} in try let res = - let (_gas_counter, outdated_ctxt) = + let _gas_counter, outdated_ctxt = Local_gas_counter.local_gas_counter_and_outdated_context ctxt in Lwt_main.run diff --git a/src/proto_alpha/lib_benchmarks_proto/sapling_generation.ml b/src/proto_alpha/lib_benchmarks_proto/sapling_generation.ml index 52a0f924a186..15b69c5e1208 100644 --- a/src/proto_alpha/lib_benchmarks_proto/sapling_generation.ml +++ b/src/proto_alpha/lib_benchmarks_proto/sapling_generation.ml @@ -127,14 +127,14 @@ let rec gen_rcm state = let add_input diff vk index position sum state = let rcm = gen_rcm state in let amount = random_amount sum in - let (new_idx, address) = + let new_idx, address = Tezos_sapling.Core.Client.Viewing_key.new_address vk index in let cv = Tezos_sapling.Core.Client.CV.of_bytes (random_bytes state 32) |> WithExceptions.Option.get ~loc:__LOC__ in - let (ciphertext, cm) = + let ciphertext, cm = Tezos_sapling.Core.Client.Forge.Output.to_ciphertext Tezos_sapling.Core.Client.Forge.Output. {address; amount; memo = Bytes.empty} @@ -221,7 +221,7 @@ let output proving_ctx vk sum = let amount = random_amount sum in let rcm = Tezos_sapling.Core.Client.Rcm.random () in let esk = Tezos_sapling.Core.Client.DH.esk_random () in - let (cv_o, proof_o) = + let cv_o, proof_o = Tezos_sapling.Core.Client.Proving.output_proof proving_ctx esk @@ -229,7 +229,7 @@ let output proving_ctx vk sum = rcm ~amount in - let (ciphertext, cm) = + let ciphertext, cm = Tezos_sapling.Core.Client.Forge.Output.to_ciphertext Tezos_sapling.Core.Client.Forge.Output. {address; amount; memo = Bytes.empty} @@ -246,7 +246,7 @@ let outputs nb_output proving_ctx vk = match nb_output with | 0 -> (output_amount, list_outputs) | nb_output -> - let (output, amount) = output proving_ctx vk sum in + let output, amount = output proving_ctx vk sum in assert ( Int64.compare amount @@ -268,7 +268,7 @@ let make_inputs to_forge local_state proving_ctx sk vk root anti_replay = (fun {rcm; position; amount; address; nf} -> let witness = Tezos_sapling.Storage.get_witness local_state position in let ar = Tezos_sapling.Core.Client.Proving.ar_random () in - let (cv, rk, proof) = + let cv, rk, proof = Tezos_sapling.Core.Client.Proving.spend_proof proving_ctx vk @@ -326,7 +326,7 @@ let prepare_seeded_state_internal ~(nb_input : int) ~(nb_nf : int) init_fresh_sapling_state ctxt >|= Protocol.Environment.wrap_tzresult >>=? fun (ctxt, id) -> let index_start = Tezos_sapling.Core.Client.Viewing_key.default_index in - let (sk, vk) = generate_spending_and_viewing_keys state in + let sk, vk = generate_spending_and_viewing_keys state in generate_commitments ~vk ~nb_input @@ -364,7 +364,7 @@ let generate ~(nb_input : int) ~(nb_output : int) ~(nb_nf : int) ~(nb_cm : int) Tezos_sapling.Core.Client.Proving.with_proving_ctx (fun proving_ctx -> make_inputs to_forge local_state proving_ctx sk vk root anti_replay >>=? fun inputs -> - let (output_amount, outputs) = outputs nb_output proving_ctx vk in + let output_amount, outputs = outputs nb_output proving_ctx vk in let input_amount = List.fold_left (fun sum {amount; _} -> diff --git a/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml index 8e969dd06543..ffe9c75e8d4f 100644 --- a/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml @@ -192,7 +192,7 @@ module Sc_rollup_add_messages_benchmark = struct let new_ctxt = let open Lwt_result_syntax in - let* (block, _) = Context.init1 () in + let* block, _ = Context.init1 () in let+ b = Incremental.begin_construction block in let state = Incremental.validation_state b in let ctxt = state.ctxt in @@ -206,7 +206,7 @@ module Sc_rollup_add_messages_benchmark = struct let ctxt_with_rollup = let open Lwt_result_syntax in let* ctxt = new_ctxt in - let+ (rollup, _size, ctxt) = + let+ rollup, _size, ctxt = Lwt.map Environment.wrap_tzresult @@ Sc_rollup_storage.originate ctxt ~kind:Example_arith ~boot_sector:"" in @@ -215,7 +215,7 @@ module Sc_rollup_add_messages_benchmark = struct let add_message_and_increment_level ctxt rollup = let open Lwt_result_syntax in - let+ (inbox, _, ctxt) = + let+ inbox, _, ctxt = Lwt.map Environment.wrap_tzresult @@ Sc_rollup_storage.add_messages ctxt rollup ["CAFEBABE"] in @@ -229,22 +229,22 @@ module Sc_rollup_add_messages_benchmark = struct if Raw_level_repr.((Raw_context.current_level ctxt).level > last_level) then return (inbox, ctxt) else - let* (inbox, ctxt) = add_message_and_increment_level ctxt rollup in + let* inbox, ctxt = add_message_and_increment_level ctxt rollup in add_messages_for_level ctxt inbox rollup in - let* (rollup, ctxt) = ctxt_with_rollup in + let* rollup, ctxt = ctxt_with_rollup in let inbox = Sc_rollup_inbox_repr.empty rollup (Raw_context.current_level ctxt).level in - let* (inbox, ctxt) = add_messages_for_level ctxt inbox rollup in - let+ (messages, _ctxt) = + let* inbox, ctxt = add_messages_for_level ctxt inbox rollup in + let+ messages, _ctxt = Lwt.return @@ Environment.wrap_tzresult @@ Raw_context.Sc_rollup_in_memory_inbox.current_messages ctxt rollup in (inbox, messages) in - let (inbox, current_messages) = + let inbox, current_messages = match Lwt_main.run @@ prepare_benchmark_scenario () with | Ok result -> result | Error _ -> assert false diff --git a/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml index 236bd10adedd..8d8589f41d8e 100644 --- a/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml @@ -188,7 +188,7 @@ let rec dummy_type_generator ~rng_state size = if size <= 1 then ticket_or_int else match (ticket_or_int, dummy_type_generator ~rng_state (size - 3)) with - | (Ex_ty l, Ex_ty r) -> ( + | Ex_ty l, Ex_ty r -> ( match pair_t (-1) l r with | Error _ -> assert false | Ok (Ty_ex_c t) -> Ex_ty t) @@ -203,7 +203,7 @@ module Has_tickets_type_benchmark : Benchmark.S = struct let make_bench_helper rng_state config () = let open Result_syntax in - let* (ctxt, _) = Lwt_main.run (Execution_context.make ~rng_state) in + let* ctxt, _ = Lwt_main.run (Execution_context.make ~rng_state) in let ctxt = Gas_helpers.set_limit ctxt in let size = Random.State.int rng_state config.max_size in let (Ex_ty ty) = dummy_type_generator ~rng_state size in @@ -245,7 +245,7 @@ let () = Registration_helpers.register (module Has_tickets_type_benchmark) let ticket_sampler rng_state = let seed = Base_samplers.uniform_bytes ~nbytes:32 rng_state in - let (pkh, _, _) = Signature.generate_key ~algo:Signature.Ed25519 ~seed () in + let pkh, _, _ = Signature.generate_key ~algo:Signature.Ed25519 ~seed () in let ticketer = Alpha_context.Contract.Implicit pkh in Script_typed_ir. {ticketer; contents = Script_int.zero; amount = Script_int.one_n} @@ -261,12 +261,12 @@ module Collect_tickets_benchmark : Benchmark.S = struct let make_bench_helper rng_state config () = let open Script_typed_ir in let open Result_syntax in - let* (ctxt, _) = Lwt_main.run (Execution_context.make ~rng_state) in + let* ctxt, _ = Lwt_main.run (Execution_context.make ~rng_state) in let ctxt = Gas_helpers.set_limit ctxt in let ty = match list_t (-1) ticket_ty with Error _ -> assert false | Ok t -> t in - let (length, elements) = + let length, elements = Structure_samplers.list ~range:{min = 0; max = config.max_size} ~sampler:ticket_sampler @@ -274,7 +274,7 @@ module Collect_tickets_benchmark : Benchmark.S = struct in let boxed_ticket_list = {elements; length} in Environment.wrap_tzresult - @@ let* (has_tickets, ctxt) = Ticket_scanner.type_has_tickets ctxt ty in + @@ let* has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt ty in let workload = {nodes = length} in let closure () = ignore diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 45853341c76d..18678c6fa131 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -503,7 +503,7 @@ let check_printable_benchmark = in (string, {Shared_linear.bytes = String.length string})) ~make_bench:(fun generator () -> - let (generated, workload) = generator () in + let generated, workload = generator () in let closure () = ignore (check_printable_ascii generated (String.length generated - 1)) in @@ -627,7 +627,7 @@ let () = Registration_helpers.register (module Ty_eq) This structure is the worse-case of the unparsing function for types because an extra test is performed to determine if the comb type needs to be folded. - *) +*) let rec dummy_type_generator size = let open Script_ir_translator in let open Script_typed_ir in diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml index 135fe840eff4..065fd6007e71 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml @@ -88,7 +88,7 @@ let pp fmtr (trace : t) = consumed let workload_to_sparse_vec (trace : t) = - let (name, {Size.traversal; int_bytes; string_bytes}, consumed) = + let name, {Size.traversal; int_bytes; string_bytes}, consumed = match trace with | Typechecker_workload {t_kind; code_or_data; micheline_size; consumed} -> let name = diff --git a/src/proto_alpha/lib_benchmarks_proto/tx_rollup_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/tx_rollup_benchmarks.ml index 21b6a275e982..37f9e9c08415 100644 --- a/src/proto_alpha/lib_benchmarks_proto/tx_rollup_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/tx_rollup_benchmarks.ml @@ -268,8 +268,7 @@ let make_key ctxt content = ctxt ~ticketer:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} ~typ:"string" - ~contents: - (Printf.sprintf {|"%s"|} content) + ~contents:(Printf.sprintf {|"%s"|} content) (* In practice, the owner is a rollup address, but this is important only for the table of tickets *) ~owner:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} @@ -280,7 +279,7 @@ let make_ticket str = ( Context.init1 () >>=? fun (blk, _) -> Incremental.begin_construction blk >>=? fun incr -> let ctxt = Incremental.alpha_ctxt incr in - let (ticket, _ctxt) = make_key ctxt str in + let ticket, _ctxt = make_key ctxt str in return ticket ) with | Ok x -> x @@ -313,8 +312,8 @@ let input ~rng_state nb_of_couple_addr nb_of_ticket_per_couple = | 0 -> acc | n -> (* Generate random identities *) - let (sk1, pk1) = gen_l2_account rng_state in - let (sk2, pk2) = gen_l2_account rng_state in + let sk1, pk1 = gen_l2_account rng_state in + let sk2, pk2 = gen_l2_account rng_state in let addr1 = Tx_rollup_l2_address.of_bls_pk pk1 in let addr2 = Tx_rollup_l2_address.of_bls_pk pk2 in (* Pick indexes *) @@ -343,13 +342,13 @@ let init_ctxt input = let* tree = list_fold_left_m (fun tree couple -> - let* (tree, _, idx1) = + let* tree, _, idx1 = Address_index.get_or_associate_index tree couple.addr1.addr in let* tree = Address_metadata.init_with_public_key tree idx1 couple.addr1.pk in - let* (tree, _, idx2) = + let* tree, _, idx2 = Address_index.get_or_associate_index tree couple.addr2.addr in let* tree = @@ -358,7 +357,7 @@ let init_ctxt input = let* tree = list_fold_left_m (fun tree ticket -> - let* (tree, _, tidx) = + let* tree, _, tidx = Ticket_index.get_or_associate_index tree ticket.hash in let* tree = Ticket_ledger.credit tree tidx idx1 qty in @@ -394,7 +393,7 @@ let create_operation ~rng_state input senders = let value = Indexable.from_value value in either idx value in - let (couple, source) = + let couple, source = (* The source must be unique in the transfer. The l2 operation forbids operation to have multiple transfers from the same source. *) let rec pick_until_new () = @@ -475,7 +474,7 @@ let create_transaction ~rng_state input nb_op = let rec aux acc senders = function | 0 -> acc | n -> - let (op, signer, senders) = create_operation ~rng_state input senders in + let op, signer, senders = create_operation ~rng_state input senders in let acc = (op, signer) :: acc in aux acc senders (n - 1) in @@ -484,7 +483,7 @@ let create_transaction ~rng_state input nb_op = aux acc senders nb_op let make_msg ~rng_state input nb_op = - let (transaction, signers) = + let transaction, signers = create_transaction ~rng_state input nb_op |> List.split in let buf = @@ -525,7 +524,7 @@ let create_proof store max_withdrawals msg = let open Prover_context.Syntax in let index = Irmin_context.index store in let* hash = hash_tree_from_store store in - let* (proof, _) = + let* proof, _ = Irmin_context.produce_stream_proof index (`Node hash) (fun tree -> Prover_apply.( catch diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index ba34dc202c11..4850838c452f 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -718,18 +718,18 @@ let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block let pp_operation formatter (a : Alpha_block_services.operation) = match (a.receipt, a.protocol_data) with - | (Receipt (Apply_results.Operation_metadata omd), Operation_data od) -> ( + | Receipt (Apply_results.Operation_metadata omd), Operation_data od -> ( match Apply_results.kind_equal_list od.contents omd.contents with | Some Apply_results.Eq -> Operation_result.pp_operation_result formatter (od.contents, omd.contents) | None -> Stdlib.failwith "Unexpected result.") - | (Empty, _) -> + | Empty, _ -> Stdlib.failwith "Pruned metadata: the operation receipt was removed accordingly to the \ node's history mode." - | (Too_large, _) -> Stdlib.failwith "Too large metadata." + | Too_large, _ -> Stdlib.failwith "Too large metadata." | _ -> Stdlib.failwith "Unexpected result." let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash diff --git a/src/proto_alpha/lib_client/client_proto_fa12.ml b/src/proto_alpha/lib_client/client_proto_fa12.ml index e9c046013c6a..4818bfe2b59b 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.ml +++ b/src/proto_alpha/lib_client/client_proto_fa12.ml @@ -270,7 +270,7 @@ type type_eq_combinator = Script.node * (Script.node -> bool) check functions, and returns a type of n-ary pair of such types and a function checking syntactical equivalence with another node. *) let t_pair ~loc l : type_eq_combinator = - let (values, are_ty) = List.split l in + let values, are_ty = List.split l in let is_pair p = match p with | Micheline.Prim (_, Script.T_pair, l, _) -> ( @@ -536,8 +536,8 @@ let parse_callback error expr = let len = String.length s - pos - 1 in let name = String.sub s (pos + 1) len in match (String.sub s 0 pos, name) with - | (addr, "default") -> of_b58_check (addr, None) - | (addr, name) -> of_b58_check (addr, Some name))) + | addr, "default" -> of_b58_check (addr, None) + | addr, name -> of_b58_check (addr, Some name))) | _ -> error () let action_of_expr ~entrypoint expr = @@ -648,7 +648,7 @@ let derive_action expr t_param = | ( Micheline.Prim (_, Script.D_Right, [right], _), Micheline.Prim (_, Script.T_or, [_; t_right], _) ) -> derive right t_right - | (_, Micheline.Prim (_, _, _, annots)) -> + | _, Micheline.Prim (_, _, _, annots) -> find_entrypoint_in_annot error annots expr | _ -> error () in @@ -747,7 +747,7 @@ let parse_error = | ( "NotEnoughAllowance", Prim (_, Script.D_Pair, [Int (_, required); Int (_, present)], _) ) -> Some (Not_enough_allowance (required, present)) - | ("UnsafeAllowanceChange", Int (_, previous)) -> + | "UnsafeAllowanceChange", Int (_, previous) -> Some (Unsafe_allowance_change previous) | _ -> None @@ -771,7 +771,7 @@ let call_contract (cctxt : #Protocol_client_context.full) ~chain ~block ~contract ~action ~tez_amount ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () = contract_has_fa12_interface cctxt ~chain ~block ~contract () >>=? fun () -> - let (entrypoint, parameters) = translate_action_to_argument action in + let entrypoint, parameters = translate_action_to_argument action in Client_proto_context.transfer_with_script cctxt ~chain diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index f3ab5864f68e..d2a2b0555f21 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -303,7 +303,7 @@ let script_size cctxt ~(chain : Chain_services.chain) ~block ?gas ?legacy let print_typecheck_result ~emacs ~show_types ~print_source_on_error program res (cctxt : #Client_context.printer) = if emacs then - let (type_map, errs, _gas) = + let type_map, errs, _gas = match res with | Ok (type_map, gas) -> (type_map, [], Some gas) | Error diff --git a/src/proto_alpha/lib_client/client_proto_utils.ml b/src/proto_alpha/lib_client/client_proto_utils.ml index 27fec54d342a..be6844cc5cf7 100644 --- a/src/proto_alpha/lib_client/client_proto_utils.ml +++ b/src/proto_alpha/lib_client/client_proto_utils.ml @@ -37,14 +37,14 @@ let to_json_and_bytes branch message = Data_encoding.Binary.to_bytes_exn encoding op ) let sign_message (cctxt : #full) ~src_sk ~block ~message = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in cctxt#message "signed content: @[%a@]" Data_encoding.Json.pp json >>= fun () -> Client_keys.sign cctxt ~watermark:Signature.Generic_operation src_sk bytes let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = - let (json, bytes) = to_json_and_bytes block message in + let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index 305c77ab229e..1e16c2704e77 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -265,7 +265,7 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -288,12 +288,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ~chain_id ~latency >>=? function - | (Operation_data op', Operation_metadata result) -> ( + | Operation_data op', Operation_metadata result -> ( match ( Operation.equal op {shell = {branch}; protocol_data = op'}, Apply_results.kind_equal_list contents result.contents ) with - | (Some Operation.Eq, Some Apply_results.Eq) -> + | Some Operation.Eq, Some Apply_results.Eq -> return ((oph, op, result) : t preapply_result) | _ -> failwith "Unexpected result") | _ -> failwith "Unexpected result" @@ -636,7 +636,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) | Single_manager minfo -> gas_patching_stats minfo need_patching gas_consumed | Cons_manager (minfo, rest) -> - let (need_patching, gas_consumed) = + let need_patching, gas_consumed = gas_patching_stats minfo need_patching gas_consumed in gas_patching_stats_list rest need_patching gas_consumed @@ -686,7 +686,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) in let rest_opt = loop rest in match (annotated_op_opt, rest_opt) with - | (None, None) -> None + | None, None -> None | _ -> let op = Option.value ~default:annotated_op annotated_op_opt in let rest = Option.value ~default:rest rest_opt in @@ -755,7 +755,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Annotated_manager_operation.t * kind Kind.manager contents_result -> kind Kind.manager contents tzresult Lwt.t = fun ~first -> function - | ((Manager_info c as op), (Manager_operation_result _ as result)) -> + | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then Lwt.return (estimated_gas_single result) >>= fun gas -> match gas with @@ -849,16 +849,16 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) kind Kind.manager contents_list tzresult Lwt.t = fun first annotated_list result_list -> match (annotated_list, result_list) with - | (Single_manager annotated, Single_result res) -> + | Single_manager annotated, Single_result res -> patch ~first (annotated, res) >>=? fun op -> return (Single op) - | (Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest)) -> + | Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest) -> patch ~first (annotated, res) >>=? fun op -> patch_list false annotated_rest res_rest >>=? fun rest -> return (Cons (op, rest)) | _ -> assert false in let gas_limit_per_patched_op = - let (need_gas_patching, gas_consumed) = + let need_gas_patching, gas_consumed = gas_patching_stats_list annotated_contents 0 Gas.Arith.zero in if need_gas_patching = 0 then hard_gas_limit_per_operation @@ -946,7 +946,7 @@ let tenderbake_adjust_confirmations (cctxt : #Client_context.full) = function Any value greater than the tenderbake_finality_confirmations is treated as if it were tenderbake_finality_confirmations. - *) +*) let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?(dry_run = false) ?(simulation = false) ?(force = false) ?successor_level ?branch ?src_sk ?verbose_signing ?fee_parameter @@ -1388,7 +1388,7 @@ let inject_manager_operation cctxt ~chain ~block ?successor_level ?branch >>=? fun (oph, op, result) -> match pack_contents_list op result with | Cons_and_result (_, _, rest) -> - let (op, result) = unpack_contents_list rest in + let op, result = unpack_contents_list rest in return (oph, op, result) | _ -> assert false) | Some _ when has_reveal operations -> diff --git a/src/proto_alpha/lib_client/limit.ml b/src/proto_alpha/lib_client/limit.ml index 3f3c798c02b6..ae20b1d6bf4b 100644 --- a/src/proto_alpha/lib_client/limit.ml +++ b/src/proto_alpha/lib_client/limit.ml @@ -35,9 +35,9 @@ let is_unknown = Option.is_none let join (type a) ~where eq (l1 : a t) (l2 : a t) = match (l1, l2) with - | (None, None) -> Result.return_none - | (Some x, None) | (None, Some x) -> Result.return_some x - | (Some x, Some y) -> + | None, None -> Result.return_none + | Some x, None | None, Some x -> Result.return_some x + | Some x, Some y -> if eq x y then Result.return_some x else error_with "Limit.join: error (%s)" where diff --git a/src/proto_alpha/lib_client/michelson_v1_emacs.ml b/src/proto_alpha/lib_client/michelson_v1_emacs.ml index 66a970b5e6e1..6de00de8b2f1 100644 --- a/src/proto_alpha/lib_client/michelson_v1_emacs.ml +++ b/src/proto_alpha/lib_client/michelson_v1_emacs.ml @@ -129,7 +129,7 @@ let first_error_location errs = find errs let report_errors ppf (parsed, errs) = - let (eco, out) = + let eco, out = List.fold_left (fun (eco, out) -> function | Environment.Ecoproto_error err -> (err :: eco, out) @@ -137,7 +137,7 @@ let report_errors ppf (parsed, errs) = ([], []) errs in - let (eco, out) = (List.rev eco, List.rev out) in + let eco, out = (List.rev eco, List.rev out) in Format.fprintf ppf "(@[<v 0>%a@,%a@])" @@ -156,7 +156,7 @@ let report_errors ppf (parsed, errs) = in match errs with | top :: errs -> - let (errs, loc) = + let errs, loc = ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs), match top with | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) -> diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index 6db6d970d166..7e63f5623b32 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -512,7 +512,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_enumeration (List.map (fun k -> - let (a, n) = human_kind k in + let a, n = human_kind k in a ^ " " ^ n) exp) | Invalid_never_expr loc -> diff --git a/src/proto_alpha/lib_client/michelson_v1_macros.ml b/src/proto_alpha/lib_client/michelson_v1_macros.ml index 448bd000108e..3b1eaa5028d4 100644 --- a/src/proto_alpha/lib_client/michelson_v1_macros.ml +++ b/src/proto_alpha/lib_client/michelson_v1_macros.ml @@ -122,9 +122,9 @@ let expand_set_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) >>? fun () -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -237,9 +237,9 @@ let expand_map_caddadr original = | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1))) >>? fun code -> (match extract_field_annots annot with - | ([], annot) -> ok (None, annot) - | ([f], annot) -> ok (Some f, annot) - | (_, _) -> error (Unexpected_macro_annotation str)) + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str)) >>? fun (field_annot, annot) -> let rec parse i acc = if i = 4 then acc @@ -383,14 +383,14 @@ let parse_pair_substr str ~len start = let rec parse ?left i = if i = len - 1 then raise_notrace Not_a_pair else if str.[i] = 'P' then - let (next_i, l) = parse ~left:true (i + 1) in - let (next_i, r) = parse ~left:false next_i in + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in (next_i, P (i, l, r)) else if str.[i] = 'A' && left = Some true then (i + 1, A) else if str.[i] = 'I' && left <> Some true then (i + 1, I) else raise_notrace Not_a_pair in - let (last, ast) = parse start in + let last, ast = parse start in if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = @@ -405,18 +405,18 @@ let unparse_pair_item ast = let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = match (ast, annots) with - | (_, []) -> (annots, acc) - | (P (i, left, right), _) -> - let (annots, acc) = find_annots_pos i left annots acc in + | _, [] -> (annots, acc) + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | (A, a :: annots) -> + | A, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([a], []) | Some (_, cdr) -> ([a], cdr) in (annots, IntMap.add p_pos pos acc) - | (I, a :: annots) -> + | I, a :: annots -> let pos = match IntMap.find p_pos acc with | None -> ([], [a]) @@ -439,7 +439,7 @@ let expand_pappaiir original = | _ -> false) then try - let (field_annots, annot) = extract_field_annots annot in + let field_annots, annot = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = @@ -447,13 +447,13 @@ let expand_pappaiir original = | P (i, left, right) -> let annot = match (i, IntMap.find i field_annots_pos) with - | (0, None) -> annot - | (_, None) -> [] - | (0, Some ([], cdr_annot)) -> "%" :: cdr_annot @ annot - | (_, Some ([], cdr_annot)) -> "%" :: cdr_annot - | (0, Some (car_annot, cdr_annot)) -> + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> ("%" :: cdr_annot) @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | (_, Some (car_annot, cdr_annot)) -> car_annot @ cdr_annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot in let acc = if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc @@ -464,7 +464,7 @@ let expand_pappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, expanded) = parse ast (0, []) in + let _, expanded = parse ast (0, []) in (match args with | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0))) @@ -498,7 +498,7 @@ let expand_unpappaiir original = (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) in - let (_, rev_expanded) = parse ast (0, []) in + let _, rev_expanded = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in (match args with | [] -> ok () @@ -541,8 +541,7 @@ let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> - List.rev (Prim (loc, i, args, annot) :: r) + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) | is -> List.rev is in ok (Some (Seq (loc, is))) @@ -712,7 +711,7 @@ let expand_rec expr = let rec error_map (expanded, errors) f = function | [] -> (List.rev expanded, List.rev errors) | hd :: tl -> - let (new_expanded, new_errors) = f hd in + let new_expanded, new_errors = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) f @@ -724,10 +723,10 @@ let expand_rec expr = | Ok expanded -> ( match expanded with | Seq (loc, items) -> - let (items, errors) = error_map expand_rec items in + let items, errors = error_map expand_rec items in (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> - let (args, errors) = error_map expand_rec args in + let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) | (Int _ | String _ | Bytes _) as atom -> (atom, [])) | Error errors -> (expr, errors) @@ -737,7 +736,7 @@ let expand_rec expr = let unexpand_carn_and_cdrn expanded = match expanded with | Seq (loc, [Prim (_, "GET", [Int (locn, n)], annot)]) -> - let (half, parity) = Z.ediv_rem n (Z.of_int 2) in + let half, parity = Z.ediv_rem n (Z.of_int 2) in if Z.(parity = zero) then Some (Prim (loc, "CDR", [Int (locn, half)], annot)) else Some (Prim (loc, "CAR", [Int (locn, half)], annot)) @@ -802,7 +801,7 @@ let unexpand_set_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -812,7 +811,7 @@ let unexpand_set_caddadr expanded = Prim (_, "CAR", [], _); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -879,7 +878,7 @@ let unexpand_map_caddadr expanded = Prim (_, "SWAP", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub | Seq ( _, @@ -889,7 +888,7 @@ let unexpand_map_caddadr expanded = Prim (_, "CAR", [], []); Prim (_, "PAIR", [], pair_annots); ] ) -> - let (_, pair_annots) = extract_field_annots pair_annots in + let _, pair_annots = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub | _ -> None in @@ -910,7 +909,7 @@ let unexpand_deprecated_dxiiivp expanded = | Seq (_, [Prim (_, "DIP", [sub], [])]) -> count (acc + 1) sub | sub -> (acc, sub) in - let (depth, sub) = count 1 sub in + let depth, sub = count 1 sub in Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None @@ -952,46 +951,46 @@ let unexpand_pappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest - | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> exec (P (0, a, b) :: rstack) rest - | (Prim (_, "PAIR", [], []) :: rest, [a]) -> exec [P (0, a, I)] rest - | (Prim (_, "PAIR", [], []) :: rest, []) -> exec [P (0, A, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [a] -> exec [P (0, a, I)] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> exec [P (0, A, I)] rest | _ -> raise_notrace Not_a_pair in match exec [] nodes with @@ -1008,41 +1007,41 @@ let unexpand_unpappaiir expanded = | Seq (loc, (_ :: _ as nodes)) -> ( let rec exec stack nodes = match (nodes, stack) with - | ([], _) -> stack + | [], _ -> stack (* support new expansion using [DIP n] *) | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, a :: rstack ) when Z.to_int n > 1 -> exec (a - :: - exec - rstack - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + rstack + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + | Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [] when Z.to_int n > 1 -> exec (A - :: - exec - [] - [ - Prim (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); - ]) + :: exec + [] + [ + Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []); + ]) rest - | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + | Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [] when Z.to_int n = 1 -> exec (A :: exec [] sub) rest (* support old expansion using [DIP] *) - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack -> exec (a :: exec rstack sub) rest - | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + | Prim (_, "DIP", [Seq (_, sub)], []) :: rest, [] -> exec (A :: exec [] sub) rest | ( Seq ( _, diff --git a/src/proto_alpha/lib_client/michelson_v1_parser.ml b/src/proto_alpha/lib_client/michelson_v1_parser.ml index 2f44d22c1fca..09a8c7d5b710 100644 --- a/src/proto_alpha/lib_client/michelson_v1_parser.ml +++ b/src/proto_alpha/lib_client/michelson_v1_parser.ml @@ -40,20 +40,20 @@ let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = - let (unexpanded, loc_table) = extract_locations ast in - let (expanded, expansion_errors) = + let unexpanded, loc_table = extract_locations ast in + let expanded, expansion_errors = Michelson_v1_macros.expand_rec (root unexpanded) in - let (expanded, unexpansion_table) = extract_locations expanded in + let expanded, unexpansion_table = extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> Stdlib.compare a b) unexpansion_table in let grouped = let rec group = function - | (acc, []) -> acc - | ([], (u, e) :: r) -> group ([(e, [u])], r) - | (((pe, us) :: racc as acc), (u, e) :: r) -> + | acc, [] -> acc + | [], (u, e) :: r -> group ([(e, [u])], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> if e = pe then group ((e, u :: us) :: racc, r) else group ((e, [u]) :: acc, r) in @@ -87,8 +87,8 @@ let expand_all source ast errors = errors @ expansion_errors @ errs ) let parse_toplevel ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in let ast = let start = min_point asts and stop = max_point asts in Seq ({start; stop}, asts) @@ -96,8 +96,8 @@ let parse_toplevel ?check source = expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = - let (tokens, lexing_errors) = Micheline_parser.tokenize source in - let (ast, parsing_errors) = Micheline_parser.parse_expression ?check tokens in + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) let expand_all ~source ~original = expand_all source original [] diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.ml b/src/proto_alpha/lib_client/michelson_v1_printer.ml index 0e53de294bc9..f2dc6bc5e870 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.ml +++ b/src/proto_alpha/lib_client/michelson_v1_printer.ml @@ -138,7 +138,7 @@ let unparse ?type_map parse expanded = let source = match type_map with | Some type_map -> - let (unexpanded, unexpansion_table) = + let unexpanded, unexpansion_table = expanded |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in @@ -170,8 +170,8 @@ let unparse ?type_map parse expanded = |> Format.asprintf "%a" Micheline_printer.print_expr in match parse source with - | (res, []) -> res - | (_, _ :: _) -> Stdlib.failwith "Michelson_v1_printer.unparse" + | res, [] -> res + | _, _ :: _ -> Stdlib.failwith "Michelson_v1_printer.unparse" let unparse_toplevel ?type_map = unparse ?type_map Michelson_v1_parser.parse_toplevel diff --git a/src/proto_alpha/lib_client/mockup.ml b/src/proto_alpha/lib_client/mockup.ml index 5703c8731297..08c087d272e6 100644 --- a/src/proto_alpha/lib_client/mockup.ml +++ b/src/proto_alpha/lib_client/mockup.ml @@ -1091,7 +1091,7 @@ module Parsed_account = struct Client_keys.list_keys wallet >>=? fun all_keys -> List.iter_s (function - | (name, pkh, _pk_opt, Some sk_uri) -> ( + | name, pkh, _pk_opt, Some sk_uri -> ( let contract = Contract.Implicit pkh in Client_proto_context.get_balance rpc_context @@ -1345,7 +1345,7 @@ let mem_init : | None -> return Protocol_constants_overrides.no_overrides | Some json -> ( match Data_encoding.Json.destruct lib_parameters_json_encoding json with - | (_, x) -> return x + | _, x -> return x | exception error -> failwith "cannot read protocol constants overrides: %a" @@ -1432,7 +1432,7 @@ let mem_init : [Block_hash.to_bytes hash; Operation_list_hash.(to_bytes @@ compute [])] in let open Protocol.Alpha_context.Block_header in - let (_, _, sk) = Signature.generate_key () in + let _, _, sk = Signature.generate_key () in let proof_of_work_nonce = Bytes.create Protocol.Alpha_context.Constants.proof_of_work_nonce_size in diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index b7b894f7c6c1..58e3cb4c80c0 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -374,10 +374,10 @@ let pp_balance_updates ppf = function | Lost_endorsing_rewards (pkh, p, r) -> let reason = match (p, r) with - | (false, false) -> "" - | (false, true) -> ",revelation" - | (true, false) -> ",participation" - | (true, true) -> ",participation,revelation" + | false, false -> "" + | false, true -> ",revelation" + | true, false -> ",participation" + | true, true -> ",participation,revelation" in Format.asprintf "lost endorsing rewards(%a%s)" diff --git a/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml b/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml index dce4c96b6afc..5057f11869ba 100644 --- a/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml +++ b/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml @@ -46,7 +46,7 @@ let to_string e = Format.asprintf "%a" pp e let assert_expands (original : (Micheline_parser.location, string) Micheline.node) (expanded : (Micheline_parser.location, string) Micheline.node) = - let ({Michelson_v1_parser.expanded = expansion; _}, errors) = + let {Michelson_v1_parser.expanded = expansion; _}, errors = let source = to_string (Micheline.strip_locations original) in Michelson_v1_parser.expand_all ~source ~original in @@ -693,7 +693,7 @@ let test_map_cdadr () = [unparse.Michelson_v1_parser.unexpanded] contains the original expression with macros *) let assert_unexpansion original ex = - let ({Michelson_v1_parser.expanded; _}, errors) = + let {Michelson_v1_parser.expanded; _}, errors = let source = to_string (Micheline.strip_locations original) in Michelson_v1_parser.expand_all ~source ~original in @@ -1320,7 +1320,7 @@ let tests = ("map_car unexpansion", fun _ -> Lwt.return (test_unexpand_map_car ())); ("diip unexpansion", fun _ -> Lwt.return (test_unexpand_diip ())); ("diip_duup1 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup1 ())); - ("diip_duup2 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup2 ())); + ("diip_duup2 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup2 ())) (***********************************************************************) (*BUG the function in Michelson_v1_macros.unexpand_map_caddadr @@ -1329,7 +1329,7 @@ let tests = (*"diip unexpansion", (fun _ -> Lwt.return (test_unexpand_diip ())) ;*) (*"map_cdr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdr ())) ;*) (*"map_caadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_caadr ())) ;*) - (*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*) + (*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*); ] let wrap (n, f) = diff --git a/src/proto_alpha/lib_client/test/test_proxy.ml b/src/proto_alpha/lib_client/test/test_proxy.ml index 54596f6aced8..273102db51e5 100644 --- a/src/proto_alpha/lib_client/test/test_proxy.ml +++ b/src/proto_alpha/lib_client/test/test_proxy.ml @@ -55,9 +55,9 @@ let key_gen = (** Whether [t1] is a prefix of [t2] *) let rec is_prefix t1 t2 = match (t1, t2) with - | ([], _) -> true - | (_, []) -> false - | (x1 :: rest1, x2 :: rest2) when x1 = x2 -> is_prefix rest1 rest2 + | [], _ -> true + | _, [] -> false + | x1 :: rest1, x2 :: rest2 when x1 = x2 -> is_prefix rest1 rest2 | _ -> false let test_split_key = diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 0bc248862571..754d5bedc66f 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -615,27 +615,27 @@ let commands_ro () = (* ----------------------------------------------------------------------------*) (* After the activation of a new version of the protocol, the older protocols - are only kept in the code base to replay the history of the chain and to query - old states. + are only kept in the code base to replay the history of the chain and to query + old states. - The commands that are not useful anymore in the old protocols are removed, - this is called protocol freezing. The commands below are those that can be - removed during protocol freezing. + The commands that are not useful anymore in the old protocols are removed, + this is called protocol freezing. The commands below are those that can be + removed during protocol freezing. - The rule of thumb to know if a command should be kept at freezing is that all - commands that modify the state of the chain should be removed and conversely - all commands that are used to query the context should be kept. For this - reason, we call read-only (or RO for short) the commands that are kept and - read-write (or RW for short) the commands that are removed. + The rule of thumb to know if a command should be kept at freezing is that all + commands that modify the state of the chain should be removed and conversely + all commands that are used to query the context should be kept. For this + reason, we call read-only (or RO for short) the commands that are kept and + read-write (or RW for short) the commands that are removed. - There are some exceptions to this rule however, for example the command - "tezos-client wait for <op> to be included" is classified as RW despite having - no effect on the context because it has no use case once all RW commands are - removed. + There are some exceptions to this rule however, for example the command + "tezos-client wait for <op> to be included" is classified as RW despite having + no effect on the context because it has no use case once all RW commands are + removed. - Keeping this in mind, the developer should decide where to add a new command. - At the end of the file, RO and RW commands are concatenated into one list that - is then exported in the mli file. *) + Keeping this in mind, the developer should decide where to add a new command. + At the end of the file, RO and RW commands are concatenated into one list that + is then exported in the mli file. *) (* ----------------------------------------------------------------------------*) let dry_run_switch = @@ -811,8 +811,7 @@ let commands_network network () = ~desc:"Register and activate an Alphanet/Zeronet faucet account." (args2 (Secret_key.force_switch ()) encrypted_switch) (prefixes ["activate"; "account"] - @@ Secret_key.fresh_alias_param - @@ prefixes ["with"] + @@ Secret_key.fresh_alias_param @@ prefixes ["with"] @@ param ~name:"activation_key" ~desc: @@ -854,8 +853,7 @@ let commands_network network () = ~desc:"Activate a fundraiser account." (args1 dry_run_switch) (prefixes ["activate"; "fundraiser"; "account"] - @@ Public_key_hash.alias_param - @@ prefixes ["with"] + @@ Public_key_hash.alias_param @@ prefixes ["with"] @@ param ~name:"code" (Clic.parameter (fun _ctx code -> @@ -1194,7 +1192,7 @@ let commands_rw () = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith @@ -1737,7 +1735,7 @@ let commands_rw () = (cctxt#chain, cctxt#block) >>=? fun current_proposal -> (match (info.current_period_kind, current_proposal) with - | ((Exploration | Promotion), Some current_proposal) -> + | (Exploration | Promotion), Some current_proposal -> if Protocol_hash.equal proposal current_proposal then return_unit else diff --git a/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml index 624ef6f7d449..d29057aefc6f 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml @@ -461,7 +461,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = src (_, dst) (cctxt : #Protocol_client_context.full) -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in get_contract_caller_keys cctxt caller >>=? fun (source, caller_pk, caller_sk) -> let action = Client_proto_fa12.Transfer (snd src, dst, amount) in @@ -590,7 +590,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = src operations_json cctxt -> - let (_, caller) = Option.value ~default:src as_address in + let _, caller = Option.value ~default:src as_address in match Data_encoding.Json.destruct (Data_encoding.list Client_proto_fa12.token_transfer_encoding) @@ -626,7 +626,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with - | ([`Index n], `A lj) -> ( + | [`Index n], `A lj -> ( match List.nth_opt lj n with | Some j -> failwith diff --git a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml index 460ef742c905..43accd96e3f6 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml @@ -729,8 +729,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = @@ Client_proto_contracts.ContractAlias.destination_param ~name:"multisig" ~desc:"name or address of the originated multisig contract" - @@ prefixes ["to"] - @@ threshold_param () + @@ prefixes ["to"] @@ threshold_param () @@ prefixes ["and"; "public"; "keys"; "to"] @@ non_terminal_seq (public_key_param ()) ~suffix:["on"; "behalf"; "of"] @@ Client_proto_contracts.ContractAlias.destination_param diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index 04bd7d6f3531..ac81bef088c8 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -183,7 +183,7 @@ let commands () = let handle_parsing_error label (cctxt : Protocol_client_context.full) (emacs_mode, no_print_source) program body = match program with - | (program, []) -> body program + | program, [] -> body program | res_with_errors when emacs_mode -> cctxt#message "(@[<v 0>(%s . ())@ (errors . %a)@])" @@ -191,7 +191,7 @@ let commands () = Michelson_v1_emacs.report_errors res_with_errors >>= fun () -> return_unit - | (parsed, errors) -> + | parsed, errors -> cctxt#message "%a" (fun ppf () -> @@ -665,8 +665,7 @@ let commands () = no_options (prefixes ["sign"; "bytes"] @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" - @@ prefixes ["for"] - @@ Client_keys.Secret_key.source_param @@ stop) + @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> Client_keys.sign cctxt sk bytes >>=? fun signature -> cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> @@ -708,8 +707,7 @@ let commands () = ~name:"entrypoint" ~desc:"the entrypoint to describe" entrypoint_parameter - @@ prefixes ["for"] - @@ Program.source_param @@ stop) + @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun ((emacs_mode, no_print_source) as setup) entrypoint program cctxt -> handle_parsing_error "entrypoint" cctxt setup program @@ fun program -> entrypoint_type diff --git a/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml index d9374dc83d19..373fda2aeae1 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml @@ -125,7 +125,7 @@ let verbosity = ref Notice let log level msg = match (level, !verbosity) with - | (Notice, _) | (Info, Info) | (Info, Debug) | (Debug, Debug) -> msg () + | Notice, _ | Info, Info | Info, Debug | Debug, Debug -> msg () | _ -> Lwt.return_unit let pp_sep ppf () = Format.fprintf ppf ",@ " @@ -347,7 +347,7 @@ let random_seed rng = let generate_fresh_source state = let seed = random_seed state.rng_state in - let (pkh, pk, sk) = Signature.generate_key ~seed () in + let pkh, pk, sk = Signature.generate_key ~seed () in let fresh = {source = {pkh; pk; sk}; origin = Explicit} in state.pool <- fresh :: state.pool ; state.pool_size <- state.pool_size + 1 ; @@ -361,7 +361,7 @@ let heads_iter (cctxt : Protocol_client_context.full) (f : Block_hash.t * Tezos_base.Block_header.t -> unit tzresult Lwt.t) : (unit tzresult Lwt.t * RPC_context.stopper) tzresult Lwt.t = let open Lwt_result_syntax in - let* (heads_stream, stopper) = Shell_services.Monitor.heads cctxt `Main in + let* heads_stream, stopper = Shell_services.Monitor.heads cctxt `Main in let rec loop () : unit tzresult Lwt.t = let*! block_hash_and_header = Lwt_stream.get heads_stream in match block_hash_and_header with @@ -1109,9 +1109,9 @@ let generate_random_transactions = (cctxt : Protocol_client_context.full) -> (verbosity := match (debug_flag, verbose_flag) with - | (true, _) -> Debug - | (false, true) -> Info - | (false, false) -> Notice) ; + | true, _ -> Debug + | false, true -> Info + | false, false -> Notice) ; Smart_contracts.init cctxt (Option.value ~default:[] smart_contract_parameters) @@ -1226,7 +1226,7 @@ let estimate_transaction_cost ?smart_contracts normalize_source cctxt (Wallet_alias "bootstrap2") >>= fun dst -> let rng_state = Random.State.make [|default_parameters.seed|] in (match (src, dst) with - | (Some src, Some dst) -> return (src, dst) + | Some src, Some dst -> return (src, dst) | _ -> cctxt#error "Cannot find bootstrap1 or bootstrap2 accounts in the wallet.") >>=? fun (src, dst) -> @@ -1236,7 +1236,7 @@ let estimate_transaction_cost ?smart_contracts Option.bind smart_contracts (fun smart_contracts -> sample_smart_contracts smart_contracts rng_state) in - let (dst, fee, gas_limit) = + let dst, fee, gas_limit = Option.value selected_smart_constract ~default: diff --git a/src/proto_alpha/lib_client_commands/client_proto_utils_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_utils_commands.ml index 7f57941fb389..c661dbd2eb6b 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_utils_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_utils_commands.ml @@ -133,8 +133,7 @@ let commands () = return the signed block." no_options (prefixes ["sign"; "block"] - @@ unsigned_block_header_param - @@ prefixes ["for"] + @@ unsigned_block_header_param @@ prefixes ["for"] @@ Client_keys.Public_key_hash.source_param ~name:"delegate" ~desc:"signing delegate" diff --git a/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml b/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml index 33e2a97d7e09..884972686fb6 100644 --- a/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml @@ -645,9 +645,7 @@ let commands () = path >>= fun () -> (* TODO must pass contract address for now *) - let (_, contract) = - WithExceptions.Option.get ~loc:__LOC__ contract_opt - in + let _, contract = WithExceptions.Option.get ~loc:__LOC__ contract_opt in Context.Client_state.register cctxt ~default_memo_size diff --git a/src/proto_alpha/lib_client_sapling/context.ml b/src/proto_alpha/lib_client_sapling/context.ml index 24615b751ca4..0ce463e82e4e 100644 --- a/src/proto_alpha/lib_client_sapling/context.ml +++ b/src/proto_alpha/lib_client_sapling/context.ml @@ -280,7 +280,7 @@ module Contract_state = struct let vks = Accounts.fold (fun account acc -> Account.(account.vk) :: acc) accounts [] in - let (size, _) = Storage.size storage in + let size, _ = Storage.size storage in let rec aux pos accounts = if pos < size then (* try to decrypt each inputs with all vks *) @@ -300,7 +300,7 @@ module Contract_state = struct | _ -> assert false (* got more than one decrypting key *) else accounts in - let (current_size, _) = Storage.size state.storage in + let current_size, _ = Storage.size state.storage in let accounts = aux current_size accounts in {accounts; storage} @@ -392,7 +392,7 @@ module Client_state = struct let sync_and_scan cctxt contract = load cctxt >>=? fun state -> find cctxt contract state >>=? fun contract_state -> - let (cm_pos, nf_pos) = Storage.size contract_state.storage in + let cm_pos, nf_pos = Storage.size contract_state.storage in get_diff cctxt contract cm_pos nf_pos >>=? fun diff -> let contract_state = Contract_state.update_storage contract_state diff in let state = Map.add contract contract_state state in diff --git a/src/proto_alpha/lib_client_sapling/wallet.ml b/src/proto_alpha/lib_client_sapling/wallet.ml index c0254f36d326..ab43f45d3889 100644 --- a/src/proto_alpha/lib_client_sapling/wallet.ml +++ b/src/proto_alpha/lib_client_sapling/wallet.ml @@ -88,7 +88,7 @@ let new_address (cctxt : #Client_context.full) name index_opt = return (Viewing_key.of_sk sk) >>=? fun vk -> (* Viewing_key.new_address finds the smallest index greater or equal to [index] that generates a correct address. *) - let (corrected_index, address) = Viewing_key.new_address vk index in + let corrected_index, address = Viewing_key.new_address vk index in Sapling_key.update cctxt name diff --git a/src/proto_alpha/lib_delegate/baking_actions.ml b/src/proto_alpha/lib_delegate/baking_actions.ml index 8387969b4f63..81dfefc9f74b 100644 --- a/src/proto_alpha/lib_delegate/baking_actions.ml +++ b/src/proto_alpha/lib_delegate/baking_actions.ml @@ -228,7 +228,7 @@ let inject_block ~state_recorder state block_to_bake ~updated_state = >>?= fun timestamp -> let external_operation_source = state.global_state.config.extra_operations in Operations_source.retrieve external_operation_source >>= fun extern_ops -> - let (simulation_kind, payload_round) = + let simulation_kind, payload_round = match kind with | Fresh pool -> let pool = @@ -518,7 +518,7 @@ let prepare_waiting_for_quorum state = (consensus_threshold, get_consensus_operation_voting_power, candidate) let start_waiting_for_preendorsement_quorum state = - let (consensus_threshold, get_preendorsement_voting_power, candidate) = + let consensus_threshold, get_preendorsement_voting_power, candidate = prepare_waiting_for_quorum state in let operation_worker = state.global_state.operation_worker in @@ -529,7 +529,7 @@ let start_waiting_for_preendorsement_quorum state = candidate let start_waiting_for_endorsement_quorum state = - let (consensus_threshold, get_endorsement_voting_power, candidate) = + let consensus_threshold, get_endorsement_voting_power, candidate = prepare_waiting_for_quorum state in let operation_worker = state.global_state.operation_worker in diff --git a/src/proto_alpha/lib_delegate/baking_cache.ml b/src/proto_alpha/lib_delegate/baking_cache.ml index 4ce45c7b7a9d..af2ac36dc1fc 100644 --- a/src/proto_alpha/lib_delegate/baking_cache.ml +++ b/src/proto_alpha/lib_delegate/baking_cache.ml @@ -67,12 +67,12 @@ module Round_cache_key = struct { predecessor_timestamp = pred_t; predecessor_round = pred_r; - time_interval = (t_beg, t_end); + time_interval = t_beg, t_end; } { predecessor_timestamp = pred_t'; predecessor_round = pred_r'; - time_interval = (t_beg', t_end'); + time_interval = t_beg', t_end'; } = Timestamp.(pred_t = pred_t') && Round.(pred_r = pred_r') diff --git a/src/proto_alpha/lib_delegate/baking_commands.ml b/src/proto_alpha/lib_delegate/baking_commands.ml index a1142dfd3b50..78d6ec9e61a1 100644 --- a/src/proto_alpha/lib_delegate/baking_commands.ml +++ b/src/proto_alpha/lib_delegate/baking_commands.ml @@ -180,7 +180,7 @@ let get_delegates (cctxt : Protocol_client_context.full) List.map_es (fun pkh -> Client_keys.get_key cctxt pkh >>=? function - | (alias, pk, sk_uri) -> return (proj_delegate (alias, pkh, pk, sk_uri))) + | alias, pk, sk_uri -> return (proj_delegate (alias, pkh, pk, sk_uri))) pkhs) >>=? fun delegates -> Tezos_signer_backends.Encrypted.decrypt_list diff --git a/src/proto_alpha/lib_delegate/baking_lib.ml b/src/proto_alpha/lib_delegate/baking_lib.ml index dd86f4b59c83..f47d397a1a31 100644 --- a/src/proto_alpha/lib_delegate/baking_lib.ml +++ b/src/proto_alpha/lib_delegate/baking_lib.ml @@ -46,7 +46,7 @@ let create_state cctxt ?synchronize ?monitor_node_mempool ~config let get_current_proposal cctxt = let open Lwt_result_syntax in - let* (block_stream, _block_stream_stopper) = + let* block_stream, _block_stream_stopper = Node_rpc.monitor_proposals cctxt ~chain:cctxt#chain () in Lwt_stream.peek block_stream >>= function @@ -59,7 +59,7 @@ let preendorse (cctxt : Protocol_client_context.full) ?(force = false) delegates = let open State_transitions in let open Lwt_result_syntax in - let* (_, current_proposal) = get_current_proposal cctxt in + let* _, current_proposal = get_current_proposal cctxt in let config = Baking_configuration.make ~force () in let* state = create_state cctxt ~config ~current_proposal delegates in let proposal = state.level_state.latest_proposal in @@ -98,7 +98,7 @@ let preendorse (cctxt : Protocol_client_context.full) ?(force = false) delegates let endorse (cctxt : Protocol_client_context.full) ?(force = false) delegates = let open State_transitions in let open Lwt_result_syntax in - let* (_, current_proposal) = get_current_proposal cctxt in + let* _, current_proposal = get_current_proposal cctxt in let config = Baking_configuration.make ~force () in create_state cctxt ~config ~current_proposal delegates >>=? fun state -> let proposal = state.level_state.latest_proposal in @@ -226,7 +226,7 @@ let propose_at_next_level ~minimal_timestamp state = let cctxt = state.global_state.cctxt in assert (Option.is_some state.level_state.elected_block) ; if minimal_timestamp then - let* (minimal_round, delegate) = + let* minimal_round, delegate = match Baking_scheduling.first_potential_round_at_next_level state @@ -272,7 +272,7 @@ let propose_at_next_level ~minimal_timestamp state = cctxt#message "Proposal injected" >>= fun () -> return state let endorsement_quorum state = - let (power, endorsements) = state_endorsing_power state in + let power, endorsements = state_endorsing_power state in if Compare.Int.( power >= state.global_state.constants.parametric.consensus_threshold) @@ -293,7 +293,7 @@ let propose (cctxt : Protocol_client_context.full) ?minimal_fees ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?force ?(minimal_timestamp = false) ?extra_operations ?context_path delegates = let open Lwt_result_syntax in - let* (_block_stream, current_proposal) = get_current_proposal cctxt in + let* _block_stream, current_proposal = get_current_proposal cctxt in let config = Baking_configuration.make ?minimal_fees @@ -340,7 +340,7 @@ let propose (cctxt : Protocol_client_context.full) ?minimal_fees propose_at_next_level ~minimal_timestamp state | None -> ( Baking_scheduling.compute_bootstrap_event state >>?= fun event -> - let*! (state, _action) = State_transitions.step state event in + let*! state, _action = State_transitions.step state event in let latest_proposal = state.level_state.latest_proposal in let open State_transitions in let round = state.round_state.current_round in @@ -462,7 +462,7 @@ let baking_minimal_timestamp state = consensus_threshold else return_unit in - let* (minimal_round, delegate) = + let* minimal_round, delegate = match Baking_scheduling.first_potential_round_at_next_level state @@ -515,7 +515,7 @@ let bake (cctxt : Protocol_client_context.full) ?minimal_fees ?extra_operations () in - let* (block_stream, current_proposal) = get_current_proposal cctxt in + let* block_stream, current_proposal = get_current_proposal cctxt in let* state = create_state cctxt diff --git a/src/proto_alpha/lib_delegate/baking_scheduling.ml b/src/proto_alpha/lib_delegate/baking_scheduling.ml index d3cbe1a60bcf..488d16c8457f 100644 --- a/src/proto_alpha/lib_delegate/baking_scheduling.ml +++ b/src/proto_alpha/lib_delegate/baking_scheduling.ml @@ -48,7 +48,7 @@ type events = Lwt.t let create_loop_state block_stream operation_worker = - let (future_block_stream, push_future_block) = Lwt_stream.create () in + let future_block_stream, push_future_block = Lwt_stream.create () in { block_stream; qc_stream = Operation_worker.get_quorum_event_stream operation_worker; @@ -511,12 +511,12 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t let next_round = compute_next_round_time state in compute_next_potential_baking_time_at_next_level state >>= fun next_baking -> match (next_round, next_baking) with - | (None, None) -> + | None, None -> Events.(emit waiting_for_new_head ()) >>= fun () -> return (Lwt_utils.never_ending () >>= fun () -> assert false) (* We have no slot at the next level in the near future, we will patiently wait for the next round. *) - | (Some next_round, None) -> ( + | Some next_round, None -> ( (* If there is an elected block, then we make the assumption that the bakers at the next level have also received an endorsement quorum, and we delay a bit injecting at the next @@ -527,7 +527,7 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t | Some _elected_block -> delay_next_round_timeout next_round) (* There is no timestamp for a successor round but there is for a future baking slot, we will wait to bake. *) - | (None, Some next_baking) -> wait_baking_time_next_level next_baking + | None, Some next_baking -> wait_baking_time_next_level next_baking (* We choose the earliest timestamp between waiting to bake and waiting for the next round. *) | ( Some ((next_round_time, next_round) as next_round_info), diff --git a/src/proto_alpha/lib_delegate/baking_state.ml b/src/proto_alpha/lib_delegate/baking_state.ml index 21e527eb6864..c7370341ff79 100644 --- a/src/proto_alpha/lib_delegate/baking_state.ml +++ b/src/proto_alpha/lib_delegate/baking_state.ml @@ -500,18 +500,18 @@ let may_record_new_state ~previous_state ~new_state = if Compare.Int32.(new_current_level = previous_current_level) then let is_new_locked_round_consistent = match (new_locked_round, previous_locked_round) with - | (None, None) -> true - | (Some _, None) -> true - | (None, Some _) -> false - | (Some new_locked_round, Some previous_locked_round) -> + | None, None -> true + | Some _, None -> true + | None, Some _ -> false + | Some new_locked_round, Some previous_locked_round -> Round.(new_locked_round.round >= previous_locked_round.round) in let is_new_endorsable_payload_consistent = match (new_endorsable_payload, previous_endorsable_payload) with - | (None, None) -> true - | (Some _, None) -> true - | (None, Some _) -> false - | (Some new_endorsable_payload, Some previous_endorsable_payload) -> + | None, None -> true + | Some _, None -> true + | None, Some _ -> false + | Some new_endorsable_payload, Some previous_endorsable_payload -> Round.( new_endorsable_payload.proposal.block.round >= previous_endorsable_payload.proposal.block.round) @@ -602,7 +602,7 @@ let compute_delegate_slots (cctxt : Protocol_client_context.full) Environment.wrap_tzresult (Raw_level.of_int32 level) >>?= fun level -> Plugin.RPC.Validators.get cctxt (chain, block) ~levels:[level] >>=? fun endorsing_rights -> - let (own_delegate_slots, all_delegate_slots) = + let own_delegate_slots, all_delegate_slots = List.fold_left (fun (own_map, all_map) slot -> let {Plugin.RPC.Validators.delegate; slots; _} = slot in diff --git a/src/proto_alpha/lib_delegate/block_forge.ml b/src/proto_alpha/lib_delegate/block_forge.ml index fe58614ba2f6..8efc10394526 100644 --- a/src/proto_alpha/lib_delegate/block_forge.ml +++ b/src/proto_alpha/lib_delegate/block_forge.ml @@ -361,13 +361,12 @@ let forge (cctxt : #Protocol_client_context.full) ~chain_id ~pred_info | Apply _ as x -> x in (match (simulation_mode, simulation_kind) with - | (Baking_state.Node, Filter operation_pool) -> - filter_via_node ~operation_pool - | (Node, Apply {ordered_pool; payload_hash}) -> + | Baking_state.Node, Filter operation_pool -> filter_via_node ~operation_pool + | Node, Apply {ordered_pool; payload_hash} -> apply_via_node ~ordered_pool ~payload_hash - | (Local context_index, Filter operation_pool) -> + | Local context_index, Filter operation_pool -> filter_with_context ~context_index ~operation_pool - | (Local context_index, Apply {ordered_pool; payload_hash}) -> + | Local context_index, Apply {ordered_pool; payload_hash} -> apply_with_context ~context_index ~ordered_pool ~payload_hash) >>=? fun (shell_header, operations, payload_hash) -> Baking_pow.mine diff --git a/src/proto_alpha/lib_delegate/client_baking_blocks.ml b/src/proto_alpha/lib_delegate/client_baking_blocks.ml index de08f768becc..db5b65b6ec3d 100644 --- a/src/proto_alpha/lib_delegate/client_baking_blocks.ml +++ b/src/proto_alpha/lib_delegate/client_baking_blocks.ml @@ -226,6 +226,5 @@ let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = let blocks = List.drop_n (length - Int32.to_int (Raw_level.diff last first)) head in - if Int32.equal level (Raw_level.to_int32 last) then - return (hash :: blocks) + if Int32.equal level (Raw_level.to_int32 last) then return (hash :: blocks) else return blocks diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml index ff3b70ef5e43..4f3638131307 100644 --- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml @@ -117,8 +117,8 @@ let get_block_offset level = let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) (op : kind Operation.t) = match (op_kind, op.protocol_data.contents) with - | (Preendorsement, Single (Preendorsement consensus_content)) - | (Endorsement, Single (Endorsement consensus_content)) -> + | Preendorsement, Single (Preendorsement consensus_content) + | Endorsement, Single (Endorsement consensus_content) -> consensus_content.block_payload_hash | _ -> . @@ -155,10 +155,10 @@ let process_consensus_op (type kind) cctxt get_payload_hash op_kind existing_op <> get_payload_hash op_kind new_op) -> (* same level and round, and different payload hash for this slot *) - let (new_op_hash, existing_op_hash) = + let new_op_hash, existing_op_hash = (Operation.hash new_op, Operation.hash existing_op) in - let (op1, op2) = + let op1, op2 = if Operation_hash.(new_op_hash < existing_op_hash) then (new_op, existing_op) else (existing_op, new_op) @@ -176,7 +176,7 @@ let process_consensus_op (type kind) cctxt () >>=? fun bytes -> let bytes = Signature.concat bytes Signature.zero in - let (double_op_detected, double_op_denounced) = + let double_op_detected, double_op_denounced = Events.( match op_kind with | Endorsement -> @@ -286,7 +286,7 @@ let process_block (cctxt : #Protocol_client_context.full) state context_block_header cctxt ~chain new_hash >>=? fun bh2 -> let hash1 = Block_header.hash bh1 in let hash2 = Block_header.hash bh2 in - let (bh1, bh2) = + let bh1, bh2 = if Block_hash.(hash1 < hash2) then (bh1, bh2) else (bh2, bh1) in (* If the blocks are on different chains then skip it *) diff --git a/src/proto_alpha/lib_delegate/node_rpc.ml b/src/proto_alpha/lib_delegate/node_rpc.ml index 05c7afebdda9..badb4fc204d4 100644 --- a/src/proto_alpha/lib_delegate/node_rpc.ml +++ b/src/proto_alpha/lib_delegate/node_rpc.ml @@ -132,7 +132,7 @@ let info cctxt ~chain ~block () = encoding, while we should use the previous protocol's [protocol_data] encoding. For now, this works because the encoding has not changed. *) - let (payload_hash, payload_round) = + let payload_hash, payload_round = match Data_encoding.Binary.of_bytes_opt Protocol.block_header_data_encoding diff --git a/src/proto_alpha/lib_delegate/operation_pool.ml b/src/proto_alpha/lib_delegate/operation_pool.ml index 692bb6561500..4eada5daf036 100644 --- a/src/proto_alpha/lib_delegate/operation_pool.ml +++ b/src/proto_alpha/lib_delegate/operation_pool.ml @@ -47,9 +47,9 @@ module Prioritized_operation = struct let compare_priority t1 t2 = match (t1, t2) with - | (High _, Low _) -> 1 - | (Low _, High _) -> -1 - | (Low _, Low _) | (High _, High _) -> 0 + | High _, Low _ -> 1 + | Low _, High _ -> -1 + | Low _, Low _ | High _, High _ -> 0 let compare a b = let c = compare_priority a b in @@ -205,8 +205,7 @@ let filter_with_relevant_consensus_ops ~(endorsement_filter : consensus_filter) (fun {protocol_data; _} -> match (protocol_data, preendorsement_filter) with (* 1a. Remove preendorsements. *) - | (Operation_data {contents = Single (Preendorsement _); _}, None) -> - false + | Operation_data {contents = Single (Preendorsement _); _}, None -> false (* 1b. Filter preendorsements. *) | ( Operation_data { @@ -307,7 +306,7 @@ let ordered_pool_of_payload ~consensus_operations let extract_operations_of_list_list = function | [consensus; votes_payload; anonymous_payload; managers_payload] -> - let (preendorsements, endorsements) = + let preendorsements, endorsements = List.fold_left (fun ( (preendorsements : Kind.preendorsement Operation.t list), (endorsements : Kind.endorsement Operation.t list) ) diff --git a/src/proto_alpha/lib_delegate/operation_worker.ml b/src/proto_alpha/lib_delegate/operation_worker.ml index dff14de45bc4..7a0191694547 100644 --- a/src/proto_alpha/lib_delegate/operation_worker.ml +++ b/src/proto_alpha/lib_delegate/operation_worker.ml @@ -241,7 +241,7 @@ let monitor_operations (cctxt : #Protocol_client_context.full) = let make_initial_state ?(monitor_node_operations = true) () = let qc_event_stream = - let (stream, push) = Lwt_stream.create () in + let stream, push = Lwt_stream.create () in {stream; push} in let canceler = Lwt_canceler.create () in @@ -280,7 +280,7 @@ let update_monitoring ?(should_lock = true) state ops = _; } as proposal_watched)) -> let preendorsements = Operation_pool.filter_preendorsements ops in - let (preendorsements_count, voting_power) = + let preendorsements_count, voting_power = List.fold_left (fun (count, power) (op : Kind.preendorsement Operation.t) -> let { @@ -340,7 +340,7 @@ let update_monitoring ?(should_lock = true) state ops = _; } as proposal_watched)) -> let endorsements = Operation_pool.filter_endorsements ops in - let (endorsements_count, voting_power) = + let endorsements_count, voting_power = List.fold_left (fun (count, power) (op : Kind.endorsement Operation.t) -> let { diff --git a/src/proto_alpha/lib_delegate/state_transitions.ml b/src/proto_alpha/lib_delegate/state_transitions.ml index 4adf5b4bc174..dd978072e535 100644 --- a/src/proto_alpha/lib_delegate/state_transitions.ml +++ b/src/proto_alpha/lib_delegate/state_transitions.ml @@ -163,14 +163,14 @@ let may_update_endorsable_payload_with_internal_pqc state match (new_proposal.block.prequorum, state.level_state.endorsable_payload) with - | (None, _) -> + | None, _ -> (* The proposal does not contain a PQC: no need to update *) state - | (Some {round = new_round; _}, Some {prequorum = {round = old_round; _}; _}) + | Some {round = new_round; _}, Some {prequorum = {round = old_round; _}; _} when Round.(new_round < old_round) -> (* The proposal pqc is outdated, do not update *) state - | (Some better_prequorum, _) -> + | Some better_prequorum, _ -> assert ( Block_payload_hash.( better_prequorum.block_payload_hash = new_proposal.block.payload_hash)) ; @@ -308,17 +308,17 @@ and may_switch_branch state new_proposal = in let current_endorsable_payload = state.level_state.endorsable_payload in match (current_endorsable_payload, new_proposal.block.prequorum) with - | (None, Some _) | (None, None) -> + | None, Some _ | None, None -> Events.(emit branch_proposal_has_better_fitness ()) >>= fun () -> (* The new branch contains a PQC (and we do not) or a better fitness, we switch. *) switch_branch state - | (Some _, None) -> + | Some _, None -> (* We have a better PQC, we don't switch as we are able to propose a better chain if we stay on our current one. *) Events.(emit branch_proposal_has_no_prequorum ()) >>= fun () -> do_nothing state - | (Some {prequorum = current_pqc; _}, Some new_pqc) -> + | Some {prequorum = current_pqc; _}, Some new_pqc -> if Round.(current_pqc.round > new_pqc.round) then Events.(emit branch_proposal_has_lower_prequorum ()) >>= fun () -> (* The other's branch PQC is lower than ours, do not @@ -564,11 +564,11 @@ let time_to_bake state at_round = at_round in match (state.level_state.elected_block, round_proposer_opt) with - | (None, _) | (_, None) -> + | None, _ | _, None -> (* Unreachable: the [Time_to_bake_next_level] event can only be triggered when we have a slot and an elected block *) assert false - | (Some elected_block, Some (delegate, _)) -> + | Some elected_block, Some (delegate, _) -> let endorsements = elected_block.endorsement_qc in let new_level_state = {state.level_state with next_level_proposed_round = Some at_round} @@ -688,15 +688,15 @@ let step (state : Baking_state.t) (event : Baking_state.event) : Events.(emit step_current_phase (phase, event)) >>= fun () -> match (phase, event) with (* Handle timeouts *) - | (_, Timeout (End_of_round {ending_round})) -> + | _, Timeout (End_of_round {ending_round}) -> (* If the round is ending, stop everything currently going on and increment the round. *) end_of_round state ending_round - | (_, Timeout (Time_to_bake_next_level {at_round})) -> + | _, Timeout (Time_to_bake_next_level {at_round}) -> (* If it is time to bake the next level, stop everything currently going on and propose the next level block *) time_to_bake state at_round - | (Idle, New_proposal block_info) -> + | Idle, New_proposal block_info -> Events.( emit new_head @@ -704,8 +704,8 @@ let step (state : Baking_state.t) (event : Baking_state.event) : block_info.block.shell.level, block_info.block.round )) >>= fun () -> handle_new_proposal state block_info - | (Awaiting_endorsements, New_proposal block_info) - | (Awaiting_preendorsements, New_proposal block_info) -> + | Awaiting_endorsements, New_proposal block_info + | Awaiting_preendorsements, New_proposal block_info -> Events.( emit new_head @@ -725,8 +725,8 @@ let step (state : Baking_state.t) (event : Baking_state.event) : Quorum_reached (candidate, _voting_power, endorsement_qc) ) -> quorum_reached_when_waiting_endorsements state candidate endorsement_qc (* Unreachable cases *) - | (Idle, (Prequorum_reached _ | Quorum_reached _)) - | (Awaiting_preendorsements, Quorum_reached _) - | (Awaiting_endorsements, Prequorum_reached _) -> + | Idle, (Prequorum_reached _ | Quorum_reached _) + | Awaiting_preendorsements, Quorum_reached _ + | Awaiting_endorsements, Prequorum_reached _ -> (* This cannot/should not happen *) do_nothing state diff --git a/src/proto_alpha/lib_delegate/test/mockup_simulator/mockup_simulator.ml b/src/proto_alpha/lib_delegate/test/mockup_simulator/mockup_simulator.ml index e361018fd87c..5194f4dd2cea 100644 --- a/src/proto_alpha/lib_delegate/test/mockup_simulator/mockup_simulator.ml +++ b/src/proto_alpha/lib_delegate/test/mockup_simulator/mockup_simulator.ml @@ -153,10 +153,10 @@ let locate_blocks (state : state) | None -> failwith "locate_blocks: can't find the block %a" Block_hash.pp hash | Some chain0 -> - let (_, chain) = List.split_n rel chain0 in + let _, chain = List.split_n rel chain0 in return chain) | `Head rel -> - let (_, chain) = List.split_n rel state.chain in + let _, chain = List.split_n rel state.chain in return chain | `Level _ -> failwith "locate_blocks: `Level block spec not handled" | `Genesis -> failwith "locate_blocks: `Genesis block spec net handled" @@ -172,7 +172,7 @@ let locate_block (state : state) (** Return the collection of live blocks for a given block identifier. *) let live_blocks (state : state) block = locate_blocks state block >>=? fun chain -> - let (segment, _) = List.split_n state.live_depth chain in + let segment, _ = List.split_n state.live_depth chain in return (List.fold_left (fun set ({rpc_context; _} : block) -> @@ -686,7 +686,7 @@ let rec listener ~(user_hooks : (module Hooks)) ~state ~broadcast_pipe = let create_fake_node_state ~i ~live_depth ~(genesis_block : Block_header.t * Environment_context.rpc_context) ~global_chain_table ~broadcast_pipes = - let (block_header0, rpc_context0) = genesis_block in + let block_header0, rpc_context0 = genesis_block in parse_protocol_data block_header0.protocol_data >>=? fun protocol_data -> let genesis0 = { @@ -851,7 +851,7 @@ let deduce_baker_sk list) (total_accounts : int) (level : int) : Signature.secret_key tzresult Lwt.t = (match (total_accounts, level) with - | (_, 0) -> return 0 (* apparently this doesn't really matter *) + | _, 0 -> return 0 (* apparently this doesn't really matter *) | _ -> failwith "cannot deduce baker for a genesis block, total accounts = %d, level = \ @@ -859,7 +859,7 @@ let deduce_baker_sk total_accounts level) >>=? fun baker_index -> - let (_, secret) = + let _, secret = List.nth accounts_with_secrets baker_index |> WithExceptions.Option.get ~loc:__LOC__ in @@ -919,8 +919,8 @@ let make_genesis_context ~delegate_selection ~initial_seed ~round0 ~round1 |> Environment.wrap_tzresult >>?= fun delegate_selection -> (match (delegate_selection, constants.initial_seed) with - | ([], seed_opt) -> return seed_opt - | (selection, (Some _ as seed)) -> ( + | [], seed_opt -> return seed_opt + | selection, (Some _ as seed) -> ( Faked_client_context.logger#warning "Checking provided seed." >>= fun () -> Tenderbrute.check_seed @@ -932,7 +932,7 @@ let make_genesis_context ~delegate_selection ~initial_seed ~round0 ~round1 | true -> return seed | false -> failwith "Provided initial seed does not match delegate selection") - | (_, None) -> + | _, None -> Faked_client_context.logger#warning "No initial seed provided, bruteforcing." >>= fun () -> @@ -1129,7 +1129,7 @@ let run ?(config = default_config) bakers_spec = (take_third (List.fold_left (fun (i, delegates_acc, ms) (n, user_hooks) -> - let (delegates, leftover_delegates) = + let delegates, leftover_delegates = List.split_n n delegates_acc in let m = diff --git a/src/proto_alpha/lib_delegate/test/test_scenario.ml b/src/proto_alpha/lib_delegate/test/test_scenario.ml index 814ff87b6470..7543a2b1ab28 100644 --- a/src/proto_alpha/lib_delegate/test/test_scenario.ml +++ b/src/proto_alpha/lib_delegate/test/test_scenario.ml @@ -95,7 +95,7 @@ let test_scenario_t1 () = let check_block_before_processing ~level ~round ~block_hash ~block_header ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = (match (!b_endorsed, level, round) with - | (false, 1l, 0l) -> + | false, 1l, 0l -> (* If any of the checks fails the whole scenario will fail. *) check_block_signature ~block_hash @@ -103,7 +103,7 @@ let test_scenario_t1 () = ~public_key:Mockup_simulator.bootstrap1 >>=? fun () -> save_proposal_payload ~protocol_data ~var:original_proposal - | (true, 1l, 1l) -> + | true, 1l, 1l -> check_block_signature ~block_hash ~block_header @@ -171,7 +171,7 @@ let test_scenario_t2 () = (* Here we test that the only block that B observes is its own proposal for level 1 at round 1. *) match (level, round) with - | (1l, 1l) -> + | 1l, 1l -> check_block_signature ~block_hash ~block_header @@ -244,7 +244,7 @@ let test_scenario_t3 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = match (level, round) with - | (1l, 2l) -> + | 1l, 2l -> check_block_signature ~block_hash ~block_header @@ -292,7 +292,7 @@ let test_scenario_t3 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = match (level, round) with - | (1l, 0l) -> + | 1l, 0l -> check_block_signature ~block_hash ~block_header @@ -325,7 +325,7 @@ let test_scenario_t3 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (level, round) with - | (1l, 1l) -> + | 1l, 1l -> return (block_hash, block_header, operations, [Block; Pass; Pass; Pass]) | _ -> @@ -407,7 +407,7 @@ let test_scenario_f1 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (!c_proposed_l1_r0, !d_proposed_l1_r1, level, round) with - | (true, true, 2l, 0l) -> + | true, true, 2l, 0l -> check_block_signature ~block_hash ~block_header @@ -425,7 +425,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Block; Block; Block]) + | true, false -> return (op_hash, op, [Pass; Block; Block; Block]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -435,7 +435,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Pass; Block; Block]) + | true, false -> return (op_hash, op, [Pass; Pass; Block; Block]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -446,7 +446,7 @@ let test_scenario_f1 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (!c_proposed_l1_r0, !d_proposed_l1_r1, level, round) with - | (false, false, 1l, 0l) -> + | false, false, 1l, 0l -> check_block_signature ~block_hash ~block_header @@ -464,7 +464,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Block; Pass; Block]) + | true, false -> return (op_hash, op, [Pass; Block; Pass; Block]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -475,7 +475,7 @@ let test_scenario_f1 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (!d_proposed_l1_r1, level, round) with - | (false, 1l, 1l) -> + | false, 1l, 1l -> check_block_signature ~block_hash ~block_header @@ -493,7 +493,7 @@ let test_scenario_f1 () = let on_inject_operation ~op_hash ~op = match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | (true, false) -> return (op_hash, op, [Pass; Block; Block; Pass]) + | true, false -> return (op_hash, op, [Pass; Block; Block; Pass]) | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) let stop_on_event = stop_on_event0 @@ -553,9 +553,9 @@ let test_scenario_f2 () = ~protocol_data:_ = let propagation_vector = match (level, round) with - | (1l, 0l) -> [Pass; Pass; Pass; Pass] - | (2l, 0l) -> [Pass; Block; Block; Block] - | (2l, 4l) -> + | 1l, 0l -> [Pass; Pass; Pass; Pass] + | 2l, 0l -> [Pass; Block; Block; Block] + | 2l, 4l -> proposal_2_4_observed := true ; [Pass; Pass; Pass; Pass] | _ -> [Block; Block; Block; Block] @@ -814,7 +814,7 @@ let test_scenario_m4 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (level, round) with - | (1l, 0l) -> + | 1l, 0l -> check_block_signature ~block_hash ~block_header @@ -918,7 +918,7 @@ let test_scenario_m5 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = match (level, round) with - | (1l, 0l) -> + | 1l, 0l -> check_block_signature ~block_hash ~block_header @@ -1006,7 +1006,7 @@ let test_scenario_m6 () = ~protocol_data:_ = let propagation_vector = match (level, round) with - | (2l, 0l) -> [Pass; Block; Block; Block] + | 2l, 0l -> [Pass; Block; Block; Block] | _ -> [Pass; Pass; Pass; Pass] in return (block_hash, block_header, operations, propagation_vector) @@ -1037,8 +1037,8 @@ let test_scenario_m6 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data = (match (level, round) with - | (1l, 1l) -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | (2l, 1l) -> + | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] + | 2l, 1l -> save_proposal_payload ~protocol_data ~var:b_proposal_2_1 >>=? fun () -> return [Pass; Pass; Pass; Pass] | _ -> return [Pass; Pass; Pass; Pass]) @@ -1147,7 +1147,7 @@ let test_scenario_m7 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data = (match (level, round) with - | (2l, 1l) -> save_proposal_payload ~protocol_data ~var:a_proposal_2_1 + | 2l, 1l -> save_proposal_payload ~protocol_data ~var:a_proposal_2_1 | _ -> return_unit) >>=? fun () -> return (block_hash, block_header, operations, [Pass; Pass; Pass; Pass]) @@ -1171,8 +1171,8 @@ let test_scenario_m7 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data:_ = (match (level, round) with - | (1l, 1l) -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | (2l, 0l) -> return [Block; Pass; Pass; Pass] + | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] + | 2l, 0l -> return [Block; Pass; Pass; Pass] | _ -> return [Pass; Pass; Pass; Pass]) >>=? fun propagation_vector -> return (block_hash, block_header, operations, propagation_vector) @@ -1187,9 +1187,9 @@ let test_scenario_m7 () = match (is_a10_endorsement, level2_preendorsement, level2_endorsement) with - | (true, _, _) -> [Pass; Block; Block; Block] - | (_, true, _) | (_, _, true) -> [Block; Block; Block; Block] - | (_, _, _) -> [Pass; Pass; Pass; Pass] + | true, _, _ -> [Pass; Block; Block; Block] + | _, true, _ | _, _, true -> [Block; Block; Block; Block] + | _, _, _ -> [Pass; Pass; Pass; Pass] in return (op_hash, op, propagation_vector) @@ -1210,7 +1210,7 @@ let test_scenario_m7 () = let check_chain_after_processing ~level ~round ~chain:_ = match (level, round) with - | (2l, 1l) -> + | 2l, 1l -> c_received_2_1 := true ; return_unit | _ -> return_unit @@ -1228,10 +1228,9 @@ let test_scenario_m7 () = level2_preendorsement, level2_endorsement ) with - | (true, _, _, _) -> [Pass; Block; Block; Block] - | (_, false, true, _) | (_, false, _, true) -> - [Block; Block; Block; Block] - | (_, _, _, _) -> [Pass; Pass; Pass; Pass] + | true, _, _, _ -> [Pass; Block; Block; Block] + | _, false, true, _ | _, false, _, true -> [Block; Block; Block; Block] + | _, _, _, _ -> [Pass; Pass; Pass; Pass] in return (op_hash, op, propagation_vector) @@ -1252,7 +1251,7 @@ let test_scenario_m7 () = let check_chain_after_processing ~level ~round ~chain:_ = match (level, round) with - | (2l, 1l) -> + | 2l, 1l -> d_received_2_1 := true ; return_unit | _ -> return_unit @@ -1270,10 +1269,9 @@ let test_scenario_m7 () = level2_preendorsement, level2_endorsement ) with - | (true, _, _, _) -> [Pass; Block; Block; Block] - | (_, false, true, _) | (_, false, _, true) -> - [Block; Block; Block; Block] - | (_, _, _, _) -> [Pass; Pass; Pass; Pass] + | true, _, _, _ -> [Pass; Block; Block; Block] + | _, false, true, _ | _, false, _, true -> [Block; Block; Block; Block] + | _, _, _, _ -> [Pass; Pass; Pass; Pass] in return (op_hash, op, propagation_vector) @@ -1381,8 +1379,8 @@ let test_scenario_m8 () = let on_inject_block ~level ~round ~block_hash ~block_header ~operations ~protocol_data = (match (level, round) with - | (1l, 1l) -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | (2l, 0l) -> + | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] + | 2l, 0l -> save_proposal_payload ~protocol_data ~var:b_proposal_2_0 >>=? fun () -> return [Block; Pass; Pass; Pass] | _ -> return [Pass; Pass; Pass; Pass]) @@ -1402,7 +1400,7 @@ let test_scenario_m8 () = ~protocol_data:_ = let propagation_vector = match (level, round) with - | (2l, 1l) -> [Block; Pass; Pass; Pass] + | 2l, 1l -> [Block; Pass; Pass; Pass] | _ -> [Pass; Pass; Pass; Pass] in return (block_hash, block_header, operations, propagation_vector) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 4092b8be8610..038cbc2fb723 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -598,7 +598,7 @@ module Mempool = struct (** Returns the weight of an operation, i.e. the fees w.r.t the gas and size consumption in the block. *) let weight_manager_operation ~validation_state ?size ~fee ~gas op = - let (weight, _resources) = + let weight, _resources = weight_and_resources_manager_operation ~validation_state ?size @@ -623,7 +623,7 @@ module Mempool = struct match validation_state with | None -> `Weight_ok (`No_replace, []) | Some validation_state -> ( - let (weight, op_resources) = + let weight, op_resources = weight_and_resources_manager_operation ~validation_state ~fee @@ -914,7 +914,7 @@ module Mempool = struct match (grandparent_level_start, validation_state_before, round_zero_duration) with - | (None, _, _) | (_, None, _) | (_, _, None) -> Lwt.return_true + | None, _, _ | _, None, _ | _, _, None -> Lwt.return_true | ( Some grandparent_level_start, Some validation_state_before, Some round_zero_duration ) -> ( @@ -2000,8 +2000,8 @@ module RPC = struct type a s. (a, s) Script_typed_ir.stack_ty * (a * s) -> Script.expr list tzresult Lwt.t = function - | (Bot_t, (EmptyCell, EmptyCell)) -> return_nil - | (Item_t (ty, rest_ty), (v, rest)) -> + | Bot_t, (EmptyCell, EmptyCell) -> return_nil + | Item_t (ty, rest_ty), (v, rest) -> Script_ir_translator.unparse_data ctxt Unparsing_mode.unparsing_mode @@ -2300,11 +2300,11 @@ module RPC = struct balance >>=? fun bal -> return (ctxt, addr, bal)) >>=? fun (ctxt, self, balance) -> - let (source, payer) = + let source, payer = match (src_opt, pay_opt) with - | (None, None) -> (self, self) - | (Some c, None) | (None, Some c) -> (c, c) - | (Some src, Some pay) -> (src, pay) + | None, None -> (self, self) + | Some c, None | None, Some c -> (c, c) + | Some src, Some pay -> (src, pay) in return (ctxt, {balance; self; source; payer}) in @@ -2517,12 +2517,12 @@ module RPC = struct (View_helpers.make_tzip4_viewer_script ty) Tez.zero >>=? fun (ctxt, viewer_contract) -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (contract, contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (contract, contract) in let gas = Option.value @@ -2609,12 +2609,12 @@ module RPC = struct script_view_type ctxt contract decoded_script view >>=? fun (input_ty, output_ty) -> Contract.get_balance ctxt contract >>=? fun balance -> - let (source, payer) = + let source, payer = match (source, payer) with - | (Some source, Some payer) -> (source, payer) - | (Some source, None) -> (source, source) - | (None, Some payer) -> (payer, payer) - | (None, None) -> (contract, contract) + | Some source, Some payer -> (source, payer) + | Some source, None -> (source, source) + | None, Some payer -> (payer, payer) + | None, None -> (contract, contract) in let now = match now with None -> Script_timestamp.now ctxt | Some t -> t @@ -2740,7 +2740,7 @@ module RPC = struct storage; }) in - let (size, cost) = Script_ir_translator.script_size script in + let size, cost = Script_ir_translator.script_size script in Gas.consume ctxt cost >>?= fun _ctxt -> return @@ size) ; Registration.register0 @@ -2835,7 +2835,7 @@ module RPC = struct ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type >|? fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _) -> - let (unreachable_entrypoint, map) = + let unreachable_entrypoint, map = Script_ir_translator.list_entrypoints_uncarbonated arg_type entrypoints @@ -3246,7 +3246,7 @@ module RPC = struct S.last_cemented_commitment_hash_with_level @@ fun ctxt address () () -> let open Lwt_tzresult_syntax in - let+ (last_cemented_commitment, level, _ctxt) = + let+ last_cemented_commitment, level, _ctxt = Alpha_context.Sc_rollup.last_cemented_commitment_hash_with_level ctxt address @@ -3257,7 +3257,7 @@ module RPC = struct Registration.register2 ~chunked:false S.commitment @@ fun ctxt address commitment_hash () () -> let open Lwt_result_syntax in - let+ (commitment, _) = + let+ commitment, _ = Alpha_context.Sc_rollup.get_commitment ctxt address commitment_hash in commitment @@ -3554,8 +3554,8 @@ module RPC = struct in let ops = match (sourcePubKey, revealed) with - | (None, _) | (_, Some _) -> ops - | (Some pk, None) -> + | None, _ | _, Some _ -> ops + | Some pk, None -> let operation = Reveal pk in Contents (Manager_operation @@ -3777,8 +3777,8 @@ module RPC = struct let requested_levels ~default_level ctxt cycles levels = match (levels, cycles) with - | ([], []) -> [default_level] - | (levels, cycles) -> + | [], [] -> [default_level] + | levels, cycles -> (* explicitly fail when requested levels or cycle are in the past... or too far in the future... TODO: https://gitlab.com/tezos/tezos/-/issues/2335 diff --git a/src/proto_alpha/lib_plugin/test/generators.ml b/src/proto_alpha/lib_plugin/test/generators.ml index 2ca5688e7284..38d6e4e13509 100644 --- a/src/proto_alpha/lib_plugin/test/generators.ml +++ b/src/proto_alpha/lib_plugin/test/generators.ml @@ -51,7 +51,7 @@ let dummy_manager_op_info oph = let dummy_manager_op_info_with_key_gen : (Plugin.Mempool.manager_op_info * Signature.public_key_hash) QCheck2.Gen.t = let open QCheck2.Gen in - let+ (oph, (pkh, _, _)) = pair operation_hash_gen public_key_hash_gen in + let+ oph, (pkh, _, _) = pair operation_hash_gen public_key_hash_gen in (dummy_manager_op_info oph, pkh) let filter_state_gen : Plugin.Mempool.state QCheck2.Gen.t = diff --git a/src/proto_alpha/lib_plugin/test/test_consensus_filter.ml b/src/proto_alpha/lib_plugin/test/test_consensus_filter.ml index 737afa30f888..06ab92ad884b 100644 --- a/src/proto_alpha/lib_plugin/test/test_consensus_filter.ml +++ b/src/proto_alpha/lib_plugin/test/test_consensus_filter.ml @@ -105,7 +105,7 @@ module Generator = struct let print_timestamp = Timestamp.to_notation let near_timestamps = - let+ (i, diff) = pair int32 small_signed_32 in + let+ i, diff = pair int32 small_signed_32 in timestamp_of_int32 i |> fun ts1 -> timestamp_of_int32 Int32.(add i diff) |> fun ts2 -> (ts1, ts2) @@ -122,7 +122,7 @@ module Generator = struct | Error _ -> assert false let successive_timestamp = - let+ (ts, (diff : int)) = pair timestamp small_nat in + let+ ts, (diff : int) = pair timestamp small_nat in let x = Period.of_seconds (Int64.of_int diff) >>? fun diff -> Timestamp.(ts +? diff) >>? fun ts2 -> Ok (ts, ts2) diff --git a/src/proto_alpha/lib_plugin/test/test_utils.ml b/src/proto_alpha/lib_plugin/test/test_utils.ml index f8926df66571..cf25d367381e 100644 --- a/src/proto_alpha/lib_plugin/test/test_utils.ml +++ b/src/proto_alpha/lib_plugin/test/test_utils.ml @@ -125,9 +125,9 @@ let eq_prechecked_managers = let eq_state s1 s2 = let eq_min_prechecked_op_weight = match (s1.min_prechecked_op_weight, s2.min_prechecked_op_weight) with - | (None, None) -> true - | (Some _, None) | (None, Some _) -> false - | (Some w1, Some w2) -> + | None, None -> true + | Some _, None | None, Some _ -> false + | Some w1, Some w2 -> Operation_hash.equal w1.operation_hash w2.operation_hash && Q.equal w1.weight w2.weight in diff --git a/src/proto_alpha/lib_protocol/amendment.ml b/src/proto_alpha/lib_protocol/amendment.ml index 5c81472bd860..1cdb6fd8758e 100644 --- a/src/proto_alpha/lib_protocol/amendment.ml +++ b/src/proto_alpha/lib_protocol/amendment.ml @@ -98,7 +98,7 @@ let get_approval_and_update_participation_ema ctxt = Vote.get_participation_ema ctxt >>=? fun participation_ema -> Vote.get_current_quorum ctxt >>=? fun expected_quorum -> Vote.clear_ballots ctxt >>= fun ctxt -> - let (approval, new_participation_ema) = + let approval, new_participation_ema = approval_and_participation_ema ballots ~maximum_vote diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 1b3d01fe2517..6265f3a43bd4 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -478,8 +478,7 @@ let () = ~pp:(fun ppf contract -> Format.fprintf ppf - "Transactions of 0ꜩ towards a contract without code are forbidden \ - (%a)." + "Transactions of 0ꜩ towards a contract without code are forbidden (%a)." Contract.pp contract) Data_encoding.(obj1 (req "contract" Contract.encoding)) @@ -996,12 +995,12 @@ let ex_ticket_size : Script_typed_ir.ticket_t Micheline.dummy_location ty >>?= fun ty -> Script_ir_translator.unparse_ty ~loc:Micheline.dummy_location ctxt ty >>?= fun (ty', ctxt) -> - let (ty_nodes, ty_size) = Script_typed_ir_size.node_size ty' in + let ty_nodes, ty_size = Script_typed_ir_size.node_size ty' in let ty_size = Saturation_repr.to_int ty_size in let ty_size_cost = Script_typed_ir_size_costs.nodes_cost ~nodes:ty_nodes in Gas.consume ctxt ty_size_cost >>?= fun ctxt -> (* contents *) - let (val_nodes, val_size) = Script_typed_ir_size.value_size ty ticket in + let val_nodes, val_size = Script_typed_ir_size.value_size ty ticket in let val_size = Saturation_repr.to_int val_size in let val_size_cost = Script_typed_ir_size_costs.nodes_cost ~nodes:val_nodes in Gas.consume ctxt val_size_cost >>?= fun ctxt -> @@ -1027,7 +1026,7 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer (Tx_rollup_errors_repr.Ticket_payload_size_limit_exceeded {payload_size = ticket_size; limit}) >>=? fun () -> - let (ex_token, ticket_amount) = + let ex_token, ticket_amount = Ticket_token.token_and_amount_of_ex_ticket ex_ticket in Ticket_balance_key.of_ex_token ctxt ~owner:(Tx_rollup dst_rollup) ex_token @@ -1041,7 +1040,7 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer Tx_rollup_l2_qty.(ticket_amount <= zero) Forbidden_zero_ticket_quantity >>?= fun () -> - let (deposit, message_size) = + let deposit, message_size = Tx_rollup_message.make_deposit payer l2_destination @@ -1471,7 +1470,7 @@ let apply_external_manager_operation_content : letting the client automatically set an appropriate storage limit. TODO : is this concern still honored by the token management refactoring ? *) - let (ctxt, paid_size) = + let ctxt, paid_size = Fees.record_global_constant_storage_space ctxt size in let result = @@ -1523,7 +1522,7 @@ let apply_external_manager_operation_content : in return (ctxt, result, []) | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} -> - let (message, message_size) = Tx_rollup_message.make_batch content in + let message, message_size = Tx_rollup_message.make_batch content in Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> Tx_rollup_inbox.append_message ctxt tx_rollup state message >>=? fun (ctxt, state, paid_storage_size_diff) -> @@ -1814,12 +1813,12 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = (Skipped (Script_typed_ir.manager_kind op.operation))) rest in - Lwt.return (Failure, List.rev (skipped @ result :: applied)) + Lwt.return (Failure, List.rev (skipped @ (result :: applied))) | Ok (ctxt, result, emitted) -> apply ctxt (pack_internal_manager_operation_result op (Applied result) - :: applied) + :: applied) (emitted @ rest)) in apply ctxt [] ops @@ -1904,7 +1903,7 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) | Tx_rollup_submit_batch {content; _} -> assert_tx_rollup_feature_enabled ctxt >>=? fun () -> let size_limit = Constants.tx_rollup_hard_size_limit_per_message ctxt in - let (_message, message_size) = Tx_rollup_message.make_batch content in + let _message, message_size = Tx_rollup_message.make_batch content in Tx_rollup_gas.hash_cost message_size >>?= fun cost -> Gas.consume ctxt cost >>?= fun ctxt -> fail_unless @@ -2171,7 +2170,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id ~chain_id internal_operations >>= function - | (Success ctxt, internal_operations_results) -> ( + | Success ctxt, internal_operations_results -> ( burn_storage_fees ctxt operation_results ~storage_limit ~payer:source >>= function | Ok (ctxt, storage_limit, operation_results) -> ( @@ -2203,7 +2202,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id ( Failure, Backtracked (operation_results, Some errors), internal_operations_results )) - | (Failure, internal_operations_results) -> + | Failure, internal_operations_results -> Lwt.return (Failure, Applied operation_results, internal_operations_results)) | Error errors -> @@ -2392,7 +2391,7 @@ let rec apply_manager_contents_list_rec : ~gas_consumed_in_precheck:(Some (Gas.cost_of_gas consumed_gas)) op >>= function - | (Failure, operation_result, internal_operation_results) -> + | Failure, operation_result, internal_operation_results -> let result = Manager_operation_result {balance_updates; operation_result; internal_operation_results} @@ -2400,7 +2399,7 @@ let rec apply_manager_contents_list_rec : Lwt.return ( Failure, Cons_result (result, mark_skipped ~payload_producer level rest) ) - | (Success ctxt, operation_result, internal_operation_results) -> + | Success ctxt, operation_result, internal_operation_results -> let result = Manager_operation_result {balance_updates; operation_result; internal_operation_results} @@ -2466,7 +2465,8 @@ type apply_mode = predecessor_level : Level.t; predecessor_round : Round.t; round : Round.t; - } (* Both partial and normal *) + } + (* Both partial and normal *) | Full_construction of { predecessor_block : Block_hash.t; payload_hash : Block_payload_hash.t; @@ -2574,7 +2574,7 @@ let compute_expected_consensus_content (type consensus_op_kind) round = predecessor_round; } )) | Full_construction {payload_hash; predecessor_block = branch; _} -> - let (ctxt', round) = + let ctxt', round = match Consensus.get_preendorsements_quorum_round ctxt with | None -> ( Consensus.set_preendorsements_quorum_round ctxt operation_round, @@ -2738,7 +2738,7 @@ let check_denunciation_age ctxt kind given_level = {kind; level = given_level; last_cycle = last_slashable_cycle}) let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = - let (already_slashed, punish) = + let already_slashed, punish = match mistake with | `Double_baking -> ( Delegate.already_slashed_for_double_baking, @@ -2778,8 +2778,8 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id Double_endorsement_evidence_result balance_updates in match (op1.protocol_data.contents, op2.protocol_data.contents) with - | (Single (Preendorsement e1), Single (Preendorsement e2)) - | (Single (Endorsement e1), Single (Endorsement e2)) -> + | Single (Preendorsement e1), Single (Preendorsement e2) + | Single (Endorsement e1), Single (Endorsement e2) -> let kind = if preendorsement then Preendorsement else Endorsement in let op1_hash = Operation.hash op1 in let op2_hash = Operation.hash op2 in @@ -2806,7 +2806,7 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id (Signature.Public_key_hash.equal delegate1 delegate2) (Inconsistent_denunciation {kind; delegate1; delegate2}) >>=? fun () -> - let (delegate_pk, delegate) = (delegate1_pk, delegate1) in + let delegate_pk, delegate = (delegate1_pk, delegate1) in Operation.check_signature delegate_pk chain_id op1 >>?= fun () -> Operation.check_signature delegate_pk chain_id op2 >>?= fun () -> punish_delegate @@ -2849,7 +2849,7 @@ let punish_double_baking ctxt chain_id bh1 bh2 ~payload_producer = Signature.Public_key_hash.(delegate1 = delegate2) (Inconsistent_denunciation {kind = Block; delegate1; delegate2}) >>=? fun () -> - let (delegate_pk, delegate) = (delegate1_pk, delegate1) in + let delegate_pk, delegate = (delegate1_pk, delegate1) in Block_header.check_signature bh1 chain_id delegate_pk >>?= fun () -> Block_header.check_signature bh2 chain_id delegate_pk >>?= fun () -> punish_delegate diff --git a/src/proto_alpha/lib_protocol/apply.mli b/src/proto_alpha/lib_protocol/apply.mli index 616e11196922..88998b9e3198 100644 --- a/src/proto_alpha/lib_protocol/apply.mli +++ b/src/proto_alpha/lib_protocol/apply.mli @@ -99,7 +99,8 @@ type apply_mode = predecessor_level : Level.t; predecessor_round : Round.t; round : Round.t; - } (* Both partial and normal *) + } + (* Both partial and normal *) | Full_construction of { predecessor_block : Block_hash.t; payload_hash : Block_payload_hash.t; diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index ca56c7583010..312d09ab8f1b 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -1070,7 +1070,7 @@ module Internal_result = struct (amount, destination, parameters)); inj = (fun (amount, destination, parameters) -> - let (entrypoint, parameters) = + let entrypoint, parameters = match parameters with | None -> (Entrypoint.default, Script.unit_parameter) | Some (entrypoint, value) -> (entrypoint, value) @@ -1268,78 +1268,76 @@ let equal_manager_kind : type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option = fun ka kb -> match (ka, kb) with - | (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) -> Some Eq - | (Kind.Reveal_manager_kind, _) -> None - | (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) -> Some Eq - | (Kind.Transaction_manager_kind, _) -> None - | (Kind.Origination_manager_kind, Kind.Origination_manager_kind) -> Some Eq - | (Kind.Origination_manager_kind, _) -> None - | (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) -> Some Eq - | (Kind.Delegation_manager_kind, _) -> None + | Kind.Reveal_manager_kind, Kind.Reveal_manager_kind -> Some Eq + | Kind.Reveal_manager_kind, _ -> None + | Kind.Transaction_manager_kind, Kind.Transaction_manager_kind -> Some Eq + | Kind.Transaction_manager_kind, _ -> None + | Kind.Origination_manager_kind, Kind.Origination_manager_kind -> Some Eq + | Kind.Origination_manager_kind, _ -> None + | Kind.Delegation_manager_kind, Kind.Delegation_manager_kind -> Some Eq + | Kind.Delegation_manager_kind, _ -> None | ( Kind.Register_global_constant_manager_kind, Kind.Register_global_constant_manager_kind ) -> Some Eq - | (Kind.Register_global_constant_manager_kind, _) -> None - | (Kind.Set_deposits_limit_manager_kind, Kind.Set_deposits_limit_manager_kind) + | Kind.Register_global_constant_manager_kind, _ -> None + | Kind.Set_deposits_limit_manager_kind, Kind.Set_deposits_limit_manager_kind -> Some Eq - | (Kind.Set_deposits_limit_manager_kind, _) -> None + | Kind.Set_deposits_limit_manager_kind, _ -> None | ( Kind.Tx_rollup_origination_manager_kind, Kind.Tx_rollup_origination_manager_kind ) -> Some Eq - | (Kind.Tx_rollup_origination_manager_kind, _) -> None + | Kind.Tx_rollup_origination_manager_kind, _ -> None | ( Kind.Tx_rollup_submit_batch_manager_kind, Kind.Tx_rollup_submit_batch_manager_kind ) -> Some Eq - | (Kind.Tx_rollup_submit_batch_manager_kind, _) -> None - | (Kind.Tx_rollup_commit_manager_kind, Kind.Tx_rollup_commit_manager_kind) -> + | Kind.Tx_rollup_submit_batch_manager_kind, _ -> None + | Kind.Tx_rollup_commit_manager_kind, Kind.Tx_rollup_commit_manager_kind -> Some Eq - | (Kind.Tx_rollup_commit_manager_kind, _) -> None + | Kind.Tx_rollup_commit_manager_kind, _ -> None | ( Kind.Tx_rollup_return_bond_manager_kind, Kind.Tx_rollup_return_bond_manager_kind ) -> Some Eq - | (Kind.Tx_rollup_return_bond_manager_kind, _) -> None + | Kind.Tx_rollup_return_bond_manager_kind, _ -> None | ( Kind.Tx_rollup_finalize_commitment_manager_kind, Kind.Tx_rollup_finalize_commitment_manager_kind ) -> Some Eq - | (Kind.Tx_rollup_finalize_commitment_manager_kind, _) -> None + | Kind.Tx_rollup_finalize_commitment_manager_kind, _ -> None | ( Kind.Tx_rollup_remove_commitment_manager_kind, Kind.Tx_rollup_remove_commitment_manager_kind ) -> Some Eq - | (Kind.Tx_rollup_remove_commitment_manager_kind, _) -> None - | ( Kind.Tx_rollup_rejection_manager_kind, - Kind.Tx_rollup_rejection_manager_kind ) -> + | Kind.Tx_rollup_remove_commitment_manager_kind, _ -> None + | Kind.Tx_rollup_rejection_manager_kind, Kind.Tx_rollup_rejection_manager_kind + -> Some Eq - | (Kind.Tx_rollup_rejection_manager_kind, _) -> None + | Kind.Tx_rollup_rejection_manager_kind, _ -> None | ( Kind.Tx_rollup_dispatch_tickets_manager_kind, Kind.Tx_rollup_dispatch_tickets_manager_kind ) -> Some Eq - | (Kind.Tx_rollup_dispatch_tickets_manager_kind, _) -> None - | (Kind.Transfer_ticket_manager_kind, Kind.Transfer_ticket_manager_kind) -> + | Kind.Tx_rollup_dispatch_tickets_manager_kind, _ -> None + | Kind.Transfer_ticket_manager_kind, Kind.Transfer_ticket_manager_kind -> Some Eq - | (Kind.Transfer_ticket_manager_kind, _) -> None - | ( Kind.Sc_rollup_originate_manager_kind, - Kind.Sc_rollup_originate_manager_kind ) -> + | Kind.Transfer_ticket_manager_kind, _ -> None + | Kind.Sc_rollup_originate_manager_kind, Kind.Sc_rollup_originate_manager_kind + -> Some Eq - | (Kind.Sc_rollup_originate_manager_kind, _) -> None + | Kind.Sc_rollup_originate_manager_kind, _ -> None | ( Kind.Sc_rollup_add_messages_manager_kind, Kind.Sc_rollup_add_messages_manager_kind ) -> Some Eq - | (Kind.Sc_rollup_add_messages_manager_kind, _) -> None - | (Kind.Sc_rollup_cement_manager_kind, Kind.Sc_rollup_cement_manager_kind) -> + | Kind.Sc_rollup_add_messages_manager_kind, _ -> None + | Kind.Sc_rollup_cement_manager_kind, Kind.Sc_rollup_cement_manager_kind -> Some Eq - | (Kind.Sc_rollup_cement_manager_kind, _) -> None - | (Kind.Sc_rollup_publish_manager_kind, Kind.Sc_rollup_publish_manager_kind) - -> + | Kind.Sc_rollup_cement_manager_kind, _ -> None + | Kind.Sc_rollup_publish_manager_kind, Kind.Sc_rollup_publish_manager_kind -> Some Eq - | (Kind.Sc_rollup_publish_manager_kind, _) -> None - | (Kind.Sc_rollup_refute_manager_kind, Kind.Sc_rollup_refute_manager_kind) -> + | Kind.Sc_rollup_publish_manager_kind, _ -> None + | Kind.Sc_rollup_refute_manager_kind, Kind.Sc_rollup_refute_manager_kind -> Some Eq - | (Kind.Sc_rollup_refute_manager_kind, _) -> None - | (Kind.Sc_rollup_timeout_manager_kind, Kind.Sc_rollup_timeout_manager_kind) - -> + | Kind.Sc_rollup_refute_manager_kind, _ -> None + | Kind.Sc_rollup_timeout_manager_kind, Kind.Sc_rollup_timeout_manager_kind -> Some Eq - | (Kind.Sc_rollup_timeout_manager_kind, _) -> None + | Kind.Sc_rollup_timeout_manager_kind, _ -> None module Encoding = struct type 'kind case = @@ -1991,10 +1989,10 @@ let contents_result_list_encoding = | Contents_result o :: os -> ( of_list os >>? fun (Contents_result_list os) -> match (o, os) with - | ( Manager_operation_result _, - Single_result (Manager_operation_result _) ) -> + | Manager_operation_result _, Single_result (Manager_operation_result _) + -> Ok (Contents_result_list (Cons_result (o, os))) - | (Manager_operation_result _, Cons_result _) -> + | Manager_operation_result _, Cons_result _ -> Ok (Contents_result_list (Cons_result (o, os))) | _ -> Error "cannot decode ill-formed operation result") in @@ -2030,9 +2028,9 @@ let contents_and_result_list_encoding = | Contents_and_result (op, res) :: rest -> ( of_list rest >>? fun (Contents_and_result_list rest) -> match (op, rest) with - | (Manager_operation _, Single_and_result (Manager_operation _, _)) -> + | Manager_operation _, Single_and_result (Manager_operation _, _) -> Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | (Manager_operation _, Cons_and_result (_, _, _)) -> + | Manager_operation _, Cons_and_result (_, _, _) -> Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) | _ -> Error "cannot decode ill-formed combined operation result") in @@ -2071,28 +2069,27 @@ let kind_equal : kind contents -> kind2 contents_result -> (kind, kind2) eq option = fun op res -> match (op, res) with - | (Endorsement _, Endorsement_result _) -> Some Eq - | (Endorsement _, _) -> None - | (Preendorsement _, Preendorsement_result _) -> Some Eq - | (Preendorsement _, _) -> None - | (Seed_nonce_revelation _, Seed_nonce_revelation_result _) -> Some Eq - | (Seed_nonce_revelation _, _) -> None - | (Double_preendorsement_evidence _, Double_preendorsement_evidence_result _) - -> - Some Eq - | (Double_preendorsement_evidence _, _) -> None - | (Double_endorsement_evidence _, Double_endorsement_evidence_result _) -> - Some Eq - | (Double_endorsement_evidence _, _) -> None - | (Double_baking_evidence _, Double_baking_evidence_result _) -> Some Eq - | (Double_baking_evidence _, _) -> None - | (Activate_account _, Activate_account_result _) -> Some Eq - | (Activate_account _, _) -> None - | (Proposals _, Proposals_result) -> Some Eq - | (Proposals _, _) -> None - | (Ballot _, Ballot_result) -> Some Eq - | (Ballot _, _) -> None - | (Failing_noop _, _) -> + | Endorsement _, Endorsement_result _ -> Some Eq + | Endorsement _, _ -> None + | Preendorsement _, Preendorsement_result _ -> Some Eq + | Preendorsement _, _ -> None + | Seed_nonce_revelation _, Seed_nonce_revelation_result _ -> Some Eq + | Seed_nonce_revelation _, _ -> None + | Double_preendorsement_evidence _, Double_preendorsement_evidence_result _ -> + Some Eq + | Double_preendorsement_evidence _, _ -> None + | Double_endorsement_evidence _, Double_endorsement_evidence_result _ -> + Some Eq + | Double_endorsement_evidence _, _ -> None + | Double_baking_evidence _, Double_baking_evidence_result _ -> Some Eq + | Double_baking_evidence _, _ -> None + | Activate_account _, Activate_account_result _ -> Some Eq + | Activate_account _, _ -> None + | Proposals _, Proposals_result -> Some Eq + | Proposals _, _ -> None + | Ballot _, Ballot_result -> Some Eq + | Ballot _, _ -> None + | Failing_noop _, _ -> (* the Failing_noop operation always fails and can't have result *) None | ( Manager_operation {operation = Reveal _; _}, @@ -2112,10 +2109,10 @@ let kind_equal : Some Eq | ( Manager_operation {operation = Reveal _; _}, Manager_operation_result - {operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _} - ) -> + {operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _} ) + -> Some Eq - | (Manager_operation {operation = Reveal _; _}, _) -> None + | Manager_operation {operation = Reveal _; _}, _ -> None | ( Manager_operation {operation = Transaction _; _}, Manager_operation_result {operation_result = Applied (Transaction_result _); _} ) -> @@ -2139,7 +2136,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Transaction _; _}, _) -> None + | Manager_operation {operation = Transaction _; _}, _ -> None | ( Manager_operation {operation = Origination _; _}, Manager_operation_result {operation_result = Applied (Origination_result _); _} ) -> @@ -2163,7 +2160,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Origination _; _}, _) -> None + | Manager_operation {operation = Origination _; _}, _ -> None | ( Manager_operation {operation = Delegation _; _}, Manager_operation_result {operation_result = Applied (Delegation_result _); _} ) -> @@ -2187,7 +2184,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Delegation _; _}, _) -> None + | Manager_operation {operation = Delegation _; _}, _ -> None | ( Manager_operation {operation = Register_global_constant _; _}, Manager_operation_result {operation_result = Applied (Register_global_constant_result _); _} ) -> @@ -2215,7 +2212,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Register_global_constant _; _}, _) -> None + | Manager_operation {operation = Register_global_constant _; _}, _ -> None | ( Manager_operation {operation = Set_deposits_limit _; _}, Manager_operation_result {operation_result = Applied (Set_deposits_limit_result _); _} ) -> @@ -2241,7 +2238,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Set_deposits_limit _; _}, _) -> None + | Manager_operation {operation = Set_deposits_limit _; _}, _ -> None | ( Manager_operation {operation = Tx_rollup_origination; _}, Manager_operation_result {operation_result = Applied (Tx_rollup_origination_result _); _} ) -> @@ -2267,7 +2264,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Tx_rollup_origination; _}, _) -> None + | Manager_operation {operation = Tx_rollup_origination; _}, _ -> None | ( Manager_operation {operation = Tx_rollup_submit_batch _; _}, Manager_operation_result {operation_result = Applied (Tx_rollup_submit_batch_result _); _} ) -> @@ -2293,7 +2290,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Tx_rollup_submit_batch _; _}, _) -> None + | Manager_operation {operation = Tx_rollup_submit_batch _; _}, _ -> None | ( Manager_operation {operation = Tx_rollup_commit _; _}, Manager_operation_result {operation_result = Applied (Tx_rollup_commit_result _); _} ) -> @@ -2318,7 +2315,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Tx_rollup_commit _; _}, _) -> None + | Manager_operation {operation = Tx_rollup_commit _; _}, _ -> None | ( Manager_operation {operation = Tx_rollup_return_bond _; _}, Manager_operation_result {operation_result = Applied (Tx_rollup_return_bond_result _); _} ) -> @@ -2344,7 +2341,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Tx_rollup_return_bond _; _}, _) -> None + | Manager_operation {operation = Tx_rollup_return_bond _; _}, _ -> None | ( Manager_operation {operation = Tx_rollup_finalize_commitment _; _}, Manager_operation_result {operation_result = Applied (Tx_rollup_finalize_commitment_result _); _} @@ -2376,12 +2373,12 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Tx_rollup_finalize_commitment _; _}, _) -> + | Manager_operation {operation = Tx_rollup_finalize_commitment _; _}, _ -> None | ( Manager_operation {operation = Tx_rollup_remove_commitment _; _}, Manager_operation_result - {operation_result = Applied (Tx_rollup_remove_commitment_result _); _} - ) -> + {operation_result = Applied (Tx_rollup_remove_commitment_result _); _} ) + -> Some Eq | ( Manager_operation {operation = Tx_rollup_remove_commitment _; _}, Manager_operation_result @@ -2408,8 +2405,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Tx_rollup_remove_commitment _; _}, _) -> - None + | Manager_operation {operation = Tx_rollup_remove_commitment _; _}, _ -> None | ( Manager_operation {operation = Tx_rollup_rejection _; _}, Manager_operation_result {operation_result = Applied (Tx_rollup_rejection_result _); _} ) -> @@ -2435,7 +2431,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Tx_rollup_rejection _; _}, _) -> None + | Manager_operation {operation = Tx_rollup_rejection _; _}, _ -> None | ( Manager_operation {operation = Tx_rollup_dispatch_tickets _; _}, Manager_operation_result {operation_result = Applied (Tx_rollup_dispatch_tickets_result _); _} ) @@ -2465,7 +2461,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Tx_rollup_dispatch_tickets _; _}, _) -> None + | Manager_operation {operation = Tx_rollup_dispatch_tickets _; _}, _ -> None | ( Manager_operation {operation = Transfer_ticket _; _}, Manager_operation_result {operation_result = Applied (Transfer_ticket_result _); _} ) -> @@ -2490,7 +2486,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Transfer_ticket _; _}, _) -> None + | Manager_operation {operation = Transfer_ticket _; _}, _ -> None | ( Manager_operation {operation = Sc_rollup_originate _; _}, Manager_operation_result {operation_result = Applied (Sc_rollup_originate_result _); _} ) -> @@ -2516,7 +2512,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Sc_rollup_originate _; _}, _) -> None + | Manager_operation {operation = Sc_rollup_originate _; _}, _ -> None | ( Manager_operation {operation = Sc_rollup_add_messages _; _}, Manager_operation_result {operation_result = Applied (Sc_rollup_add_messages_result _); _} ) -> @@ -2542,7 +2538,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Sc_rollup_add_messages _; _}, _) -> None + | Manager_operation {operation = Sc_rollup_add_messages _; _}, _ -> None | ( Manager_operation {operation = Sc_rollup_cement _; _}, Manager_operation_result {operation_result = Applied (Sc_rollup_cement_result _); _} ) -> @@ -2567,7 +2563,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Sc_rollup_cement _; _}, _) -> None + | Manager_operation {operation = Sc_rollup_cement _; _}, _ -> None | ( Manager_operation {operation = Sc_rollup_publish _; _}, Manager_operation_result {operation_result = Applied (Sc_rollup_publish_result _); _} ) -> @@ -2592,7 +2588,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Sc_rollup_publish _; _}, _) -> None + | Manager_operation {operation = Sc_rollup_publish _; _}, _ -> None | ( Manager_operation {operation = Sc_rollup_refute _; _}, Manager_operation_result {operation_result = Applied (Sc_rollup_refute_result _); _} ) -> @@ -2617,7 +2613,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Sc_rollup_refute _; _}, _) -> None + | Manager_operation {operation = Sc_rollup_refute _; _}, _ -> None | ( Manager_operation {operation = Sc_rollup_timeout _; _}, Manager_operation_result {operation_result = Applied (Sc_rollup_timeout_result _); _} ) -> @@ -2642,7 +2638,7 @@ let kind_equal : _; } ) -> Some Eq - | (Manager_operation {operation = Sc_rollup_timeout _; _}, _) -> None + | Manager_operation {operation = Sc_rollup_timeout _; _}, _ -> None let rec kind_equal_list : type kind kind2. @@ -2650,9 +2646,9 @@ let rec kind_equal_list : = fun contents res -> match (contents, res) with - | (Single op, Single_result res) -> ( + | Single op, Single_result res -> ( match kind_equal op res with None -> None | Some Eq -> Some Eq) - | (Cons (op, ops), Cons_result (res, ress)) -> ( + | Cons (op, ops), Cons_result (res, ress) -> ( match kind_equal op res with | None -> None | Some Eq -> ( @@ -2668,8 +2664,8 @@ let[@coq_axiom_with_reason "gadt"] rec pack_contents_list : kind contents_and_result_list = fun contents res -> match (contents, res) with - | (Single op, Single_result res) -> Single_and_result (op, res) - | (Cons (op, ops), Cons_result (res, ress)) -> + | Single op, Single_result res -> Single_and_result (op, res) + | Cons (op, ops), Cons_result (res, ress) -> Cons_and_result (op, res, pack_contents_list ops ress) | ( Single (Manager_operation _), Cons_result (Manager_operation_result _, Single_result _) ) -> @@ -2690,7 +2686,7 @@ let[@coq_axiom_with_reason "gadt"] rec pack_contents_list : Single_result (Manager_operation_result {operation_result = Backtracked _; _}) ) -> . - | (Single _, Cons_result _) -> . + | Single _, Cons_result _ -> . let rec unpack_contents_list : type kind. @@ -2698,7 +2694,7 @@ let rec unpack_contents_list : kind contents_list * kind contents_result_list = function | Single_and_result (op, res) -> (Single op, Single_result res) | Cons_and_result (op, res, rest) -> - let (ops, ress) = unpack_contents_list rest in + let ops, ress = unpack_contents_list rest in (Cons (op, ops), Cons_result (res, ress)) let rec to_list = function @@ -2717,8 +2713,8 @@ let operation_data_and_metadata_encoding = (req "contents" (dynamic_size contents_and_result_list_encoding)) (opt "signature" Signature.encoding)) (function - | (Operation_data _, No_operation_metadata) -> None - | (Operation_data op, Operation_metadata res) -> ( + | Operation_data _, No_operation_metadata -> None + | Operation_data op, Operation_metadata res -> ( match kind_equal_list op.contents res.contents with | None -> Pervasives.failwith @@ -2729,7 +2725,7 @@ let operation_data_and_metadata_encoding = (pack_contents_list op.contents res.contents), op.signature ))) (fun (Contents_and_result_list contents, signature) -> - let (op_contents, res_contents) = unpack_contents_list contents in + let op_contents, res_contents = unpack_contents_list contents in ( Operation_data {contents = op_contents; signature}, Operation_metadata {contents = res_contents} )); case @@ -2739,9 +2735,9 @@ let operation_data_and_metadata_encoding = (req "contents" (dynamic_size Operation.contents_list_encoding)) (opt "signature" Signature.encoding)) (function - | (Operation_data op, No_operation_metadata) -> + | Operation_data op, No_operation_metadata -> Some (Contents_list op.contents, op.signature) - | (Operation_data _, Operation_metadata _) -> None) + | Operation_data _, Operation_metadata _ -> None) (fun (Contents_list contents, signature) -> (Operation_data {contents; signature}, No_operation_metadata)); ] diff --git a/src/proto_alpha/lib_protocol/baking.ml b/src/proto_alpha/lib_protocol/baking.ml index eb10613fe00d..00bc864d9102 100644 --- a/src/proto_alpha/lib_protocol/baking.ml +++ b/src/proto_alpha/lib_protocol/baking.ml @@ -104,7 +104,7 @@ let endorsing_rights_by_first_slot ctxt level = (fun (ctxt, (delegates_map, slots_map)) slot -> Stake_distribution.slot_owner ctxt level slot >|=? fun (ctxt, (pk, pkh)) -> - let (initial_slot, delegates_map) = + let initial_slot, delegates_map = match Signature.Public_key_hash.Map.find pkh delegates_map with | None -> (slot, Signature.Public_key_hash.Map.add pkh slot delegates_map) diff --git a/src/proto_alpha/lib_protocol/bond_id_repr.ml b/src/proto_alpha/lib_protocol/bond_id_repr.ml index d2db05f9211d..4ac94a058071 100644 --- a/src/proto_alpha/lib_protocol/bond_id_repr.ml +++ b/src/proto_alpha/lib_protocol/bond_id_repr.ml @@ -30,7 +30,7 @@ include Compare.Make (struct let compare id1 id2 = match (id1, id2) with - | (Tx_rollup_bond_id id1, Tx_rollup_bond_id id2) -> + | Tx_rollup_bond_id id1, Tx_rollup_bond_id id2 -> Tx_rollup_repr.compare id1 id2 end) diff --git a/src/proto_alpha/lib_protocol/cache_memory_helpers.ml b/src/proto_alpha/lib_protocol/cache_memory_helpers.ml index c89b5e56aed2..b114ca26c97b 100644 --- a/src/proto_alpha/lib_protocol/cache_memory_helpers.ml +++ b/src/proto_alpha/lib_protocol/cache_memory_helpers.ml @@ -142,8 +142,7 @@ let option_size_vec some x = let some x = ret_adding (some x) h1w in Option.fold ~none:zero ~some x -let list_cell_size elt_size = - header_size +! word_size +! word_size +! elt_size +let list_cell_size elt_size = header_size +! word_size +! word_size +! elt_size [@@ocaml.inline always] let list_fold_size elt_size list = @@ -152,8 +151,7 @@ let list_fold_size elt_size list = zero list -let boxed_tup2 x y = - header_size +! word_size +! word_size +! x +! y +let boxed_tup2 x y = header_size +! word_size +! word_size +! x +! y [@@ocaml.inline always] let node_size = diff --git a/src/proto_alpha/lib_protocol/carbonated_map.ml b/src/proto_alpha/lib_protocol/carbonated_map.ml index a24528c66a9c..dcd812c9836c 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.ml +++ b/src/proto_alpha/lib_protocol/carbonated_map.ml @@ -132,19 +132,19 @@ module Make_builder (C : COMPARABLE) = struct (* The call to [f] must also account for gas *) f ctxt old_val_opt >>? fun (new_val_opt, ctxt) -> match (old_val_opt, new_val_opt) with - | (Some _, Some new_val) -> + | Some _, Some new_val -> (* Consume gas for adding to the map *) G.consume ctxt update_cost >|? fun ctxt -> ({map = M.add key new_val map; size}, ctxt) - | (Some _, None) -> + | Some _, None -> (* Consume gas for removing from the map *) G.consume ctxt update_cost >|? fun ctxt -> ({map = M.remove key map; size = size - 1}, ctxt) - | (None, Some new_val) -> + | None, Some new_val -> (* Consume gas for adding to the map *) G.consume ctxt update_cost >|? fun ctxt -> ({map = M.add key new_val map; size = size + 1}, ctxt) - | (None, None) -> ok ({map; size}, ctxt) + | None, None -> ok ({map; size}, ctxt) let to_list ctxt {map; size} = G.consume ctxt (Carbonated_map_costs.fold_cost ~size) >|? fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/contract_repr.ml b/src/proto_alpha/lib_protocol/contract_repr.ml index 038143560ba3..e7befb910d8a 100644 --- a/src/proto_alpha/lib_protocol/contract_repr.ml +++ b/src/proto_alpha/lib_protocol/contract_repr.ml @@ -32,11 +32,11 @@ include Compare.Make (struct let compare l1 l2 = match (l1, l2) with - | (Implicit pkh1, Implicit pkh2) -> + | Implicit pkh1, Implicit pkh2 -> Signature.Public_key_hash.compare pkh1 pkh2 - | (Originated h1, Originated h2) -> Contract_hash.compare h1 h2 - | (Implicit _, Originated _) -> -1 - | (Originated _, Implicit _) -> 1 + | Originated h1, Originated h2 -> Contract_hash.compare h1 h2 + | Implicit _, Originated _ -> -1 + | Originated _, Implicit _ -> 1 end) let blake2b_hash_size = diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 75a3a50a1631..ee2a3a66a40e 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -445,7 +445,7 @@ let[@coq_axiom_with_reason "gadt"] register () = ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type >>? fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _) -> - let (unreachable_entrypoint, map) = + let unreachable_entrypoint, map = Script_ir_translator.list_entrypoints_uncarbonated arg_type entrypoints diff --git a/src/proto_alpha/lib_protocol/contract_storage.ml b/src/proto_alpha/lib_protocol/contract_storage.ml index 9ce34d750ceb..ac00a29e514f 100644 --- a/src/proto_alpha/lib_protocol/contract_storage.ml +++ b/src/proto_alpha/lib_protocol/contract_storage.ml @@ -534,14 +534,14 @@ let get_script c contract = Storage.Contract.Code.find c contract >>=? fun (c, code) -> Storage.Contract.Storage.find c contract >>=? fun (c, storage) -> match (code, storage) with - | (None, None) -> return (c, None) - | (Some code, Some storage) -> return (c, Some {Script_repr.code; storage}) - | (None, Some _) | (Some _, None) -> failwith "get_script" + | None, None -> return (c, None) + | Some code, Some storage -> return (c, Some {Script_repr.code; storage}) + | None, Some _ | Some _, None -> failwith "get_script" let get_storage ctxt contract = Storage.Contract.Storage.find ctxt contract >>=? function - | (ctxt, None) -> return (ctxt, None) - | (ctxt, Some storage) -> + | ctxt, None -> return (ctxt, None) + | ctxt, Some storage -> Raw_context.consume_gas ctxt (Script_repr.force_decode_cost storage) >>?= fun ctxt -> Script_repr.force_decode storage >>?= fun storage -> diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml index a82e2fcd8363..d2f0fa7c7656 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_storage.ml @@ -784,11 +784,11 @@ module Random = struct sampler_for_cycle c cycle >>=? fun (c, seed, state) -> let sample ~int_bound ~mass_bound = let state = init_random_state seed level offset in - let (i, state) = take_int64 (Int64.of_int int_bound) state in - let (elt, _) = take_int64 mass_bound state in + let i, state = take_int64 (Int64.of_int int_bound) state in + let elt, _ = take_int64 mass_bound state in (Int64.to_int i, elt) in - let (pk, pkh) = Sampler.sample state sample in + let pk, pkh = Sampler.sample state sample in return (c, (pk, pkh)) end @@ -1017,7 +1017,7 @@ let delegate_participation_info ctxt delegate = let contract = Contract_repr.Implicit delegate in Storage.Contract.Missed_endorsements.find ctxt contract >>=? fun missed_endorsements -> - let (missed_slots, missed_levels, remaining_allowed_missed_slots) = + let missed_slots, missed_levels, remaining_allowed_missed_slots = match missed_endorsements with | None -> (0, 0, maximal_cycle_inactivity) | Some {remaining_slots; missed_levels} -> diff --git a/src/proto_alpha/lib_protocol/dependent_bool.ml b/src/proto_alpha/lib_protocol/dependent_bool.ml index 8fb3c49ec11a..26d5bd7a9b5e 100644 --- a/src/proto_alpha/lib_protocol/dependent_bool.ml +++ b/src/proto_alpha/lib_protocol/dependent_bool.ml @@ -41,10 +41,10 @@ type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand let dand : type a b. a dbool -> b dbool -> (a, b) ex_dand = fun a b -> match (a, b) with - | (No, No) -> Ex_dand NoNo - | (No, Yes) -> Ex_dand NoYes - | (Yes, No) -> Ex_dand YesNo - | (Yes, Yes) -> Ex_dand YesYes + | No, No -> Ex_dand NoNo + | No, Yes -> Ex_dand NoYes + | Yes, No -> Ex_dand YesNo + | Yes, Yes -> Ex_dand YesYes let dbool_of_dand : type a b r. (a, b, r) dand -> r dbool = function | NoNo -> No @@ -58,7 +58,7 @@ let merge_dand : type a b c1 c2. (a, b, c1) dand -> (a, b, c2) dand -> (c1, c2) eq = fun w1 w2 -> match (w1, w2) with - | (NoNo, NoNo) -> Eq - | (NoYes, NoYes) -> Eq - | (YesNo, YesNo) -> Eq - | (YesYes, YesYes) -> Eq + | NoNo, NoNo -> Eq + | NoYes, NoYes -> Eq + | YesNo, YesNo -> Eq + | YesYes, YesYes -> Eq diff --git a/src/proto_alpha/lib_protocol/destination_repr.ml b/src/proto_alpha/lib_protocol/destination_repr.ml index 216e22674b9d..b8a798212913 100644 --- a/src/proto_alpha/lib_protocol/destination_repr.ml +++ b/src/proto_alpha/lib_protocol/destination_repr.ml @@ -37,8 +37,8 @@ include Compare.Make (struct let compare l1 l2 = match (l1, l2) with - | (Contract k1, Contract k2) -> Contract_repr.compare k1 k2 - | (Tx_rollup k1, Tx_rollup k2) -> Tx_rollup_repr.compare k1 k2 + | Contract k1, Contract k2 -> Contract_repr.compare k1 k2 + | Tx_rollup k1, Tx_rollup k2 -> Tx_rollup_repr.compare k1 k2 (* This function is used by the Michelson interpreter to compare addresses. It is of significant importance to remember that in Michelson, address comparison is used to distinguish between @@ -46,8 +46,8 @@ include Compare.Make (struct KT1 < others], which the two following lines ensure. The wildcards are therefore here for a reason, and should not be modified when new constructors are added to [t]. *) - | (Contract _, _) -> -1 - | (_, Contract _) -> 1 + | Contract _, _ -> -1 + | _, Contract _ -> 1 end) let to_b58check = function diff --git a/src/proto_alpha/lib_protocol/fitness_repr.ml b/src/proto_alpha/lib_protocol/fitness_repr.ml index 0a1c3bd7fa8a..8abc162cf542 100644 --- a/src/proto_alpha/lib_protocol/fitness_repr.ml +++ b/src/proto_alpha/lib_protocol/fitness_repr.ml @@ -255,9 +255,9 @@ let check_locked_round fitness ~locked_round = in let correct = match (locked_round, expected_locked_round) with - | (None, None) -> true - | (Some _, None) | (None, Some _) -> false - | (Some v, Some v') -> Round_repr.(v = v') + | None, None -> true + | Some _, None | None, Some _ -> false + | Some v, Some v' -> Round_repr.(v = v') in error_unless correct Wrong_fitness diff --git a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml index 9a70fbce2081..62831ed1d33b 100644 --- a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml +++ b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml @@ -122,7 +122,7 @@ let rec size_of_comparable_value : | Address_t -> address v | Tx_rollup_l2_address_t -> tx_rollup_l2_address v | Pair_t (leaf, node, _, YesYes) -> - let (lv, rv) = v in + let lv, rv = v in let size = size_of_comparable_value leaf lv + size_of_comparable_value node rv in diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 3aa7e3f3fce0..3597f4bfa47f 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -41,8 +41,7 @@ let return x = of_result (ok x) [@@ocaml.inline always] let return_unit = return () (* Inlined [Option.bind] for performance. *) -let ( >>?? ) m f = - match m with None -> None | Some x -> f x +let ( >>?? ) m f = match m with None -> None | Some x -> f x [@@ocaml.inline always] let bind m f gas = @@ -50,14 +49,12 @@ let bind m f gas = match res with Ok y -> f y gas | Error _ as err -> of_result err gas [@@ocaml.inline always] -let map f m gas = - m gas >>?? fun (x, gas) -> of_result (x >|? f) gas +let map f m gas = m gas >>?? fun (x, gas) -> of_result (x >|? f) gas [@@ocaml.inline always] let bind_result m f = bind (of_result m) f [@@ocaml.inline always] -let bind_recover m f gas = - m gas >>?? fun (x, gas) -> f x gas +let bind_recover m f gas = m gas >>?? fun (x, gas) -> f x gas [@@ocaml.inline always] let consume_gas cost gas = @@ -73,7 +70,7 @@ let run ctxt m = | Some (res, _new_gas_counter) -> ok (res, ctxt) | None -> error Gas.Operation_quota_exceeded) | Limited {remaining = _} -> ( - let (gas_counter, outdated_ctxt) = + let gas_counter, outdated_ctxt = local_gas_counter_and_outdated_context ctxt in match m gas_counter with diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.ml b/src/proto_alpha/lib_protocol/global_constants_storage.ml index 429b454d44f1..7de7c9479df8 100644 --- a/src/proto_alpha/lib_protocol/global_constants_storage.ml +++ b/src/proto_alpha/lib_protocol/global_constants_storage.ml @@ -185,7 +185,7 @@ let expand_node context node = match (args, annot) with (* A constant Prim should always have a single String argument, being a properly formatted hash. *) - | ([String (_, address)], []) -> ( + | [String (_, address)], [] -> ( match Script_expr_hash.of_b58check_opt address with | None -> fail Badly_formed_constant_expression | Some hash -> ( diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml index 918e33f7d216..0dce5fd663ed 100644 --- a/src/proto_alpha/lib_protocol/indexable.ml +++ b/src/proto_alpha/lib_protocol/indexable.ml @@ -141,11 +141,11 @@ let compare : = fun c x y -> match (x, y) with - | ((Hidden_index x | Index x), (Hidden_index y | Index y)) -> + | (Hidden_index x | Index x), (Hidden_index y | Index y) -> Compare.Int32.compare x y - | ((Hidden_value x | Value x), (Hidden_value y | Value y)) -> c x y - | ((Hidden_index _ | Index _), (Hidden_value _ | Value _)) -> -1 - | ((Hidden_value _ | Value _), (Hidden_index _ | Index _)) -> 1 + | (Hidden_value x | Value x), (Hidden_value y | Value y) -> c x y + | (Hidden_index _ | Index _), (Hidden_value _ | Value _) -> -1 + | (Hidden_value _ | Value _), (Hidden_index _ | Index _) -> 1 let compare_values c : 'a value -> 'a value -> int = fun (Value x) (Value y) -> c x y diff --git a/src/proto_alpha/lib_protocol/lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/lazy_storage_diff.ml index 9a7030c35741..a6126aabfe94 100644 --- a/src/proto_alpha/lib_protocol/lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/lazy_storage_diff.ml @@ -375,8 +375,7 @@ let item_encoding = let item_in_memory_size (Item - ( kind - (* kinds are constant tags *), + ( kind (* kinds are constant tags *), _id_is_a_Z_fitting_in_an_int_for_a_long_time, diff )) = let open Cache_memory_helpers in diff --git a/src/proto_alpha/lib_protocol/lazy_storage_kind.ml b/src/proto_alpha/lib_protocol/lazy_storage_kind.ml index 799e55e047f7..59014e154784 100644 --- a/src/proto_alpha/lib_protocol/lazy_storage_kind.ml +++ b/src/proto_alpha/lib_protocol/lazy_storage_kind.ml @@ -222,10 +222,10 @@ let equal : (i1, a1, u1) t -> (i2, a2, u2) t -> (i1 * a1 * u1, i2 * a2 * u2) cmp = fun k1 k2 -> match (k1, k2) with - | (Big_map, Big_map) -> Eq - | (Sapling_state, Sapling_state) -> Eq - | (Big_map, _) -> Neq - | (_, Big_map) -> Neq + | Big_map, Big_map -> Eq + | Sapling_state, Sapling_state -> Eq + | Big_map, _ -> Neq + | _, Big_map -> Neq type ('i, 'a, 'u) kind = ('i, 'a, 'u) t @@ -285,17 +285,17 @@ module IdSet = struct let mem (type i a u) (kind : (i, a, u) kind) (id : i) set = match (kind, set) with - | (Big_map, {big_map; _}) -> Big_map.IdSet.mem id big_map - | (Sapling_state, {sapling_state; _}) -> + | Big_map, {big_map; _} -> Big_map.IdSet.mem id big_map + | Sapling_state, {sapling_state; _} -> Sapling_state.IdSet.mem id sapling_state [@@coq_axiom_with_reason "gadt"] let add (type i a u) (kind : (i, a, u) kind) (id : i) set = match (kind, set) with - | (Big_map, {big_map; _}) -> + | Big_map, {big_map; _} -> let big_map = Big_map.IdSet.add id big_map in {set with big_map} - | (Sapling_state, {sapling_state; _}) -> + | Sapling_state, {sapling_state; _} -> let sapling_state = Sapling_state.IdSet.add id sapling_state in {set with sapling_state} [@@coq_axiom_with_reason "gadt"] @@ -311,8 +311,8 @@ module IdSet = struct let fold (type i a u) (kind : (i, a, u) kind) (f : i -> 'acc -> 'acc) set (acc : 'acc) = match (kind, set) with - | (Big_map, {big_map; _}) -> Big_map.IdSet.fold f big_map acc - | (Sapling_state, {sapling_state; _}) -> + | Big_map, {big_map; _} -> Big_map.IdSet.fold f big_map acc + | Sapling_state, {sapling_state; _} -> Sapling_state.IdSet.fold f sapling_state acc [@@coq_axiom_with_reason "gadt"] diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index b6cefc71d1e4..f7840ac0b33e 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -684,48 +684,48 @@ let relative_position_within_block op1 op2 = let (Operation_data op1) = op1.protocol_data in let (Operation_data op2) = op2.protocol_data in match[@coq_match_with_default] (op1.contents, op2.contents) with - | (Single (Preendorsement _), Single (Preendorsement _)) -> 0 - | (Single (Preendorsement _), _) -> -1 - | (_, Single (Preendorsement _)) -> 1 - | (Single (Endorsement _), Single (Endorsement _)) -> 0 - | (Single (Endorsement _), _) -> -1 - | (_, Single (Endorsement _)) -> 1 - | (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) -> 0 - | (_, Single (Seed_nonce_revelation _)) -> 1 - | (Single (Seed_nonce_revelation _), _) -> -1 + | Single (Preendorsement _), Single (Preendorsement _) -> 0 + | Single (Preendorsement _), _ -> -1 + | _, Single (Preendorsement _) -> 1 + | Single (Endorsement _), Single (Endorsement _) -> 0 + | Single (Endorsement _), _ -> -1 + | _, Single (Endorsement _) -> 1 + | Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _) -> 0 + | _, Single (Seed_nonce_revelation _) -> 1 + | Single (Seed_nonce_revelation _), _ -> -1 | ( Single (Double_preendorsement_evidence _), Single (Double_preendorsement_evidence _) ) -> 0 - | (_, Single (Double_preendorsement_evidence _)) -> 1 - | (Single (Double_preendorsement_evidence _), _) -> -1 + | _, Single (Double_preendorsement_evidence _) -> 1 + | Single (Double_preendorsement_evidence _), _ -> -1 | ( Single (Double_endorsement_evidence _), Single (Double_endorsement_evidence _) ) -> 0 - | (_, Single (Double_endorsement_evidence _)) -> 1 - | (Single (Double_endorsement_evidence _), _) -> -1 - | (Single (Double_baking_evidence _), Single (Double_baking_evidence _)) -> 0 - | (_, Single (Double_baking_evidence _)) -> 1 - | (Single (Double_baking_evidence _), _) -> -1 - | (Single (Activate_account _), Single (Activate_account _)) -> 0 - | (_, Single (Activate_account _)) -> 1 - | (Single (Activate_account _), _) -> -1 - | (Single (Proposals _), Single (Proposals _)) -> 0 - | (_, Single (Proposals _)) -> 1 - | (Single (Proposals _), _) -> -1 - | (Single (Ballot _), Single (Ballot _)) -> 0 - | (_, Single (Ballot _)) -> 1 - | (Single (Ballot _), _) -> -1 - | (Single (Failing_noop _), Single (Failing_noop _)) -> 0 - | (_, Single (Failing_noop _)) -> 1 - | (Single (Failing_noop _), _) -> -1 + | _, Single (Double_endorsement_evidence _) -> 1 + | Single (Double_endorsement_evidence _), _ -> -1 + | Single (Double_baking_evidence _), Single (Double_baking_evidence _) -> 0 + | _, Single (Double_baking_evidence _) -> 1 + | Single (Double_baking_evidence _), _ -> -1 + | Single (Activate_account _), Single (Activate_account _) -> 0 + | _, Single (Activate_account _) -> 1 + | Single (Activate_account _), _ -> -1 + | Single (Proposals _), Single (Proposals _) -> 0 + | _, Single (Proposals _) -> 1 + | Single (Proposals _), _ -> -1 + | Single (Ballot _), Single (Ballot _) -> 0 + | _, Single (Ballot _) -> 1 + | Single (Ballot _), _ -> -1 + | Single (Failing_noop _), Single (Failing_noop _) -> 0 + | _, Single (Failing_noop _) -> 1 + | Single (Failing_noop _), _ -> -1 (* Manager operations with smaller counter are pre-validated first. *) - | (Single (Manager_operation op1), Single (Manager_operation op2)) -> + | Single (Manager_operation op1), Single (Manager_operation op2) -> Z.compare op1.counter op2.counter - | (Cons (Manager_operation op1, _), Single (Manager_operation op2)) -> + | Cons (Manager_operation op1, _), Single (Manager_operation op2) -> Z.compare op1.counter op2.counter - | (Single (Manager_operation op1), Cons (Manager_operation op2, _)) -> + | Single (Manager_operation op1), Cons (Manager_operation op2, _) -> Z.compare op1.counter op2.counter - | (Cons (Manager_operation op1, _), Cons (Manager_operation op2, _)) -> + | Cons (Manager_operation op1, _), Cons (Manager_operation op2, _) -> Z.compare op1.counter op2.counter let init ctxt block_header = diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index 12f1bd6ca9db..9f9aaa0c6da9 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -165,7 +165,7 @@ end) Post-condition: len(to_bin pos depth) = depth *) let to_bin ~pos ~depth = let rec aux acc pos depth = - let (pos', dir) = (pos / 2, pos mod 2) in + let pos', dir = (pos / 2, pos mod 2) in match depth with | 0 -> acc | d -> aux (Compare.Int.(dir = 1) :: acc) pos' (d - 1) @@ -184,36 +184,36 @@ end) let snoc t (el : elt) = let rec traverse tree depth key = match (tree, key) with - | (Node (_, t_left, Empty), true :: _key) -> + | Node (_, t_left, Empty), true :: _key -> (* The base case where the left subtree is full and we start * the right subtree by creating a new tree the size of the remaining * depth and placing the new element in its leftmost position. *) let t_right = make_spine_with el (depth - 1) in node_of t_left t_right - | (Node (_, t_left, Empty), false :: key) -> + | Node (_, t_left, Empty), false :: key -> (* Traversing left, the left subtree is not full (and thus the right * subtree is empty). Recurse on left subtree. *) let t_left = traverse t_left (depth - 1) key in node_of t_left Empty - | (Node (_, t_left, t_right), true :: key) -> + | Node (_, t_left, t_right), true :: key -> (* Traversing right, the left subtree is full. * Recurse on right subtree *) let t_right = traverse t_right (depth - 1) key in node_of t_left t_right - | (_, _) -> + | _, _ -> (* Impossible by construction of the tree and of the key. * See [tree] invariants and [to_bin]. *) assert false in - let (tree', depth') = + let tree', depth' = match (t.tree, t.depth, t.next_pos) with - | (Empty, 0, 0) -> (node_of (leaf_of el) Empty, 1) - | (tree, depth, pos) when Int32.(equal (shift_left 1l depth) (of_int pos)) + | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) + | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos)) -> let t_right = make_spine_with el depth in (node_of tree t_right, depth + 1) - | (tree, depth, pos) -> + | tree, depth, pos -> let key = to_bin ~pos ~depth in (traverse tree depth key, depth) in @@ -230,29 +230,29 @@ end) let snoc_tr t (el : elt) = let rec traverse (z : zipper) tree depth key = match (tree, key) with - | (Node (_, t_left, Empty), true :: _key) -> + | Node (_, t_left, Empty), true :: _key -> let t_right = make_spine_with el (depth - 1) in rebuild_tree z (node_of t_left t_right) - | (Node (_, t_left, Empty), false :: key) -> + | Node (_, t_left, Empty), false :: key -> let z = Left (z, Empty) in (traverse [@tailcall]) z t_left (depth - 1) key - | (Node (_, t_left, t_right), true :: key) -> + | Node (_, t_left, t_right), true :: key -> let z = Right (t_left, z) in (traverse [@tailcall]) z t_right (depth - 1) key - | (_, _) -> + | _, _ -> (* Impossible by construction of the tree and of the key. * See [tree] invariants and [to_bin]. *) assert false in - let (tree', depth') = + let tree', depth' = match (t.tree, t.depth, t.next_pos) with - | (Empty, 0, 0) -> (node_of (leaf_of el) Empty, 1) - | (tree, depth, pos) when Int32.(equal (shift_left 1l depth) (of_int pos)) + | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) + | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos)) -> let t_right = make_spine_with el depth in (node_of tree t_right, depth + 1) - | (tree, depth, pos) -> + | tree, depth, pos -> let key = to_bin ~pos ~depth in (traverse Top tree depth key, depth) in @@ -278,8 +278,8 @@ end) let key = to_bin ~pos ~depth in let rec aux acc tree key = match (tree, key) with - | (Leaf _, []) -> ok acc - | (Node (_, l, r), b :: key) -> + | Leaf _, [] -> ok acc + | Node (_, l, r), b :: key -> if b then aux (root l :: acc) r key else aux (root r :: acc) l key | _ -> error Merkle_list_invalid_position in @@ -325,9 +325,9 @@ end) let equal t1 t2 = let rec eq_tree t1 t2 = match (t1, t2) with - | (Empty, Empty) -> true - | (Leaf h1, Leaf h2) -> H.equal h1 h2 - | (Node (h1, l1, r1), Node (h2, l2, r2)) -> + | Empty, Empty -> true + | Leaf h1, Leaf h2 -> H.equal h1 h2 + | Node (h1, l1, r1), Node (h2, l2, r2) -> H.equal h1 h2 && eq_tree l1 l2 && eq_tree r1 r2 | _ -> false in diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index 19246cde04bb..af392490784f 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -1404,8 +1404,8 @@ module Cost_of = struct | Chain_id_t -> (apply [@tailcall]) Gas.(acc +@ compare_chain_id) k | Pair_t (tl, tr, _, YesYes) -> (* Reasonable over-approximation of the cost of lexicographic comparison. *) - let (xl, xr) = x in - let (yl, yr) = y in + let xl, xr = x in + let yl, yr = y in (compare [@tailcall]) tl xl @@ -1414,21 +1414,21 @@ module Cost_of = struct (Compare (tr, xr, yr, k)) | Union_t (tl, tr, _, YesYes) -> ( match (x, y) with - | (L x, L y) -> + | L x, L y -> (compare [@tailcall]) tl x y Gas.(acc +@ compare_union_tag) k - | (L _, R _) -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k - | (R _, L _) -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k - | (R x, R y) -> + | L _, R _ -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k + | R _, L _ -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k + | R x, R y -> (compare [@tailcall]) tr x y Gas.(acc +@ compare_union_tag) k) | Option_t (t, _, Yes) -> ( match (x, y) with - | (None, None) -> + | None, None -> (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k - | (None, Some _) -> + | None, Some _ -> (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k - | (Some _, None) -> + | Some _, None -> (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k - | (Some x, Some y) -> + | Some x, Some y -> (compare [@tailcall]) t x y Gas.(acc +@ compare_option_tag) k) and apply cost k = match k with diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index b85b7ea06598..97464d4f6aee 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -760,9 +760,9 @@ let prim_encoding = (* Alpha_013 addition *) ("tx_rollup_l2_address", T_tx_rollup_l2_address); ("MIN_BLOCK_TIME", I_MIN_BLOCK_TIME); - ("sapling_transaction", T_sapling_transaction); + ("sapling_transaction", T_sapling_transaction) (* New instructions must be added here, for backward compatibility of the encoding. *) - (* Keep the comment above at the end of the list *) + (* Keep the comment above at the end of the list *); ] let () = diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 59b639903385..ea4f9d380fa6 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -452,9 +452,9 @@ let rec of_list_internal = function | Contents o :: os -> ( of_list_internal os >>? fun (Contents_list os) -> match (o, os) with - | (Manager_operation _, Single (Manager_operation _)) -> + | Manager_operation _, Single (Manager_operation _) -> Ok (Contents_list (Cons (o, os))) - | (Manager_operation _, Cons _) -> Ok (Contents_list (Cons (o, os))) + | Manager_operation _, Cons _ -> Ok (Contents_list (Cons (o, os))) | _ -> Error "Operation list of length > 1 should only contains manager \ @@ -570,7 +570,7 @@ module Encoding = struct (amount, destination, parameters)); inj = (fun (amount, destination, parameters) -> - let (entrypoint, parameters) = + let entrypoint, parameters = match parameters with | None -> (Entrypoint_repr.default, Script_repr.unit_parameter) | Some (entrypoint, value) -> (entrypoint, value) @@ -1614,89 +1614,88 @@ let equal_manager_operation_kind : type a b. a manager_operation -> b manager_operation -> (a, b) eq option = fun op1 op2 -> match (op1, op2) with - | (Reveal _, Reveal _) -> Some Eq - | (Reveal _, _) -> None - | (Transaction _, Transaction _) -> Some Eq - | (Transaction _, _) -> None - | (Origination _, Origination _) -> Some Eq - | (Origination _, _) -> None - | (Delegation _, Delegation _) -> Some Eq - | (Delegation _, _) -> None - | (Register_global_constant _, Register_global_constant _) -> Some Eq - | (Register_global_constant _, _) -> None - | (Set_deposits_limit _, Set_deposits_limit _) -> Some Eq - | (Set_deposits_limit _, _) -> None - | (Tx_rollup_origination, Tx_rollup_origination) -> Some Eq - | (Tx_rollup_origination, _) -> None - | (Tx_rollup_submit_batch _, Tx_rollup_submit_batch _) -> Some Eq - | (Tx_rollup_submit_batch _, _) -> None - | (Tx_rollup_commit _, Tx_rollup_commit _) -> Some Eq - | (Tx_rollup_commit _, _) -> None - | (Tx_rollup_return_bond _, Tx_rollup_return_bond _) -> Some Eq - | (Tx_rollup_return_bond _, _) -> None - | (Tx_rollup_finalize_commitment _, Tx_rollup_finalize_commitment _) -> - Some Eq - | (Tx_rollup_finalize_commitment _, _) -> None - | (Tx_rollup_remove_commitment _, Tx_rollup_remove_commitment _) -> Some Eq - | (Tx_rollup_remove_commitment _, _) -> None - | (Tx_rollup_rejection _, Tx_rollup_rejection _) -> Some Eq - | (Tx_rollup_rejection _, _) -> None - | (Tx_rollup_dispatch_tickets _, Tx_rollup_dispatch_tickets _) -> Some Eq - | (Tx_rollup_dispatch_tickets _, _) -> None - | (Transfer_ticket _, Transfer_ticket _) -> Some Eq - | (Transfer_ticket _, _) -> None - | (Sc_rollup_originate _, Sc_rollup_originate _) -> Some Eq - | (Sc_rollup_originate _, _) -> None - | (Sc_rollup_add_messages _, Sc_rollup_add_messages _) -> Some Eq - | (Sc_rollup_add_messages _, _) -> None - | (Sc_rollup_cement _, Sc_rollup_cement _) -> Some Eq - | (Sc_rollup_cement _, _) -> None - | (Sc_rollup_publish _, Sc_rollup_publish _) -> Some Eq - | (Sc_rollup_publish _, _) -> None - | (Sc_rollup_refute _, Sc_rollup_refute _) -> Some Eq - | (Sc_rollup_refute _, _) -> None - | (Sc_rollup_timeout _, Sc_rollup_timeout _) -> Some Eq - | (Sc_rollup_timeout _, _) -> None + | Reveal _, Reveal _ -> Some Eq + | Reveal _, _ -> None + | Transaction _, Transaction _ -> Some Eq + | Transaction _, _ -> None + | Origination _, Origination _ -> Some Eq + | Origination _, _ -> None + | Delegation _, Delegation _ -> Some Eq + | Delegation _, _ -> None + | Register_global_constant _, Register_global_constant _ -> Some Eq + | Register_global_constant _, _ -> None + | Set_deposits_limit _, Set_deposits_limit _ -> Some Eq + | Set_deposits_limit _, _ -> None + | Tx_rollup_origination, Tx_rollup_origination -> Some Eq + | Tx_rollup_origination, _ -> None + | Tx_rollup_submit_batch _, Tx_rollup_submit_batch _ -> Some Eq + | Tx_rollup_submit_batch _, _ -> None + | Tx_rollup_commit _, Tx_rollup_commit _ -> Some Eq + | Tx_rollup_commit _, _ -> None + | Tx_rollup_return_bond _, Tx_rollup_return_bond _ -> Some Eq + | Tx_rollup_return_bond _, _ -> None + | Tx_rollup_finalize_commitment _, Tx_rollup_finalize_commitment _ -> Some Eq + | Tx_rollup_finalize_commitment _, _ -> None + | Tx_rollup_remove_commitment _, Tx_rollup_remove_commitment _ -> Some Eq + | Tx_rollup_remove_commitment _, _ -> None + | Tx_rollup_rejection _, Tx_rollup_rejection _ -> Some Eq + | Tx_rollup_rejection _, _ -> None + | Tx_rollup_dispatch_tickets _, Tx_rollup_dispatch_tickets _ -> Some Eq + | Tx_rollup_dispatch_tickets _, _ -> None + | Transfer_ticket _, Transfer_ticket _ -> Some Eq + | Transfer_ticket _, _ -> None + | Sc_rollup_originate _, Sc_rollup_originate _ -> Some Eq + | Sc_rollup_originate _, _ -> None + | Sc_rollup_add_messages _, Sc_rollup_add_messages _ -> Some Eq + | Sc_rollup_add_messages _, _ -> None + | Sc_rollup_cement _, Sc_rollup_cement _ -> Some Eq + | Sc_rollup_cement _, _ -> None + | Sc_rollup_publish _, Sc_rollup_publish _ -> Some Eq + | Sc_rollup_publish _, _ -> None + | Sc_rollup_refute _, Sc_rollup_refute _ -> Some Eq + | Sc_rollup_refute _, _ -> None + | Sc_rollup_timeout _, Sc_rollup_timeout _ -> Some Eq + | Sc_rollup_timeout _, _ -> None let equal_contents_kind : type a b. a contents -> b contents -> (a, b) eq option = fun op1 op2 -> match (op1, op2) with - | (Preendorsement _, Preendorsement _) -> Some Eq - | (Preendorsement _, _) -> None - | (Endorsement _, Endorsement _) -> Some Eq - | (Endorsement _, _) -> None - | (Seed_nonce_revelation _, Seed_nonce_revelation _) -> Some Eq - | (Seed_nonce_revelation _, _) -> None - | (Double_endorsement_evidence _, Double_endorsement_evidence _) -> Some Eq - | (Double_endorsement_evidence _, _) -> None - | (Double_preendorsement_evidence _, Double_preendorsement_evidence _) -> + | Preendorsement _, Preendorsement _ -> Some Eq + | Preendorsement _, _ -> None + | Endorsement _, Endorsement _ -> Some Eq + | Endorsement _, _ -> None + | Seed_nonce_revelation _, Seed_nonce_revelation _ -> Some Eq + | Seed_nonce_revelation _, _ -> None + | Double_endorsement_evidence _, Double_endorsement_evidence _ -> Some Eq + | Double_endorsement_evidence _, _ -> None + | Double_preendorsement_evidence _, Double_preendorsement_evidence _ -> Some Eq - | (Double_preendorsement_evidence _, _) -> None - | (Double_baking_evidence _, Double_baking_evidence _) -> Some Eq - | (Double_baking_evidence _, _) -> None - | (Activate_account _, Activate_account _) -> Some Eq - | (Activate_account _, _) -> None - | (Proposals _, Proposals _) -> Some Eq - | (Proposals _, _) -> None - | (Ballot _, Ballot _) -> Some Eq - | (Ballot _, _) -> None - | (Failing_noop _, Failing_noop _) -> Some Eq - | (Failing_noop _, _) -> None - | (Manager_operation op1, Manager_operation op2) -> ( + | Double_preendorsement_evidence _, _ -> None + | Double_baking_evidence _, Double_baking_evidence _ -> Some Eq + | Double_baking_evidence _, _ -> None + | Activate_account _, Activate_account _ -> Some Eq + | Activate_account _, _ -> None + | Proposals _, Proposals _ -> Some Eq + | Proposals _, _ -> None + | Ballot _, Ballot _ -> Some Eq + | Ballot _, _ -> None + | Failing_noop _, Failing_noop _ -> Some Eq + | Failing_noop _, _ -> None + | Manager_operation op1, Manager_operation op2 -> ( match equal_manager_operation_kind op1.operation op2.operation with | None -> None | Some Eq -> Some Eq) - | (Manager_operation _, _) -> None + | Manager_operation _, _ -> None let rec equal_contents_kind_list : type a b. a contents_list -> b contents_list -> (a, b) eq option = fun op1 op2 -> match (op1, op2) with - | (Single op1, Single op2) -> equal_contents_kind op1 op2 - | (Single _, Cons _) -> None - | (Cons _, Single _) -> None - | (Cons (op1, ops1), Cons (op2, ops2)) -> ( + | Single op1, Single op2 -> equal_contents_kind op1 op2 + | Single _, Cons _ -> None + | Cons _, Single _ -> None + | Cons (op1, ops1), Cons (op2, ops2) -> ( match equal_contents_kind op1 op2 with | None -> None | Some Eq -> ( diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index e34b4a9299c2..37a2728b6fa3 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -36,8 +36,8 @@ module Sc_rollup_address_comparable = struct let compare_cost _rollup = Saturation_repr.safe_int 15 end -(* This will not create the map yet, as functions to consume gas have not - been defined yet. However, it will make the type of the carbonated map +(* This will not create the map yet, as functions to consume gas have not + been defined yet. However, it will make the type of the carbonated map available to be used in the definition of type back. *) module Sc_rollup_address_map_builder = @@ -536,14 +536,14 @@ let check_enough_gas ctxt cost = let gas_consumed ~since ~until = match (gas_level since, gas_level until) with - | (Limited {remaining = before}, Limited {remaining = after}) -> + | Limited {remaining = before}, Limited {remaining = after} -> Gas_limit_repr.Arith.sub before after - | (_, _) -> Gas_limit_repr.Arith.zero + | _, _ -> Gas_limit_repr.Arith.zero -(* Once gas consuming functions have been defined, - we can instantiate the carbonated map. +(* Once gas consuming functions have been defined, + we can instantiate the carbonated map. See [Sc_rollup_carbonated_map_maker] above. - *) +*) module Gas = struct type context = t @@ -1402,7 +1402,7 @@ end module Sc_rollup_in_memory_inbox = struct let current_messages ctxt rollup = let open Tzresult_syntax in - let+ (messages, ctxt) = + let+ messages, ctxt = Sc_rollup_carbonated_map.find ctxt rollup @@ -1414,7 +1414,7 @@ module Sc_rollup_in_memory_inbox = struct let set_current_messages ctxt rollup tree = let open Tzresult_syntax in - let+ (sc_rollup_current_messages, ctxt) = + let+ sc_rollup_current_messages, ctxt = Sc_rollup_carbonated_map.update ctxt rollup diff --git a/src/proto_alpha/lib_protocol/receipt_repr.ml b/src/proto_alpha/lib_protocol/receipt_repr.ml index 392bd5a99e39..605962af8cc6 100644 --- a/src/proto_alpha/lib_protocol/receipt_repr.ml +++ b/src/proto_alpha/lib_protocol/receipt_repr.ml @@ -237,22 +237,21 @@ let is_not_zero c = not (Compare.Int.equal c 0) let compare_balance ba bb = match (ba, bb) with - | (Contract ca, Contract cb) -> Contract_repr.compare ca cb - | (Deposits pkha, Deposits pkhb) -> - Signature.Public_key_hash.compare pkha pkhb - | ( Lost_endorsing_rewards (pkha, pa, ra), - Lost_endorsing_rewards (pkhb, pb, rb) ) -> + | Contract ca, Contract cb -> Contract_repr.compare ca cb + | Deposits pkha, Deposits pkhb -> Signature.Public_key_hash.compare pkha pkhb + | Lost_endorsing_rewards (pkha, pa, ra), Lost_endorsing_rewards (pkhb, pb, rb) + -> let c = Signature.Public_key_hash.compare pkha pkhb in if is_not_zero c then c else let c = Compare.Bool.compare pa pb in if is_not_zero c then c else Compare.Bool.compare ra rb - | (Commitments bpkha, Commitments bpkhb) -> + | Commitments bpkha, Commitments bpkhb -> Blinded_public_key_hash.compare bpkha bpkhb - | (Frozen_bonds (ca, ra), Frozen_bonds (cb, rb)) -> + | Frozen_bonds (ca, ra), Frozen_bonds (cb, rb) -> let c = Contract_repr.compare ca cb in if is_not_zero c then c else Bond_id_repr.compare ra rb - | (_, _) -> + | _, _ -> let index b = match b with | Contract _ -> 0 @@ -361,7 +360,7 @@ let balance_updates_encoding = @@ list (conv (function - | (balance, balance_update, update_origin) -> + | balance, balance_update, update_origin -> ((balance, balance_update), update_origin)) (fun ((balance, balance_update), update_origin) -> (balance, balance_update, update_origin)) @@ -396,7 +395,7 @@ let group_balance_updates balance_updates = | None -> ok (Some update) | Some balance -> ( match (balance, update) with - | (Credited a, Debited b) | (Debited b, Credited a) -> + | Credited a, Debited b | Debited b, Credited a -> (* Remove the binding since it just fell down to zero *) if Tez_repr.(a = b) then ok None else if Tez_repr.(a > b) then @@ -405,10 +404,10 @@ let group_balance_updates balance_updates = else Tez_repr.(b -? a) >>? fun update -> ok (Some (Debited update)) - | (Credited a, Credited b) -> + | Credited a, Credited b -> Tez_repr.(a +? b) >>? fun update -> ok (Some (Credited update)) - | (Debited a, Debited b) -> + | Debited a, Debited b -> Tez_repr.(a +? b) >>? fun update -> ok (Some (Debited update)))) acc) diff --git a/src/proto_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml index a7394e33715c..4f8c5c7b20ee 100644 --- a/src/proto_alpha/lib_protocol/round_repr.ml +++ b/src/proto_alpha/lib_protocol/round_repr.ml @@ -211,29 +211,29 @@ let () = (* The duration of round n follows the arithmetic sequence: - round_duration(0) = first_round_duration - round_duration(r+1) = round_duration(r) + delay_increment_per_round + round_duration(0) = first_round_duration + round_duration(r+1) = round_duration(r) + delay_increment_per_round - Hence, this sequence can be explicited into: + Hence, this sequence can be explicited into: - round_duration(r) = first_round_duration + r * delay_increment_per_round + round_duration(r) = first_round_duration + r * delay_increment_per_round - The level offset of round r is the sum of the durations of the rounds up - until round r - 1. In other words, when r > 0 + The level offset of round r is the sum of the durations of the rounds up + until round r - 1. In other words, when r > 0 - raw_level_offset_of_round(0) = 0 - raw_level_offset_of_round(r+1) = - raw_level_offset_of_round(r) + round_duration(r) + raw_level_offset_of_round(0) = 0 + raw_level_offset_of_round(r+1) = + raw_level_offset_of_round(r) + round_duration(r) -Hence + Hence - raw_level_offset_of_round(r) = Σ_{k=0}^{r-1} (round_duration(k)) + raw_level_offset_of_round(r) = Σ_{k=0}^{r-1} (round_duration(k)) - After unfolding the series, the same function can be finally explicited into + After unfolding the series, the same function can be finally explicited into - raw_level_offset_of_round(0) = 0 - raw_level_offset_of_round(r) = r * first_round_duration - + 1/2 * r * (r - 1) * delay_increment_per_round + raw_level_offset_of_round(0) = 0 + raw_level_offset_of_round(r) = r * first_round_duration + + 1/2 * r * (r - 1) * delay_increment_per_round *) let raw_level_offset_of_round round_durations ~round = if Compare.Int32.(round = zero) then ok Int64.zero diff --git a/src/proto_alpha/lib_protocol/sampler.ml b/src/proto_alpha/lib_protocol/sampler.ml index 7c6518152e45..043e05945f86 100644 --- a/src/proto_alpha/lib_protocol/sampler.ml +++ b/src/proto_alpha/lib_protocol/sampler.ml @@ -76,12 +76,12 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct let rec init_loop total p alias small large = match (small, large) with - | ([], _) -> List.iter (fun (_, i) -> FallbackArray.set p i total) large - | (_, []) -> + | [], _ -> List.iter (fun (_, i) -> FallbackArray.set p i total) large + | _, [] -> (* This can only happen because of numerical inaccuracies e.g. when using [Mass.t = float] *) List.iter (fun (_, i) -> FallbackArray.set p i total) small - | ((qi, i) :: small', (qj, j) :: large') -> + | (qi, i) :: small', (qj, j) :: large' -> FallbackArray.set p i qi ; FallbackArray.set alias i j ; let qj' = Mass.sub (Mass.add qi qj) total in @@ -93,7 +93,7 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct fun ~fallback measure -> FallbackArray.of_list ~fallback ~proj:fst measure let check_and_cleanup measure = - let (total, measure) = + let total, measure = List.fold_left (fun ((total, m) as acc) ((_, p) as point) -> if Mass.(zero < p) then (Mass.add total p, point :: m) @@ -110,10 +110,10 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct (* NB: duplicate elements in the support are not merged; the algorithm should still function correctly. *) let create (measure : ('a * Mass.t) list) = - let (fallback, total, measure) = check_and_cleanup measure in + let fallback, total, measure = check_and_cleanup measure in let length = List.length measure in let n = Mass.of_int length in - let (_, small, large) = + let _, small, large = List.fold_left (fun (i, small, large) (_, p) -> let q = Mass.mul p n in @@ -130,7 +130,7 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct let sample {total; support; p; alias} draw_i_elt = let n = FallbackArray.length support in - let (i, elt) = draw_i_elt ~int_bound:n ~mass_bound:total in + let i, elt = draw_i_elt ~int_bound:n ~mass_bound:total in let p = FallbackArray.get p i in if Mass.(elt < p) then FallbackArray.get support i else @@ -215,5 +215,5 @@ end 10000 delegates without overflows. If/when this happens, the implementation should be revisited. - *) +*) include Make (Mass) diff --git a/src/proto_alpha/lib_protocol/sapling_repr.ml b/src/proto_alpha/lib_protocol/sapling_repr.ml index 0b472fea5c28..5b9a1586d73f 100644 --- a/src/proto_alpha/lib_protocol/sapling_repr.ml +++ b/src/proto_alpha/lib_protocol/sapling_repr.ml @@ -35,7 +35,7 @@ let transaction_encoding = Sapling.UTXO.transaction_encoding contracts to keep a temporary state that may be discarded. Diffs are also returned by an RPC to allow a client to synchronize its own state with the chain. - *) +*) type diff = { commitments_and_ciphertexts : (Sapling.Commitment.t * Sapling.Ciphertext.t) list; diff --git a/src/proto_alpha/lib_protocol/sapling_storage.ml b/src/proto_alpha/lib_protocol/sapling_storage.ml index 167f75f1f913..3f151b757847 100644 --- a/src/proto_alpha/lib_protocol/sapling_storage.ml +++ b/src/proto_alpha/lib_protocol/sapling_storage.ml @@ -121,10 +121,10 @@ module Commitments : COMMITMENTS = struct assert_node node height ; assert_height height ; Storage.Sapling.Commitments.find (ctx, id) node >|=? function - | (ctx, None) -> + | ctx, None -> let hash = H.uncommitted ~height in (ctx, hash) - | (ctx, Some hash) -> (ctx, hash) + | ctx, Some hash -> (ctx, hash) let left node = Int64.mul node 2L @@ -137,7 +137,7 @@ module Commitments : COMMITMENTS = struct match l with | [] -> ([], l) | x :: xs -> - let (l1, l2) = split_at Int64.(pred n) xs in + let l1, l2 = split_at Int64.(pred n) xs in (x :: l1, l2) (* [insert tree height pos cms] inserts the list of commitments @@ -154,9 +154,9 @@ module Commitments : COMMITMENTS = struct assert_height height ; assert_pos pos height ; match (height, cms) with - | (_, []) -> + | _, [] -> get_root_height ctx id node height >|=? fun (ctx, h) -> (ctx, 0, h) - | (0, [cm]) -> + | 0, [cm] -> let h = H.of_commitment cm in Storage.Sapling.Commitments.init (ctx, id) node h >|=? fun (ctx, size) -> (ctx, size, h) @@ -164,7 +164,7 @@ module Commitments : COMMITMENTS = struct let height = height - 1 in (if Compare.Int64.(pos < pow2 height) then let at = Int64.(sub (pow2 height) pos) in - let (cml, cmr) = split_at at cms in + let cml, cmr = split_at at cms in insert ctx id (left node) height pos cml >>=? fun (ctx, size_l, hl) -> insert ctx id (right node) height 0L cmr >|=? fun (ctx, size_r, hr) -> (ctx, size_l + size_r, hl, hr) @@ -187,8 +187,8 @@ module Commitments : COMMITMENTS = struct (* we don't count gas for this function, it is called only by RPC *) >>=? function - | (_ctx, None) -> return acc - | (_ctx, Some h) -> + | _ctx, None -> return acc + | _ctx, Some h -> if Compare.Int.(height = 0) then return (f acc h) else let full = pow2 (height - 1) in @@ -251,7 +251,7 @@ end (* Collection of nullifiers w/o duplicates, append-only. It has a dual implementation with a hash map for constant `mem` and with a ordered set to - retrieve by position. *) + retrieve by position. *) module Nullifiers = struct let init = Storage.Sapling.nullifiers_init diff --git a/src/proto_alpha/lib_protocol/sapling_validator.ml b/src/proto_alpha/lib_protocol/sapling_validator.ml index ce0e41e0133c..a9784cae9421 100644 --- a/src/proto_alpha/lib_protocol/sapling_validator.ml +++ b/src/proto_alpha/lib_protocol/sapling_validator.ml @@ -31,8 +31,8 @@ let rec check_and_update_nullifiers ctxt state inputs = | input :: inputs -> ( Sapling_storage.nullifiers_mem ctxt state Sapling.UTXO.(input.nf) >>=? function - | (ctxt, true) -> return (ctxt, None) - | (ctxt, false) -> + | ctxt, true -> return (ctxt, None) + | ctxt, false -> let state = Sapling_storage.nullifiers_add state Sapling.UTXO.(input.nf) in @@ -67,8 +67,8 @@ let verify_update : if not pass then return (ctxt, None) else check_and_update_nullifiers ctxt state transaction.inputs >|=? function - | (ctxt, None) -> (ctxt, None) - | (ctxt, Some state) -> + | ctxt, None -> (ctxt, None) + | ctxt, Some state -> Sapling.Verification.with_verification_ctx (fun vctx -> let pass = (* Check all the output ZK proofs *) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 4122a2b17896..3590243dec30 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -122,10 +122,10 @@ module Make (Context : P) : let equal_instruction i1 i2 = match (i1, i2) with - | (IPush x, IPush y) -> Compare.Int.(x = y) - | (IAdd, IAdd) -> true - | (IStore x, IStore y) -> Compare.String.(x = y) - | (_, _) -> false + | IPush x, IPush y -> Compare.Int.(x = y) + | IAdd, IAdd -> true + | IStore x, IStore y -> Compare.String.(x = y) + | _, _ -> false let pp_instruction fmt = function | IPush x -> Format.fprintf fmt "push(%d)" x @@ -192,7 +192,7 @@ module Make (Context : P) : let bind m f state = let open Lwt_syntax in - let* (state, res) = m state in + let* state, res = m state in match res with None -> return (state, None) | Some res -> f res state module Syntax = struct @@ -230,7 +230,7 @@ module Make (Context : P) : match obytes with | None -> return (state, Some None) | Some bytes -> - let* (state, value) = decode encoding bytes state in + let* state, value = decode encoding bytes state in return (state, Some value) let children key encoding state = @@ -243,11 +243,11 @@ module Make (Context : P) : match obytes with | None -> internal_error "Invalid children" state | Some bytes -> ( - let* (state, v) = decode encoding bytes state in + let* state, v = decode encoding bytes state in match v with | None -> return (state, None) | Some v -> ( - let* (state, l) = aux children in + let* state, l = aux children in match l with | None -> return (state, None) | Some l -> return (state, Some ((key, v) :: l))))) @@ -650,7 +650,7 @@ module Make (Context : P) : let pp state = let open Lwt_syntax in - let* (_, pp) = Monad.run pp state in + let* _, pp = Monad.run pp state in match pp with | None -> return @@ fun fmt _ -> Format.fprintf fmt "<opaque>" | Some pp -> return pp @@ -666,7 +666,7 @@ module Make (Context : P) : return () in let open Lwt_syntax in - let* (state, _) = run m state in + let* state, _ = run m state in return state let state_hash state = @@ -682,7 +682,7 @@ module Make (Context : P) : let open Lwt_syntax in let* state = Monad.run m state in match state with - | (_, Some hash) -> return hash + | _, Some hash -> return hash | _ -> (* Hash computation always succeeds. *) assert false let boot = @@ -694,12 +694,12 @@ module Make (Context : P) : let result_of ~default m state = let open Lwt_syntax in - let* (_, v) = run m state in + let* _, v = run m state in match v with None -> return default | Some v -> return v let state_of m state = let open Lwt_syntax in - let* (s, _) = run m state in + let* s, _ = run m state in return s let get_tick = result_of ~default:Tick.initial CurrentTick.get @@ -759,7 +759,7 @@ module Make (Context : P) : let next_char = let open Monad.Syntax in LexerState.( - let* (start, len) = get in + let* start, len = get in set (start, len + 1)) let no_message_to_lex () = @@ -767,7 +767,7 @@ module Make (Context : P) : let current_char = let open Monad.Syntax in - let* (start, len) = LexerState.get in + let* start, len = LexerState.get in let* msg = NextMessage.get in match msg with | None -> no_message_to_lex () @@ -778,7 +778,7 @@ module Make (Context : P) : let lexeme = let open Monad.Syntax in - let* (start, len) = LexerState.get in + let* start, len = LexerState.get in let* msg = NextMessage.get in match msg with | None -> no_message_to_lex () diff --git a/src/proto_alpha/lib_protocol/sc_rollup_costs.ml b/src/proto_alpha/lib_protocol/sc_rollup_costs.ml index 6d03f9fc37df..cef08193861d 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_costs.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_costs.ml @@ -48,11 +48,11 @@ module Constants = struct end (* We assume that the gas cost of adding messages [[ m_1; ... ; m_n]] at level - [l] is linear in the sum of lengths of the messages, and it is logarithmic - in [l]. That is, [cost_add_messages([m_1; .. ; m_n], l)] = - `n * cost_add_message_base + - cost_add_message_per_bytes * \sum_{i=1}^n length(m_i) + - cost_add_inbox_per_level * l`. + [l] is linear in the sum of lengths of the messages, and it is logarithmic + in [l]. That is, [cost_add_messages([m_1; .. ; m_n], l)] = + `n * cost_add_message_base + + cost_add_message_per_bytes * \sum_{i=1}^n length(m_i) + + cost_add_inbox_per_level * l`. *) let cost_add_messages ~num_messages ~total_messages_size l = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml index e0df36088222..a5bcc03d1eb0 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -208,13 +208,13 @@ module Index = struct match Staker.compare a b with 1 -> (b, a) | _ -> (a, b) let staker stakers player = - let (alice, bob) = normalize stakers in + let alice, bob = normalize stakers in match player with Alice -> alice | Bob -> bob end let initial inbox ~(parent : Commitment.t) ~(child : Commitment.t) ~refuter ~defender = - let (alice, _) = Index.normalize (refuter, defender) in + let alice, _ = Index.normalize (refuter, defender) in let alice_to_play = Staker.equal alice refuter in let tick = Sc_rollup_tick_repr.of_number_of_ticks child.number_of_ticks in { @@ -420,7 +420,7 @@ let check_dissection start start_tick stop stop_tick dissection = in let* _ = match (List.hd dissection, List.last_opt dissection) with - | (Some (a, a_tick), Some (b, b_tick)) -> + | Some (a, a_tick), Some (b, b_tick) -> check (Option.equal State_hash.equal a start && (not (Option.equal State_hash.equal b stop)) @@ -455,7 +455,7 @@ let check_proof start start_tick stop stop_tick proof = let play game refutation = let result = let open Result_syntax in - let* (start, start_tick, stop, stop_tick) = + let* start, start_tick, stop, stop_tick = find_choice game refutation.choice in match refutation.step with diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml index 221117c2534a..70ec0f4122ef 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -491,7 +491,7 @@ module MakeHashingScheme (Tree : TREE) : if Raw_level_repr.(level < inbox.level) then fail (Invalid_level_add_messages level) else - let (history, inbox) = archive_if_needed history inbox level in + let history, inbox = archive_if_needed history inbox level in List.fold_left_es (fun (messages, inbox) payload -> add_message inbox payload messages >>= return) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index fb84a0575c39..e7b00869e92f 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -123,7 +123,7 @@ type outbox_message = Atomic_transaction_batch of atomic_transaction_batch let make_inbox_message ctxt ty ~payload ~sender ~source = let open Lwt_tzresult_syntax in - let+ (payload, ctxt) = + let+ payload, ctxt = Script_ir_translator.unparse_data ctxt Script_ir_translator.Optimized @@ -191,7 +191,7 @@ let transactions_batch_of_internal ctxt {transactions_internal} = let open Lwt_tzresult_syntax in let or_internal_transaction ctxt {unparsed_parameters_ty; unparsed_parameters; destination; entrypoint} = - let*? (Ex_ty parameters_ty, ctxt) = + let*? Ex_ty parameters_ty, ctxt = Script_ir_translator.parse_ty ~legacy:false ~allow_lazy_storage:false @@ -205,7 +205,7 @@ let transactions_batch_of_internal ctxt {transactions_internal} = We should rule out big-maps. [allow_forged] controls both tickets and big-maps. Here we only want to allow tickets. *) - let* (parameters, ctxt) = + let* parameters, ctxt = Script_ir_translator.parse_data ctxt ~legacy:false @@ -225,10 +225,10 @@ let transactions_batch_of_internal ctxt {transactions_internal} = }, ctxt ) in - let+ (ctxt, transactions) = + let+ ctxt, transactions = List.fold_left_map_es (fun ctxt msg -> - let+ (t, ctxt) = or_internal_transaction ctxt msg in + let+ t, ctxt = or_internal_transaction ctxt msg in (ctxt, t)) ctxt transactions_internal @@ -248,16 +248,16 @@ let outbox_message_of_bytes ctxt bytes = | Some x -> ok x | None -> error Error_decode_inbox_message in - let+ (ts, ctxt) = transactions_batch_of_internal ctxt msg in + let+ ts, ctxt = transactions_batch_of_internal ctxt msg in (Atomic_transaction_batch ts, ctxt) module Internal_for_tests = struct let make_transaction ctxt parameters_ty ~parameters ~destination ~entrypoint = let open Lwt_tzresult_syntax in - let* (unparsed_parameters, ctxt) = + let* unparsed_parameters, ctxt = Script_ir_translator.unparse_data ctxt Optimized parameters_ty parameters in - let*? (unparsed_parameters_ty, ctxt) = + let*? unparsed_parameters_ty, ctxt = Script_ir_translator.unparse_ty ctxt ~loc:Micheline.dummy_location diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml index 57d9d97de6d1..c7bade5f42a2 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml @@ -328,7 +328,7 @@ module Kind = struct let encoding = Data_encoding.union ~tag_size:`Uint16 [example_arith_case] - let equal x y = match (x, y) with (Example_arith, Example_arith) -> true + let equal x y = match (x, y) with Example_arith, Example_arith -> true let pp fmt kind = match kind with Example_arith -> Format.fprintf fmt "Example_arith" diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 4ba49deffe36..5578473ff579 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -285,7 +285,7 @@ let kind ctxt address = Store.PVM_kind.find ctxt address let last_cemented_commitment ctxt rollup = let open Lwt_tzresult_syntax in - let* (ctxt, res) = Store.Last_cemented_commitment.find ctxt rollup in + let* ctxt, res = Store.Last_cemented_commitment.find ctxt rollup in match res with | None -> fail (Sc_rollup_does_not_exist rollup) | Some lcc -> return (lcc, ctxt) @@ -293,17 +293,17 @@ let last_cemented_commitment ctxt rollup = (** Try to consume n messages. *) let consume_n_messages ctxt rollup n = let open Lwt_tzresult_syntax in - let* (ctxt, inbox) = Store.Inbox.get ctxt rollup in + let* ctxt, inbox = Store.Inbox.get ctxt rollup in Sc_rollup_inbox_repr.consume_n_messages n inbox >>?= function | None -> return ctxt | Some inbox -> - let* (ctxt, size) = Store.Inbox.update ctxt rollup inbox in + let* ctxt, size = Store.Inbox.update ctxt rollup inbox in assert (Compare.Int.(size <= 0)) ; return ctxt let inbox ctxt rollup = let open Lwt_tzresult_syntax in - let* (ctxt, res) = Store.Inbox.find ctxt rollup in + let* ctxt, res = Store.Inbox.find ctxt rollup in match res with | None -> fail (Sc_rollup_does_not_exist rollup) | Some inbox -> return (inbox, ctxt) @@ -317,8 +317,8 @@ let assert_inbox_size_ok ctxt next_size = let add_messages ctxt rollup messages = let open Lwt_tzresult_syntax in let open Raw_context in - let* (inbox, ctxt) = inbox ctxt rollup in - let* (num_messages, total_messages_size, ctxt) = + let* inbox, ctxt = inbox ctxt rollup in + let* num_messages, total_messages_size, ctxt = List.fold_left_es (fun (num_messages, total_messages_size, ctxt) message -> let*? ctxt = @@ -326,7 +326,7 @@ let add_messages ctxt rollup messages = ctxt Sc_rollup_costs.Constants.cost_update_num_and_size_of_messages in - let (num_messages, total_messages_size) = + let num_messages, total_messages_size = Internal.update_num_and_size_of_messages ~num_messages ~total_messages_size @@ -349,7 +349,7 @@ let add_messages ctxt rollup messages = (Raw_level_repr.to_int32 inbox_level) (Raw_level_repr.to_int32 origination_level) in - let*? (current_messages, ctxt) = + let*? current_messages, ctxt = Sc_rollup_in_memory_inbox.current_messages ctxt rollup in let gas_cost_add_messages = @@ -362,14 +362,14 @@ let add_messages ctxt rollup messages = history. On the contrary, the history is stored by the rollup node to produce inclusion proofs when needed. *) - let* (current_messages, inbox) = + let* current_messages, inbox = Sc_rollup_inbox_repr.( add_messages_no_history inbox level messages current_messages) in let*? ctxt = Sc_rollup_in_memory_inbox.set_current_messages ctxt rollup current_messages in - let* (ctxt, size) = Store.Inbox.update ctxt rollup inbox in + let* ctxt, size = Store.Inbox.update ctxt rollup inbox in return (inbox, Z.of_int size, ctxt) (* This function is called in other functions in the module only after they have @@ -380,7 +380,7 @@ let add_messages ctxt rollup messages = [get_commitment_internal]. *) let get_commitment_internal ctxt rollup commitment = let open Lwt_tzresult_syntax in - let* (ctxt, res) = Store.Commitments.find (ctxt, rollup) commitment in + let* ctxt, res = Store.Commitments.find (ctxt, rollup) commitment in match res with | None -> fail (Sc_rollup_unknown_commitment commitment) | Some commitment -> return (commitment, ctxt) @@ -388,26 +388,26 @@ let get_commitment_internal ctxt rollup commitment = let get_commitment ctxt rollup commitment = let open Lwt_tzresult_syntax in (* Assert that a last cemented commitment exists. *) - let* (_lcc, ctxt) = last_cemented_commitment ctxt rollup in + let* _lcc, ctxt = last_cemented_commitment ctxt rollup in get_commitment_internal ctxt rollup commitment let get_predecessor ctxt rollup node = let open Lwt_tzresult_syntax in - let* (commitment, ctxt) = get_commitment_internal ctxt rollup node in + let* commitment, ctxt = get_commitment_internal ctxt rollup node in return (commitment.predecessor, ctxt) let find_staker ctxt rollup staker = let open Lwt_tzresult_syntax in - let* (ctxt, res) = Store.Stakers.find (ctxt, rollup) staker in + let* ctxt, res = Store.Stakers.find (ctxt, rollup) staker in match res with | None -> fail Sc_rollup_not_staked | Some branch -> return (branch, ctxt) let modify_staker_count ctxt rollup f = let open Lwt_tzresult_syntax in - let* (ctxt, maybe_count) = Store.Staker_count.find ctxt rollup in + let* ctxt, maybe_count = Store.Staker_count.find ctxt rollup in let count = Option.value ~default:0l maybe_count in - let* (ctxt, size_diff, _was_bound) = + let* ctxt, size_diff, _was_bound = Store.Staker_count.add ctxt rollup (f count) in assert (Compare.Int.(size_diff = 0)) ; @@ -415,7 +415,7 @@ let modify_staker_count ctxt rollup f = let get_commitment_stake_count ctxt rollup node = let open Lwt_tzresult_syntax in - let* (ctxt, maybe_staked_on_commitment) = + let* ctxt, maybe_staked_on_commitment = Store.Commitment_stake_count.find (ctxt, rollup) node in return (Option.value ~default:0l maybe_staked_on_commitment, ctxt) @@ -426,11 +426,11 @@ let get_commitment_stake_count ctxt rollup node = *) let set_commitment_added ctxt rollup node new_value = let open Lwt_tzresult_syntax in - let* (ctxt, res) = Store.Commitment_added.find (ctxt, rollup) node in + let* ctxt, res = Store.Commitment_added.find (ctxt, rollup) node in let new_value = match res with None -> new_value | Some old_value -> old_value in - let* (ctxt, size_diff, _was_bound) = + let* ctxt, size_diff, _was_bound = Store.Commitment_added.add (ctxt, rollup) node new_value in return (size_diff, ctxt) @@ -439,36 +439,36 @@ let deallocate ctxt rollup node = let open Lwt_tzresult_syntax in if Commitment_hash.(node = zero) then return ctxt else - let* (ctxt, _size_freed) = + let* ctxt, _size_freed = Store.Commitments.remove_existing (ctxt, rollup) node in - let* (ctxt, _size_freed) = + let* ctxt, _size_freed = Store.Commitment_added.remove_existing (ctxt, rollup) node in - let* (ctxt, _size_freed) = + let* ctxt, _size_freed = Store.Commitment_stake_count.remove_existing (ctxt, rollup) node in return ctxt let modify_commitment_stake_count ctxt rollup node f = let open Lwt_tzresult_syntax in - let* (count, ctxt) = get_commitment_stake_count ctxt rollup node in + let* count, ctxt = get_commitment_stake_count ctxt rollup node in let new_count = f count in - let* (ctxt, size_diff, _was_bound) = + let* ctxt, size_diff, _was_bound = Store.Commitment_stake_count.add (ctxt, rollup) node new_count in return (new_count, size_diff, ctxt) let increase_commitment_stake_count ctxt rollup node = let open Lwt_tzresult_syntax in - let* (_new_count, size_diff, ctxt) = + let* _new_count, size_diff, ctxt = modify_commitment_stake_count ctxt rollup node Int32.succ in return (size_diff, ctxt) let decrease_commitment_stake_count ctxt rollup node = let open Lwt_tzresult_syntax in - let* (new_count, _size_diff, ctxt) = + let* new_count, _size_diff, ctxt = modify_commitment_stake_count ctxt rollup node Int32.pred in if Compare.Int32.(new_count <= 0l) then deallocate ctxt rollup node @@ -476,22 +476,22 @@ let decrease_commitment_stake_count ctxt rollup node = let deposit_stake ctxt rollup staker = let open Lwt_tzresult_syntax in - let* (lcc, ctxt) = last_cemented_commitment ctxt rollup in - let* (ctxt, res) = Store.Stakers.find (ctxt, rollup) staker in + let* lcc, ctxt = last_cemented_commitment ctxt rollup in + let* ctxt, res = Store.Stakers.find (ctxt, rollup) staker in match res with | None -> (* TODO: https://gitlab.com/tezos/tezos/-/issues/2449 We should lock stake here, and fail if there aren't enough funds. *) - let* (ctxt, _size) = Store.Stakers.init (ctxt, rollup) staker lcc in + let* ctxt, _size = Store.Stakers.init (ctxt, rollup) staker lcc in let* ctxt = modify_staker_count ctxt rollup Int32.succ in return ctxt | Some _ -> fail Sc_rollup_already_staked let withdraw_stake ctxt rollup staker = let open Lwt_tzresult_syntax in - let* (lcc, ctxt) = last_cemented_commitment ctxt rollup in - let* (ctxt, res) = Store.Stakers.find (ctxt, rollup) staker in + let* lcc, ctxt = last_cemented_commitment ctxt rollup in + let* ctxt, res = Store.Stakers.find (ctxt, rollup) staker in match res with | None -> fail Sc_rollup_not_staked | Some staked_on_commitment -> @@ -499,7 +499,7 @@ let withdraw_stake ctxt rollup staker = (* TODO: https://gitlab.com/tezos/tezos/-/issues/2449 We should refund stake here. *) - let* (ctxt, _size_freed) = + let* ctxt, _size_freed = Store.Stakers.remove_existing (ctxt, rollup) staker in modify_staker_count ctxt rollup Int32.pred @@ -507,12 +507,12 @@ let withdraw_stake ctxt rollup staker = let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment = let open Lwt_tzresult_syntax in - let* (ctxt, min_level) = + let* ctxt, min_level = if Commitment_hash.(lcc = zero) then let* level = Store.Initial_level.get ctxt rollup in return (ctxt, level) else - let* (lcc, ctxt) = get_commitment_internal ctxt rollup lcc in + let* lcc, ctxt = get_commitment_internal ctxt rollup lcc in return (ctxt, Commitment.(lcc.inbox_level)) in let max_level = Commitment.(commitment.inbox_level) in @@ -531,12 +531,12 @@ let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment = let assert_commitment_frequency ctxt rollup commitment = let open Lwt_tzresult_syntax in let pred = Commitment.(commitment.predecessor) in - let* (ctxt, pred_level) = + let* ctxt, pred_level = if Commitment_hash.(pred = zero) then let* level = Store.Initial_level.get ctxt rollup in return (ctxt, level) else - let* (pred, ctxt) = + let* pred, ctxt = get_commitment_internal ctxt rollup commitment.predecessor in return (ctxt, Commitment.(pred.inbox_level)) @@ -581,8 +581,8 @@ let assert_refine_conditions_met ctxt rollup lcc commitment = let refine_stake ctxt rollup staker commitment = let open Lwt_tzresult_syntax in - let* (lcc, ctxt) = last_cemented_commitment ctxt rollup in - let* (staked_on, ctxt) = find_staker ctxt rollup staker in + let* lcc, ctxt = last_cemented_commitment ctxt rollup in + let* staked_on, ctxt = find_staker ctxt rollup staker in let* ctxt = assert_refine_conditions_met ctxt rollup lcc commitment in let new_hash = Commitment.hash commitment in (* TODO: https://gitlab.com/tezos/tezos/-/issues/2559 @@ -594,17 +594,17 @@ let refine_stake ctxt rollup staker commitment = if Commitment_hash.(node = staked_on) then ( (* Previously staked commit found: Insert new commitment if not existing *) - let* (ctxt, commitment_size_diff, _was_bound) = + let* ctxt, commitment_size_diff, _was_bound = Store.Commitments.add (ctxt, rollup) new_hash commitment in let level = (Raw_context.current_level ctxt).level in - let* (commitment_added_size_diff, ctxt) = + let* commitment_added_size_diff, ctxt = set_commitment_added ctxt rollup new_hash level in - let* (ctxt, staker_count_diff) = + let* ctxt, staker_count_diff = Store.Stakers.update (ctxt, rollup) staker new_hash in - let* (stake_count_size_diff, ctxt) = + let* stake_count_size_diff, ctxt = increase_commitment_stake_count ctxt rollup new_hash in (* WARNING: [commitment_storage_size] is a defined constant, and used @@ -621,22 +621,23 @@ let refine_stake ctxt rollup staker commitment = (* First submission adds [sc_rollup_commitment_storage_size_in_bytes] to storage. Later submission adds 0 due to content-addressing. *) assert (Compare.Int.(size_diff = 0 || size_diff = expected_size_diff)) ; - return (new_hash, ctxt) (* See WARNING above. *)) + return (new_hash, ctxt) + (* See WARNING above. *)) else if Commitment_hash.(node = lcc) then (* We reached the LCC, but [staker] is not staked directly on it. Thus, we backtracked. Note that everyone is staked indirectly on the LCC. *) fail Sc_rollup_staker_backtracked else - let* (pred, ctxt) = get_predecessor ctxt rollup node in - let* (_size, ctxt) = increase_commitment_stake_count ctxt rollup node in + let* pred, ctxt = get_predecessor ctxt rollup node in + let* _size, ctxt = increase_commitment_stake_count ctxt rollup node in (go [@ocaml.tailcall]) pred ctxt in go Commitment.(commitment.predecessor) ctxt let publish_commitment ctxt rollup staker commitment = let open Lwt_tzresult_syntax in - let* (ctxt, res) = Store.Stakers.find (ctxt, rollup) staker in + let* ctxt, res = Store.Stakers.find (ctxt, rollup) staker in match res with | None -> let* ctxt = deposit_stake ctxt rollup staker in @@ -650,21 +651,21 @@ let cement_commitment ctxt rollup new_lcc = in (* Calling [last_final_commitment] first to trigger failure in case of non-existing rollup. *) - let* (old_lcc, ctxt) = last_cemented_commitment ctxt rollup in + let* old_lcc, ctxt = last_cemented_commitment ctxt rollup in (* Get is safe, as [Stakers_size] is initialized on origination. *) - let* (ctxt, total_staker_count) = Store.Staker_count.get ctxt rollup in + let* ctxt, total_staker_count = Store.Staker_count.get ctxt rollup in if Compare.Int32.(total_staker_count <= 0l) then fail Sc_rollup_no_stakers else - let* (new_lcc_commitment, ctxt) = + let* new_lcc_commitment, ctxt = get_commitment_internal ctxt rollup new_lcc in - let* (ctxt, new_lcc_added) = + let* ctxt, new_lcc_added = Store.Commitment_added.get (ctxt, rollup) new_lcc in if Commitment_hash.(new_lcc_commitment.predecessor <> old_lcc) then fail Sc_rollup_parent_not_lcc else - let* (new_lcc_stake_count, ctxt) = + let* new_lcc_stake_count, ctxt = get_commitment_stake_count ctxt rollup new_lcc in if Compare.Int32.(total_staker_count <> new_lcc_stake_count) then @@ -675,7 +676,7 @@ let cement_commitment ctxt rollup new_lcc = then fail Sc_rollup_too_recent else (* update LCC *) - let* (ctxt, lcc_size_diff) = + let* ctxt, lcc_size_diff = Store.Last_cemented_commitment.update ctxt rollup new_lcc in assert (Compare.Int.(lcc_size_diff = 0)) ; @@ -698,7 +699,7 @@ type conflict_point = Commitment_hash.t * Commitment_hash.t let goto_inbox_level ctxt rollup inbox_level commit = let open Lwt_tzresult_syntax in let rec go ctxt commit = - let* (info, ctxt) = get_commitment_internal ctxt rollup commit in + let* info, ctxt = get_commitment_internal ctxt rollup commit in if Raw_level_repr.(info.Commitment.inbox_level <= inbox_level) then ( (* Assert that we're exactly at that level. If this isn't the case, we're most likely in a situation where inbox levels are inconsistent. *) @@ -711,10 +712,10 @@ let goto_inbox_level ctxt rollup inbox_level commit = let get_conflict_point ctxt rollup staker1 staker2 = let open Lwt_tzresult_syntax in (* Ensure the LCC is set. *) - let* (lcc, ctxt) = last_cemented_commitment ctxt rollup in + let* lcc, ctxt = last_cemented_commitment ctxt rollup in (* Find out on which commitments the competitors are staked. *) - let* (commit1, ctxt) = find_staker ctxt rollup staker1 in - let* (commit2, ctxt) = find_staker ctxt rollup staker2 in + let* commit1, ctxt = find_staker ctxt rollup staker1 in + let* commit2, ctxt = find_staker ctxt rollup staker2 in let* () = fail_when Commitment_hash.( @@ -725,8 +726,8 @@ let get_conflict_point ctxt rollup staker1 staker2 = || commit2 = lcc) Sc_rollup_no_conflict in - let* (commit1_info, ctxt) = get_commitment_internal ctxt rollup commit1 in - let* (commit2_info, ctxt) = get_commitment_internal ctxt rollup commit2 in + let* commit1_info, ctxt = get_commitment_internal ctxt rollup commit1 in + let* commit2_info, ctxt = get_commitment_internal ctxt rollup commit2 in (* Make sure that both commits are at the same inbox level. In case they are not move the commit that is farther ahead to the exact inbox level of the other. @@ -737,10 +738,10 @@ let get_conflict_point ctxt rollup staker1 staker2 = let target_inbox_level = Raw_level_repr.min commit1_info.inbox_level commit2_info.inbox_level in - let* (commit1, ctxt) = + let* commit1, ctxt = goto_inbox_level ctxt rollup target_inbox_level commit1 in - let* (commit2, ctxt) = + let* commit2, ctxt = goto_inbox_level ctxt rollup target_inbox_level commit2 in (* The inbox level of a commitment increases by a fixed amount over the preceding commitment. @@ -753,8 +754,8 @@ let get_conflict_point ctxt rollup staker1 staker2 = enough to land at the other commit. *) fail Sc_rollup_no_conflict else - let* (commit1_info, ctxt) = get_commitment_internal ctxt rollup commit1 in - let* (commit2_info, ctxt) = get_commitment_internal ctxt rollup commit2 in + let* commit1_info, ctxt = get_commitment_internal ctxt rollup commit1 in + let* commit2_info, ctxt = get_commitment_internal ctxt rollup commit2 in assert ( Raw_level_repr.(commit1_info.inbox_level = commit2_info.inbox_level)) ; if Commitment_hash.(commit1_info.predecessor = commit2_info.predecessor) @@ -772,21 +773,21 @@ let get_conflict_point ctxt rollup staker1 staker2 = let remove_staker ctxt rollup staker = let open Lwt_tzresult_syntax in - let* (lcc, ctxt) = last_cemented_commitment ctxt rollup in - let* (ctxt, res) = Store.Stakers.find (ctxt, rollup) staker in + let* lcc, ctxt = last_cemented_commitment ctxt rollup in + let* ctxt, res = Store.Stakers.find (ctxt, rollup) staker in match res with | None -> fail Sc_rollup_not_staked | Some staked_on -> if Commitment_hash.(staked_on = lcc) then fail Sc_rollup_remove_lcc else - let* (ctxt, _size_diff) = + let* ctxt, _size_diff = Store.Stakers.remove_existing (ctxt, rollup) staker in let* ctxt = modify_staker_count ctxt rollup Int32.pred in let rec go node ctxt = if Commitment_hash.(node = lcc) then return ctxt else - let* (pred, ctxt) = get_predecessor ctxt rollup node in + let* pred, ctxt = get_predecessor ctxt rollup node in let* ctxt = decrease_commitment_stake_count ctxt rollup node in (go [@ocaml.tailcall]) pred ctxt in @@ -810,12 +811,12 @@ let get_boot_sector ctxt rollup = let last_cemented_commitment_hash_with_level ctxt rollup = let open Lwt_tzresult_syntax in - let* (commitment_hash, ctxt) = last_cemented_commitment ctxt rollup in + let* commitment_hash, ctxt = last_cemented_commitment ctxt rollup in if Commitment_hash.(commitment_hash = zero) then let+ initial_level = Storage.Sc_rollup.Initial_level.get ctxt rollup in (commitment_hash, initial_level, ctxt) else - let+ ({inbox_level; _}, ctxt) = + let+ {inbox_level; _}, ctxt = get_commitment_internal ctxt rollup commitment_hash in (commitment_hash, inbox_level, ctxt) @@ -830,41 +831,39 @@ let timeout_level ctxt = let get_or_init_game ctxt rollup ~refuter ~defender = let open Lwt_tzresult_syntax in let stakers = Sc_rollup_game_repr.Index.normalize (refuter, defender) in - let* (ctxt, game) = Store.Game.find (ctxt, rollup) stakers in + let* ctxt, game = Store.Game.find (ctxt, rollup) stakers in match game with | Some g -> return (g, ctxt) | None -> - let* (ctxt, opp_1) = Store.Opponent.find (ctxt, rollup) refuter in - let* (ctxt, opp_2) = Store.Opponent.find (ctxt, rollup) defender in + let* ctxt, opp_1 = Store.Opponent.find (ctxt, rollup) refuter in + let* ctxt, opp_2 = Store.Opponent.find (ctxt, rollup) defender in let* _ = match (opp_1, opp_2) with - | (None, None) -> return () + | None, None -> return () | _ -> fail Sc_rollup_staker_in_game in - let* ((_, child), ctxt) = - get_conflict_point ctxt rollup refuter defender - in - let* (child, ctxt) = get_commitment_internal ctxt rollup child in - let* (parent, ctxt) = + let* (_, child), ctxt = get_conflict_point ctxt rollup refuter defender in + let* child, ctxt = get_commitment_internal ctxt rollup child in + let* parent, ctxt = get_commitment_internal ctxt rollup child.predecessor in - let* (ctxt, inbox) = Store.Inbox.get ctxt rollup in + let* ctxt, inbox = Store.Inbox.get ctxt rollup in let game = Sc_rollup_game_repr.initial inbox ~parent ~child ~refuter ~defender in - let* (ctxt, _) = Store.Game.init (ctxt, rollup) stakers game in - let* (ctxt, _) = + let* ctxt, _ = Store.Game.init (ctxt, rollup) stakers game in + let* ctxt, _ = Store.Game_timeout.init (ctxt, rollup) stakers (timeout_level ctxt) in - let* (ctxt, _) = Store.Opponent.init (ctxt, rollup) refuter defender in - let* (ctxt, _) = Store.Opponent.init (ctxt, rollup) defender refuter in + let* ctxt, _ = Store.Opponent.init (ctxt, rollup) refuter defender in + let* ctxt, _ = Store.Opponent.init (ctxt, rollup) defender refuter in return (game, ctxt) (* TODO: #2926 this requires carbonation *) let update_game ctxt rollup ~player ~opponent refutation = let open Lwt_tzresult_syntax in - let (alice, bob) = Sc_rollup_game_repr.Index.normalize (player, opponent) in - let* (game, ctxt) = + let alice, bob = Sc_rollup_game_repr.Index.normalize (player, opponent) in + let* game, ctxt = get_or_init_game ctxt rollup ~refuter:player ~defender:opponent in let* _ = @@ -875,8 +874,8 @@ let update_game ctxt rollup ~player ~opponent refutation = match Sc_rollup_game_repr.play game refutation with | Either.Left outcome -> return (Some outcome, ctxt) | Either.Right new_game -> - let* (ctxt, _) = Store.Game.update (ctxt, rollup) (alice, bob) new_game in - let* (ctxt, _) = + let* ctxt, _ = Store.Game.update (ctxt, rollup) (alice, bob) new_game in + let* ctxt, _ = Store.Game_timeout.update (ctxt, rollup) (alice, bob) @@ -888,12 +887,12 @@ let update_game ctxt rollup ~player ~opponent refutation = let timeout ctxt rollup stakers = let open Lwt_tzresult_syntax in let level = (Raw_context.current_level ctxt).level in - let (alice, bob) = Sc_rollup_game_repr.Index.normalize stakers in - let* (ctxt, game) = Store.Game.find (ctxt, rollup) (alice, bob) in + let alice, bob = Sc_rollup_game_repr.Index.normalize stakers in + let* ctxt, game = Store.Game.find (ctxt, rollup) (alice, bob) in match game with | None -> fail Sc_rollup_no_game | Some game -> - let* (ctxt, timeout_level) = + let* ctxt, timeout_level = Store.Game_timeout.get (ctxt, rollup) (alice, bob) in if Raw_level_repr.(level > timeout_level) then @@ -903,11 +902,11 @@ let timeout ctxt rollup stakers = (* TODO: #2926 this requires carbonation *) let apply_outcome ctxt rollup stakers (outcome : Sc_rollup_game_repr.outcome) = let open Lwt_tzresult_syntax in - let (alice, bob) = Sc_rollup_game_repr.Index.normalize stakers in + let alice, bob = Sc_rollup_game_repr.Index.normalize stakers in let losing_staker = Sc_rollup_game_repr.Index.staker stakers outcome.loser in let* ctxt = remove_staker ctxt rollup losing_staker in - let* (ctxt, _, _) = Store.Game.remove (ctxt, rollup) (alice, bob) in - let* (ctxt, _, _) = Store.Game_timeout.remove (ctxt, rollup) (alice, bob) in - let* (ctxt, _, _) = Store.Opponent.remove (ctxt, rollup) alice in - let* (ctxt, _, _) = Store.Opponent.remove (ctxt, rollup) bob in + let* ctxt, _, _ = Store.Game.remove (ctxt, rollup) (alice, bob) in + let* ctxt, _, _ = Store.Game_timeout.remove (ctxt, rollup) (alice, bob) in + let* ctxt, _, _ = Store.Opponent.remove (ctxt, rollup) alice in + let* ctxt, _, _ = Store.Opponent.remove (ctxt, rollup) bob in return (Sc_rollup_game_repr.Ended (outcome.reason, losing_staker), ctxt) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.mli b/src/proto_alpha/lib_protocol/sc_rollup_storage.mli index cb7f1cf9ad37..6a8897842376 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.mli @@ -422,14 +422,14 @@ val initial_level : val get_boot_sector : Raw_context.t -> Sc_rollup_repr.t -> string tzresult Lwt.t (* [last_cemented_commitment_hash_with_level ctxt sc_rollup] returns the hash - and level of the last cemented commitment (lcc) for [sc_rollup]. If the - rollup exists but no lcc exists, the initial commitment - `Sc_rollup.Commitment.zero` together with the rollup origination level is - returned. - - May fail with: - {ul - {li [Sc_rollup_does_not_exist] if [rollup] does not exist}} *) + and level of the last cemented commitment (lcc) for [sc_rollup]. If the + rollup exists but no lcc exists, the initial commitment + `Sc_rollup.Commitment.zero` together with the rollup origination level is + returned. + + May fail with: + {ul + {li [Sc_rollup_does_not_exist] if [rollup] does not exist}} *) val last_cemented_commitment_hash_with_level : Raw_context.t -> Sc_rollup_repr.t -> diff --git a/src/proto_alpha/lib_protocol/script_cache.ml b/src/proto_alpha/lib_protocol/script_cache.ml index 296cf3b20f63..74ecd7973811 100644 --- a/src/proto_alpha/lib_protocol/script_cache.ml +++ b/src/proto_alpha/lib_protocol/script_cache.ml @@ -45,7 +45,7 @@ let load_and_elaborate ctxt addr = [script_size] (for efficiency). This is safe, as we already pay gas proportional to storage size in [parse_script] beforehand. *) - let (size, cost) = script_size ex_script in + let size, cost = script_size ex_script in Gas.consume ctxt cost >>?= fun ctxt -> return (ctxt, Some (script, ex_script, size))) @@ -65,14 +65,14 @@ module Client = struct *) contract_of_identifier identifier >>?= fun addr -> load_and_elaborate ctxt addr >>=? function - | (_, None) -> + | _, None -> (* [value_of_identifier ctxt k] is applied to identifiers stored in the cache. Only script-based contracts that have been executed are in the cache. Hence, [get_script] always succeeds for these identifiers if [ctxt] and the [cache] are properly synchronized by the shell. *) failwith "Script_cache: Inconsistent script cache." - | (_, Some (unparsed_script, ir_script, _)) -> + | _, Some (unparsed_script, ir_script, _) -> return (unparsed_script, ir_script) end @@ -85,8 +85,8 @@ let find ctxt addr = return (ctxt, identifier, Some (unparsed_script, ex_script)) | None -> ( load_and_elaborate ctxt addr >>=? function - | (ctxt, None) -> return (ctxt, identifier, None) - | (ctxt, Some (unparsed_script, script_ir, size)) -> + | ctxt, None -> return (ctxt, identifier, None) + | ctxt, Some (unparsed_script, script_ir, size) -> let cached_value = (unparsed_script, script_ir) in Lwt.return ( Cache.update ctxt identifier (Some (cached_value, size)) diff --git a/src/proto_alpha/lib_protocol/script_comparable.ml b/src/proto_alpha/lib_protocol/script_comparable.ml index 394285268528..d570ef9bda76 100644 --- a/src/proto_alpha/lib_protocol/script_comparable.ml +++ b/src/proto_alpha/lib_protocol/script_comparable.ml @@ -47,48 +47,46 @@ let compare_comparable : type a. a comparable_ty -> a -> a -> int = type a. a comparable_ty -> compare_comparable_cont -> a -> a -> int = fun kind k x y -> match (kind, x, y) with - | (Unit_t, (), ()) -> (apply [@tailcall]) 0 k - | (Never_t, _, _) -> . - | (Signature_t, x, y) -> - (apply [@tailcall]) (Script_signature.compare x y) k - | (String_t, x, y) -> (apply [@tailcall]) (Script_string.compare x y) k - | (Bool_t, x, y) -> (apply [@tailcall]) (Compare.Bool.compare x y) k - | (Mutez_t, x, y) -> (apply [@tailcall]) (Tez.compare x y) k - | (Key_hash_t, x, y) -> + | Unit_t, (), () -> (apply [@tailcall]) 0 k + | Never_t, _, _ -> . + | Signature_t, x, y -> (apply [@tailcall]) (Script_signature.compare x y) k + | String_t, x, y -> (apply [@tailcall]) (Script_string.compare x y) k + | Bool_t, x, y -> (apply [@tailcall]) (Compare.Bool.compare x y) k + | Mutez_t, x, y -> (apply [@tailcall]) (Tez.compare x y) k + | Key_hash_t, x, y -> (apply [@tailcall]) (Signature.Public_key_hash.compare x y) k - | (Key_t, x, y) -> (apply [@tailcall]) (Signature.Public_key.compare x y) k - | (Int_t, x, y) -> (apply [@tailcall]) (Script_int.compare x y) k - | (Nat_t, x, y) -> (apply [@tailcall]) (Script_int.compare x y) k - | (Timestamp_t, x, y) -> - (apply [@tailcall]) (Script_timestamp.compare x y) k - | (Address_t, x, y) -> (apply [@tailcall]) (compare_address x y) k - | (Tx_rollup_l2_address_t, x, y) -> + | Key_t, x, y -> (apply [@tailcall]) (Signature.Public_key.compare x y) k + | Int_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k + | Nat_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k + | Timestamp_t, x, y -> (apply [@tailcall]) (Script_timestamp.compare x y) k + | Address_t, x, y -> (apply [@tailcall]) (compare_address x y) k + | Tx_rollup_l2_address_t, x, y -> (apply [@tailcall]) (compare_tx_rollup_l2_address x y) k - | (Bytes_t, x, y) -> (apply [@tailcall]) (Compare.Bytes.compare x y) k - | (Chain_id_t, x, y) -> (apply [@tailcall]) (Script_chain_id.compare x y) k - | (Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry)) -> + | Bytes_t, x, y -> (apply [@tailcall]) (Compare.Bytes.compare x y) k + | Chain_id_t, x, y -> (apply [@tailcall]) (Script_chain_id.compare x y) k + | Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry) -> (compare_comparable [@tailcall]) tl (Compare_comparable (tr, rx, ry, k)) lx ly - | (Union_t (tl, _, _, YesYes), L x, L y) -> + | Union_t (tl, _, _, YesYes), L x, L y -> (compare_comparable [@tailcall]) tl k x y - | (Union_t _, L _, R _) -> -1 - | (Union_t _, R _, L _) -> 1 - | (Union_t (_, tr, _, YesYes), R x, R y) -> + | Union_t _, L _, R _ -> -1 + | Union_t _, R _, L _ -> 1 + | Union_t (_, tr, _, YesYes), R x, R y -> (compare_comparable [@tailcall]) tr k x y - | (Option_t _, None, None) -> (apply [@tailcall]) 0 k - | (Option_t _, None, Some _) -> -1 - | (Option_t _, Some _, None) -> 1 - | (Option_t (t, _, Yes), Some x, Some y) -> + | Option_t _, None, None -> (apply [@tailcall]) 0 k + | Option_t _, None, Some _ -> -1 + | Option_t _, Some _, None -> 1 + | Option_t (t, _, Yes), Some x, Some y -> (compare_comparable [@tailcall]) t k x y and apply ret k = match (ret, k) with - | (0, Compare_comparable (ty, x, y, k)) -> + | 0, Compare_comparable (ty, x, y, k) -> (compare_comparable [@tailcall]) ty k x y - | (0, Compare_comparable_return) -> 0 - | (ret, _) -> + | 0, Compare_comparable_return -> 0 + | ret, _ -> (* ret <> 0, we perform an early exit *) if Compare.Int.(ret > 0) then 1 else -1 in diff --git a/src/proto_alpha/lib_protocol/script_int.ml b/src/proto_alpha/lib_protocol/script_int.ml index fba40417adb4..a2ef0ebc257e 100644 --- a/src/proto_alpha/lib_protocol/script_int.ml +++ b/src/proto_alpha/lib_protocol/script_int.ml @@ -71,7 +71,7 @@ let mul (Num_tag x) (Num_tag y) = Num_tag (Z.mul x y) let ediv (Num_tag x) (Num_tag y) = let ediv_tagged x y = - let (quo, rem) = Z.ediv_rem x y in + let quo, rem = Z.ediv_rem x y in (Num_tag quo, Num_tag rem) in Option.catch (fun () -> ediv_tagged x y) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 0b837ff570ac..699b0d304607 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -253,7 +253,7 @@ let rec kmap_exit : fun mk g gas (body, xs, ys, yk) ks accu stack -> let ys = Script_map.update yk (Some accu) ys in let ks = mk (KMap_enter_body (body, xs, ys, ks)) in - let (accu, stack) = stack in + let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] @@ -271,7 +271,7 @@ and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = and klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = fun mk g gas (body, xs, ys, len) ks accu stack -> let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in - let (accu, stack) = stack in + let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] @@ -296,7 +296,7 @@ and kloop_in_left : type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = fun g gas ks0 ki ks' accu stack -> - let (accu', stack') = stack in + let accu', stack' = stack in if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' else (next [@ocaml.tailcall]) g gas ks' accu' stack' [@@inline] @@ -374,7 +374,7 @@ and ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = let ks = log_if_needed (KList_enter_body (body, xs, ys, len, KCons (k, ks))) in - let (accu, stack) = stack in + let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] @@ -382,7 +382,7 @@ and ilist_iter : type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let xs = accu.elements in let ks = log_if_needed (KIter (body, xs, KCons (k, ks))) in - let (accu, stack) = stack in + let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] @@ -391,7 +391,7 @@ and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = let set = accu in let l = List.rev (Script_set.fold (fun e acc -> e :: acc) set []) in let ks = log_if_needed (KIter (body, l, KCons (k, ks))) in - let (accu, stack) = stack in + let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] @@ -402,7 +402,7 @@ and imap_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type let xs = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in let ys = Script_map.empty_from map in let ks = log_if_needed (KMap_enter_body (body, xs, ys, KCons (k, ks))) in - let (accu, stack) = stack in + let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] @@ -411,14 +411,14 @@ and imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = let map = accu in let l = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in let ks = log_if_needed (KIter (body, l, KCons (k, ks))) in - let (accu, stack) = stack in + let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = fun logger g gas (kinfo, k) ks accu stack -> let x = accu in - let (y, stack) = stack in + let y, stack = stack in match Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some y -> @@ -427,7 +427,7 @@ and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = fun logger g gas (kinfo, k) ks accu stack -> let y = accu in - let (x, stack) = stack in + let x, stack = stack in match Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some y -> @@ -435,14 +435,14 @@ and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = fun logger g gas (kinfo, k) ks accu stack -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in match Script_int.shift_left_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = fun logger g gas (kinfo, k) ks accu stack -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in match Script_int.shift_right_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack @@ -461,7 +461,7 @@ and ifailwith : ifailwith_type = and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun logger g gas k ks accu stack -> - let arg = accu and (code, stack) = stack in + let arg = accu and code, stack = stack in let (Lam (code, _)) = code in let code = match logger with @@ -482,11 +482,11 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | IHalt _ -> (next [@ocaml.tailcall]) g gas ks accu stack (* stack ops *) | IDrop (_, k) -> - let (accu, stack) = stack in + let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack | IDup (_, k) -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) | ISwap (_, k) -> - let (top, stack) = stack in + let top, stack = stack in (step [@ocaml.tailcall]) g gas k ks top (accu, stack) | IConst (_, v, k) -> (step [@ocaml.tailcall]) g gas k ks v (accu, stack) (* options *) @@ -497,7 +497,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | IIf_none {branch_if_none; branch_if_some; k; _} -> ( match accu with | None -> - let (accu, stack) = stack in + let accu, stack = stack in (step [@ocaml.tailcall]) g gas @@ -521,16 +521,16 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) g gas body ks' v stack) (* pairs *) | ICons_pair (_, k) -> - let (b, stack) = stack in + let b, stack = stack in (step [@ocaml.tailcall]) g gas k ks (accu, b) stack | IUnpair (_, k) -> - let (a, b) = accu in + let a, b = accu in (step [@ocaml.tailcall]) g gas k ks a (b, stack) | ICar (_, k) -> - let (a, _) = accu in + let a, _ = accu in (step [@ocaml.tailcall]) g gas k ks a stack | ICdr (_, k) -> - let (_, b) = accu in + let _, b = accu in (step [@ocaml.tailcall]) g gas k ks b stack (* unions *) | ICons_left (_, k) -> (step [@ocaml.tailcall]) g gas k ks (L accu) stack @@ -555,7 +555,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = stack) (* lists *) | ICons_list (_, k) -> - let (tl, stack) = stack in + let tl, stack = stack in let accu = Script_list.cons accu tl in (step [@ocaml.tailcall]) g gas k ks accu stack | INil (_, k) -> @@ -565,7 +565,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | IIf_cons {branch_if_cons; branch_if_nil; k; _} -> ( match accu.elements with | [] -> - let (accu, stack) = stack in + let accu, stack = stack in (step [@ocaml.tailcall]) g gas @@ -598,11 +598,11 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | ISet_iter (_, body, k) -> (iset_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack | ISet_mem (_, k) -> - let (set, stack) = stack in + let set, stack = stack in let res = Script_set.mem accu set in (step [@ocaml.tailcall]) g gas k ks res stack | ISet_update (_, k) -> - let (presence, (set, stack)) = stack in + let presence, (set, stack) = stack in let res = Script_set.update accu presence set in (step [@ocaml.tailcall]) g gas k ks res stack | ISet_size (_, k) -> @@ -617,21 +617,21 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | IMap_iter (_, body, k) -> (imap_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack | IMap_mem (_, k) -> - let (map, stack) = stack in + let map, stack = stack in let res = Script_map.mem accu map in (step [@ocaml.tailcall]) g gas k ks res stack | IMap_get (_, k) -> - let (map, stack) = stack in + let map, stack = stack in let res = Script_map.get accu map in (step [@ocaml.tailcall]) g gas k ks res stack | IMap_update (_, k) -> - let (v, (map, stack)) = stack in + let v, (map, stack) = stack in let key = accu in let res = Script_map.update key v map in (step [@ocaml.tailcall]) g gas k ks res stack | IMap_get_and_update (_, k) -> let key = accu in - let (v, (map, rest)) = stack in + let v, (map, rest) = stack in let map' = Script_map.update key v map in let v' = Script_map.get key map in (step [@ocaml.tailcall]) g gas k ks v' (map', rest) @@ -643,14 +643,14 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let ebm = Script_ir_translator.empty_big_map tk tv in (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack) | IBig_map_mem (_, k) -> - let (map, stack) = stack in + let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_mem ctxt key map ) >>=? fun (res, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack | IBig_map_get (_, k) -> - let (map, stack) = stack in + let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_get ctxt key map ) @@ -658,14 +658,14 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack | IBig_map_update (_, k) -> let key = accu in - let (maybe_value, (map, stack)) = stack in + let maybe_value, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_update ctxt key maybe_value map ) >>=? fun (big_map, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks big_map stack | IBig_map_get_and_update (_, k) -> let key = accu in - let (v, (map, stack)) = stack in + let v, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_get_and_update ctxt key v map ) >>=? fun ((v', map'), ctxt, gas) -> @@ -673,28 +673,28 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (* timestamp operations *) | IAdd_seconds_to_timestamp (_, k) -> let n = accu in - let (t, stack) = stack in + let t, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack | IAdd_timestamp_to_seconds (_, k) -> let t = accu in - let (n, stack) = stack in + let n, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack | ISub_timestamp_seconds (_, k) -> let t = accu in - let (s, stack) = stack in + let s, stack = stack in let result = Script_timestamp.sub_delta t s in (step [@ocaml.tailcall]) g gas k ks result stack | IDiff_timestamps (_, k) -> let t1 = accu in - let (t2, stack) = stack in + let t2, stack = stack in let result = Script_timestamp.diff t1 t2 in (step [@ocaml.tailcall]) g gas k ks result stack (* string operations *) | IConcat_string_pair (_, k) -> let x = accu in - let (y, stack) = stack in + let y, stack = stack in let s = Script_string.concat_pair x y in (step [@ocaml.tailcall]) g gas k ks s stack | IConcat_string (_, k) -> @@ -710,7 +710,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let s = Script_string.concat ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack | ISlice_string (_, k) -> - let offset = accu and (length, (s, stack)) = stack in + let offset = accu and length, (s, stack) = stack in let s_length = Z.of_int (Script_string.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -726,7 +726,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (* bytes operations *) | IConcat_bytes_pair (_, k) -> let x = accu in - let (y, stack) = stack in + let y, stack = stack in let s = Bytes.cat x y in (step [@ocaml.tailcall]) g gas k ks s stack | IConcat_bytes (_, k) -> @@ -742,7 +742,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let s = Bytes.concat Bytes.empty ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack | ISlice_bytes (_, k) -> - let offset = accu and (length, (s, stack)) = stack in + let offset = accu and length, (s, stack) = stack in let s_length = Z.of_int (Bytes.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -758,17 +758,17 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (* currency operations *) | IAdd_tez (_, k) -> let x = accu in - let (y, stack) = stack in + let y, stack = stack in Tez.(x +? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack | ISub_tez (_, k) -> let x = accu in - let (y, stack) = stack in + let y, stack = stack in let res = Tez.sub_opt x y in (step [@ocaml.tailcall]) g gas k ks res stack | ISub_tez_legacy (_, k) -> let x = accu in - let (y, stack) = stack in + let y, stack = stack in Tez.(x -? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack | IMul_teznat (kinfo, k) -> @@ -778,15 +778,15 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (* boolean operations *) | IOr (_, k) -> let x = accu in - let (y, stack) = stack in + let y, stack = stack in (step [@ocaml.tailcall]) g gas k ks (x || y) stack | IAnd (_, k) -> let x = accu in - let (y, stack) = stack in + let y, stack = stack in (step [@ocaml.tailcall]) g gas k ks (x && y) stack | IXor (_, k) -> let x = accu in - let (y, stack) = stack in + let y, stack = stack in let res = Compare.Bool.(x <> y) in (step [@ocaml.tailcall]) g gas k ks res stack | INot (_, k) -> @@ -810,36 +810,36 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let res = Script_int.neg x in (step [@ocaml.tailcall]) g gas k ks res stack | IAdd_int (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.add x y in (step [@ocaml.tailcall]) g gas k ks res stack | IAdd_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.add_n x y in (step [@ocaml.tailcall]) g gas k ks res stack | ISub_int (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.sub x y in (step [@ocaml.tailcall]) g gas k ks res stack | IMul_int (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack | IMul_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.mul_n x y in (step [@ocaml.tailcall]) g gas k ks res stack | IEdiv_teznat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let x = Script_int.of_int64 (Tez.to_mutez x) in let result = match Script_int.ediv x y with | None -> None | Some (q, r) -> ( match (Script_int.to_int64 q, Script_int.to_int64 r) with - | (Some q, Some r) -> ( + | Some q, Some r -> ( match (Tez.of_mutez q, Tez.of_mutez r) with - | (Some q, Some r) -> Some (q, r) + | Some q, Some r -> Some (q, r) (* Cannot overflow *) | _ -> assert false) (* Cannot overflow *) @@ -847,7 +847,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks result stack | IEdiv_tez (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in let result = @@ -863,29 +863,29 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks result stack | IEdiv_int (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.ediv x y in (step [@ocaml.tailcall]) g gas k ks res stack | IEdiv_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.ediv_n x y in (step [@ocaml.tailcall]) g gas k ks res stack | ILsl_nat (kinfo, k) -> ilsl_nat None g gas (kinfo, k) ks accu stack | ILsr_nat (kinfo, k) -> ilsr_nat None g gas (kinfo, k) ks accu stack | IOr_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.logor x y in (step [@ocaml.tailcall]) g gas k ks res stack | IAnd_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack | IAnd_int_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack | IXor_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let res = Script_int.logxor x y in (step [@ocaml.tailcall]) g gas k ks res stack | INot_int (_, k) -> @@ -894,7 +894,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) g gas k ks res stack (* control *) | IIf {branch_if_true; branch_if_false; k; _} -> - let (res, stack) = stack in + let res, stack = stack in if accu then (step [@ocaml.tailcall]) g @@ -920,12 +920,12 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | IDip (_, b, k) -> let ign = accu in let ks = KUndip (ign, KCons (k, ks)) in - let (accu, stack) = stack in + let accu, stack = stack in (step [@ocaml.tailcall]) g gas b ks accu stack | IExec (_, k) -> iexec None g gas k ks accu stack | IApply (_, capture_ty, k) -> let capture = accu in - let (lam, stack) = stack in + let lam, stack = stack in apply ctxt gas capture_ty capture lam >>=? fun (lam', ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack | ILambda (_, lam, k) -> @@ -936,7 +936,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (* comparison *) | ICompare (_, ty, k) -> let a = accu in - let (b, stack) = stack in + let b, stack = stack in let r = Script_int.of_int @@ Script_comparable.compare_comparable ty a b in @@ -1005,13 +1005,13 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = addr.destination ~entrypoint >>=? fun (ctxt, maybe_contract) -> - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let accu = maybe_contract in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) | ITransfer_tokens (kinfo, k) -> let p = accu in - let (amount, (Typed_contract {arg_ty; address}, stack)) = stack in + let amount, (Typed_contract {arg_ty; address}, stack) = stack in let {destination; entrypoint} = address in transfer (ctxt, sc) @@ -1037,11 +1037,11 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) g gas k ks res stack | IView (_, View_signature {name; input_ty; output_ty}, k) -> ( let input = accu in - let (addr, stack) = stack in + let addr, stack = stack in let c = addr.destination in let ctxt = update_context gas ctxt in let return_none ctxt = - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack in match c with @@ -1105,7 +1105,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let ks = KCons (ICons_some (kkinfo, k), ks) in Contract.get_balance_carbonated ctxt c >>=? fun (ctxt, balance) -> - let (gas, ctxt) = + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) @@ -1132,7 +1132,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | ICreate_contract {storage_type; code; k; kinfo = _} -> (* Removed the instruction's arguments manager, spendable and delegatable *) let delegate = accu in - let (credit, (init, stack)) = stack in + let credit, (init, stack) = stack in create_contract g gas storage_type code delegate credit init >>=? fun (res, contract, ctxt, gas) -> let stack = @@ -1147,11 +1147,11 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let piop = Internal_operation {source = sc.self; operation; nonce} in let res = {piop; lazy_storage_diff = None} in - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack | IBalance (_, k) -> let ctxt = update_context gas ctxt in - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks sc.balance (accu, stack) | ILevel (_, k) -> @@ -1168,7 +1168,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let new_stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack | ICheck_signature (_, k) -> - let key = accu and (signature, (message, stack)) = stack in + let key = accu and signature, (message, stack) = stack in let res = Script_signature.check key signature message in (step [@ocaml.tailcall]) g gas k ks res stack | IHash_key (_, k) -> @@ -1208,7 +1208,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let accu = sc.amount and stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks accu stack | IDig (_, _n, n', k) -> - let ((accu, stack), x) = + let (accu, stack), x = interp_stack_prefix_preserving_operation (fun v stack -> (stack, v)) n' @@ -1219,8 +1219,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) g gas k ks accu stack | IDug (_, _n, n', k) -> let v = accu in - let (accu, stack) = stack in - let ((accu, stack), ()) = + let accu, stack = stack in + let (accu, stack), () = interp_stack_prefix_preserving_operation (fun accu stack -> ((v, (accu, stack)), ())) n' @@ -1229,7 +1229,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks accu stack | IDipn (_, _n, n', b, k) -> - let (accu, stack, restore_prefix) = kundip n' accu stack k in + let accu, stack, restore_prefix = kundip n' accu stack k in let ks = KCons (restore_prefix, ks) in (step [@ocaml.tailcall]) g gas b ks accu stack | IDropn (_, _n, n', k) -> @@ -1244,19 +1244,19 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = match w with | KRest -> (accu, stack) | KPrefix (_, w) -> - let (accu, stack) = stack in + let accu, stack = stack in aux w accu stack in aux n' accu stack in - let (accu, stack) = stack in + let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack | ISapling_empty_state (_, memo_size, k) -> let state = Sapling.empty_state ~memo_size () in (step [@ocaml.tailcall]) g gas k ks state (accu, stack) | ISapling_verify_update (_, k) -> ( let transaction = accu in - let (state, stack) = stack in + let state, stack = stack in let address = Contract.to_b58check sc.self in let sc_chain_id = Script_chain_id.make sc.chain_id in let chain_id = Script_chain_id.to_b58check sc_chain_id in @@ -1264,7 +1264,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let ctxt = update_context gas ctxt in Sapling.verify_update ctxt state transaction anti_replay >>=? fun (ctxt, balance_state_opt) -> - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in match balance_state_opt with | Some (balance, state) -> let state = @@ -1276,7 +1276,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) | ISapling_verify_update_deprecated (_, k) -> ( let transaction = accu in - let (state, stack) = stack in + let state, stack = stack in let address = Contract.to_b58check sc.self in let sc_chain_id = Script_chain_id.make sc.chain_id in let chain_id = Script_chain_id.to_b58check sc_chain_id in @@ -1284,7 +1284,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let ctxt = update_context gas ctxt in Sapling.Legacy.verify_update ctxt state transaction anti_replay >>=? fun (ctxt, balance_state_opt) -> - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in match balance_state_opt with | Some (balance, state) -> let state = Some (Script_int.of_int64 balance, state) in @@ -1300,13 +1300,13 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let ctxt = update_context gas ctxt in Vote.get_voting_power ctxt key_hash >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks power stack | ITotal_voting_power (_, k) -> let ctxt = update_context gas ctxt in Vote.get_total_voting_power ctxt >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks power (accu, stack) | IKeccak (_, k) -> @@ -1318,36 +1318,36 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let hash = Raw_hashes.sha3_256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack | IAdd_bls12_381_g1 (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let accu = Script_bls.G1.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IAdd_bls12_381_g2 (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let accu = Script_bls.G2.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IAdd_bls12_381_fr (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let accu = Script_bls.Fr.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IMul_bls12_381_g1 (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let accu = Script_bls.G1.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IMul_bls12_381_g2 (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let accu = Script_bls.G2.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IMul_bls12_381_fr (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let accu = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IMul_bls12_381_fr_z (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu and y, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack | IMul_bls12_381_z_fr (_, k) -> - let y = accu and (x, stack) = stack in + let y = accu and x, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack @@ -1377,13 +1377,13 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (before, after) comb_gadt_witness -> before -> after = fun witness stack -> match (witness, stack) with - | (Comb_one, stack) -> stack - | (Comb_succ witness', (a, tl)) -> - let (b, tl') = aux witness' tl in + | Comb_one, stack -> stack + | Comb_succ witness', (a, tl) -> + let b, tl' = aux witness' tl in ((a, b), tl') in let stack = aux witness (accu, stack) in - let (accu, stack) = stack in + let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack | IUncomb (_, _, witness, k) -> let rec aux : @@ -1391,11 +1391,11 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (before, after) uncomb_gadt_witness -> before -> after = fun witness stack -> match (witness, stack) with - | (Uncomb_one, stack) -> stack - | (Uncomb_succ witness', ((a, b), tl)) -> (a, aux witness' (b, tl)) + | Uncomb_one, stack -> stack + | Uncomb_succ witness', ((a, b), tl) -> (a, aux witness' (b, tl)) in let stack = aux witness (accu, stack) in - let (accu, stack) = stack in + let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack | IComb_get (_, _, witness, k) -> let comb = accu in @@ -1404,14 +1404,14 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (before, after) comb_get_gadt_witness -> before -> after = fun witness comb -> match (witness, comb) with - | (Comb_get_zero, v) -> v - | (Comb_get_one, (a, _)) -> a - | (Comb_get_plus_two witness', (_, b)) -> aux witness' b + | Comb_get_zero, v -> v + | Comb_get_one, (a, _) -> a + | Comb_get_plus_two witness', (_, b) -> aux witness' b in let accu = aux witness comb in (step [@ocaml.tailcall]) g gas k ks accu stack | IComb_set (_, _, witness, k) -> - let value = accu and (comb, stack) = stack in + let value = accu and comb, stack = stack in let rec aux : type value before after. (value, before, after) comb_set_gadt_witness -> @@ -1420,10 +1420,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = after = fun witness value item -> match (witness, item) with - | (Comb_set_zero, _) -> value - | (Comb_set_one, (_hd, tl)) -> (value, tl) - | (Comb_set_plus_two witness', (hd, tl)) -> - (hd, aux witness' value tl) + | Comb_set_zero, _ -> value + | Comb_set_one, (_hd, tl) -> (value, tl) + | Comb_set_plus_two witness', (hd, tl) -> (hd, aux witness' value tl) in let accu = aux witness value comb in (step [@ocaml.tailcall]) g gas k ks accu stack @@ -1433,15 +1432,15 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (before, after) dup_n_gadt_witness -> before -> after = fun witness stack -> match (witness, stack) with - | (Dup_n_zero, (a, _)) -> a - | (Dup_n_succ witness', (_, tl)) -> aux witness' tl + | Dup_n_zero, (a, _) -> a + | Dup_n_succ witness', (_, tl) -> aux witness' tl in let stack = (accu, stack) in let accu = aux witness stack in (step [@ocaml.tailcall]) g gas k ks accu stack (* Tickets *) | ITicket (_, k) -> - let contents = accu and (amount, stack) = stack in + let contents = accu and amount, stack = stack in let ticketer = sc.self in let accu = {ticketer; contents; amount} in (step [@ocaml.tailcall]) g gas k ks accu stack @@ -1453,7 +1452,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let accu = (addr, (contents, amount)) in (step [@ocaml.tailcall]) g gas k ks accu stack | ISplit_ticket (_, k) -> - let ticket = accu and ((amount_a, amount_b), stack) = stack in + let ticket = accu and (amount_a, amount_b), stack = stack in let result = if Compare.Int.( @@ -1466,7 +1465,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks result stack | IJoin_tickets (_, contents_ty, k) -> - let (ticket_a, ticket_b) = accu in + let ticket_a, ticket_b = accu in let result = if Compare.Int.( @@ -1489,7 +1488,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | IOpen_chest (_, k) -> let open Timelock in let chest_key = accu in - let (chest, (time_z, stack)) = stack in + let chest, (time_z, stack) = stack in (* If the time is not an integer we then consider the proof as incorrect. Indeed the verification asks for an integer for practical reasons. Therefore no proof can be correct.*) @@ -1532,9 +1531,9 @@ and log : type a s b t r f. logger * logging_event -> (a, s, b, t, r, f) step_type = fun (logger, event) ((ctxt, _) as g) gas k ks accu stack -> (match (k, event) with - | (ILog _, LogEntry) -> () - | (_, LogEntry) -> log_entry logger ctxt gas k accu stack - | (_, LogExit prev_kinfo) -> log_exit logger ctxt gas prev_kinfo k accu stack) ; + | ILog _, LogEntry -> () + | _, LogEntry -> log_entry logger ctxt gas k accu stack + | _, LogExit prev_kinfo -> log_exit logger ctxt gas prev_kinfo k accu stack) ; let k = log_next_kinstr logger k in let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in match k with @@ -1645,7 +1644,7 @@ and klog : *) let step_descr ~log_now logger (ctxt, sc) descr accu stack = - let (gas, outdated_ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, outdated_ctxt = local_gas_counter_and_outdated_context ctxt in (match logger with | None -> step (outdated_ctxt, sc) gas descr.kinstr KNil accu stack | Some logger -> @@ -1669,7 +1668,7 @@ let kstep logger ctxt step_constants kinstr accu stack = | None -> kinstr | Some logger -> ILog (kinfo_of_kinstr kinstr, LogEntry, logger, kinstr) in - let (gas, outdated_ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, outdated_ctxt = local_gas_counter_and_outdated_context ctxt in step (outdated_ctxt, step_constants) gas kinstr KNil accu stack >>=? fun (accu, stack, ctxt, gas) -> return (accu, stack, update_context gas ctxt) @@ -1778,7 +1777,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal ) >>=? fun (unparsed_storage, ctxt) -> let op_to_couple op = (op.piop, op.lazy_storage_diff) in - let (operations, op_diffs) = + let operations, op_diffs = ops.elements |> List.map op_to_couple |> List.split in let lazy_storage_diff_all = @@ -1812,7 +1811,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal [script_size] (for efficiency). This is safe, as we already pay gas proportional to storage size in [unparse_data]. *) - let (size, cost) = Script_ir_translator.script_size script in + let size, cost = Script_ir_translator.script_size script in Gas.consume ctxt cost >>?= fun ctxt -> return ( { diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 1fe15e6e01cd..44c0f255b918 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -84,10 +84,10 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = let set = accu in Interp_costs.set_iter set | ISet_mem _ -> - let v = accu and (set, _) = stack in + let v = accu and set, _ = stack in Interp_costs.set_mem v set | ISet_update _ -> - let v = accu and (_, (set, _)) = stack in + let v = accu and _, (set, _) = stack in Interp_costs.set_update v set | IMap_map _ -> let map = accu in @@ -96,59 +96,59 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = let map = accu in Interp_costs.map_iter map | IMap_mem _ -> - let v = accu and (map, _) = stack in + let v = accu and map, _ = stack in Interp_costs.map_mem v map | IMap_get _ -> - let v = accu and (map, _) = stack in + let v = accu and map, _ = stack in Interp_costs.map_get v map | IMap_update _ -> - let k = accu and (_, (map, _)) = stack in + let k = accu and _, (map, _) = stack in Interp_costs.map_update k map | IMap_get_and_update _ -> - let k = accu and (_, (map, _)) = stack in + let k = accu and _, (map, _) = stack in Interp_costs.map_get_and_update k map | IBig_map_mem _ -> - let (Big_map map, _) = stack in + let Big_map map, _ = stack in Interp_costs.big_map_mem map.diff | IBig_map_get _ -> - let (Big_map map, _) = stack in + let Big_map map, _ = stack in Interp_costs.big_map_get map.diff | IBig_map_update _ -> - let (_, (Big_map map, _)) = stack in + let _, (Big_map map, _) = stack in Interp_costs.big_map_update map.diff | IBig_map_get_and_update _ -> - let (_, (Big_map map, _)) = stack in + let _, (Big_map map, _) = stack in Interp_costs.big_map_get_and_update map.diff | IAdd_seconds_to_timestamp _ -> - let n = accu and (t, _) = stack in + let n = accu and t, _ = stack in Interp_costs.add_seconds_timestamp n t | IAdd_timestamp_to_seconds _ -> - let t = accu and (n, _) = stack in + let t = accu and n, _ = stack in Interp_costs.add_timestamp_seconds t n | ISub_timestamp_seconds _ -> - let t = accu and (n, _) = stack in + let t = accu and n, _ = stack in Interp_costs.sub_timestamp_seconds t n | IDiff_timestamps _ -> - let t1 = accu and (t2, _) = stack in + let t1 = accu and t2, _ = stack in Interp_costs.diff_timestamps t1 t2 | IConcat_string_pair _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.concat_string_pair x y | IConcat_string _ -> let ss = accu in Interp_costs.concat_string_precheck ss | ISlice_string _ -> let _offset = accu in - let (_length, (s, _)) = stack in + let _length, (s, _) = stack in Interp_costs.slice_string s | IConcat_bytes_pair _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.concat_bytes_pair x y | IConcat_bytes _ -> let ss = accu in Interp_costs.concat_string_precheck ss | ISlice_bytes _ -> - let (_, (s, _)) = stack in + let _, (s, _) = stack in Interp_costs.slice_bytes s | IMul_teznat _ -> Interp_costs.mul_teznat | IMul_nattez _ -> Interp_costs.mul_nattez @@ -159,28 +159,28 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = let x = accu in Interp_costs.neg x | IAdd_int _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.add_int x y | IAdd_nat _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.add_nat x y | ISub_int _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.sub_int x y | IMul_int _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.mul_int x y | IMul_nat _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.mul_nat x y | IEdiv_teznat _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.ediv_teznat x y | IEdiv_int _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.ediv_int x y | IEdiv_nat _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.ediv_nat x y | ILsl_nat _ -> let x = accu in @@ -189,25 +189,25 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = let x = accu in Interp_costs.lsr_nat x | IOr_nat _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.or_nat x y | IAnd_nat _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.and_nat x y | IAnd_int_nat _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.and_int_nat x y | IXor_nat _ -> - let x = accu and (y, _) = stack in + let x = accu and y, _ = stack in Interp_costs.xor_nat x y | INot_int _ -> let x = accu in Interp_costs.not_int x | ICompare (_, ty, _) -> - let a = accu and (b, _) = stack in + let a = accu and b, _ = stack in Interp_costs.compare ty a b | ICheck_signature _ -> - let key = accu and (_, (message, _)) = stack in + let key = accu and _, (message, _) = stack in Interp_costs.check_signature key message | IHash_key _ -> let pk = accu in @@ -242,10 +242,10 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = let outputs = List.length tx.outputs in Interp_costs.sapling_verify_update_deprecated ~inputs ~outputs | ISplit_ticket _ -> - let ticket = accu and ((amount_a, amount_b), _) = stack in + let ticket = accu and (amount_a, amount_b), _ = stack in Interp_costs.split_ticket ticket.amount amount_a amount_b | IJoin_tickets (_, ty, _) -> - let (ticket_a, ticket_b) = accu in + let ticket_a, ticket_b = accu in Interp_costs.join_tickets ty ticket_a ticket_b | IHalt _ -> Interp_costs.halt | IDrop _ -> Interp_costs.drop @@ -341,7 +341,7 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = let z = accu in Interp_costs.mul_bls12_381_fr_z z | IMul_bls12_381_z_fr _ -> - let (z, _) = stack in + let z, _ = stack in Interp_costs.mul_bls12_381_z_fr z | IDup_n (_, n, _, _) -> Interp_costs.dupn n | IComb (_, n, _, _) -> Interp_costs.comb n @@ -351,7 +351,7 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = | ITicket _ -> Interp_costs.ticket | IRead_ticket _ -> Interp_costs.read_ticket | IOpen_chest _ -> - let _chest_key = accu and (chest, (time, _)) = stack in + let _chest_key = accu and chest, (time, _) = stack in Interp_costs.open_chest ~chest ~time:(Script_int.to_zint time) | ILog _ -> Gas.free [@@ocaml.inline always] @@ -437,7 +437,6 @@ let log_kinstr logger i = ILog (kinfo_of_kinstr i, LogEntry, logger, i) non-instrumented code. "Zero-cost logging" means that the normal non-instrumented execution is not impacted by the ability to instrument it, not that the logging itself has no cost. - *) let log_next_kinstr logger i = let apply k = @@ -472,7 +471,7 @@ let rec kundip : match w with | KPrefix (kinfo, w) -> let k = IConst (kinfo, accu, k) in - let (accu, stack) = stack in + let accu, stack = stack in kundip w accu stack k | KRest -> (accu, stack, k) @@ -514,7 +513,7 @@ let apply ctxt gas capture_ty capture lam = ] ) in let lam' = Lam (full_descr, full_expr) in - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in return (lam', ctxt, gas) let make_transaction_to_contract ctxt ~destination ~amount ~entrypoint ~location @@ -624,7 +623,7 @@ let transfer (ctxt, sc) gas amount location parameters_ty parameters fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let iop = {source = sc.self; operation; nonce} in let res = {piop = Internal_operation iop; lazy_storage_diff} in - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in return (res, ctxt, gas) (** [create_contract (ctxt, sc) gas storage_ty code delegate credit init] @@ -663,7 +662,7 @@ let create_contract (ctxt, sc) gas storage_type code delegate credit init = fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let piop = Internal_operation {source = sc.self; operation; nonce} in let res = {piop; lazy_storage_diff} in - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in return (res, contract, ctxt, gas) (* [unpack ctxt ty bytes] deserialize [bytes] into a value of type [ty]. *) @@ -709,10 +708,10 @@ let rec interp_stack_prefix_preserving_operation : (d * w) * result = fun f n accu stk -> match (n, stk) with - | (KPrefix (_, n), rest) -> + | KPrefix (_, n), rest -> interp_stack_prefix_preserving_operation f n (fst rest) (snd rest) |> fun ((v, rest'), result) -> ((accu, (v, rest')), result) - | (KRest, v) -> f accu v + | KRest, v -> f accu v (* diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index a0cb334ce141..a9d0cdfce7dd 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -120,18 +120,18 @@ let classify_annot loc l : (var_annot option list * type_annot option list * field_annot option list) tzresult = try - let (_, rv, _, rt, _, rf) = + let _, rv, _, rt, _, rf = List.fold_left (fun (in_v, rv, in_t, rt, in_f, rf) a -> match (a, in_v, rv, in_t, rt, in_f, rf) with - | (Var_annot_opt a, true, _, _, _, _, _) - | (Var_annot_opt a, false, [], _, _, _, _) -> + | Var_annot_opt a, true, _, _, _, _, _ + | Var_annot_opt a, false, [], _, _, _, _ -> (true, a :: rv, false, rt, false, rf) - | (Type_annot_opt a, _, _, true, _, _, _) - | (Type_annot_opt a, _, _, false, [], _, _) -> + | Type_annot_opt a, _, _, true, _, _, _ + | Type_annot_opt a, _, _, false, [], _, _ -> (false, rv, true, a :: rt, false, rf) - | (Field_annot_opt a, _, _, _, _, true, _) - | (Field_annot_opt a, _, _, _, _, false, []) -> + | Field_annot_opt a, _, _, _, _, true, _ + | Field_annot_opt a, _, _, _, _, false, [] -> (false, rv, false, rt, true, opt_field_of_field_opt a :: rf) | _ -> raise Exit) (false, [], false, [], false, []) @@ -192,8 +192,8 @@ let extract_field_annot : let has_field_annot node = extract_field_annot node >|? function - | (_node, Some _) -> true - | (_node, None) -> false + | _node, Some _ -> true + | _node, None -> false let remove_field_annot node = extract_field_annot node >|? fun (node, _a) -> node diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ecdc6de7df2a..11f7323a23dc 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -121,11 +121,11 @@ let location = function let kind_equal a b = match (a, b) with - | (Int_kind, Int_kind) - | (String_kind, String_kind) - | (Bytes_kind, Bytes_kind) - | (Prim_kind, Prim_kind) - | (Seq_kind, Seq_kind) -> + | Int_kind, Int_kind + | String_kind, String_kind + | Bytes_kind, Bytes_kind + | Prim_kind, Prim_kind + | Seq_kind, Seq_kind -> true | _ -> false @@ -145,11 +145,11 @@ let unexpected expr exp_kinds exp_ns exp_prims = | Prim (loc, name, _, _) -> ( let open Michelson_v1_primitives in match (namespace name, exp_ns) with - | (Type_namespace, Type_namespace) - | (Instr_namespace, Instr_namespace) - | (Constant_namespace, Constant_namespace) -> + | Type_namespace, Type_namespace + | Instr_namespace, Instr_namespace + | Constant_namespace, Constant_namespace -> Invalid_primitive (loc, exp_prims, name) - | (ns, _) -> Invalid_namespace (loc, name, exp_ns, ns)) + | ns, _ -> Invalid_namespace (loc, name, exp_ns, ns)) let check_kind kinds expr = let kind = kind expr in @@ -172,7 +172,7 @@ let rec unparse_ty_and_entrypoints_uncarbonated : type a ac loc. loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node = fun ~loc ty {nested = nested_entrypoints; at_node} -> - let (name, args) = + let name, args = match ty with | Unit_t -> (T_unit, []) | Int_t -> (T_int, []) @@ -212,7 +212,7 @@ let rec unparse_ty_and_entrypoints_uncarbonated : | Prim (_, T_pair, ts, []) -> (T_pair, tl :: ts) | _ -> (T_pair, [tl; tr])) | Union_t (utl, utr, _meta, _) -> - let (entrypoints_l, entrypoints_r) = + let entrypoints_l, entrypoints_r = match nested_entrypoints with | Entrypoints_None -> (no_entrypoints, no_entrypoints) | Entrypoints_Union {left; right} -> (left, right) @@ -492,7 +492,7 @@ let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode *) let res = match (mode, r_comb_witness, r) with - | (Optimized, Comb_Pair _, Micheline.Seq (_, r)) -> + | Optimized, Comb_Pair _, Micheline.Seq (_, r) -> (* Optimized case n > 4 *) Micheline.Seq (loc, l :: r) | ( Optimized, @@ -500,7 +500,7 @@ let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) -> (* Optimized case n = 4 *) Micheline.Seq (loc, [l; x2; x3; x4]) - | (Readable, Comb_Pair _, Prim (_, D_Pair, xs, [])) -> + | Readable, Comb_Pair _, Prim (_, D_Pair, xs, []) -> (* Readable case n > 2 *) Prim (loc, D_Pair, l :: xs, []) | _ -> @@ -551,35 +551,35 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : >>?= fun ctxt -> match (ty, a) with - | (Unit_t, v) -> Lwt.return @@ unparse_unit ~loc ctxt v - | (Int_t, v) -> Lwt.return @@ unparse_int ~loc ctxt v - | (Nat_t, v) -> Lwt.return @@ unparse_nat ~loc ctxt v - | (String_t, s) -> Lwt.return @@ unparse_string ~loc ctxt s - | (Bytes_t, s) -> Lwt.return @@ unparse_bytes ~loc ctxt s - | (Bool_t, b) -> Lwt.return @@ unparse_bool ~loc ctxt b - | (Timestamp_t, t) -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | (Address_t, address) -> Lwt.return @@ unparse_address ~loc ctxt mode address - | (Tx_rollup_l2_address_t, address) -> + | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, address -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | (Signature_t, s) -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | (Mutez_t, v) -> Lwt.return @@ unparse_mutez ~loc ctxt v - | (Key_t, k) -> Lwt.return @@ unparse_key ~loc ctxt mode k - | (Key_hash_t, k) -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | (Chain_id_t, chain_id) -> + | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Chain_id_t, chain_id -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | (Pair_t (tl, tr, _, YesYes), pair) -> + | Pair_t (tl, tr, _, YesYes), pair -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | (Union_t (tl, tr, _, YesYes), v) -> + | Union_t (tl, tr, _, YesYes), v -> let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | (Option_t (t, _, Yes), v) -> + | Option_t (t, _, Yes), v -> let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in unparse_option ~loc unparse_v ctxt v - | (Never_t, _) -> . + | Never_t, _ -> . let pack_node unparsed ctxt = Gas.consume ctxt (Script.strip_locations_cost unparsed) >>? fun ctxt -> @@ -712,7 +712,7 @@ let memo_size_eq : The result is an equality witness between the types of the two inputs within the gas monad (for gas consumption). - *) +*) let rec ty_eq : type a ac b bc error_trace. error_details:(Script.location, error_trace) error_details -> @@ -754,125 +754,125 @@ let rec ty_eq : trace_of_error @@ default_ty_eq_error loc ty1 ty2) in match (ty1, ty2) with - | (Unit_t, Unit_t) -> return (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Unit_t, _) -> not_equal () - | (Int_t, Int_t) -> return Eq - | (Int_t, _) -> not_equal () - | (Nat_t, Nat_t) -> return Eq - | (Nat_t, _) -> not_equal () - | (Key_t, Key_t) -> return Eq - | (Key_t, _) -> not_equal () - | (Key_hash_t, Key_hash_t) -> return Eq - | (Key_hash_t, _) -> not_equal () - | (String_t, String_t) -> return Eq - | (String_t, _) -> not_equal () - | (Bytes_t, Bytes_t) -> return Eq - | (Bytes_t, _) -> not_equal () - | (Signature_t, Signature_t) -> return Eq - | (Signature_t, _) -> not_equal () - | (Mutez_t, Mutez_t) -> return Eq - | (Mutez_t, _) -> not_equal () - | (Timestamp_t, Timestamp_t) -> return Eq - | (Timestamp_t, _) -> not_equal () - | (Address_t, Address_t) -> return Eq - | (Address_t, _) -> not_equal () - | (Tx_rollup_l2_address_t, Tx_rollup_l2_address_t) -> return Eq - | (Tx_rollup_l2_address_t, _) -> not_equal () - | (Bool_t, Bool_t) -> return Eq - | (Bool_t, _) -> not_equal () - | (Chain_id_t, Chain_id_t) -> return Eq - | (Chain_id_t, _) -> not_equal () - | (Never_t, Never_t) -> return Eq - | (Never_t, _) -> not_equal () - | (Operation_t, Operation_t) -> return Eq - | (Operation_t, _) -> not_equal () - | (Bls12_381_g1_t, Bls12_381_g1_t) -> return Eq - | (Bls12_381_g1_t, _) -> not_equal () - | (Bls12_381_g2_t, Bls12_381_g2_t) -> return Eq - | (Bls12_381_g2_t, _) -> not_equal () - | (Bls12_381_fr_t, Bls12_381_fr_t) -> return Eq - | (Bls12_381_fr_t, _) -> not_equal () - | (Map_t (tal, tar, meta1), Map_t (tbl, tbr, meta2)) -> + | Unit_t, Unit_t -> return (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) + | Unit_t, _ -> not_equal () + | Int_t, Int_t -> return Eq + | Int_t, _ -> not_equal () + | Nat_t, Nat_t -> return Eq + | Nat_t, _ -> not_equal () + | Key_t, Key_t -> return Eq + | Key_t, _ -> not_equal () + | Key_hash_t, Key_hash_t -> return Eq + | Key_hash_t, _ -> not_equal () + | String_t, String_t -> return Eq + | String_t, _ -> not_equal () + | Bytes_t, Bytes_t -> return Eq + | Bytes_t, _ -> not_equal () + | Signature_t, Signature_t -> return Eq + | Signature_t, _ -> not_equal () + | Mutez_t, Mutez_t -> return Eq + | Mutez_t, _ -> not_equal () + | Timestamp_t, Timestamp_t -> return Eq + | Timestamp_t, _ -> not_equal () + | Address_t, Address_t -> return Eq + | Address_t, _ -> not_equal () + | Tx_rollup_l2_address_t, Tx_rollup_l2_address_t -> return Eq + | Tx_rollup_l2_address_t, _ -> not_equal () + | Bool_t, Bool_t -> return Eq + | Bool_t, _ -> not_equal () + | Chain_id_t, Chain_id_t -> return Eq + | Chain_id_t, _ -> not_equal () + | Never_t, Never_t -> return Eq + | Never_t, _ -> not_equal () + | Operation_t, Operation_t -> return Eq + | Operation_t, _ -> not_equal () + | Bls12_381_g1_t, Bls12_381_g1_t -> return Eq + | Bls12_381_g1_t, _ -> not_equal () + | Bls12_381_g2_t, Bls12_381_g2_t -> return Eq + | Bls12_381_g2_t, _ -> not_equal () + | Bls12_381_fr_t, Bls12_381_fr_t -> return Eq + | Bls12_381_fr_t, _ -> not_equal () + | Map_t (tal, tar, meta1), Map_t (tbl, tbr, meta2) -> let* () = type_metadata_eq meta1 meta2 in let* Eq = help tar tbr in let+ Eq = ty_eq ~error_details tal tbl in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Map_t _, _) -> not_equal () - | (Big_map_t (tal, tar, meta1), Big_map_t (tbl, tbr, meta2)) -> + | Map_t _, _ -> not_equal () + | Big_map_t (tal, tar, meta1), Big_map_t (tbl, tbr, meta2) -> let* () = type_metadata_eq meta1 meta2 in let* Eq = help tar tbr in let+ Eq = ty_eq ~error_details tal tbl in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Big_map_t _, _) -> not_equal () - | (Set_t (ea, meta1), Set_t (eb, meta2)) -> + | Big_map_t _, _ -> not_equal () + | Set_t (ea, meta1), Set_t (eb, meta2) -> let* () = type_metadata_eq meta1 meta2 in let+ Eq = ty_eq ~error_details ea eb in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Set_t _, _) -> not_equal () - | (Ticket_t (ea, meta1), Ticket_t (eb, meta2)) -> + | Set_t _, _ -> not_equal () + | Ticket_t (ea, meta1), Ticket_t (eb, meta2) -> let* () = type_metadata_eq meta1 meta2 in let+ Eq = ty_eq ~error_details ea eb in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Ticket_t _, _) -> not_equal () - | (Pair_t (tal, tar, meta1, cmp1), Pair_t (tbl, tbr, meta2, cmp2)) -> + | Ticket_t _, _ -> not_equal () + | Pair_t (tal, tar, meta1, cmp1), Pair_t (tbl, tbr, meta2, cmp2) -> let* () = type_metadata_eq meta1 meta2 in let* Eq = help tal tbl in let+ Eq = help tar tbr in let Eq = Dependent_bool.merge_dand cmp1 cmp2 in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Pair_t _, _) -> not_equal () - | (Union_t (tal, tar, meta1, cmp1), Union_t (tbl, tbr, meta2, cmp2)) -> + | Pair_t _, _ -> not_equal () + | Union_t (tal, tar, meta1, cmp1), Union_t (tbl, tbr, meta2, cmp2) -> let* () = type_metadata_eq meta1 meta2 in let* Eq = help tal tbl in let+ Eq = help tar tbr in let Eq = Dependent_bool.merge_dand cmp1 cmp2 in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Union_t _, _) -> not_equal () - | (Lambda_t (tal, tar, meta1), Lambda_t (tbl, tbr, meta2)) -> + | Union_t _, _ -> not_equal () + | Lambda_t (tal, tar, meta1), Lambda_t (tbl, tbr, meta2) -> let* () = type_metadata_eq meta1 meta2 in let* Eq = help tal tbl in let+ Eq = help tar tbr in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Lambda_t _, _) -> not_equal () - | (Contract_t (tal, meta1), Contract_t (tbl, meta2)) -> + | Lambda_t _, _ -> not_equal () + | Contract_t (tal, meta1), Contract_t (tbl, meta2) -> let* () = type_metadata_eq meta1 meta2 in let+ Eq = help tal tbl in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Contract_t _, _) -> not_equal () - | (Option_t (tva, meta1, _), Option_t (tvb, meta2, _)) -> + | Contract_t _, _ -> not_equal () + | Option_t (tva, meta1, _), Option_t (tvb, meta2, _) -> let* () = type_metadata_eq meta1 meta2 in let+ Eq = help tva tvb in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (Option_t _, _) -> not_equal () - | (List_t (tva, meta1), List_t (tvb, meta2)) -> + | Option_t _, _ -> not_equal () + | List_t (tva, meta1), List_t (tvb, meta2) -> let* () = type_metadata_eq meta1 meta2 in let+ Eq = help tva tvb in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) - | (List_t _, _) -> not_equal () - | (Sapling_state_t ms1, Sapling_state_t ms2) -> + | List_t _, _ -> not_equal () + | Sapling_state_t ms1, Sapling_state_t ms2 -> let+ () = memo_size_eq ms1 ms2 in Eq - | (Sapling_state_t _, _) -> not_equal () - | (Sapling_transaction_t ms1, Sapling_transaction_t ms2) -> + | Sapling_state_t _, _ -> not_equal () + | Sapling_transaction_t ms1, Sapling_transaction_t ms2 -> let+ () = memo_size_eq ms1 ms2 in Eq - | (Sapling_transaction_t _, _) -> not_equal () - | ( Sapling_transaction_deprecated_t ms1, - Sapling_transaction_deprecated_t ms2 ) -> + | Sapling_transaction_t _, _ -> not_equal () + | Sapling_transaction_deprecated_t ms1, Sapling_transaction_deprecated_t ms2 + -> let+ () = memo_size_eq ms1 ms2 in Eq - | (Sapling_transaction_deprecated_t _, _) -> not_equal () - | (Chest_t, Chest_t) -> return Eq - | (Chest_t, _) -> not_equal () - | (Chest_key_t, Chest_key_t) -> return Eq - | (Chest_key_t, _) -> not_equal () + | Sapling_transaction_deprecated_t _, _ -> not_equal () + | Chest_t, Chest_t -> return Eq + | Chest_t, _ -> not_equal () + | Chest_key_t, Chest_key_t -> return Eq + | Chest_key_t, _ -> not_equal () in help ty1 ty2 [@@coq_axiom_with_reason "non-top-level mutual recursion"] (* Same as ty_eq but for stacks. A single error monad is used here because there is no need to - recover from stack merging errors. *) + recover from stack merging errors. *) let rec stack_eq : type ta tb ts tu. Script.location -> @@ -883,15 +883,15 @@ let rec stack_eq : (((ta, ts) stack_ty, (tb, tu) stack_ty) eq * context) tzresult = fun loc ctxt lvl stack1 stack2 -> match (stack1, stack2) with - | (Bot_t, Bot_t) -> ok (Eq, ctxt) - | (Item_t (ty1, rest1), Item_t (ty2, rest2)) -> + | Bot_t, Bot_t -> ok (Eq, ctxt) + | Item_t (ty1, rest1), Item_t (ty2, rest2) -> Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) ty1 ty2 |> record_trace (Bad_stack_item lvl) >>? fun (eq, ctxt) -> eq >>? fun Eq -> stack_eq loc ctxt (lvl + 1) rest1 rest2 >|? fun (Eq, ctxt) -> ((Eq : ((ta, ts) stack_ty, (tb, tu) stack_ty) eq), ctxt) - | (_, _) -> error Bad_stack_length + | _, _ -> error Bad_stack_length (* ---- Type checker results -------------------------------------------------*) @@ -921,7 +921,7 @@ let merge_branches : ((c, v) judgement * context) tzresult = fun ctxt loc btr bfr {branch} -> match (btr, bfr) with - | (Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf)) -> + | Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf) -> let unmatched_branches () = let aftbt = serialize_stack_for_error ctxt aftbt in let aftbf = serialize_stack_for_error ctxt aftbf in @@ -931,12 +931,12 @@ let merge_branches : unmatched_branches ( stack_eq loc ctxt 1 aftbt aftbf >|? fun (Eq, ctxt) -> (Typed (branch dbt dbf), ctxt) ) - | (Failed {descr = descrt}, Failed {descr = descrf}) -> + | Failed {descr = descrt}, Failed {descr = descrf} -> let descr ret = branch (descrt ret) (descrf ret) in ok (Failed {descr}, ctxt) - | (Typed dbt, Failed {descr = descrf}) -> + | Typed dbt, Failed {descr = descrf} -> ok (Typed (branch dbt (descrf dbt.aft)), ctxt) - | (Failed {descr = descrt}, Typed dbf) -> + | Failed {descr = descrt}, Typed dbf -> ok (Typed (branch (descrt dbf.aft) dbf), ctxt) let parse_memo_size (n : (location, _) Micheline.node) : @@ -1414,8 +1414,7 @@ let parse_packable_ty ctxt ~stack_depth ~legacy node = ~legacy ~allow_lazy_storage:false ~allow_operation:false - ~allow_contract: - legacy + ~allow_contract:legacy (* type contract is forbidden in UNPACK because of https://gitlab.com/tezos/tezos/-/issues/301 *) ~allow_ticket:false @@ -1638,22 +1637,22 @@ let rec make_dug_proof_argument : (a, s, x) dug_proof_argument option = fun loc n x stk -> match (n, stk) with - | (0, rest) -> Some (Dug_proof_argument (KRest, Item_t (x, rest))) - | (n, Item_t (v, rest)) -> + | 0, rest -> Some (Dug_proof_argument (KRest, Item_t (x, rest))) + | n, Item_t (v, rest) -> make_dug_proof_argument loc (n - 1) x rest |> Option.map @@ fun (Dug_proof_argument (n', aft')) -> let kinfo = {iloc = loc; kstack_ty = aft'} in Dug_proof_argument (KPrefix (kinfo, n'), Item_t (v, aft')) - | (_, _) -> None + | _, _ -> None let rec make_comb_get_proof_argument : type b bc. int -> (b, bc) ty -> b comb_get_proof_argument option = fun n ty -> match (n, ty) with - | (0, value_ty) -> Some (Comb_get_proof_argument (Comb_get_zero, value_ty)) - | (1, Pair_t (hd_ty, _, _annot, _)) -> + | 0, value_ty -> Some (Comb_get_proof_argument (Comb_get_zero, value_ty)) + | 1, Pair_t (hd_ty, _, _annot, _) -> Some (Comb_get_proof_argument (Comb_get_one, hd_ty)) - | (n, Pair_t (_, tl_ty, _annot, _)) -> + | n, Pair_t (_, tl_ty, _annot, _) -> make_comb_get_proof_argument (n - 2) tl_ty |> Option.map @@ fun (Comb_get_proof_argument (comb_get_left_witness, ty')) -> @@ -1671,11 +1670,11 @@ let rec make_comb_set_proof_argument : (value, before) comb_set_proof_argument tzresult = fun ctxt stack_ty loc n value_ty ty -> match (n, ty) with - | (0, _) -> ok @@ Comb_set_proof_argument (Comb_set_zero, value_ty) - | (1, Pair_t (_hd_ty, tl_ty, _, _)) -> + | 0, _ -> ok @@ Comb_set_proof_argument (Comb_set_zero, value_ty) + | 1, Pair_t (_hd_ty, tl_ty, _, _) -> pair_t loc value_ty tl_ty >|? fun (Ty_ex_c after_ty) -> Comb_set_proof_argument (Comb_set_one, after_ty) - | (n, Pair_t (hd_ty, tl_ty, _, _)) -> + | n, Pair_t (hd_ty, tl_ty, _, _) -> make_comb_set_proof_argument ctxt stack_ty loc (n - 2) value_ty tl_ty >>? fun (Comb_set_proof_argument (comb_set_left_witness, tl_ty')) -> pair_t loc hd_ty tl_ty' >|? fun (Ty_ex_c after_ty) -> @@ -1706,11 +1705,10 @@ let find_entrypoint (type full fullc error_context error_trace) fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in match (ty, entrypoints) with - | (_, {at_node = Some {name; original_type_expr}; _}) + | _, {at_node = Some {name; original_type_expr}; _} when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) - | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) - -> ( + | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> ( Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> return @@ -1726,7 +1724,7 @@ let find_entrypoint (type full fullc error_context error_trace) in Ex_ty_cstr {ty; construct = (fun e -> R (construct e)); original_type_expr}) - | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) + | _, {nested = Entrypoints_None; _} -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in Gas_monad.bind_recover (find_entrypoint full root entrypoint) @@ function @@ -1795,7 +1793,7 @@ let well_formed_entrypoints (type full fullc) (full : (full, fullc) ty) (prim list option * Entrypoint.Set.t) tzresult = fun t entrypoints path reachable acc -> match (t, entrypoints) with - | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) -> + | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> merge (D_Left :: path) tl left reachable acc >>? fun (acc, l_reachable) -> merge (D_Right :: path) tr right reachable acc @@ -1804,7 +1802,7 @@ let well_formed_entrypoints (type full fullc) (full : (full, fullc) ty) check tr right (D_Right :: path) r_reachable acc | _ -> ok acc in - let (init, reachable) = + let init, reachable = match entrypoints.at_node with | None -> (Entrypoint.Set.empty, false) | Some {name; original_type_expr = _} -> @@ -2126,9 +2124,9 @@ let parse_pair (type r) parse_l parse_r ctxt ~legacy let parse_comb loc l rs = parse_l ctxt l >>=? fun (l, ctxt) -> (match (rs, r_comb_witness) with - | ([r], _) -> ok r - | ([], _) -> error @@ Invalid_arity (loc, D_Pair, 2, 1) - | (_ :: _, Comb_Pair _) -> + | [r], _ -> ok r + | [], _ -> error @@ Invalid_arity (loc, D_Pair, 2, 1) + | _ :: _, Comb_Pair _ -> (* Unfold [Pair x1 ... xn] as [Pair x1 (Pair x2 ... xn-1 xn))] for type [pair ta (pair tb1 tb2)] and n >= 3 only *) ok (Prim (loc, D_Pair, rs, [])) @@ -2343,33 +2341,30 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|=? fun (_, map, ctxt) -> (map, ctxt) in match (ty, script_data) with - | (Unit_t, expr) -> + | Unit_t, expr -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) - | (Bool_t, expr) -> - Lwt.return @@ traced_no_lwt @@ parse_bool ctxt ~legacy expr - | (String_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_string ctxt expr - | (Bytes_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr - | (Int_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr - | (Nat_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr - | (Mutez_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr - | (Timestamp_t, expr) -> + | Bool_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bool ctxt ~legacy expr + | String_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_string ctxt expr + | Bytes_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr + | Int_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr + | Nat_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr + | Mutez_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr + | Timestamp_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_timestamp ctxt expr - | (Key_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_key ctxt expr - | (Key_hash_t, expr) -> - Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr - | (Signature_t, expr) -> + | Key_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key ctxt expr + | Key_hash_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr + | Signature_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_signature ctxt expr - | (Operation_t, _) -> + | Operation_t, _ -> (* operations cannot appear in parameters or storage, the protocol should never parse the bytes of an operation *) assert false - | (Chain_id_t, expr) -> - Lwt.return @@ traced_no_lwt @@ parse_chain_id ctxt expr - | (Address_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr - | (Tx_rollup_l2_address_t, expr) -> + | Chain_id_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chain_id ctxt expr + | Address_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr + | Tx_rollup_l2_address_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_tx_rollup_l2_address ctxt expr - | (Contract_t (arg_ty, _), expr) -> + | Contract_t (arg_ty, _), expr -> traced ( parse_address ctxt expr >>?= fun (address, ctxt) -> let loc = location expr in @@ -2382,7 +2377,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : ~entrypoint:address.entrypoint >|=? fun (ctxt, _) -> (Typed_contract {arg_ty; address}, ctxt) ) (* Pairs *) - | (Pair_t (tl, tr, _, _), expr) -> + | Pair_t (tl, tr, _, _), expr -> let r_witness = comb_witness1 tr in let parse_l ctxt v = non_terminal_recursion ?type_logger ctxt ~legacy tl v @@ -2392,7 +2387,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : in traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr (* Unions *) - | (Union_t (tl, tr, _, _), expr) -> + | Union_t (tl, tr, _, _), expr -> let parse_l ctxt v = non_terminal_recursion ?type_logger ctxt ~legacy tl v in @@ -2401,7 +2396,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : in traced @@ parse_union parse_l parse_r ctxt ~legacy expr (* Lambdas *) - | (Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr)) -> + | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> traced @@ parse_returning Tc_context.data @@ -2412,16 +2407,16 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : ta tr script_instr - | (Lambda_t _, expr) -> + | Lambda_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) - | (Option_t (t, _, _), expr) -> + | Option_t (t, _, _), expr -> let parse_v ctxt v = non_terminal_recursion ?type_logger ctxt ~legacy t v in traced @@ parse_option parse_v ctxt ~legacy expr (* Lists *) - | (List_t (t, _ty_name), Seq (_loc, items)) -> + | List_t (t, _ty_name), Seq (_loc, items) -> traced @@ List.fold_right_es (fun v (rest, ctxt) -> @@ -2429,10 +2424,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|=? fun (v, ctxt) -> (Script_list.cons v rest, ctxt)) items (Script_list.empty, ctxt) - | (List_t _, expr) -> + | List_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) - | (Ticket_t (t, _ty_name), expr) -> + | Ticket_t (t, _ty_name), expr -> if allow_forged then opened_ticket_type (location expr) t >>?= fun ty -> non_terminal_recursion ?type_logger ctxt ~legacy ty expr @@ -2442,7 +2437,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Tx_rollup _ -> fail (Unexpected_ticket_owner destination) else traced_fail (Unexpected_forged_value (location expr)) (* Sets *) - | (Set_t (t, _ty_name), (Seq (loc, vs) as expr)) -> + | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> traced @@ List.fold_left_es (fun (last_value, set, ctxt) v -> @@ -2473,14 +2468,14 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : (None, Script_set.empty t, ctxt) vs >|=? fun (_, set, ctxt) -> (set, ctxt) - | (Set_t _, expr) -> + | Set_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) - | (Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr)) -> + | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> parse_items ?type_logger ctxt expr tk tv vs (fun x -> x) - | (Map_t _, expr) -> + | Map_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - | (Big_map_t (tk, tv, _ty_name), expr) -> + | Big_map_t (tk, tv, _ty_name), expr -> (match expr with | Int (loc, id) -> return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) @@ -2508,8 +2503,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : if allow_forged then let id = Big_map.Id.parse_z id in Big_map.exists ctxt id >>=? function - | (_, None) -> traced_fail (Invalid_big_map (loc, id)) - | (ctxt, Some (btk, btv)) -> + | _, None -> traced_fail (Invalid_big_map (loc, id)) + | ctxt, Some (btk, btv) -> Lwt.return ( parse_comparable_ty ~stack_depth:(stack_depth + 1) @@ -2533,38 +2528,38 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : else traced_fail (Unexpected_forged_value loc)) >|=? fun (id, ctxt) -> (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) - | (Never_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_never expr + | Never_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_never expr (* Bls12_381 types *) - | (Bls12_381_g1_t, Bytes (_, bs)) -> ( + | Bls12_381_g1_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_g1 >>?= fun ctxt -> match Script_bls.G1.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) - | (Bls12_381_g1_t, expr) -> + | Bls12_381_g1_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Bls12_381_g2_t, Bytes (_, bs)) -> ( + | Bls12_381_g2_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt -> match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) - | (Bls12_381_g2_t, expr) -> + | Bls12_381_g2_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Bls12_381_fr_t, Bytes (_, bs)) -> ( + | Bls12_381_fr_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> match Script_bls.Fr.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) - | (Bls12_381_fr_t, Int (_, v)) -> + | Bls12_381_fr_t, Int (_, v) -> Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> return (Script_bls.Fr.of_z v, ctxt) - | (Bls12_381_fr_t, expr) -> + | Bls12_381_fr_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. *) (* Sapling *) - | (Sapling_transaction_t memo_size, Bytes (_, bytes)) -> ( + | Sapling_transaction_t memo_size, Bytes (_, bytes) -> ( match Data_encoding.Binary.of_bytes_opt Sapling.transaction_encoding bytes with @@ -2579,9 +2574,9 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : transac_memo_size >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) - | (Sapling_transaction_t _, expr) -> + | Sapling_transaction_t _, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes)) -> ( + | Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes) -> ( match Data_encoding.Binary.of_bytes_opt Sapling.Legacy.transaction_encoding @@ -2598,9 +2593,9 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : transac_memo_size >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) - | (Sapling_transaction_deprecated_t _, expr) -> + | Sapling_transaction_deprecated_t _, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Sapling_state_t memo_size, Int (loc, id)) -> + | Sapling_state_t memo_size, Int (loc, id) -> if allow_forged then let id = Sapling.Id.parse_z id in Sapling.state_from_id ctxt id >>=? fun (state, ctxt) -> @@ -2612,15 +2607,15 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : state.Sapling.memo_size >|? fun () -> (state, ctxt) ) else traced_fail (Unexpected_forged_value loc) - | (Sapling_state_t memo_size, Seq (_, [])) -> + | Sapling_state_t memo_size, Seq (_, []) -> return (Sapling.empty_state ~memo_size (), ctxt) - | (Sapling_state_t _, expr) -> + | Sapling_state_t _, expr -> (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) traced_fail (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) - | (Chest_key_t, Bytes (_, bytes)) -> ( + | Chest_key_t, Bytes (_, bytes) -> ( Gas.consume ctxt Typecheck_costs.chest_key >>?= fun ctxt -> match Data_encoding.Binary.of_bytes_opt @@ -2629,9 +2624,9 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : with | Some chest_key -> return (chest_key, ctxt) | None -> fail_parse_data ()) - | (Chest_key_t, expr) -> + | Chest_key_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Chest_t, Bytes (_, bytes)) -> ( + | Chest_t, Bytes (_, bytes) -> ( Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) >>?= fun ctxt -> match @@ -2639,7 +2634,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : with | Some chest -> return (chest, ctxt) | None -> fail_parse_data ()) - | (Chest_t, expr) -> + | Chest_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) and parse_view : @@ -2744,7 +2739,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : script_instr (Item_t (arg, Bot_t)) >>=? function - | (Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt) -> + | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt -> Lwt.return (let error_details = Informative loc in Gas_monad.run ctxt @@ -2756,11 +2751,11 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : >>? fun (eq, ctxt) -> eq >|? fun Eq -> ((Lam (close_descr descr, script_instr) : (arg, ret) lambda), ctxt)) - | (Typed {loc; aft = stack_ty; _}, ctxt) -> + | Typed {loc; aft = stack_ty; _}, ctxt -> let ret = serialize_ty_for_error ret in let stack_ty = serialize_stack_for_error ctxt stack_ty in fail @@ Bad_return (loc, stack_ty, ret) - | (Failed {descr}, ctxt) -> + | Failed {descr}, ctxt -> return ( (Lam (close_descr (descr (Item_t (ret, Bot_t))), script_instr) : (arg, ret) lambda), @@ -2790,8 +2785,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in let log_stack loc stack_ty aft = match (type_logger, script_instr) with - | (None, _) | (Some _, (Int _ | String _ | Bytes _)) -> () - | (Some log, (Prim _ | Seq _)) -> + | None, _ | Some _, (Int _ | String _ | Bytes _) -> () + | Some log, (Prim _ | Seq _) -> (* Unparsing for logging is not carbonated as this is used only by the client and not the protocol *) let stack_ty_before = unparse_stack_uncarbonated stack_ty in @@ -2823,11 +2818,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in match (script_instr, stack_ty) with (* stack ops *) - | (Prim (loc, I_DROP, [], annot), Item_t (_, rest)) -> + | Prim (loc, I_DROP, [], annot), Item_t (_, rest) -> (error_unexpected_annot loc annot >>?= fun () -> typed ctxt loc {apply = (fun kinfo k -> IDrop (kinfo, k))} rest : ((a, s) judgement * context) tzresult Lwt.t) - | (Prim (loc, I_DROP, [n], result_annot), whole_stack) -> + | Prim (loc, I_DROP, [n], result_annot), whole_stack -> parse_uint10 n >>?= fun whole_n -> Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) >>?= fun ctxt -> let rec make_proof_argument : @@ -2835,13 +2830,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : int -> (a, s) stack_ty -> (a, s) dropn_proof_argument tzresult = fun n stk -> match (Compare.Int.(n = 0), stk) with - | (true, rest) -> ok @@ Dropn_proof_argument (KRest, rest) - | (false, Item_t (_, rest)) -> + | true, rest -> ok @@ Dropn_proof_argument (KRest, rest) + | false, Item_t (_, rest) -> make_proof_argument (n - 1) rest >|? fun (Dropn_proof_argument (n', stack_after_drops)) -> let kinfo = {iloc = loc; kstack_ty = rest} in Dropn_proof_argument (KPrefix (kinfo, n'), stack_after_drops) - | (_, _) -> + | _, _ -> let whole_stack = serialize_stack_for_error ctxt whole_stack in error (Bad_stack (loc, I_DROP, whole_n, whole_stack)) in @@ -2850,11 +2845,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun (Dropn_proof_argument (n', stack_after_drops)) -> let kdropn kinfo k = IDropn (kinfo, whole_n, n', k) in typed ctxt loc {apply = kdropn} stack_after_drops - | (Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _) -> + | Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _ -> (* Technically, the arities 0 and 1 are allowed but the error only mentions 1. However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *) fail (Invalid_arity (loc, I_DROP, 1, List.length l)) - | (Prim (loc, I_DUP, [], annot), (Item_t (v, _) as stack)) -> + | Prim (loc, I_DUP, [], annot), (Item_t (v, _) as stack) -> check_var_annot loc annot >>?= fun () -> record_trace_eval (fun () -> @@ -2864,16 +2859,15 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun ctxt -> let dup = {apply = (fun kinfo k -> IDup (kinfo, k))} in typed ctxt loc dup (Item_t (v, stack)) - | (Prim (loc, I_DUP, [n], v_annot), stack_ty) -> + | Prim (loc, I_DUP, [n], v_annot), stack_ty -> check_var_annot loc v_annot >>?= fun () -> let rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a * s) dup_n_proof_argument tzresult = fun n (stack_ty : (a, s) stack_ty) -> match (n, stack_ty) with - | (1, Item_t (hd_ty, _)) -> - ok @@ Dup_n_proof_argument (Dup_n_zero, hd_ty) - | (n, Item_t (_, tl_ty)) -> + | 1, Item_t (hd_ty, _) -> ok @@ Dup_n_proof_argument (Dup_n_zero, hd_ty) + | n, Item_t (_, tl_ty) -> make_proof_argument (n - 1) tl_ty >|? fun (Dup_n_proof_argument (dup_n_witness, b_ty)) -> Dup_n_proof_argument (Dup_n_succ dup_n_witness, b_ty) @@ -2895,19 +2889,19 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun ctxt -> let dupn = {apply = (fun kinfo k -> IDup_n (kinfo, n, witness, k))} in typed ctxt loc dupn (Item_t (after_ty, stack_ty)) - | (Prim (loc, I_DIG, [n], result_annot), stack) -> + | Prim (loc, I_DIG, [n], result_annot), stack -> let rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a, s) dig_proof_argument tzresult = fun n stk -> match (Compare.Int.(n = 0), stk) with - | (true, Item_t (v, rest)) -> ok @@ Dig_proof_argument (KRest, v, rest) - | (false, Item_t (v, rest)) -> + | true, Item_t (v, rest) -> ok @@ Dig_proof_argument (KRest, v, rest) + | false, Item_t (v, rest) -> make_proof_argument (n - 1) rest >|? fun (Dig_proof_argument (n', x, aft')) -> let kinfo = {iloc = loc; kstack_ty = aft'} in Dig_proof_argument (KPrefix (kinfo, n'), x, Item_t (v, aft')) - | (_, _) -> + | _, _ -> let whole_stack = serialize_stack_for_error ctxt stack in error (Bad_stack (loc, I_DIG, 3, whole_stack)) in @@ -2917,9 +2911,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : make_proof_argument n stack >>?= fun (Dig_proof_argument (n', x, aft)) -> let dig = {apply = (fun kinfo k -> IDig (kinfo, n, n', k))} in typed ctxt loc dig (Item_t (x, aft)) - | (Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _) -> + | Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _ -> fail (Invalid_arity (loc, I_DIG, 1, List.length l)) - | (Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack)) -> ( + | Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack) -> ( parse_uint10 n >>?= fun whole_n -> Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) >>?= fun ctxt -> error_unexpected_annot loc result_annot >>?= fun () -> @@ -2930,19 +2924,19 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | Some (Dug_proof_argument (n', aft)) -> let dug = {apply = (fun kinfo k -> IDug (kinfo, whole_n, n', k))} in typed ctxt loc dug aft) - | (Prim (loc, I_DUG, [_], result_annot), stack) -> + | Prim (loc, I_DUG, [_], result_annot), stack -> Lwt.return ( error_unexpected_annot loc result_annot >>? fun () -> let stack = serialize_stack_for_error ctxt stack in error (Bad_stack (loc, I_DUG, 1, stack)) ) - | (Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _) -> + | Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _ -> fail (Invalid_arity (loc, I_DUG, 1, List.length l)) - | (Prim (loc, I_SWAP, [], annot), Item_t (v, Item_t (w, rest))) -> + | Prim (loc, I_SWAP, [], annot), Item_t (v, Item_t (w, rest)) -> error_unexpected_annot loc annot >>?= fun () -> let swap = {apply = (fun kinfo k -> ISwap (kinfo, k))} in let stack_ty = Item_t (w, Item_t (v, rest)) in typed ctxt loc swap stack_ty - | (Prim (loc, I_PUSH, [t; d], annot), stack) -> + | Prim (loc, I_PUSH, [t; d], annot), stack -> check_var_annot loc annot >>?= fun () -> parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> @@ -2957,16 +2951,16 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>=? fun (v, ctxt) -> let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in typed ctxt loc const (Item_t (t, stack)) - | (Prim (loc, I_UNIT, [], annot), stack) -> + | Prim (loc, I_UNIT, [], annot), stack -> check_var_type_annot loc annot >>?= fun () -> let const = {apply = (fun kinfo k -> IConst (kinfo, (), k))} in typed ctxt loc const (Item_t (unit_t, stack)) (* options *) - | (Prim (loc, I_SOME, [], annot), Item_t (t, rest)) -> + | Prim (loc, I_SOME, [], annot), Item_t (t, rest) -> check_var_type_annot loc annot >>?= fun () -> let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) - | (Prim (loc, I_NONE, [t], annot), stack) -> + | Prim (loc, I_NONE, [t], annot), stack -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> @@ -2974,7 +2968,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : option_t loc t >>?= fun ty -> let stack_ty = Item_t (ty, stack) in typed ctxt loc cons_none stack_ty - | (Prim (loc, I_MAP, [body], annot), Item_t (Option_t (t, _, _), rest)) -> ( + | Prim (loc, I_MAP, [body], annot), Item_t (Option_t (t, _, _), rest) -> ( check_kind [Seq_kind] body >>?= fun () -> check_var_type_annot loc annot >>?= fun () -> non_terminal_recursion @@ -3034,22 +3028,22 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in Lwt.return @@ merge_branches ctxt loc btr bfr {branch} (* pairs *) - | (Prim (loc, I_PAIR, [], annot), Item_t (a, Item_t (b, rest))) -> + | Prim (loc, I_PAIR, [], annot), Item_t (a, Item_t (b, rest)) -> check_constr_annot loc annot >>?= fun () -> pair_t loc a b >>?= fun (Ty_ex_c ty) -> let stack_ty = Item_t (ty, rest) in let cons_pair = {apply = (fun kinfo k -> ICons_pair (kinfo, k))} in typed ctxt loc cons_pair stack_ty - | (Prim (loc, I_PAIR, [n], annot), stack_ty) -> + | Prim (loc, I_PAIR, [n], annot), stack_ty -> check_var_annot loc annot >>?= fun () -> let rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a * s) comb_proof_argument tzresult = fun n stack_ty -> match (n, stack_ty) with - | (1, Item_t (a_ty, tl_ty)) -> + | 1, Item_t (a_ty, tl_ty) -> ok (Comb_proof_argument (Comb_one, Item_t (a_ty, tl_ty))) - | (n, Item_t (a_ty, tl_ty)) -> + | n, Item_t (a_ty, tl_ty) -> make_proof_argument (n - 1) tl_ty >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty'))) -> @@ -3067,15 +3061,15 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun (Comb_proof_argument (witness, after_ty)) -> let comb = {apply = (fun kinfo k -> IComb (kinfo, n, witness, k))} in typed ctxt loc comb after_ty - | (Prim (loc, I_UNPAIR, [n], annot), stack_ty) -> + | Prim (loc, I_UNPAIR, [n], annot), stack_ty -> error_unexpected_annot loc annot >>?= fun () -> let rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a * s) uncomb_proof_argument tzresult = fun n stack_ty -> match (n, stack_ty) with - | (1, stack) -> ok @@ Uncomb_proof_argument (Uncomb_one, stack) - | (n, Item_t (Pair_t (a_ty, b_ty, _, _), tl_ty)) -> + | 1, stack -> ok @@ Uncomb_proof_argument (Uncomb_one, stack) + | n, Item_t (Pair_t (a_ty, b_ty, _, _), tl_ty) -> make_proof_argument (n - 1) (Item_t (b_ty, tl_ty)) >|? fun (Uncomb_proof_argument (uncomb_witness, after_ty)) -> Uncomb_proof_argument @@ -3092,7 +3086,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun (Uncomb_proof_argument (witness, after_ty)) -> let uncomb = {apply = (fun kinfo k -> IUncomb (kinfo, n, witness, k))} in typed ctxt loc uncomb after_ty - | (Prim (loc, I_GET, [n], annot), Item_t (comb_ty, rest_ty)) -> ( + | Prim (loc, I_GET, [n], annot), Item_t (comb_ty, rest_ty) -> ( check_var_annot loc annot >>?= fun () -> parse_uint11 n >>?= fun n -> Gas.consume ctxt (Typecheck_costs.proof_argument n) >>?= fun ctxt -> @@ -3118,20 +3112,20 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : {apply = (fun kinfo k -> IComb_set (kinfo, n, witness, k))} in typed ctxt loc comb_set after_stack_ty - | (Prim (loc, I_UNPAIR, [], annot), Item_t (Pair_t (a, b, _, _), rest)) -> + | Prim (loc, I_UNPAIR, [], annot), Item_t (Pair_t (a, b, _, _), rest) -> check_unpair_annot loc annot >>?= fun () -> let unpair = {apply = (fun kinfo k -> IUnpair (kinfo, k))} in typed ctxt loc unpair (Item_t (a, Item_t (b, rest))) - | (Prim (loc, I_CAR, [], annot), Item_t (Pair_t (a, _, _, _), rest)) -> + | Prim (loc, I_CAR, [], annot), Item_t (Pair_t (a, _, _, _), rest) -> check_destr_annot loc annot >>?= fun () -> let car = {apply = (fun kinfo k -> ICar (kinfo, k))} in typed ctxt loc car (Item_t (a, rest)) - | (Prim (loc, I_CDR, [], annot), Item_t (Pair_t (_, b, _, _), rest)) -> + | Prim (loc, I_CDR, [], annot), Item_t (Pair_t (_, b, _, _), rest) -> check_destr_annot loc annot >>?= fun () -> let cdr = {apply = (fun kinfo k -> ICdr (kinfo, k))} in typed ctxt loc cdr (Item_t (b, rest)) (* unions *) - | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest)) -> + | Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr >>?= fun (Ex_ty tr, ctxt) -> check_constr_annot loc annot >>?= fun () -> @@ -3139,7 +3133,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : union_t loc tl tr >>?= fun (Ty_ex_c ty) -> let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_left stack_ty - | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest)) -> + | Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl >>?= fun (Ex_ty tl, ctxt) -> check_constr_annot loc annot >>?= fun () -> @@ -3184,7 +3178,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in Lwt.return @@ merge_branches ctxt loc btr bfr {branch} (* lists *) - | (Prim (loc, I_NIL, [t], annot), stack) -> + | Prim (loc, I_NIL, [t], annot), stack -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> @@ -3227,11 +3221,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : {loc; instr; bef; aft = ibt.aft} in Lwt.return @@ merge_branches ctxt loc btr bfr {branch} - | (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest)) -> + | Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest) -> check_var_type_annot loc annot >>?= fun () -> let list_size = {apply = (fun kinfo k -> IList_size (kinfo, k))} in typed ctxt loc list_size (Item_t (nat_t, rest)) - | (Prim (loc, I_MAP, [body], annot), Item_t (List_t (elt, _), starting_rest)) + | Prim (loc, I_MAP, [body], annot), Item_t (List_t (elt, _), starting_rest) -> ( check_kind [Seq_kind] body >>?= fun () -> check_var_type_annot loc annot >>?= fun () -> @@ -3267,7 +3261,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let aft = serialize_stack_for_error ctxt aft in error (Invalid_map_body (loc, aft)) | Failed _ -> error (Invalid_map_block_fail loc)) - | (Prim (loc, I_ITER, [body], annot), Item_t (List_t (elt, _), rest)) -> ( + | Prim (loc, I_ITER, [body], annot), Item_t (List_t (elt, _), rest) -> ( check_kind [Seq_kind] body >>?= fun () -> error_unexpected_annot loc annot >>?= fun () -> non_terminal_recursion @@ -3305,13 +3299,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | Failed {descr} -> typed_no_lwt ctxt loc (mk_list_iter (descr rest)) rest ) (* sets *) - | (Prim (loc, I_EMPTY_SET, [t], annot), rest) -> + | Prim (loc, I_EMPTY_SET, [t], annot), rest -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in set_t loc t >>?= fun ty -> typed ctxt loc instr (Item_t (ty, rest)) - | (Prim (loc, I_ITER, [body], annot), Item_t (Set_t (elt, _), rest)) -> ( + | Prim (loc, I_ITER, [body], annot), Item_t (Set_t (elt, _), rest) -> ( check_kind [Seq_kind] body >>?= fun () -> error_unexpected_annot loc annot >>?= fun () -> non_terminal_recursion @@ -3348,7 +3342,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed_no_lwt ctxt loc (mk_iset_iter ibody) rest ) | Failed {descr} -> typed_no_lwt ctxt loc (mk_iset_iter (descr rest)) rest ) - | (Prim (loc, I_MEM, [], annot), Item_t (v, Item_t (Set_t (elt, _), rest))) -> + | Prim (loc, I_MEM, [], annot), Item_t (v, Item_t (Set_t (elt, _), rest)) -> check_var_type_annot loc annot >>?= fun () -> check_item_ty ctxt elt v loc I_MEM 1 2 >>?= fun (Eq, ctxt) -> let instr = {apply = (fun kinfo k -> ISet_mem (kinfo, k))} in @@ -3360,12 +3354,12 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISet_update (kinfo, k))} in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) - | (Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest)) -> + | Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISet_size (kinfo, k))} in typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) - | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) -> + | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv @@ -3373,7 +3367,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in map_t loc tk tv >>?= fun ty -> typed ctxt loc instr (Item_t (ty, stack)) - | (Prim (loc, I_MAP, [body], annot), Item_t (Map_t (k, elt, _), starting_rest)) + | Prim (loc, I_MAP, [body], annot), Item_t (Map_t (k, elt, _), starting_rest) -> ( check_kind [Seq_kind] body >>?= fun () -> check_var_type_annot loc annot >>?= fun () -> @@ -3414,8 +3408,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let aft = serialize_stack_for_error ctxt aft in error (Invalid_map_body (loc, aft)) | Failed _ -> error (Invalid_map_block_fail loc)) - | ( Prim (loc, I_ITER, [body], annot), - Item_t (Map_t (key, element_ty, _), rest) ) -> ( + | Prim (loc, I_ITER, [body], annot), Item_t (Map_t (key, element_ty, _), rest) + -> ( check_kind [Seq_kind] body >>?= fun () -> error_unexpected_annot loc annot >>?= fun () -> pair_t loc key element_ty >>?= fun (Ty_ex_c ty) -> @@ -3452,14 +3446,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>? fun (Eq, ctxt) : ((a, s) judgement * context) tzresult -> typed_no_lwt ctxt loc (make_instr ibody) rest ) | Failed {descr} -> typed_no_lwt ctxt loc (make_instr (descr rest)) rest) - | (Prim (loc, I_MEM, [], annot), Item_t (vk, Item_t (Map_t (k, _, _), rest))) - -> + | Prim (loc, I_MEM, [], annot), Item_t (vk, Item_t (Map_t (k, _, _), rest)) -> check_item_ty ctxt vk k loc I_MEM 1 2 >>?= fun (Eq, ctxt) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMap_mem (kinfo, k))} in (typed ctxt loc instr (Item_t (bool_t, rest)) : ((a, s) judgement * context) tzresult Lwt.t) - | (Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Map_t (k, elt, _), rest))) + | Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Map_t (k, elt, _), rest)) -> check_item_ty ctxt vk k loc I_GET 1 2 >>?= fun (Eq, ctxt) -> check_var_annot loc annot >>?= fun () -> @@ -3487,12 +3480,12 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMap_get_and_update (kinfo, k))} in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) - | (Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _), rest)) -> + | Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _), rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMap_size (kinfo, k))} in typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) - | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) -> + | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv @@ -3544,7 +3537,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) (* Sapling *) - | (Prim (loc, I_SAPLING_EMPTY_STATE, [memo_size], annot), rest) -> + | Prim (loc, I_SAPLING_EMPTY_STATE, [memo_size], annot), rest -> parse_memo_size memo_size >>?= fun memo_size -> check_var_annot loc annot >>?= fun () -> let instr = @@ -3590,12 +3583,12 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (ty, rest) in typed ctxt loc instr stack (* control *) - | (Seq (loc, []), stack) -> + | Seq (loc, []), stack -> let instr = {apply = (fun _kinfo k -> k)} in typed ctxt loc instr stack - | (Seq (_, [single]), stack) -> + | Seq (_, [single]), stack -> non_terminal_recursion ?type_logger tc_context ctxt ~legacy single stack - | (Seq (loc, hd :: tl), stack) -> ( + | Seq (loc, hd :: tl), stack -> ( non_terminal_recursion ?type_logger tc_context ctxt ~legacy hd stack >>=? fun (judgement, ctxt) -> match judgement with @@ -3617,7 +3610,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | Typed itl -> Typed (compose_descr loc ihd itl) in (judgement, ctxt)) - | (Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t, rest) as bef)) -> + | Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t, rest) as bef) -> check_kind [Seq_kind] bt >>?= fun () -> check_kind [Seq_kind] bf >>?= fun () -> error_unexpected_annot loc annot >>?= fun () -> @@ -3640,7 +3633,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : {loc; instr; bef; aft = ibt.aft} in Lwt.return @@ merge_branches ctxt loc btr bfr {branch} - | (Prim (loc, I_LOOP, [body], annot), (Item_t (Bool_t, rest) as stack)) -> ( + | Prim (loc, I_LOOP, [body], annot), (Item_t (Bool_t, rest) as stack) -> ( check_kind [Seq_kind] body >>?= fun () -> error_unexpected_annot loc annot >>?= fun () -> non_terminal_recursion ?type_logger tc_context ctxt ~legacy body rest @@ -3731,7 +3724,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) - | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) -> + | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg >>?= fun (Ex_ty arg, ctxt) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret @@ -3777,7 +3770,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : fun res_ty -> let stack = Item_t (res_ty, rest) in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) - | (Prim (loc, I_DIP, [code], annot), Item_t (v, rest)) -> ( + | Prim (loc, I_DIP, [code], annot), Item_t (v, rest) -> ( error_unexpected_annot loc annot >>?= fun () -> check_kind [Seq_kind] code >>?= fun () -> non_terminal_recursion ?type_logger tc_context ctxt ~legacy code rest @@ -3797,7 +3790,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (v, descr.aft) in typed ctxt loc instr stack | Failed _ -> fail (Fail_not_in_tail_position loc)) - | (Prim (loc, I_DIP, [n; code], result_annot), stack) -> + | Prim (loc, I_DIP, [n; code], result_annot), stack -> parse_uint10 n >>?= fun n -> Gas.consume ctxt (Typecheck_costs.proof_argument n) >>?= fun ctxt -> let rec make_proof_argument : @@ -3805,7 +3798,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : int -> (a, s) stack_ty -> (a, s) dipn_proof_argument tzresult Lwt.t = fun n stk -> match (Compare.Int.(n = 0), stk) with - | (true, rest) -> ( + | true, rest -> ( non_terminal_recursion ?type_logger tc_context @@ -3822,13 +3815,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (Dipn_proof_argument (KRest, ctxt, descr, descr.aft) : (a, s) dipn_proof_argument) | Failed _ -> error (Fail_not_in_tail_position loc)) - | (false, Item_t (v, rest)) -> + | false, Item_t (v, rest) -> make_proof_argument (n - 1) rest >|=? fun (Dipn_proof_argument (n', ctxt, descr, aft')) -> let kinfo' = {iloc = loc; kstack_ty = aft'} in let w = KPrefix (kinfo', n') in Dipn_proof_argument (w, ctxt, descr, Item_t (v, aft')) - | (_, _) -> + | _, _ -> Lwt.return (let whole_stack = serialize_stack_for_error ctxt stack in error (Bad_stack (loc, I_DIP, 1, whole_stack))) @@ -3841,11 +3834,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let b = descr.instr.apply kinfo (IHalt kinfoh) in let res = {apply = (fun kinfo k -> IDipn (kinfo, n, n', b, k))} in typed ctxt loc res aft - | (Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _) -> + | Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _ -> (* Technically, the arities 1 and 2 are allowed but the error only mentions 2. However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *) fail (Invalid_arity (loc, I_DIP, 2, List.length l)) - | (Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest)) -> + | Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest) -> Lwt.return ( error_unexpected_annot loc annot >>? fun () -> (if legacy then Result.return_unit @@ -3855,7 +3848,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let descr aft = {loc; instr; bef = stack_ty; aft} in log_stack loc stack_ty Bot_t ; (Failed {descr}, ctxt) ) - | (Prim (loc, I_NEVER, [], annot), Item_t (Never_t, _rest)) -> + | Prim (loc, I_NEVER, [], annot), Item_t (Never_t, _rest) -> Lwt.return ( error_unexpected_annot loc annot >|? fun () -> let instr = {apply = (fun kinfo _k -> INever kinfo)} in @@ -3863,8 +3856,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : log_stack loc stack_ty Bot_t ; (Failed {descr}, ctxt) ) (* timestamp operations *) - | (Prim (loc, I_ADD, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest))) - -> + | Prim (loc, I_ADD, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAdd_timestamp_to_seconds (kinfo, k))} @@ -3877,8 +3869,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : {apply = (fun kinfo k -> IAdd_seconds_to_timestamp (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest))) - -> + | Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISub_timestamp_seconds (kinfo, k))} @@ -3897,7 +3888,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IConcat_string_pair (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_CONCAT, [], annot), Item_t (List_t (String_t, _), rest)) -> + | Prim (loc, I_CONCAT, [], annot), Item_t (List_t (String_t, _), rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IConcat_string (kinfo, k))} in typed ctxt loc instr (Item_t (String_t, rest)) @@ -3907,7 +3898,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> ISlice_string (kinfo, k))} in let stack = Item_t (option_string_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_SIZE, [], annot), Item_t (String_t, rest)) -> + | Prim (loc, I_SIZE, [], annot), Item_t (String_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IString_size (kinfo, k))} in let stack = Item_t (nat_t, rest) in @@ -3918,7 +3909,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IConcat_bytes_pair (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_CONCAT, [], annot), Item_t (List_t (Bytes_t, _), rest)) -> + | Prim (loc, I_CONCAT, [], annot), Item_t (List_t (Bytes_t, _), rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IConcat_bytes (kinfo, k))} in let stack = Item_t (Bytes_t, rest) in @@ -3929,7 +3920,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> ISlice_bytes (kinfo, k))} in let stack = Item_t (option_bytes_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t, rest)) -> + | Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IBytes_size (kinfo, k))} in let stack = Item_t (nat_t, rest) in @@ -3947,200 +3938,199 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> ISub_tez_legacy (kinfo, k))} in typed ctxt loc instr stack else fail (Deprecated_instruction I_SUB) - | ( Prim (loc, I_SUB_MUTEZ, [], annot), - Item_t (Mutez_t, Item_t (Mutez_t, rest)) ) -> + | Prim (loc, I_SUB_MUTEZ, [], annot), Item_t (Mutez_t, Item_t (Mutez_t, rest)) + -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISub_tez (kinfo, k))} in let stack = Item_t (option_mutez_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_MUL, [], annot), Item_t (Mutez_t, Item_t (Nat_t, rest))) -> + | Prim (loc, I_MUL, [], annot), Item_t (Mutez_t, Item_t (Nat_t, rest)) -> (* no type name check *) check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_teznat (kinfo, k))} in let stack = Item_t (Mutez_t, rest) in typed ctxt loc instr stack - | ( Prim (loc, I_MUL, [], annot), - Item_t (Nat_t, (Item_t (Mutez_t, _) as stack)) ) -> + | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Mutez_t, _) as stack)) + -> (* no type name check *) check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_nattez (kinfo, k))} in typed ctxt loc instr stack (* boolean operations *) - | (Prim (loc, I_OR, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack))) + | Prim (loc, I_OR, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IOr (kinfo, k))} in typed ctxt loc instr stack - | ( Prim (loc, I_AND, [], annot), - Item_t (Bool_t, (Item_t (Bool_t, _) as stack)) ) -> + | Prim (loc, I_AND, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack)) + -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAnd (kinfo, k))} in typed ctxt loc instr stack - | ( Prim (loc, I_XOR, [], annot), - Item_t (Bool_t, (Item_t (Bool_t, _) as stack)) ) -> + | Prim (loc, I_XOR, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack)) + -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IXor (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_NOT, [], annot), (Item_t (Bool_t, _) as stack)) -> + | Prim (loc, I_NOT, [], annot), (Item_t (Bool_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INot (kinfo, k))} in typed ctxt loc instr stack (* integer operations *) - | (Prim (loc, I_ABS, [], annot), Item_t (Int_t, rest)) -> + | Prim (loc, I_ABS, [], annot), Item_t (Int_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAbs_int (kinfo, k))} in let stack = Item_t (nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_ISNAT, [], annot), Item_t (Int_t, rest)) -> + | Prim (loc, I_ISNAT, [], annot), Item_t (Int_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IIs_nat (kinfo, k))} in let stack = Item_t (option_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_INT, [], annot), Item_t (Nat_t, rest)) -> + | Prim (loc, I_INT, [], annot), Item_t (Nat_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IInt_nat (kinfo, k))} in let stack = Item_t (int_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_NEG, [], annot), (Item_t (Int_t, _) as stack)) -> + | Prim (loc, I_NEG, [], annot), (Item_t (Int_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INeg (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_NEG, [], annot), Item_t (Nat_t, rest)) -> + | Prim (loc, I_NEG, [], annot), Item_t (Nat_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INeg (kinfo, k))} in let stack = Item_t (int_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_ADD, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack))) + | Prim (loc, I_ADD, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAdd_int (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_ADD, [], annot), Item_t (Int_t, Item_t (Nat_t, rest))) -> + | Prim (loc, I_ADD, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAdd_int (kinfo, k))} in let stack = Item_t (Int_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_ADD, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack))) + | Prim (loc, I_ADD, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAdd_int (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_ADD, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))) + | Prim (loc, I_ADD, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAdd_nat (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_SUB, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack))) + | Prim (loc, I_SUB, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISub_int (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_SUB, [], annot), Item_t (Int_t, Item_t (Nat_t, rest))) -> + | Prim (loc, I_SUB, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISub_int (kinfo, k))} in let stack = Item_t (Int_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_SUB, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack))) + | Prim (loc, I_SUB, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISub_int (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_SUB, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest))) -> + | Prim (loc, I_SUB, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISub_int (kinfo, k))} in let stack = Item_t (int_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_MUL, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack))) + | Prim (loc, I_MUL, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_int (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_MUL, [], annot), Item_t (Int_t, Item_t (Nat_t, rest))) -> + | Prim (loc, I_MUL, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_int (kinfo, k))} in let stack = Item_t (Int_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack))) + | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_nat (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))) + | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_nat (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t, Item_t (Nat_t, rest))) -> + | Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t, Item_t (Nat_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_teznat (kinfo, k))} in let stack = Item_t (option_pair_mutez_mutez_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t, Item_t (Mutez_t, rest))) -> + | Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t, Item_t (Mutez_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_tez (kinfo, k))} in let stack = Item_t (option_pair_nat_mutez_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Int_t, rest))) -> + | Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_int (kinfo, k))} in let stack = Item_t (option_pair_int_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Nat_t, rest))) -> + | Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_int (kinfo, k))} in let stack = Item_t (option_pair_int_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Int_t, rest))) -> + | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_nat (kinfo, k))} in let stack = Item_t (option_pair_int_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest))) -> + | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEdiv_nat (kinfo, k))} in let stack = Item_t (option_pair_nat_nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_LSL, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))) + | Prim (loc, I_LSL, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ILsl_nat (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_LSR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))) + | Prim (loc, I_LSR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ILsr_nat (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_OR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))) - -> + | Prim (loc, I_OR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IOr_nat (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_AND, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))) + | Prim (loc, I_AND, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAnd_nat (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_AND, [], annot), Item_t (Int_t, (Item_t (Nat_t, _) as stack))) + | Prim (loc, I_AND, [], annot), Item_t (Int_t, (Item_t (Nat_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAnd_int_nat (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_XOR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack))) + | Prim (loc, I_XOR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IXor_nat (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_NOT, [], annot), (Item_t (Int_t, _) as stack)) -> + | Prim (loc, I_NOT, [], annot), (Item_t (Int_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INot_int (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_NOT, [], annot), Item_t (Nat_t, rest)) -> + | Prim (loc, I_NOT, [], annot), Item_t (Nat_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INot_int (kinfo, k))} in let stack = Item_t (int_t, rest) in typed ctxt loc instr stack (* comparison *) - | (Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest))) -> + | Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest)) -> check_var_annot loc annot >>?= fun () -> check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 >>?= fun (Eq, ctxt) -> check_comparable loc t1 >>?= fun Eq -> @@ -4148,38 +4138,38 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (int_t, rest) in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) (* comparators *) - | (Prim (loc, I_EQ, [], annot), Item_t (Int_t, rest)) -> + | Prim (loc, I_EQ, [], annot), Item_t (Int_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEq (kinfo, k))} in let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_NEQ, [], annot), Item_t (Int_t, rest)) -> + | Prim (loc, I_NEQ, [], annot), Item_t (Int_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INeq (kinfo, k))} in let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_LT, [], annot), Item_t (Int_t, rest)) -> + | Prim (loc, I_LT, [], annot), Item_t (Int_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ILt (kinfo, k))} in let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_GT, [], annot), Item_t (Int_t, rest)) -> + | Prim (loc, I_GT, [], annot), Item_t (Int_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IGt (kinfo, k))} in let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_LE, [], annot), Item_t (Int_t, rest)) -> + | Prim (loc, I_LE, [], annot), Item_t (Int_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ILe (kinfo, k))} in let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_GE, [], annot), Item_t (Int_t, rest)) -> + | Prim (loc, I_GE, [], annot), Item_t (Int_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IGe (kinfo, k))} in let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack (* annotations *) - | (Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack)) -> + | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) -> check_var_annot loc annot >>?= fun () -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t >>?= fun (Ex_ty cast_t, ctxt) -> @@ -4189,13 +4179,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (* We can reuse [stack] because [a ty = b ty] means [a = b]. *) let instr = {apply = (fun _ k -> k)} in (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) - | (Prim (loc, I_RENAME, [], annot), (Item_t _ as stack)) -> + | Prim (loc, I_RENAME, [], annot), (Item_t _ as stack) -> check_var_annot loc annot >>?= fun () -> (* can erase annot *) let instr = {apply = (fun _ k -> k)} in typed ctxt loc instr stack (* packing *) - | (Prim (loc, I_PACK, [], annot), Item_t (t, rest)) -> + | Prim (loc, I_PACK, [], annot), Item_t (t, rest) -> check_packable ~legacy:true (* allow to pack contracts for hash/signature checks *) loc @@ -4205,7 +4195,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> IPack (kinfo, t, k))} in let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest)) -> + | Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest) -> parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> @@ -4214,12 +4204,12 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (res_ty, rest) in typed ctxt loc instr stack (* protocol *) - | (Prim (loc, I_ADDRESS, [], annot), Item_t (Contract_t _, rest)) -> + | Prim (loc, I_ADDRESS, [], annot), Item_t (Contract_t _, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAddress (kinfo, k))} in let stack = Item_t (address_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest)) -> + | Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest) -> parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> contract_t loc t >>?= fun contract_ty -> @@ -4262,9 +4252,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> ISet_delegate (kinfo, k))} in let stack = Item_t (operation_t, rest) in typed ctxt loc instr stack - | (Prim (_, I_CREATE_ACCOUNT, _, _), _) -> + | Prim (_, I_CREATE_ACCOUNT, _, _), _ -> fail (Deprecated_instruction I_CREATE_ACCOUNT) - | (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t, rest)) -> + | Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IImplicit_account (kinfo, k))} in let stack = Item_t (contract_unit_t, rest) in @@ -4339,60 +4329,60 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in let stack = Item_t (operation_t, Item_t (address_t, rest)) in typed ctxt loc instr stack - | (Prim (loc, I_NOW, [], annot), stack) -> + | Prim (loc, I_NOW, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INow (kinfo, k))} in let stack = Item_t (timestamp_t, stack) in typed ctxt loc instr stack - | (Prim (loc, I_MIN_BLOCK_TIME, [], _), stack) -> + | Prim (loc, I_MIN_BLOCK_TIME, [], _), stack -> typed ctxt loc {apply = (fun kinfo k -> IMin_block_time (kinfo, k))} (Item_t (nat_t, stack)) - | (Prim (loc, I_AMOUNT, [], annot), stack) -> + | Prim (loc, I_AMOUNT, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IAmount (kinfo, k))} in let stack = Item_t (mutez_t, stack) in typed ctxt loc instr stack - | (Prim (loc, I_CHAIN_ID, [], annot), stack) -> + | Prim (loc, I_CHAIN_ID, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IChainId (kinfo, k))} in let stack = Item_t (chain_id_t, stack) in typed ctxt loc instr stack - | (Prim (loc, I_BALANCE, [], annot), stack) -> + | Prim (loc, I_BALANCE, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IBalance (kinfo, k))} in let stack = Item_t (mutez_t, stack) in typed ctxt loc instr stack - | (Prim (loc, I_LEVEL, [], annot), stack) -> + | Prim (loc, I_LEVEL, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ILevel (kinfo, k))} in let stack = Item_t (nat_t, stack) in typed ctxt loc instr stack - | (Prim (loc, I_VOTING_POWER, [], annot), Item_t (Key_hash_t, rest)) -> + | Prim (loc, I_VOTING_POWER, [], annot), Item_t (Key_hash_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IVoting_power (kinfo, k))} in let stack = Item_t (nat_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_TOTAL_VOTING_POWER, [], annot), stack) -> + | Prim (loc, I_TOTAL_VOTING_POWER, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ITotal_voting_power (kinfo, k))} in let stack = Item_t (nat_t, stack) in typed ctxt loc instr stack - | (Prim (_, I_STEPS_TO_QUOTA, _, _), _) -> + | Prim (_, I_STEPS_TO_QUOTA, _, _), _ -> fail (Deprecated_instruction I_STEPS_TO_QUOTA) - | (Prim (loc, I_SOURCE, [], annot), stack) -> + | Prim (loc, I_SOURCE, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISource (kinfo, k))} in let stack = Item_t (address_t, stack) in typed ctxt loc instr stack - | (Prim (loc, I_SENDER, [], annot), stack) -> + | Prim (loc, I_SENDER, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISender (kinfo, k))} in let stack = Item_t (address_t, stack) in typed ctxt loc instr stack - | (Prim (loc, (I_SELF as prim), [], annot), stack) -> + | Prim (loc, (I_SELF as prim), [], annot), stack -> Lwt.return ( parse_entrypoint_annot_lax loc annot >>? fun entrypoint -> let open Tc_context in @@ -4425,13 +4415,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in let stack = Item_t (res_ty, stack) in typed_no_lwt ctxt loc instr stack ) - | (Prim (loc, I_SELF_ADDRESS, [], annot), stack) -> + | Prim (loc, I_SELF_ADDRESS, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISelf_address (kinfo, k))} in let stack = Item_t (address_t, stack) in typed ctxt loc instr stack (* cryptography *) - | (Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t, rest)) -> + | Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IHash_key (kinfo, k))} in let stack = Item_t (key_hash_t, rest) in @@ -4442,23 +4432,23 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let instr = {apply = (fun kinfo k -> ICheck_signature (kinfo, k))} in let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_BLAKE2B, [], annot), (Item_t (Bytes_t, _) as stack)) -> + | Prim (loc, I_BLAKE2B, [], annot), (Item_t (Bytes_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IBlake2b (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_SHA256, [], annot), (Item_t (Bytes_t, _) as stack)) -> + | Prim (loc, I_SHA256, [], annot), (Item_t (Bytes_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISha256 (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_SHA512, [], annot), (Item_t (Bytes_t, _) as stack)) -> + | Prim (loc, I_SHA512, [], annot), (Item_t (Bytes_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISha512 (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_KECCAK, [], annot), (Item_t (Bytes_t, _) as stack)) -> + | Prim (loc, I_KECCAK, [], annot), (Item_t (Bytes_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IKeccak (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_SHA3, [], annot), (Item_t (Bytes_t, _) as stack)) -> + | Prim (loc, I_SHA3, [], annot), (Item_t (Bytes_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> ISha3 (kinfo, k))} in typed ctxt loc instr stack @@ -4504,38 +4494,38 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_bls12_381_fr_z (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t, Item_t (Int_t, rest))) + | Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t, Item_t (Int_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_bls12_381_z_fr (kinfo, k))} in let stack = Item_t (Bls12_381_fr_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t, Item_t (Nat_t, rest))) + | Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t, Item_t (Nat_t, rest)) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IMul_bls12_381_z_fr (kinfo, k))} in let stack = Item_t (Bls12_381_fr_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_INT, [], annot), Item_t (Bls12_381_fr_t, rest)) -> + | Prim (loc, I_INT, [], annot), Item_t (Bls12_381_fr_t, rest) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IInt_bls12_381_fr (kinfo, k))} in let stack = Item_t (int_t, rest) in typed ctxt loc instr stack - | (Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_g1_t, _) as stack)) -> + | Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_g1_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INeg_bls12_381_g1 (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_g2_t, _) as stack)) -> + | Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_g2_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INeg_bls12_381_g2 (kinfo, k))} in typed ctxt loc instr stack - | (Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_fr_t, _) as stack)) -> + | Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_fr_t, _) as stack) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> INeg_bls12_381_fr (kinfo, k))} in typed ctxt loc instr stack | ( Prim (loc, I_PAIRING_CHECK, [], annot), - Item_t (List_t (Pair_t (Bls12_381_g1_t, Bls12_381_g2_t, _, _), _), rest) - ) -> + Item_t (List_t (Pair_t (Bls12_381_g1_t, Bls12_381_g2_t, _, _), _), rest) ) + -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IPairing_check_bls12_381 (kinfo, k))} @@ -4543,7 +4533,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (bool_t, rest) in typed ctxt loc instr stack (* Tickets *) - | (Prim (loc, I_TICKET, [], annot), Item_t (t, Item_t (Nat_t, rest))) -> + | Prim (loc, I_TICKET, [], annot), Item_t (t, Item_t (Nat_t, rest)) -> check_var_annot loc annot >>?= fun () -> check_comparable loc t >>?= fun Eq -> ticket_t loc t >>?= fun res_ty -> @@ -4656,14 +4646,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Item_t (t, _) ) -> let t = serialize_ty_for_error t in fail (Undefined_unop (loc, name, t)) - | (Prim (loc, ((I_UPDATE | I_SLICE | I_OPEN_CHEST) as name), [], _), stack) -> + | Prim (loc, ((I_UPDATE | I_SLICE | I_OPEN_CHEST) as name), [], _), stack -> Lwt.return (let stack = serialize_stack_for_error ctxt stack in error (Bad_stack (loc, name, 3, stack))) - | (Prim (loc, I_CREATE_CONTRACT, _, _), stack) -> + | Prim (loc, I_CREATE_CONTRACT, _, _), stack -> let stack = serialize_stack_for_error ctxt stack in fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) - | (Prim (loc, I_TRANSFER_TOKENS, [], _), stack) -> + | Prim (loc, I_TRANSFER_TOKENS, [], _), stack -> Lwt.return (let stack = serialize_stack_for_error ctxt stack in error (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack))) @@ -4696,7 +4686,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (let stack = serialize_stack_for_error ctxt stack in error (Bad_stack (loc, name, 2, stack))) (* Generic parsing errors *) - | (expr, _) -> + | expr, _ -> fail @@ unexpected expr @@ -4951,9 +4941,9 @@ and parse_toplevel : find_fields ctxt None None None (Script_map.empty string_t) fields >>? fun (ctxt, toplevel) -> match toplevel with - | (None, _, _, _) -> error (Missing_field K_parameter) - | (Some _, None, _, _) -> error (Missing_field K_storage) - | (Some _, Some _, None, _) -> error (Missing_field K_code) + | None, _, _, _ -> error (Missing_field K_parameter) + | Some _, None, _, _ -> error (Missing_field K_storage) + | Some _, Some _, None, _ -> error (Missing_field K_code) | ( Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, cannot), @@ -4971,7 +4961,7 @@ and parse_toplevel : | [single] when legacy -> ( is_field_annot ploc single >|? fun is_field_annot -> match (is_field_annot, p) with - | (true, Prim (loc, prim, args, annots)) -> + | true, Prim (loc, prim, args, annots) -> (Prim (loc, prim, args, single :: annots), []) | _ -> (p, [])) | _ -> ok (p, pannot)) @@ -5073,10 +5063,10 @@ let parse_contract_for_script : when Entrypoint.( entrypoint = Alpha_context.Tx_rollup.deposit_entrypoint) -> ( Tx_rollup_state.find ctxt tx_rollup >|=? function - | (ctxt, Some _) -> + | ctxt, Some _ -> let address = {destination = contract; entrypoint} in (ctxt, Some (Typed_contract {arg_ty = arg; address})) - | (ctxt, None) -> (ctxt, None)) + | ctxt, None -> (ctxt, None)) | _ -> return (ctxt, None)) let view_size view = @@ -5090,7 +5080,7 @@ let code_size ctxt code views = (* The size of the storage_type and the arg_type is counted by [lambda_size]. *) let ir_size = lambda_size code in - let (nodes, code_size) = views_size ++ ir_size in + let nodes, code_size = views_size ++ ir_size in (* We consume gas after the fact in order to not have to instrument [node_size] (for efficiency). This is safe, as we already pay gas proportional to [views_size] and @@ -5299,16 +5289,14 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) prim list list * (ex_ty * Script.node) Entrypoint.Map.t = fun t entrypoints path reachable acc -> match (t, entrypoints) with - | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) -> - let (acc, l_reachable) = merge (D_Left :: path) tl left reachable acc in - let (acc, r_reachable) = - merge (D_Right :: path) tr right reachable acc - in + | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> + let acc, l_reachable = merge (D_Left :: path) tl left reachable acc in + let acc, r_reachable = merge (D_Right :: path) tr right reachable acc in let acc = fold_tree tl left (D_Left :: path) l_reachable acc in fold_tree tr right (D_Right :: path) r_reachable acc | _ -> acc in - let (init, reachable) = + let init, reachable = match entrypoints.root.at_node with | None -> (Entrypoint.Map.empty, false) | Some {name; original_type_expr} -> @@ -5338,42 +5326,42 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : in let loc = Micheline.dummy_location in match (ty, a) with - | (Unit_t, v) -> Lwt.return @@ unparse_unit ~loc ctxt v - | (Int_t, v) -> Lwt.return @@ unparse_int ~loc ctxt v - | (Nat_t, v) -> Lwt.return @@ unparse_nat ~loc ctxt v - | (String_t, s) -> Lwt.return @@ unparse_string ~loc ctxt s - | (Bytes_t, s) -> Lwt.return @@ unparse_bytes ~loc ctxt s - | (Bool_t, b) -> Lwt.return @@ unparse_bool ~loc ctxt b - | (Timestamp_t, t) -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | (Address_t, address) -> Lwt.return @@ unparse_address ~loc ctxt mode address - | (Tx_rollup_l2_address_t, address) -> + | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, address -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | (Contract_t _, contract) -> + | Contract_t _, contract -> Lwt.return @@ unparse_contract ~loc ctxt mode contract - | (Signature_t, s) -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | (Mutez_t, v) -> Lwt.return @@ unparse_mutez ~loc ctxt v - | (Key_t, k) -> Lwt.return @@ unparse_key ~loc ctxt mode k - | (Key_hash_t, k) -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | (Operation_t, operation) -> + | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Operation_t, operation -> Lwt.return @@ unparse_operation ~loc ctxt operation - | (Chain_id_t, chain_id) -> + | Chain_id_t, chain_id -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | (Bls12_381_g1_t, x) -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x - | (Bls12_381_g2_t, x) -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x - | (Bls12_381_fr_t, x) -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x - | (Pair_t (tl, tr, _, _), pair) -> + | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x + | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x + | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x + | Pair_t (tl, tr, _, _), pair -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | (Union_t (tl, tr, _, _), v) -> + | Union_t (tl, tr, _, _), v -> let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | (Option_t (t, _, _), v) -> + | Option_t (t, _, _), v -> let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in unparse_option ~loc unparse_v ctxt v - | (List_t (t, _), items) -> + | List_t (t, _), items -> List.fold_left_es (fun (l, ctxt) element -> non_terminal_recursion ctxt mode t element @@ -5381,7 +5369,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) items.elements >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) - | (Ticket_t (t, _), {ticketer; contents; amount}) -> + | Ticket_t (t, _), {ticketer; contents; amount} -> (* ideally we would like to allow a little overhead here because it is only used for unparsing *) opened_ticket_type loc t >>?= fun t -> let destination : Destination.t = Contract ticketer in @@ -5392,7 +5380,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : mode t (addr, (contents, amount)) - | (Set_t (t, _), set) -> + | Set_t (t, _), set -> List.fold_left_es (fun (l, ctxt) item -> unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> @@ -5400,14 +5388,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) (Script_set.fold (fun e acc -> e :: acc) set []) >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Map_t (kt, vt, _), map) -> + | Map_t (kt, vt, _), map -> let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _}) + | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _} when Compare.Int.( = ) size 0 -> return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) - | (Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _}) -> + | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} -> let items = Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] in @@ -5432,7 +5420,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], [] ), ctxt ) - | (Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _}) -> + | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} -> let items = Big_map_overlay.fold (fun _ (k, v) acc -> @@ -5448,17 +5436,17 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : in unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Lambda_t _, Lam (_, original_code)) -> + | Lambda_t _, Lam (_, original_code) -> unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code - | (Never_t, _) -> . - | (Sapling_transaction_t _, s) -> + | Never_t, _ -> . + | Sapling_transaction_t _, s -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s in (Bytes (loc, bytes), ctxt) ) - | (Sapling_transaction_deprecated_t _, s) -> + | Sapling_transaction_deprecated_t _, s -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) >|? fun ctxt -> @@ -5468,7 +5456,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : s in (Bytes (loc, bytes), ctxt) ) - | (Sapling_state_t _, {id; diff; _}) -> + | Sapling_state_t _, {id; diff; _} -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> ( (match diff with @@ -5490,14 +5478,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : Micheline.Prim (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), ctxt ) ) - | (Chest_key_t, s) -> + | Chest_key_t, s -> unparse_with_data_encoding ~loc ctxt s Unparse_costs.chest_key Script_timelock.chest_key_encoding - | (Chest_t, s) -> + | Chest_t, s -> unparse_with_data_encoding ~loc ctxt @@ -5691,20 +5679,20 @@ let empty_big_map key_type value_type = let big_map_mem ctxt key (Big_map {id; diff; key_type; _}) = hash_comparable_data ctxt key_type key >>=? fun (key, ctxt) -> match (Big_map_overlay.find key diff.map, id) with - | (None, None) -> return (false, ctxt) - | (None, Some id) -> + | None, None -> return (false, ctxt) + | None, Some id -> Alpha_context.Big_map.mem ctxt id key >|=? fun (ctxt, res) -> (res, ctxt) - | (Some (_, None), _) -> return (false, ctxt) - | (Some (_, Some _), _) -> return (true, ctxt) + | Some (_, None), _ -> return (false, ctxt) + | Some (_, Some _), _ -> return (true, ctxt) let big_map_get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = match (Big_map_overlay.find key diff.map, id) with - | (Some (_, x), _) -> return (x, ctxt) - | (None, None) -> return (None, ctxt) - | (None, Some id) -> ( + | Some (_, x), _ -> return (x, ctxt) + | None, None -> return (None, ctxt) + | None, Some id -> ( Alpha_context.Big_map.get_opt ctxt id key >>=? function - | (ctxt, None) -> return (None, ctxt) - | (ctxt, Some value) -> + | ctxt, None -> return (None, ctxt) + | ctxt, Some value -> parse_data ~stack_depth:0 ctxt @@ -5862,8 +5850,8 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = in let aux2 cons t1 t2 = match (has_lazy_storage t1, has_lazy_storage t2) with - | (False_f, False_f) -> False_f - | (h1, h2) -> cons h1 h2 + | False_f, False_f -> False_f + | h1, h2 -> cons h1 h2 in match ty with | Big_map_t (_, _, _) -> Big_map_f @@ -5925,8 +5913,8 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> match (has_lazy_storage, ty, x) with - | (False_f, _, _) -> return (ctxt, x, ids_to_copy, acc) - | (Big_map_f, Big_map_t (_, _, _), map) -> + | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) + | Big_map_f, Big_map_t (_, _, _), map -> diff_of_big_map ctxt mode ~temporary ~ids_to_copy map >|=? fun (diff, id, ctxt) -> let map = @@ -5941,7 +5929,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let diff = Lazy_storage.make Big_map id diff in let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in (ctxt, map, ids_to_copy, diff :: acc) - | (Sapling_state_f, Sapling_state_t _, sapling_state) -> + | Sapling_state_f, Sapling_state_t _, sapling_state -> diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state >|=? fun (diff, id, ctxt) -> let sapling_state = @@ -5950,22 +5938,22 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let diff = Lazy_storage.make Sapling_state id diff in let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in (ctxt, sapling_state, ids_to_copy, diff :: acc) - | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr)) -> + | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl >>=? fun (ctxt, xl, ids_to_copy, acc) -> aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr >|=? fun (ctxt, xr, ids_to_copy, acc) -> (ctxt, (xl, xr), ids_to_copy, acc) - | (Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x) -> + | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) - | (Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x) -> + | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) - | (Option_f has_lazy_storage, Option_t (ty, _, _), Some x) -> + | Option_f has_lazy_storage, Option_t (ty, _, _), Some x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc) - | (List_f has_lazy_storage, List_t (ty, _), l) -> + | List_f has_lazy_storage, List_t (ty, _), l -> List.fold_left_es (fun (ctxt, l, ids_to_copy, acc) x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -5976,7 +5964,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode >|=? fun (ctxt, l, ids_to_copy, acc) -> let reversed = {length = l.length; elements = List.rev l.elements} in (ctxt, reversed, ids_to_copy, acc) - | (Map_f has_lazy_storage, Map_t (_, ty, _), map) -> + | Map_f has_lazy_storage, Map_t (_, ty, _), map -> let (module M) = Script_map.get_module map in let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in List.fold_left_es @@ -6005,7 +5993,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode and type value = M.value), ids_to_copy, acc ) - | (_, Option_t (_, _, _), None) -> return (ctxt, None, ids_to_copy, acc) + | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc) in let has_lazy_storage = has_lazy_storage ty in aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -6033,32 +6021,32 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : fun ~f ~init ctxt ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> match (has_lazy_storage, ty, x) with - | (Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _}) -> + | Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _} -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) - | (Sapling_state_f, Sapling_state_t _, {id = Some id; _}) -> + | Sapling_state_f, Sapling_state_t _, {id = Some id; _} -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) - | (False_f, _, _) -> ok (Fold_lazy_storage.Ok init, ctxt) - | (Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _}) -> + | False_f, _, _ -> ok (Fold_lazy_storage.Ok init, ctxt) + | Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt) - | (Sapling_state_f, Sapling_state_t _, {id = None; _}) -> + | Sapling_state_f, Sapling_state_t _, {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt) - | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr)) -> ( + | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> ( fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl >>? fun (init, ctxt) -> match init with | Fold_lazy_storage.Ok init -> fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr | Fold_lazy_storage.Error -> ok (init, ctxt)) - | (Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x) -> + | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | (Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x) -> + | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | (_, Option_t (_, _, _), None) -> ok (Fold_lazy_storage.Ok init, ctxt) - | (Option_f has_lazy_storage, Option_t (ty, _, _), Some x) -> + | _, Option_t (_, _, _), None -> ok (Fold_lazy_storage.Ok init, ctxt) + | Option_f has_lazy_storage, Option_t (ty, _, _), Some x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | (List_f has_lazy_storage, List_t (ty, _), l) -> + | List_f has_lazy_storage, List_t (ty, _), l -> List.fold_left_e (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x -> match init with @@ -6067,7 +6055,7 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : | Fold_lazy_storage.Error -> ok (init, ctxt)) (Fold_lazy_storage.Ok init, ctxt) l.elements - | (Map_f has_lazy_storage, Map_t (_, ty, _), m) -> + | Map_f has_lazy_storage, Map_t (_, ty, _), m -> Script_map.fold (fun _ v @@ -6226,7 +6214,7 @@ let script_size entrypoints = _; views = _; })) = - let (nodes, storage_size) = + let nodes, storage_size = Script_typed_ir_size.value_size storage_type storage in let cost = Script_typed_ir_size_costs.nodes_cost ~nodes in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 022b9beb4c0f..919e2e71ead8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -27,37 +27,37 @@ (* Overview: -This mli is organized into roughly three parts: - -1. A set of new types prefixed with "ex_" -Michelson is encoded in a GADT that preserves certain properties about its -type system. If you haven't read about GADT's, check out the relevant section -in the Tezos docs: -https://tezos.gitlab.io/developer/gadt.html#generalized-algebraic-data-types-gadts - -The idea is that type representing a Michelson type, ['a ty], is parameterized -by a type 'a. But that 'a can't be just _any_ type; it must be valid according -to the definition of ['a ty]. Thus, if I give you a value of type ['a ty], -all you know is that "there exists some 'a such that 'a ty exists". You must be -careful not to accidentally quantify 'a universally, that is "for all 'a, -'a ty exists", otherwise you'll get an annoying error about 'a trying to escape -it's scope. We do this by hiding 'a in an existential type. This is what -ex_comparable_ty, ex_ty, ex_stack_ty, etc. do. - -2. A set of functions dealing with high-level Michelson types: -This module also provides functions for interacting with the list, map, -set, and big_map Michelson types. - -3. A set of functions for parsing and typechecking Michelson. -Finally, and what you likely came for, the module provides many functions prefixed -with "parse_" that convert untyped Micheline (which is essentially S-expressions -with a few primitive atom types) into the GADT encoding well-typed Michelson. Likewise -there is a number of functions prefixed "unparse_" that do the reverse. These functions -consume gas, and thus are parameterized by an [Alpha_context.t]. - -The variety of functions reflects the variety of things one might want to parse, -from [parse_data] for arbitrary Micheline expressions to [parse_contract] for -well-formed Michelson contracts. + This mli is organized into roughly three parts: + + 1. A set of new types prefixed with "ex_" + Michelson is encoded in a GADT that preserves certain properties about its + type system. If you haven't read about GADT's, check out the relevant section + in the Tezos docs: + https://tezos.gitlab.io/developer/gadt.html#generalized-algebraic-data-types-gadts + + The idea is that type representing a Michelson type, ['a ty], is parameterized + by a type 'a. But that 'a can't be just _any_ type; it must be valid according + to the definition of ['a ty]. Thus, if I give you a value of type ['a ty], + all you know is that "there exists some 'a such that 'a ty exists". You must be + careful not to accidentally quantify 'a universally, that is "for all 'a, + 'a ty exists", otherwise you'll get an annoying error about 'a trying to escape + it's scope. We do this by hiding 'a in an existential type. This is what + ex_comparable_ty, ex_ty, ex_stack_ty, etc. do. + + 2. A set of functions dealing with high-level Michelson types: + This module also provides functions for interacting with the list, map, + set, and big_map Michelson types. + + 3. A set of functions for parsing and typechecking Michelson. + Finally, and what you likely came for, the module provides many functions prefixed + with "parse_" that convert untyped Micheline (which is essentially S-expressions + with a few primitive atom types) into the GADT encoding well-typed Michelson. Likewise + there is a number of functions prefixed "unparse_" that do the reverse. These functions + consume gas, and thus are parameterized by an [Alpha_context.t]. + + The variety of functions reflects the variety of things one might want to parse, + from [parse_data] for arbitrary Micheline expressions to [parse_contract] for + well-formed Michelson contracts. *) (** {1 Michelson Existential Witness types} *) diff --git a/src/proto_alpha/lib_protocol/script_map.ml b/src/proto_alpha/lib_protocol/script_map.ml index 1a9aa5018fcf..5e7dcf3b44da 100644 --- a/src/proto_alpha/lib_protocol/script_map.ml +++ b/src/proto_alpha/lib_protocol/script_map.ml @@ -75,7 +75,7 @@ let get : type key value. key -> (key, value) map -> value option = let update : type a b. a -> b option -> (a, b) map -> (a, b) map = fun k v (Map_tag (module Box)) -> - let (boxed, size) = + let boxed, size = let contains = match Box.OPS.find k Box.boxed with None -> false | _ -> true in diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 85d50f7b2e39..0ae56ce6e9f3 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -605,16 +605,16 @@ let lambda_size lam = over the corpus of mainnet contracts in Granada. *) - let (lambda_nodes, lambda_size) = + let lambda_nodes, lambda_size = lambda_size ~count_lambda_nodes:true zero lam in - let (lambda_extra_size_nodes, lambda_extra_size) = lambda_extra_size lam in + let lambda_extra_size_nodes, lambda_extra_size = lambda_extra_size lam in let size = (lambda_size *? 157 /? 100) +! (lambda_extra_size *? 18 /? 100) in (Nodes.add lambda_nodes lambda_extra_size_nodes, size) let kinstr_size kinstr = - let (kinstr_extra_size_nodes, kinstr_extra_size) = kinstr_extra_size kinstr in - let (kinstr_nodes, kinstr_size) = + let kinstr_extra_size_nodes, kinstr_extra_size = kinstr_extra_size kinstr in + let kinstr_nodes, kinstr_size = kinstr_size ~count_lambda_nodes:true zero kinstr in let size = (kinstr_size *? 157 /? 100) +! (kinstr_extra_size *? 18 /? 100) in diff --git a/src/proto_alpha/lib_protocol/seed_repr.ml b/src/proto_alpha/lib_protocol/seed_repr.ml index b9f6d85160c8..f3873d795502 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.ml +++ b/src/proto_alpha/lib_protocol/seed_repr.ml @@ -79,7 +79,7 @@ let take_int32 s bound = Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in let rec loop s = - let (bytes, s) = take s in + let bytes, s = take s in let r = TzEndian.get_int32 bytes 0 in (* The absolute value of min_int is min_int. Also, every positive integer is represented twice (positive and negative), @@ -102,7 +102,7 @@ let take_int64 s bound = in let rec loop s = - let (bytes, s) = take s in + let bytes, s = take s in let r = TzEndian.get_int64 bytes 0 in (* The absolute value of min_int is min_int. Also, every positive integer is represented twice (positive and negative), diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.ml b/src/proto_alpha/lib_protocol/skip_list_repr.ml index 3a5a221d34fc..6686e8f87bf8 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.ml +++ b/src/proto_alpha/lib_protocol/skip_list_repr.ml @@ -241,9 +241,9 @@ end) : S = struct let target_index = index target and cell_index = index cell in let rec valid_path index cell_ptr path = match (cell_ptr, path) with - | (final_cell, []) -> + | final_cell, [] -> equal_ptr target_ptr final_cell && Compare.Int.(index = target_index) - | (cell_ptr, cell_ptr' :: path) -> + | cell_ptr, cell_ptr' :: path -> assume_some (deref cell_ptr) @@ fun cell -> assume_some (deref cell_ptr') @@ fun cell' -> mem equal_ptr cell_ptr' cell.back_pointers diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 2c77354f98fb..7d178652fa40 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -395,11 +395,11 @@ module Global_constants = struct let name = ["global_constant"] end)) (Make_index (Script_expr_hash)) - (struct - type t = Script_repr.expr + (struct + type t = Script_repr.expr - let encoding = Script_repr.expr_encoding - end) + let encoding = Script_repr.expr_encoding + end) end (** Big maps handling *) @@ -492,11 +492,11 @@ module Big_map = struct let name = ["contents"] end)) (Make_index (Script_expr_hash)) - (struct - type t = Script_repr.expr + (struct + type t = Script_repr.expr - let encoding = Script_repr.expr_encoding - end) + let encoding = Script_repr.expr_encoding + end) type context = I.context @@ -938,7 +938,7 @@ module Cycle = struct let name = ["slashed_deposits"] end)) (Pair (Make_index (Raw_level_repr.Index)) (Public_key_hash_index)) - (Slashed_level) + (Slashed_level) module Selected_stake_distribution = Indexed_context.Make_map @@ -1017,11 +1017,11 @@ module Cycle = struct let name = ["nonces"] end)) (Make_index (Raw_level_repr.Index)) - (struct - type t = nonce_status + (struct + type t = nonce_status - let encoding = nonce_status_encoding - end) + let encoding = nonce_status_encoding + end) module Seed = Indexed_context.Make_map @@ -1259,7 +1259,7 @@ module Commitments = let name = ["commitments"] end)) (Make_index (Blinded_public_key_hash.Index)) - (Tez_repr) + (Tez_repr) (** Ramp up rewards... *) @@ -1277,33 +1277,33 @@ module Ramp_up = struct let name = ["ramp_up"; "rewards"] end)) (Make_index (Cycle_repr.Index)) - (struct - type t = reward + (struct + type t = reward - let encoding = - Data_encoding.( - conv - (fun { - baking_reward_fixed_portion; - baking_reward_bonus_per_slot; - endorsing_reward_per_slot; - } -> - ( baking_reward_fixed_portion, - baking_reward_bonus_per_slot, - endorsing_reward_per_slot )) - (fun ( baking_reward_fixed_portion, - baking_reward_bonus_per_slot, - endorsing_reward_per_slot ) -> - { + let encoding = + Data_encoding.( + conv + (fun { baking_reward_fixed_portion; baking_reward_bonus_per_slot; endorsing_reward_per_slot; - }) - (obj3 - (req "baking_reward_fixed_portion" Tez_repr.encoding) - (req "baking_reward_bonus_per_slot" Tez_repr.encoding) - (req "endorsing_reward_per_slot" Tez_repr.encoding))) - end) + } -> + ( baking_reward_fixed_portion, + baking_reward_bonus_per_slot, + endorsing_reward_per_slot )) + (fun ( baking_reward_fixed_portion, + baking_reward_bonus_per_slot, + endorsing_reward_per_slot ) -> + { + baking_reward_fixed_portion; + baking_reward_bonus_per_slot; + endorsing_reward_per_slot; + }) + (obj3 + (req "baking_reward_fixed_portion" Tez_repr.encoding) + (req "baking_reward_bonus_per_slot" Tez_repr.encoding) + (req "endorsing_reward_per_slot" Tez_repr.encoding))) + end) end module Pending_migration = struct @@ -1571,11 +1571,11 @@ module Sc_rollup = struct let name = ["commitments"] end)) (Make_index (Sc_rollup_repr.Commitment_hash_index)) - (struct - type t = Sc_rollup_repr.Commitment.t + (struct + type t = Sc_rollup_repr.Commitment.t - let encoding = Sc_rollup_repr.Commitment.encoding - end) + let encoding = Sc_rollup_repr.Commitment.encoding + end) module Commitment_stake_count = Make_indexed_carbonated_data_storage @@ -1584,11 +1584,11 @@ module Sc_rollup = struct let name = ["commitment_stake_count"] end)) (Make_index (Sc_rollup_repr.Commitment_hash_index)) - (struct - type t = int32 + (struct + type t = int32 - let encoding = Data_encoding.int32 - end) + let encoding = Data_encoding.int32 + end) module Commitment_added = Make_indexed_carbonated_data_storage @@ -1597,11 +1597,11 @@ module Sc_rollup = struct let name = ["commitment_added"] end)) (Make_index (Sc_rollup_repr.Commitment_hash_index)) - (struct - type t = Raw_level_repr.t + (struct + type t = Raw_level_repr.t - let encoding = Raw_level_repr.encoding - end) + let encoding = Raw_level_repr.encoding + end) module Game = Make_indexed_carbonated_data_storage @@ -1610,11 +1610,11 @@ module Sc_rollup = struct let name = ["game"] end)) (Make_index (Sc_rollup_game_repr.Index)) - (struct - type t = Sc_rollup_game_repr.t + (struct + type t = Sc_rollup_game_repr.t - let encoding = Sc_rollup_game_repr.encoding - end) + let encoding = Sc_rollup_game_repr.encoding + end) module Game_timeout = Make_indexed_carbonated_data_storage @@ -1623,11 +1623,11 @@ module Sc_rollup = struct let name = ["game_timeout"] end)) (Make_index (Sc_rollup_game_repr.Index)) - (struct - type t = Raw_level_repr.t + (struct + type t = Raw_level_repr.t - let encoding = Raw_level_repr.encoding - end) + let encoding = Raw_level_repr.encoding + end) module Opponent = Make_indexed_carbonated_data_storage diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli index 19d08a472ba7..21565d0e3f31 100644 --- a/src/proto_alpha/lib_protocol/storage.mli +++ b/src/proto_alpha/lib_protocol/storage.mli @@ -398,7 +398,7 @@ module Delegate_sampler_state : Indexed_data_storage with type key = Cycle_repr.t and type value = - (Signature.Public_key.t * Signature.Public_key_hash.t) Sampler.t + (Signature.Public_key.t * Signature.Public_key_hash.t) Sampler.t and type t := Raw_context.t (** Votes *) diff --git a/src/proto_alpha/lib_protocol/storage_description.ml b/src/proto_alpha/lib_protocol/storage_description.ml index 7bac72c5a969..86aed867ac16 100644 --- a/src/proto_alpha/lib_protocol/storage_description.ml +++ b/src/proto_alpha/lib_protocol/storage_description.ml @@ -89,8 +89,8 @@ let pp_rev_path ppf path = let rec register_named_subcontext : type r. r t -> string list -> r t = fun desc names -> match (desc.dir, names) with - | (_, []) -> desc - | (Value _, _) | (IndexedDir _, _) -> + | _, [] -> desc + | Value _, _ | IndexedDir _, _ -> Format.kasprintf invalid_arg "Could not register a named subcontext at %a because of an existing %a." @@ -98,11 +98,11 @@ let rec register_named_subcontext : type r. r t -> string list -> r t = desc.rev_path pp desc - | (Empty, name :: names) -> + | Empty, name :: names -> let subdir = {rev_path = name :: desc.rev_path; dir = Empty} in desc.dir <- NamedDir (StringMap.singleton name subdir) ; register_named_subcontext subdir names - | (NamedDir map, name :: names) -> + | NamedDir map, name :: names -> let subdir = match StringMap.find name map with | Some subdir -> subdir @@ -130,8 +130,8 @@ let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function let unpack_l = unpack l in let unpack_r = unpack r in fun x -> - let (c, d) = unpack_r x in - let (b, a) = unpack_l c in + let c, d = unpack_r x in + let b, a = unpack_l c in (b, (a, d)) [@@coq_axiom_with_reason "gadt"] @@ -174,7 +174,7 @@ let rec register_indexed_subcontext : let equal_left x y = Compare.Int.(compare_left x y = 0) in let list_left r = list r >|=? fun l -> destutter equal_left l in let list_right r = - let (a, k) = unpack left r in + let a, k = unpack left r in list a >|=? fun l -> List.map snd (List.filter (fun (x, _) -> equal_left x k) l) in @@ -352,7 +352,7 @@ let build_directory : type key. key t -> key RPC_directory.t = (Tag 0) ~title:"Leaf" (dynamic_size arg_encoding) - (function (key, None) -> Some key | _ -> None) + (function key, None -> Some key | _ -> None) (fun key -> (key, None)); case (Tag 1) @@ -360,7 +360,7 @@ let build_directory : type key. key t -> key RPC_directory.t = (tup2 (dynamic_size arg_encoding) (dynamic_size handler.encoding)) - (function (key, Some value) -> Some (key, value) | _ -> None) + (function key, Some value -> Some (key, value) | _ -> None) (fun (key, value) -> (key, Some value)); ] in diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index df7cab104674..d32d3f00c456 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -219,7 +219,7 @@ module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t = struct | None -> None | Some (l1, l2) -> ( match (I1.of_path l1, I2.of_path l2) with - | (Some x, Some y) -> Some (x, y) + | Some x, Some y -> Some (x, y) | _ -> None) type 'a ipath = 'a I1.ipath I2.ipath @@ -260,7 +260,7 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : let unpack = unpack I.args in register_value (* TODO fixme 'elements...' *) ~get:(fun c -> - let (c, k) = unpack c in + let c, k = unpack c in mem c k >>= function true -> return_some true | false -> return_none) (register_indexed_subcontext ~list:(fun c -> elements c >|= ok) @@ -344,7 +344,7 @@ struct let unpack = unpack I.args in register_value ~get:(fun c -> - let (c, k) = unpack c in + let c, k = unpack c in find c k) (register_indexed_subcontext ~list:(fun c -> keys c >|= ok) @@ -486,7 +486,7 @@ module Make_indexed_carbonated_data_storage_INTERNAL ~init:(ok (s, [], offset, length)) ~f:(fun file tree acc -> match (C.Tree.kind tree, acc) with - | (`Tree, Ok (s, rev_values, offset, length)) -> ( + | `Tree, Ok (s, rev_values, offset, length) -> ( if Compare.Int.(length <= 0) then (* Keep going until the end, we have no means of short-circuiting *) Lwt.return acc @@ -534,7 +534,7 @@ module Make_indexed_carbonated_data_storage_INTERNAL let unpack = unpack I.args in register_value (* TODO export consumed gas ?? *) ~get:(fun c -> - let (c, k) = unpack c in + let c, k = unpack c in find c k >|=? fun (_, v) -> v) (register_indexed_subcontext ~list:(fun c -> keys_unaccounted c >|= ok) @@ -708,90 +708,90 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let to_key i k = I.to_path i k let mem c k = - let (t, i) = unpack c in + let t, i = unpack c in C.mem t (to_key i k) let mem_tree c k = - let (t, i) = unpack c in + let t, i = unpack c in C.mem_tree t (to_key i k) let get c k = - let (t, i) = unpack c in + let t, i = unpack c in C.get t (to_key i k) let get_tree c k = - let (t, i) = unpack c in + let t, i = unpack c in C.get_tree t (to_key i k) let find c k = - let (t, i) = unpack c in + let t, i = unpack c in C.find t (to_key i k) let find_tree c k = - let (t, i) = unpack c in + let t, i = unpack c in C.find_tree t (to_key i k) let list c ?offset ?length k = - let (t, i) = unpack c in + let t, i = unpack c in C.list t ?offset ?length (to_key i k) let init c k v = - let (t, i) = unpack c in + let t, i = unpack c in C.init t (to_key i k) v >|=? fun t -> pack t i let init_tree c k v = - let (t, i) = unpack c in + let t, i = unpack c in C.init_tree t (to_key i k) v >|=? fun t -> pack t i let update c k v = - let (t, i) = unpack c in + let t, i = unpack c in C.update t (to_key i k) v >|=? fun t -> pack t i let update_tree c k v = - let (t, i) = unpack c in + let t, i = unpack c in C.update_tree t (to_key i k) v >|=? fun t -> pack t i let add c k v = - let (t, i) = unpack c in + let t, i = unpack c in C.add t (to_key i k) v >|= fun t -> pack t i let add_tree c k v = - let (t, i) = unpack c in + let t, i = unpack c in C.add_tree t (to_key i k) v >|= fun t -> pack t i let add_or_remove c k v = - let (t, i) = unpack c in + let t, i = unpack c in C.add_or_remove t (to_key i k) v >|= fun t -> pack t i let add_or_remove_tree c k v = - let (t, i) = unpack c in + let t, i = unpack c in C.add_or_remove_tree t (to_key i k) v >|= fun t -> pack t i let remove_existing c k = - let (t, i) = unpack c in + let t, i = unpack c in C.remove_existing t (to_key i k) >|=? fun t -> pack t i let remove_existing_tree c k = - let (t, i) = unpack c in + let t, i = unpack c in C.remove_existing_tree t (to_key i k) >|=? fun t -> pack t i let remove c k = - let (t, i) = unpack c in + let t, i = unpack c in C.remove t (to_key i k) >|= fun t -> pack t i let fold ?depth c k ~order ~init ~f = - let (t, i) = unpack c in + let t, i = unpack c in C.fold ?depth t (to_key i k) ~order ~init ~f let config c = - let (t, _) = unpack c in + let t, _ = unpack c in C.config t module Tree = struct include C.Tree let empty c = - let (t, _) = unpack c in + let t, _ = unpack c in C.Tree.empty t end @@ -804,11 +804,11 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let equal_config = C.equal_config let project c = - let (t, _) = unpack c in + let t, _ = unpack c in C.project t let absolute_key c k = - let (t, i) = unpack c in + let t, i = unpack c in C.absolute_key t (to_key i k) type error += Block_quota_exceeded = C.Block_quota_exceeded @@ -816,17 +816,17 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : type error += Operation_quota_exceeded = C.Operation_quota_exceeded let consume_gas c g = - let (t, i) = unpack c in + let t, i = unpack c in C.consume_gas t g >>? fun t -> ok (pack t i) let check_enough_gas c g = - let (t, _i) = unpack c in + let t, _i = unpack c in C.check_enough_gas t g let description = description let length c = - let (t, _i) = unpack c in + let t, _i = unpack c in C.length t end @@ -844,18 +844,18 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let add s i = Raw_context.add (pack s i) N.name inited >|= fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in C.project s let remove s i = Raw_context.remove (pack s i) N.name >|= fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in C.project s let clear s = fold_keys s ~init:s ~order:`Sorted ~f:(fun i s -> Raw_context.remove (pack s i) N.name >|= fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in s) >|= fun t -> C.project t @@ -875,7 +875,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : in register_value ~get:(fun c -> - let (c, k) = unpack c in + let c, k = unpack c in mem c k >>= function true -> return_some true | false -> return_none) (register_named_subcontext description N.name) Data_encoding.bool @@ -911,39 +911,39 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let update s i v = Raw_context.update (pack s i) N.name (to_bytes v) >|=? fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in C.project s let init s i v = Raw_context.init (pack s i) N.name (to_bytes v) >|=? fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in C.project s let add s i v = Raw_context.add (pack s i) N.name (to_bytes v) >|= fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in C.project s let add_or_remove s i v = Raw_context.add_or_remove (pack s i) N.name (Option.map to_bytes v) >|= fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in C.project s let remove s i = Raw_context.remove (pack s i) N.name >|= fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in C.project s let remove_existing s i = Raw_context.remove_existing (pack s i) N.name >|=? fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in C.project s let clear s = fold_keys s ~order:`Sorted ~init:s ~f:(fun i s -> Raw_context.remove (pack s i) N.name >|= fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in s) >|= fun t -> C.project t @@ -968,7 +968,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let unpack = unpack I.args in register_value ~get:(fun c -> - let (c, k) = unpack c in + let c, k = unpack c in find c k) (register_named_subcontext Raw_context.description N.name) V.encoding @@ -1037,7 +1037,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let find s i = consume_mem_gas (pack s i) >>?= fun c -> - let (s, _) = unpack c in + let s, _ = unpack c in Raw_context.mem (pack s i) data_name >>= fun exists -> if exists then get s i >|=? fun (s, v) -> (s, Some v) else return (C.project s, None) @@ -1084,7 +1084,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let unpack = unpack I.args in register_value ~get:(fun c -> - let (c, k) = unpack c in + let c, k = unpack c in find c k >|=? fun (_, v) -> v) (register_named_subcontext Raw_context.description N.name) V.encoding diff --git a/src/proto_alpha/lib_protocol/test/helpers/account.ml b/src/proto_alpha/lib_protocol/test/helpers/account.ml index 47e8e5a2e7ec..76047a436749 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/account.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/account.ml @@ -41,7 +41,7 @@ let random_seed ~rng_state = Char.chr (Random.State.int rng_state 256)) let new_account ?seed () = - let (pkh, pk, sk) = Signature.generate_key ~algo:Ed25519 ?seed () in + let pkh, pk, sk = Signature.generate_key ~algo:Ed25519 ?seed () in let account = {pkh; pk; sk} in Signature.Public_key_hash.Table.add known_accounts pkh account ; account @@ -91,7 +91,7 @@ let generate_accounts ?rng_state ?(initial_balances = []) n : (t * Tez.t) list = in List.map (fun i -> - let (pkh, pk, sk) = + let pkh, pk, sk = Signature.generate_key ~algo:Ed25519 ~seed:(random_seed ~rng_state) () in let account = {pkh; pk; sk} in @@ -105,7 +105,7 @@ let commitment_secret = |> WithExceptions.Option.get ~loc:__LOC__ let new_commitment ?seed () = - let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in + let pkh, pk, sk = Signature.generate_key ?seed ~algo:Ed25519 () in let unactivated_account = {pkh; pk; sk} in let open Commitment in let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 3687342b17dd..6f2588e54c6b 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -27,7 +27,6 @@ open Protocol module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *) - open Alpha_context (* This type collects a block and the context that results from its application *) @@ -670,10 +669,10 @@ let bake_with_metadata ?locked_round ?policy ?timestamp ?operation ?operations ?payload_round ?check_size ~baking_mode ?liquidity_baking_toggle_vote pred = let operations = match (operation, operations) with - | (Some op, Some ops) -> Some (op :: ops) - | (Some op, None) -> Some [op] - | (None, Some ops) -> Some ops - | (None, None) -> None + | Some op, Some ops -> Some (op :: ops) + | Some op, None -> Some [op] + | None, Some ops -> Some ops + | None, None -> None in Forge.forge_header ?payload_round diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index 807fe29bd939..e08f29d45aa3 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -371,11 +371,11 @@ type (_, _) tup = let tup_hd : type a r. (a, r) tup -> r -> a = fun tup elts -> match (tup, elts) with - | (T1, v) -> v - | (T2, (v, _)) -> v - | (T3, (v, _, _)) -> v - | (TList _, v :: _) -> v - | (TList _, []) -> assert false + | T1, v -> v + | T2, (v, _) -> v + | T3, (v, _, _) -> v + | TList _, v :: _ -> v + | TList _, [] -> assert false let tup_n : type a r. (a, r) tup -> int = function | T1 -> 1 @@ -386,10 +386,10 @@ let tup_n : type a r. (a, r) tup -> int = function let tup_get : type a r. (a, r) tup -> a list -> r = fun tup list -> match (tup, list) with - | (T1, [v]) -> v - | (T2, [v1; v2]) -> (v1, v2) - | (T3, [v1; v2; v3]) -> (v1, v2, v3) - | (TList _, l) -> l + | T1, [v] -> v + | T2, [v1; v2] -> (v1, v2) + | T3, [v1; v2; v3] -> (v1, v2, v3) + | TList _, l -> l | _ -> assert false let init_gen tup ?rng_state ?commitments ?(initial_balances = []) diff --git a/src/proto_alpha/lib_protocol/test/helpers/expr.ml b/src/proto_alpha/lib_protocol/test/helpers/expr.ml index 37074c20b00e..468d09535ae8 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/expr.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/expr.ml @@ -30,7 +30,7 @@ exception Expression_from_string (** Parse a Michelson expression from string, raising an exception on error. *) let from_string ?(check_micheline_indentation = false) str : Script.expr = - let (ast, errs) = + let ast, errs = Michelson_v1_parser.parse_expression ~check:check_micheline_indentation str in (match errs with @@ -42,7 +42,7 @@ let from_string ?(check_micheline_indentation = false) str : Script.expr = (** Parses a Michelson contract from string, raising an exception on error. *) let toplevel_from_string ?(check_micheline_indentation = false) str = - let (ast, errs) = + let ast, errs = Michelson_v1_parser.parse_toplevel ~check:check_micheline_indentation str in match errs with [] -> ast.expanded | _ -> Stdlib.failwith "parse toplevel" diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index 4657e9431d05..e33ad28ded18 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -25,7 +25,6 @@ open Protocol module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *) - open Alpha_context type t = { @@ -171,12 +170,12 @@ let add_operation ?expect_apply_failure ?expect_failure ?(check_size = true) st Constants_repr.max_operation_data_length))) ; apply_operation st.state op >|= Environment.wrap_tzresult >>= fun result -> match (expect_apply_failure, result) with - | (Some _, Ok _) -> failwith "Error expected while adding operation" - | (Some f, Error err) -> f err >|=? fun () -> st - | (None, result) -> ( + | Some _, Ok _ -> failwith "Error expected while adding operation" + | Some f, Error err -> f err >|=? fun () -> st + | None, result -> ( result >>?= fun result -> match result with - | (state, (Operation_metadata result as metadata)) -> + | state, (Operation_metadata result as metadata) -> detect_script_failure result |> fun result -> (match expect_failure with | None -> Lwt.return result @@ -191,7 +190,7 @@ let add_operation ?expect_apply_failure ?expect_failure ?(check_size = true) st rev_operations = op :: st.rev_operations; rev_tickets = metadata :: st.rev_tickets; } - | (state, (No_operation_metadata as metadata)) -> + | state, (No_operation_metadata as metadata) -> return { st with diff --git a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.ml b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.ml index 878d6f4aaa82..6df79e0a3707 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.ml @@ -275,7 +275,7 @@ let gen_scenario : tzbtc -> liquidity -> int -> (specs * contract_id step list) QCheck.Gen.t = fun total_tzbtc total_liquidity size -> let* specs = gen_specs total_tzbtc total_liquidity in - let (state, env) = SymbolicMachine.build specs in + let state, env = SymbolicMachine.build specs in let+ scenario = gen_steps env state size in (specs, scenario) @@ -312,7 +312,7 @@ let gen_adversary_scenario : (specs * contract_id * contract_id step list) QCheck.Gen.t = fun total_tzbtc total_liquidity size -> let* specs = gen_specs total_tzbtc total_liquidity in - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let* c = oneofl env.implicit_accounts in let+ scenario = gen_steps ~source:c ~destination:c env state size in (specs, c, scenario) @@ -341,7 +341,7 @@ let arb_adversary_scenario : We shrink a valid scenario by removing steps from its tails, because a prefix of a valid scenario remains a valid scenario. Removing a random element of a scenario could lead to an - invalid scenario. *) + invalid scenario. *) (* Note (2) diff --git a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml index 958e24ef27c4..049f97313bc3 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml @@ -122,7 +122,7 @@ let far_future = Script_timestamp.of_zint (Z.of_int 42_000) module List_helpers = struct let rec zip l r = match (l, r) with - | (xl :: rstl, xr :: rstr) -> (xl, xr) :: zip rstl rstr + | xl :: rstl, xr :: rstr -> (xl, xr) :: zip rstl rstr | _ -> [] let nth_exn l n = @@ -476,7 +476,7 @@ module Machine = struct get_cpmm_total_liquidity env state >>= fun lqtTotal -> let lqtTotal = Z.of_int lqtTotal in let amount = Tez.of_mutez_exn xtz_deposit in - let (_, tokens_deposited) = + let _, tokens_deposited = Cpmm_logic.Simulate_raw.addLiquidity ~tokenPool ~xtzPool @@ -854,7 +854,7 @@ module ConcreteBaseMachine : let init ~invariant ?subsidy accounts_balances = let liquidity_baking_subsidy = Option.map Tez.of_mutez_exn subsidy in - let (n, initial_balances) = initial_xtz_repartition accounts_balances in + let n, initial_balances = initial_xtz_repartition accounts_balances in Context.init_n n ~consensus_threshold:0 @@ -869,7 +869,7 @@ module ConcreteBaseMachine : ?liquidity_baking_subsidy () >>= function - | (blk, holder :: accounts) -> + | blk, holder :: accounts -> let ctxt = Context.B blk in Context.get_liquidity_baking_cpmm_address ctxt >>= fun cpmm_contract -> Context.Contract.storage ctxt cpmm_contract >>= fun storage -> @@ -1055,13 +1055,13 @@ module AbstractMachine = struct Z.of_int @@ get_tzbtc_balance env.cpmm_contract env state in let tokensSold = Z.of_int tzbtc in - let (xtz_bought, xtz_net_bought) = + let xtz_bought, xtz_net_bought = Cpmm_logic.Simulate_raw.tokenToXtz ~xtzPool ~tokenPool ~tokensSold in (Z.to_int64 xtz_net_bought, Tez.to_mutez xtz_bought) let token_to_xtz ~src dst amount env _ state = - let (xtz_bought, xtz_net_bought) = xtz_bought amount env state in + let xtz_bought, xtz_net_bought = xtz_bought amount env state in state |> transfer_tzbtc_balance src env.cpmm_contract amount |> update_xtz_balance env.cpmm_contract (fun b -> Int64.sub b xtz_bought) @@ -1075,13 +1075,13 @@ module AbstractMachine = struct Z.of_int @@ get_tzbtc_balance env.cpmm_contract env state in let amount = Tez.of_mutez_exn amount in - let (tzbtc_bought, xtz_earnt) = + let tzbtc_bought, xtz_earnt = Cpmm_logic.Simulate_raw.xtzToToken ~xtzPool ~tokenPool ~amount in (Z.to_int tzbtc_bought, Z.to_int64 xtz_earnt) let xtz_to_token ~src dst amount env _ state = - let (tzbtc_bought, xtz_earnt) = tzbtc_bought env state amount in + let tzbtc_bought, xtz_earnt = tzbtc_bought env state amount in update_xtz_balance src (fun b -> Int64.sub b amount) state |> update_xtz_balance env.cpmm_contract (Int64.add xtz_earnt) |> transfer_tzbtc_balance env.cpmm_contract dst tzbtc_bought @@ -1100,7 +1100,7 @@ module AbstractMachine = struct in let lqtTotal = Z.of_int state.cpmm_total_liquidity in let amount = Tez.of_mutez_exn xtz_deposit in - let (lqt_minted, tokens_deposited) = + let lqt_minted, tokens_deposited = Cpmm_logic.Simulate_raw.addLiquidity ~tokenPool ~xtzPool @@ -1128,7 +1128,7 @@ module AbstractMachine = struct in let lqtTotal = Z.of_int state.cpmm_total_liquidity in let lqtBurned = Z.of_int lqt_burned in - let (xtz_withdrawn, tokens_withdrawn) = + let xtz_withdrawn, tokens_withdrawn = Cpmm_logic.Simulate_raw.removeLiquidity ~tokenPool ~xtzPool @@ -1181,7 +1181,7 @@ module SymbolicBaseMachine : end) let init ~invariant:_ ?(subsidy = default_subsidy) accounts_balances = - let (_, initial_balances) = initial_xtz_repartition accounts_balances in + let _, initial_balances = initial_xtz_repartition accounts_balances in let len = Int64.of_int (List.length accounts_balances) in match initial_balances with | holder_xtz :: accounts -> @@ -1193,15 +1193,12 @@ module SymbolicBaseMachine : cpmm_total_liquidity = cpmm_initial_liquidity_supply; accounts_balances = (Cpmm, {cpmm_initial_balance with xtz = xtz_cpmm}) - :: - (Holder, {xtz = holder_xtz; tzbtc = 0; liquidity = 0}) - :: - (TzBTCAdmin, {xtz = 0L; tzbtc = 0; liquidity = 0}) - :: - List.mapi - (fun i xtz -> - (ImplicitAccount i, {xtz; tzbtc = 0; liquidity = 0})) - accounts; + :: (Holder, {xtz = holder_xtz; tzbtc = 0; liquidity = 0}) + :: (TzBTCAdmin, {xtz = 0L; tzbtc = 0; liquidity = 0}) + :: List.mapi + (fun i xtz -> + (ImplicitAccount i, {xtz; tzbtc = 0; liquidity = 0})) + accounts; }, { cpmm_contract = Cpmm; @@ -1325,7 +1322,7 @@ module ValidationBaseMachine : ?subsidy balances >>= fun (blk, env) -> - let (state, _) = + let state, _ = SymbolicBaseMachine.init ~invariant:(fun _ _ -> true) ?subsidy balances in let state = refine_state env state in diff --git a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml index 7dc62faa10e5..dc5c6b4c8cf2 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml @@ -221,11 +221,11 @@ module Storage = struct >>=? fun (address_hash, ctxt) -> Big_map.get_opt ctxt tokens address_hash >|= Environment.wrap_tzresult >>=? function - | (_, Some canonical) -> ( + | _, Some canonical -> ( match Tezos_micheline.Micheline.root canonical with | Tezos_micheline.Micheline.Int (_, amount) -> return @@ Some amount | _ -> assert false) - | (_, None) -> return @@ None + | _, None -> return @@ None let getBalance (ctxt : Context.t) ~(contract : Contract.t) (owner : Script_typed_ir.address) = diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index ecfc414634ce..cd795053dbe5 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -185,7 +185,7 @@ let combine_operations ?public_key ?counter ?spurious_operation ~source ctxt | true -> (None, counter)) >>=? fun (manager_op, counter) -> (* Update counters and transform into a contents_list *) - let (counter, rev_operations) = + let counter, rev_operations = List.fold_left (fun (counter, acc) -> function | Contents (Manager_operation m) -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml index 8339f0f73f9b..7cdd89cfd055 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml @@ -85,7 +85,7 @@ module Common = struct let rec aux n index res = if Compare.Int.( <= ) n 0 then res else - let (new_index, new_addr) = + let new_index, new_addr = Tezos_sapling.Core.Client.Viewing_key.new_address vk index in aux (n - 1) new_index (new_addr :: res) @@ -316,7 +316,7 @@ module Alpha_context_helpers = struct let transfer w cs is = let anti_replay = "anti-replay" in - let (ins, outs) = transfer_inputs_outputs w cs is in + let ins, outs = transfer_inputs_outputs w cs is in (* change the wallet of this last line *) Tezos_sapling.Forge.forge_transaction ins @@ -328,7 +328,7 @@ module Alpha_context_helpers = struct let transfer_legacy w cs is = let anti_replay = "anti-replay" in - let (ins, outs) = transfer_inputs_outputs w cs is in + let ins, outs = transfer_inputs_outputs w cs is in (* change the wallet of this last line *) Tezos_sapling.Forge.forge_transaction_legacy ins outs w.sk anti_replay cs @@ -422,7 +422,7 @@ module Interpreter_helpers = struct let rec aux number_transac number_outputs index amount_output total res = if Compare.Int.(number_transac <= 0) then (res, total) else - let (new_index, new_addr) = + let new_index, new_addr = Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk index) in let outputs = diff --git a/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml b/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml index f87c824ccb84..cb704d6e0e0f 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml @@ -261,9 +261,9 @@ module Generators = struct | [] -> ([], None) | hd :: tl -> ( match replace_with_constant hd loc with - | (node, Some x) -> (node :: tl, Some x) - | (_, None) -> - let (l, x) = loop tl in + | node, Some x -> (node :: tl, Some x) + | _, None -> + let l, x = loop tl in (hd :: l, x)) in match node with @@ -283,7 +283,7 @@ module Generators = struct in (Prim (-1, H_constant, [String (-1, hash)], []), Some node) else - let (result, x) = loop args in + let result, x = loop args in (Prim (l, prim, result, annot), x) | Seq (l, args) as node -> if l = loc then @@ -293,7 +293,7 @@ module Generators = struct in (Prim (-1, H_constant, [String (-1, hash)], []), Some node) else - let (result, x) = loop args in + let result, x = loop args in (Seq (l, result), x) let micheline_gen p_gen annot_gen = @@ -318,8 +318,8 @@ module Generators = struct let size = Script_repr.micheline_nodes (root expr) in 0 -- (size - 1) >|= fun loc -> match replace_with_constant (root expr) loc with - | (_, None) -> assert false - | (node, Some replaced_node) -> + | _, None -> assert false + | node, Some replaced_node -> (expr, strip_locations node, strip_locations replaced_node) let canonical_with_constant_arbitrary () = diff --git a/src/proto_alpha/lib_protocol/test/helpers/tx_rollup_l2_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/tx_rollup_l2_helpers.ml index f254a406668f..33c9c482b6bb 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/tx_rollup_l2_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/tx_rollup_l2_helpers.ml @@ -99,7 +99,7 @@ let rng_state = Random.State.make_self_init () let gen_l1_address ?seed () = Signature.generate_key ~algo:Ed25519 ?seed () let gen_l2_address () = - let (_pkh, public_key, secret_key) = Bls.generate_key () in + let _pkh, public_key, secret_key = Bls.generate_key () in (secret_key, public_key, Tx_rollup_l2_address.of_bls_pk public_key) (** [make_unit_ticket_key ctxt ticketer l2_address] computes the key hash of diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml index 63f7b3b2de7a..f10301f8eae7 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml @@ -262,7 +262,7 @@ let test_rewards_block_and_payload_producer () = ~payload_round:(Some Round.zero) ~locked_round:(Some Round.zero) ~policy:(By_account baker_b2') - ~operations:(tx :: preendos @ endos) + ~operations:((tx :: preendos) @ endos) b1 >>=? fun b2' -> (* [baker_b2], as payload producer, gets the block reward and the fees *) @@ -336,7 +336,7 @@ let test_enough_active_stake_to_bake ~has_active_stake () = let test_committee_sampling () = let test_distribution max_round distribution = - let (initial_balances, bounds) = List.split distribution in + let initial_balances, bounds = List.split distribution in let accounts = Account.generate_accounts ~initial_balances (List.length initial_balances) in @@ -374,7 +374,7 @@ let test_committee_sampling () = bounds ; List.iter (fun {Plugin.RPC.Baking_rights.delegate = pkh; _} -> - let (bounds, n) = Stdlib.Hashtbl.find stats pkh in + let bounds, n = Stdlib.Hashtbl.find stats pkh in Stdlib.Hashtbl.replace stats pkh (bounds, n + 1)) bakers ; let one_failed = ref false in diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_delegation.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_delegation.ml index a92324b2a502..e9bf056d429b 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_delegation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_delegation.ml @@ -1291,15 +1291,15 @@ let tests_delegate_registration = ~amount:Tez.one_mutez ~fee:max_tez); Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (switch with \ - delegation, small fee)" + "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, \ + small fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit_debit ~amount:Tez.one_mutez ~fee:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (switch with \ - delegation, large fee)" + "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, \ + large fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit_debit ~amount:Tez.one_mutez @@ -1324,29 +1324,27 @@ let tests_delegate_registration = ~fee:(of_int 10_000_000) ~amount:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (init with delegation, small \ - fee)" + "unregistered delegate key - credit 1μꜩ (init with delegation, small fee)" `Quick (test_unregistered_delegate_key_init_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (init with delegation, large \ - fee)" + "unregistered delegate key - credit 1μꜩ (init with delegation, large fee)" `Quick (test_unregistered_delegate_key_init_delegation_credit ~amount:Tez.one_mutez ~fee:max_tez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (switch with delegation, \ - small fee)" + "unregistered delegate key - credit 1μꜩ (switch with delegation, small \ + fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.one_mutez); Tztest.tztest - "unregistered delegate key - credit 1μꜩ (switch with delegation, \ - large fee)" + "unregistered delegate key - credit 1μꜩ (switch with delegation, large \ + fee)" `Quick (test_unregistered_delegate_key_switch_delegation_credit ~amount:Tez.one_mutez @@ -1395,8 +1393,8 @@ let tests_delegate_registration = (test_failed_self_delegation_emptied_implicit_contract Tez.one_mutez); (* credit 1μtz, delegate, debit 1μtz *) Tztest.tztest - "empty delegated contract is not deleted: credit 1μꜩ, delegate & \ - debit 1μꜩ" + "empty delegated contract is not deleted: credit 1μꜩ, delegate & debit \ + 1μꜩ" `Quick (test_emptying_delegated_implicit_contract_fails Tez.one_mutez); (*** valid registration ***) @@ -1407,20 +1405,20 @@ let tests_delegate_registration = `Quick (test_valid_delegate_registration_init_delegation_credit Tez.one_mutez); Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation (switch \ - with delegation)" + "valid delegate registration: credit 1μꜩ, self delegation (switch with \ + delegation)" `Quick (test_valid_delegate_registration_switch_delegation_credit Tez.one_mutez); (* valid registration: credit 1 μꜩ, self delegation, debit 1μꜩ *) Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation, debit \ - 1μꜩ (init with delegation)" + "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ \ + (init with delegation)" `Quick (test_valid_delegate_registration_init_delegation_credit_debit Tez.one_mutez); Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation, debit \ - 1μꜩ (switch with delegation)" + "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ \ + (switch with delegation)" `Quick (test_valid_delegate_registration_switch_delegation_credit_debit Tez.one_mutez); diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_baking.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_baking.ml index 5aacf11ca926..3eb68159fc42 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_baking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_baking.ml @@ -58,7 +58,7 @@ let order_block_hashes ~correct_order bh1 bh2 = else (bh1, bh2) let double_baking ctxt ?(correct_order = true) bh1 bh2 = - let (bh1, bh2) = order_block_hashes ~correct_order bh1 bh2 in + let bh1, bh2 = order_block_hashes ~correct_order bh1 bh2 in Op.double_baking ctxt bh1 bh2 (****************************************************************) @@ -104,7 +104,7 @@ let order_endorsements ~correct_order op1 op2 = [test_valid_double_baking_followed_by_double_endorsing] and [test_valid_double_endorsing_followed_by_double_baking] *) let double_endorsement ctxt ?(correct_order = true) op1 op2 = - let (e1, e2) = order_endorsements ~correct_order op1 op2 in + let e1, e2 = order_endorsements ~correct_order op1 op2 in Op.double_endorsement ctxt e1 e2 let test_valid_double_baking_followed_by_double_endorsing () = diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_endorsement.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_endorsement.ml index b5e849ed6baf..b91a39c9d528 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_endorsement.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_endorsement.ml @@ -58,7 +58,7 @@ let order_endorsements ~correct_order op1 op2 = else (op1, op2) let double_endorsement ctxt ?(correct_order = true) op1 op2 = - let (e1, e2) = order_endorsements ~correct_order op1 op2 in + let e1, e2 = order_endorsements ~correct_order op1 op2 in Op.double_endorsement ctxt e1 e2 (** This test verifies that when a "cheater" double endorses and @@ -236,7 +236,7 @@ let test_different_delegates () = Context.get_endorser (B blk_a) >>=? fun (endorser_a, a_slots) -> Context.get_first_different_endorsers (B blk_b) >>=? fun (endorser_b1c, endorser_b2c) -> - let (endorser_b, b_slots) = + let endorser_b, b_slots = if Signature.Public_key_hash.( = ) endorser_a endorser_b1c.delegate then (endorser_b2c.delegate, endorser_b2c.slots) else (endorser_b1c.delegate, endorser_b1c.slots) @@ -274,7 +274,7 @@ let test_wrong_delegate () = >>=? fun endorsement_a -> Context.get_endorser_n (B blk_b) 0 >>=? fun (endorser0, slots0) -> Context.get_endorser_n (B blk_b) 1 >>=? fun (endorser1, slots1) -> - let (endorser_b, b_slots) = + let endorser_b, b_slots = if Signature.Public_key_hash.equal endorser_a endorser0 then (endorser1, slots1) else (endorser0, slots0) diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_preendorsement.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_preendorsement.ml index 810c9d4e810c..1f844fe614b8 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_preendorsement.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_preendorsement.ml @@ -147,7 +147,7 @@ end = struct situation. In case baker <> endorser, bal_bad of the baker gets half of burnt deposit of d1, so it's higher *) - let (high, low) = + let high, low = if Signature.Public_key_hash.equal baker d1 then (bal_good, bal_bad) else (bal_bad, bal_good) in @@ -189,7 +189,7 @@ end = struct >>=? fun op1 -> Op.preendorsement ~delegate:d2 ~endorsed_block:head_B (B blk) () >>=? fun op2 -> - let (op1, op2) = order_preendorsements ~correct_order:true op1 op2 in + let op1, op2 = order_preendorsements ~correct_order:true op1 op2 in (* bake `nb_blocks_before_denunciation` before double preend. denunciation *) bake_n nb_blocks_before_denunciation blk >>=? fun blk -> let op : Operation.packed = Op.double_preendorsement (B blk) op1 op2 in diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_frozen_deposits.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_frozen_deposits.ml index e097a222b058..e09c1b05b9d7 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_frozen_deposits.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_frozen_deposits.ml @@ -51,24 +51,24 @@ let get_first_2_accounts_contracts (a1, a2) = (* Terminology: -- staking balance = full balance + delegated stake; obtained with - Delegate.staking_balance + - staking balance = full balance + delegated stake; obtained with + Delegate.staking_balance -- active stake = the amount of tez with which a delegate participates in - consensus; it must be greater than 1 roll and less or equal the staking - balance; it is computed in [Delegate_storage.select_distribution_for_cycle] + - active stake = the amount of tez with which a delegate participates in + consensus; it must be greater than 1 roll and less or equal the staking + balance; it is computed in [Delegate_storage.select_distribution_for_cycle] -- frozen deposits = represents frozen_deposits_percentage of the maximum stake during - preserved_cycles + max_slashing_period cycles; obtained with - Delegate.current_frozen_deposits + - frozen deposits = represents frozen_deposits_percentage of the maximum stake during + preserved_cycles + max_slashing_period cycles; obtained with + Delegate.current_frozen_deposits -- spendable balance = full balance - frozen deposits; obtained with Contract.balance + - spendable balance = full balance - frozen deposits; obtained with Contract.balance -- full balance = spendable balance + frozen deposits; obtained with Delegate.full_balance + - full balance = spendable balance + frozen deposits; obtained with Delegate.full_balance *) let test_invariants () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, _account2)) = + let (contract1, account1), (contract2, _account2) = get_first_2_accounts_contracts contracts in Context.Delegate.staking_balance (B genesis) account1 @@ -129,7 +129,7 @@ let test_invariants () = let test_set_limit balance_percentage () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in (Context.Delegate.frozen_deposits_limit (B genesis) account1 >>=? function @@ -187,7 +187,7 @@ let test_set_limit balance_percentage () = let test_set_too_high_limit () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((contract1, _account1), _) = get_first_2_accounts_contracts contracts in + let (contract1, _account1), _ = get_first_2_accounts_contracts contracts in let max_limit = Tez.of_mutez_exn Int64.( @@ -216,7 +216,7 @@ let test_set_too_high_limit () = let test_unset_limit () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.current_frozen_deposits (B genesis) account1 @@ -263,7 +263,7 @@ let test_unset_limit () = let test_cannot_bake_with_zero_deposits () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in (* N.B. there is no non-zero frozen deposits value for which one cannot bake: @@ -296,7 +296,7 @@ let test_cannot_bake_with_zero_deposits () = let test_deposits_after_stake_removal () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.current_frozen_deposits (B genesis) account1 @@ -364,7 +364,7 @@ let test_deposits_after_stake_removal () = let test_unfreeze_deposits_after_deactivation () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((contract1, account1), (_contract2, account2)) = + let (contract1, account1), (_contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.full_balance (B genesis) account1 >>=? fun initial_balance -> @@ -410,7 +410,7 @@ let test_unfreeze_deposits_after_deactivation () = let test_frozen_deposits_with_delegation () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((_contract1, account1), (contract2, account2)) = + let (_contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in Context.Delegate.staking_balance (B genesis) account1 @@ -470,7 +470,7 @@ let test_frozen_deposits_with_delegation () = let test_frozen_deposits_with_overdelegation () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in (* - [account1] and [account2] give their spendable balance to [new_account] @@ -549,7 +549,7 @@ let test_frozen_deposits_with_overdelegation () = let test_set_limit_with_overdelegation () = let constants = {constants with frozen_deposits_percentage = 10} in Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let ((contract1, account1), (contract2, account2)) = + let (contract1, account1), (contract2, account2) = get_first_2_accounts_contracts contracts in (* - [account1] and [account2] will give 80% of their balance to @@ -617,7 +617,7 @@ let test_set_limit_with_overdelegation () = [new_cycle + preserved_cycles]. *) let test_error_is_thrown_when_smaller_upper_bound_for_frozen_window () = Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (contract1, contract2) = contracts in + let contract1, contract2 = contracts in let account1 = Context.Contract.pkh contract1 in (* [account2] delegates (through [new_account]) to [account1] its spendable balance. The point is to make [account1] have a lot of staking balance so diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_participation.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_participation.ml index 919ef95c96b0..7b39c2bfed10 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_participation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_participation.ml @@ -78,7 +78,7 @@ let test_participation ~sufficient_participation () = let minimal_nb_active_slots = mpr.numerator * expected_nb_slots / mpr.denominator in - let (account1, account2) = + let account1, account2 = match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false in let del1 = Context.Contract.pkh account1 in @@ -94,7 +94,7 @@ let test_participation ~sufficient_participation () = Environment.wrap_tzresult (Raw_level.of_int32 int_level) >>?= fun level -> Context.get_endorsing_power_for_delegate (B b_crt) ~levels:[level] del1 >>=? fun endorsing_power_for_level -> - let (endorser, new_endorsing_power) = + let endorser, new_endorsing_power = if sufficient_participation && endorsing_power < minimal_nb_active_slots then (del2, endorsing_power + endorsing_power_for_level) else (del1, endorsing_power) diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml index a1f93f13e021..fe2123e86329 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml @@ -82,11 +82,11 @@ end = struct b1 >>= fun res -> match (res, post_process) with - | (Ok ok, Ok success_fun) -> success_fun ok - | (Error _, Error (error_title, _error_category)) -> + | Ok ok, Ok success_fun -> success_fun ok + | Error _, Error (error_title, _error_category) -> Assert.proto_error_with_info ~loc res error_title - | (Ok _, Error _) -> Assert.error ~loc res (fun _ -> false) - | (Error _, Ok _) -> Assert.error ~loc res (fun _ -> false) + | Ok _, Error _ -> Assert.error ~loc res (fun _ -> false) + | Error _, Ok _ -> Assert.error ~loc res (fun _ -> false) (****************************************************************) (* Tests *) diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_seed.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_seed.ml index e51bd253c91d..afb73d4646ea 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_seed.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_seed.ml @@ -104,7 +104,7 @@ let test_revelation_early_wrong_right_twice () = Block.bake_until_cycle_end ~policy b >>=? fun b -> (* test that revealing at the right time but the wrong value produces an error *) - let (wrong_hash, _) = Nonce.generate () in + let wrong_hash, _ = Nonce.generate () in Op.seed_nonce_revelation (B b) level_commitment diff --git a/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_levels.ml b/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_levels.ml index 54fe48a4537b..0f5d52e56ce7 100644 --- a/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_levels.ml +++ b/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_levels.ml @@ -220,10 +220,10 @@ let apply_with_gas header ?(operations = []) (pred : Block.t) = let bake_with_gas ?policy ?timestamp ?operation ?operations pred = let operations = match (operation, operations) with - | (Some op, Some ops) -> Some (op :: ops) - | (Some op, None) -> Some [op] - | (None, Some ops) -> Some ops - | (None, None) -> None + | Some op, Some ops -> Some (op :: ops) + | Some op, None -> Some [op] + | None, Some ops -> Some ops + | None, None -> None in Block.Forge.forge_header ?timestamp ?policy ?operations pred >>=? fun header -> @@ -299,7 +299,7 @@ let block_with_one_origination contract = let full_block () = init_block [nil_contract; fail_contract; loop_contract] >>=? fun (block, src, originated) -> - let (dst_nil, dst_fail, dst_loop) = + let dst_nil, dst_fail, dst_loop = match originated with [c1; c2; c3] -> (c1, c2, c3) | _ -> assert false in return (block, src, dst_nil, dst_fail, dst_loop) @@ -392,10 +392,9 @@ let test_malformed_block_max_limit_reached () = *) let lld = [(dst, Alpha_context.Gas.Arith.integral_of_int_exn 1)] - :: - List.map - (fun _ -> [(dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)]) - [1; 1; 1; 1; 1] + :: List.map + (fun _ -> [(dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)]) + [1; 1; 1; 1; 1] in bake_operations_with_gas ~counter:Z.one block src lld >>= function | Error _ -> return_unit @@ -416,10 +415,9 @@ let test_malformed_block_max_limit_reached' () = let lld = [ (dst, Alpha_context.Gas.Arith.integral_of_int_exn 1) - :: - List.map - (fun _ -> (dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)) - [1; 1; 1; 1; 1]; + :: List.map + (fun _ -> (dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)) + [1; 1; 1; 1; 1]; ] in bake_operations_with_gas ~counter:Z.one block src lld >>= function diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_block_time_instructions.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_block_time_instructions.ml index 44a4a6a8887e..c9870db5a549 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_block_time_instructions.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_block_time_instructions.ml @@ -37,14 +37,14 @@ open Alpha_context let context_with_constants constants = let open Lwt_result_syntax in - let* (block, _contracts) = Context.init_with_constants1 constants in + let* block, _contracts = Context.init_with_constants1 constants in let+ incremental = Incremental.begin_construction block in Incremental.alpha_ctxt incremental let test_min_block_time () = let open Lwt_result_syntax in let* context = context_with_constants Default_parameters.constants_mainnet in - let* (result, _) = + let* result, _ = Contract_helpers.run_script context ~storage:"0" diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml index cd55c3228f92..03a84159c6b2 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml @@ -81,12 +81,11 @@ let gen_diffs idx : list = let open Lazy_storage_diff in Remove - :: - (gen_inits idx - |> List.map (fun (init, updates_lens) -> - gen_updates_list updates_lens - |> List.map (fun updates -> Update {init; updates})) - |> List.flatten) + :: (gen_inits idx + |> List.map (fun (init, updates_lens) -> + gen_updates_list updates_lens + |> List.map (fun updates -> Update {init; updates})) + |> List.flatten) let gen_diffs_items idx : Lazy_storage_diff.diffs_item list = let id = ids.(idx) in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml index 5c4fac892119..1568557b3db2 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml @@ -162,7 +162,7 @@ module Legacy_patch_test (Patches : LEGACY_SCRIPT_PATCHES) : (* Number 3 below controls how many accounts should be created. This number shouldn't be too small or the context won't have enough tokens to form a roll. *) - let* (block, _contracts) = Context.init3 () in + let* block, _contracts = Context.init3 () in let* inc = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt inc in let* _ = diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml index b05e03bf67dc..e87874738316 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml @@ -607,7 +607,7 @@ module Interpreter_tests = struct originate_contract "contracts/sapling_contract.tz" "{ }" src0 genesis baker >>=? fun (dst, b1, anti_replay) -> let wa = wallet_gen () in - let (list_transac, total) = + let list_transac, total = shield ~memo_size wa.sk 4 wa.vk (Format.sprintf "0x%s") anti_replay in let parameters = parameters_of_list list_transac in @@ -615,7 +615,7 @@ module Interpreter_tests = struct transac_and_sync ~memo_size b1 parameters total src0 dst baker >>=? fun (b2, _state) -> (* we shield again on another block, forging with the empty state *) - let (list_transac, total) = + let list_transac, total = shield ~memo_size wa.sk 4 wa.vk (Format.sprintf "0x%s") anti_replay in let parameters = parameters_of_list list_transac in @@ -807,7 +807,7 @@ module Interpreter_tests = struct it as a parameter *) let wa = wallet_gen () in - let (transactions, _total) = + let transactions, _total = shield ~memo_size wa.sk @@ -984,7 +984,7 @@ module Interpreter_tests = struct originate_contract "contracts/sapling_contract_drop.tz" "Unit" src b baker >>=? fun (dst, b, anti_replay) -> let {sk; vk} = wallet_gen () in - let (list_transac, _total) = + let list_transac, _total = shield ~memo_size:8 sk 4 vk (Format.sprintf "0x%s") anti_replay in let parameters = parameters_of_list list_transac in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_cache.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_cache.ml index fc035b42bb32..43443e4f230e 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_cache.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_cache.ml @@ -171,12 +171,11 @@ let test_find_correctly_looks_up () = Contract.get_script ctxt addr >|= Environment.wrap_tzresult >>=? fun (ctxt, script) -> (match (result, script) with - | (None, _) -> ok false - | (Some _, None) -> + | None, _ -> ok false + | Some _, None -> (* because we assume that get_script correctly behaves. *) assert false - | (Some (cached_script, _), Some script) -> - equal_scripts script cached_script) + | Some (cached_script, _), Some script -> equal_scripts script cached_script) >>?= fun cond -> fail_unless cond @@ -356,7 +355,7 @@ let test_entries_shows_lru () = (List.length rev_entries) (List.length rev_contracts) ; match (rev_entries, rev_contracts) with - | ([], _) -> + | [], _ -> (* We do not count liquidity baking contract. *) let removed_contracts = List.length rev_contracts - 1 in fail_unless @@ -367,7 +366,7 @@ let test_entries_shows_lru () = is full, %d remaining while expecting %d" removed_contracts (ncontracts / 2))) - | ((contract, size) :: rev_entries, (_, contract') :: rev_contracts) -> + | (contract, size) :: rev_entries, (_, contract') :: rev_contracts -> fail_unless (size = new_size || contract = liquidity_baking_contract) (err @@ -383,7 +382,7 @@ let test_entries_shows_lru () = (Printf.sprintf "entries do not return cached contracts in right order")) >>=? fun () -> aux rev_entries rev_contracts - | (_, []) -> + | _, [] -> (* There cannot be more entries than contracts. *) assert false in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml index 211a5fe3c090..cf55b895045a 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml @@ -163,7 +163,7 @@ let nsample = 100 let check_value_size () = let check (Ex (what, ty, v, error)) = let expected_size = footprint v in - let (_, size) = Script_typed_ir_size.value_size ty v in + let _, size = Script_typed_ir_size.value_size ty v in let size = Saturation_repr.to_int size in fail_when (expected_size + error < size || size < expected_size) @@ -641,7 +641,7 @@ let check_ty_size () = match (sample_ty (Random.int 10 + 1) : ex_ty) with | Ex_ty ty -> let expected_size = footprint ty in - let (_, size) = Script_typed_ir_size.Internal_for_tests.ty_size ty in + let _, size = Script_typed_ir_size.Internal_for_tests.ty_size ty in let size = Saturation_repr.to_int size in let what = "some type" in fail_when diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index 97b0db9465a8..f21f1fbdda08 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -55,7 +55,7 @@ let string_list_of_ex_token_diffs ctxt token_diffs = let open Lwt_result_syntax in let accum (xs, ctxt) (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = - let* (x, ctxt) = + let* x, ctxt = wrap @@ Script_ir_translator.unparse_comparable_data ~loc:() @@ -76,18 +76,18 @@ let string_list_of_ex_token_diffs ctxt token_diffs = in return (str :: xs, ctxt) in - let* (xs, ctxt) = List.fold_left_es accum ([], ctxt) token_diffs in + let* xs, ctxt = List.fold_left_es accum ([], ctxt) token_diffs in return (List.rev xs, ctxt) let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = let open Lwt_result_syntax in wrap - @@ let*? (Script_ir_translator.Ex_comparable_ty contents_type, ctxt) = + @@ let*? Script_ir_translator.Ex_comparable_ty contents_type, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in Script_ir_translator.parse_comparable_ty ctxt node in let*? ticketer = Contract.of_b58check ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in Script_ir_translator.parse_comparable_data ctxt contents_type node in @@ -95,7 +95,7 @@ let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = let assert_equal_ticket_diffs ~loc ctxt given expected = let open Lwt_result_syntax in - let* (ctxt, tbs1) = + let* ctxt, tbs1 = List.fold_left_map_es (fun ctxt ((ticketer, content), delta) -> make_ex_token @@ -107,8 +107,8 @@ let assert_equal_ticket_diffs ~loc ctxt given expected = ctxt expected in - let* (tbs1, ctxt) = string_list_of_ex_token_diffs ctxt tbs1 in - let* (tbs2, _ctxt) = string_list_of_ex_token_diffs ctxt given in + let* tbs1, ctxt = string_list_of_ex_token_diffs ctxt tbs1 in + let* tbs2, _ctxt = string_list_of_ex_token_diffs ctxt given in assert_equal_string_list ~loc "Compare token balances" @@ -119,10 +119,10 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = let open Lwt_result_syntax in List.fold_right_es (fun (key, value) (kvs, ctxt) -> - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap (Script_ir_translator.hash_comparable_data ctxt key_type key) in - let* (key_node, ctxt) = + let* key_node, ctxt = wrap (Script_ir_translator.unparse_comparable_data ~loc:Micheline.dummy_location @@ -131,11 +131,11 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = key_type key) in - let* (value, ctxt) = + let* value, ctxt = match value with | None -> return (None, ctxt) | Some value -> - let* (value_node, ctxt) = + let* value_node, ctxt = wrap (Script_ir_translator.unparse_data ctxt @@ -159,8 +159,8 @@ let make_alloc big_map_id alloc updates = let init () = let open Lwt_result_syntax in - let* (block, source) = Context.init1 () in - let* (operation, originated) = + let* block, source = Context.init1 () in + let* operation, originated = Op.contract_origination (B block) source ~script:Op.dummy_script in let* block = Block.bake ~operation block in @@ -190,22 +190,22 @@ let ticket_list_script = let setup ctxt ~key_type ~value_type entries = let open Lwt_result_syntax in - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in - let* (updates, ctxt) = + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* updates, ctxt = updates_of_key_values ctxt ~key_type ~value_type (List.map (fun (k, v) -> (k, Some v)) entries) in - let*? (key_type_node, ctxt) = + let*? key_type_node, ctxt = Environment.wrap_tzresult @@ Script_ir_translator.unparse_ty ~loc:Micheline.dummy_location ctxt key_type in - let*? (value_type_node, ctxt) = + let*? value_type_node, ctxt = Environment.wrap_tzresult @@ Script_ir_translator.unparse_ty ~loc:Micheline.dummy_location @@ -219,7 +219,7 @@ let setup ctxt ~key_type ~value_type entries = let new_big_map ctxt contract ~key_type ~value_type entries = let open Lwt_result_syntax in - let* (alloc, big_map_id, ctxt) = setup ctxt ~key_type ~value_type entries in + let* alloc, big_map_id, ctxt = setup ctxt ~key_type ~value_type entries in let storage = Expr.from_string "{}" in let* ctxt = wrap @@ Contract.update_script_storage ctxt contract storage (Some [alloc]) @@ -228,25 +228,25 @@ let new_big_map ctxt contract ~key_type ~value_type entries = let alloc_diff ctxt ~key_type ~value_type entries = let open Lwt_result_syntax in - let* (allocations, _, ctxt) = setup ctxt ~key_type ~value_type entries in + let* allocations, _, ctxt = setup ctxt ~key_type ~value_type entries in return (allocations, ctxt) let remove_diff ctxt contract ~key_type ~value_type ~existing_entries = let open Lwt_result_syntax in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in return (Lazy_storage.make Lazy_storage.Kind.Big_map big_map_id Remove, ctxt) let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = let open Lwt_result_syntax in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in - let* (updates, ctxt) = + let* updates, ctxt = updates_of_key_values ctxt ~key_type ~value_type updates in - let* (ctxt, new_big_map_id) = wrap @@ Big_map.fresh ctxt ~temporary:false in + let* ctxt, new_big_map_id = wrap @@ Big_map.fresh ctxt ~temporary:false in return ( Lazy_storage.make Lazy_storage.Kind.Big_map @@ -257,10 +257,10 @@ let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = let open Lwt_result_syntax in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in - let* (updates, ctxt) = + let* updates, ctxt = updates_of_key_values ctxt ~key_type ~value_type updates in return @@ -273,7 +273,7 @@ let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates let empty_big_map ctxt ~key_type ~value_type = let open Lwt_result_syntax in let open Script_typed_ir in - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in return ( Big_map { @@ -287,7 +287,7 @@ let empty_big_map ctxt ~key_type ~value_type = let make_big_map ctxt contract ~key_type ~value_type entries = let open Lwt_result_syntax in let open Script_typed_ir in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type entries in return @@ -307,7 +307,7 @@ let originate_script block ~script ~storage ~src ~baker ~forges_tickets = let script = Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} in - let* (operation, destination) = + let* operation, destination = Op.contract_origination (B block) src ~fee:(Test_tez.of_int 10) ~script in let* incr = @@ -362,7 +362,7 @@ let origination_operation ctxt ~src ~script ~orig_contract = let originate block ~src ~baker ~script ~storage ~forges_tickets = let open Lwt_result_syntax in - let* (orig_contract, script, block) = + let* orig_contract, script, block = originate_script block ~script ~storage ~src ~baker ~forges_tickets in let* incr = @@ -372,7 +372,7 @@ let originate block ~src ~baker ~script ~storage ~forges_tickets = let transfer_operation ctxt ~src ~destination ~arg_type ~arg = let open Lwt_result_syntax in - let* (params_node, ctxt) = + let* params_node, ctxt = wrap (Script_ir_translator.unparse_data ctxt @@ -421,9 +421,9 @@ let type_has_tickets ctxt ty = let assert_ticket_diffs ctxt ~loc ~arg_type ~storage_type ~arg ~old_storage ~new_storage ~lazy_storage_diff expected = let open Lwt_result_syntax in - let*? (arg_type_has_tickets, ctxt) = type_has_tickets ctxt arg_type in - let*? (storage_type_has_tickets, ctxt) = type_has_tickets ctxt storage_type in - let* (ticket_diff, ctxt) = + let*? arg_type_has_tickets, ctxt = type_has_tickets ctxt arg_type in + let*? storage_type_has_tickets, ctxt = type_has_tickets ctxt storage_type in + let* ticket_diff, ctxt = wrap (Ticket_accounting.ticket_diffs ctxt @@ -434,19 +434,19 @@ let assert_ticket_diffs ctxt ~loc ~arg_type ~storage_type ~arg ~old_storage ~new_storage ~lazy_storage_diff) in - let*? (ticket_diffs, ctxt) = + let*? ticket_diffs, ctxt = Environment.wrap_tzresult @@ Ticket_token_map.to_list ctxt ticket_diff in assert_equal_ticket_diffs ~loc ctxt ticket_diffs expected let assert_balance ctxt ~loc key expected = let open Lwt_result_syntax in - let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + let* balance, _ = wrap @@ Ticket_balance.get_balance ctxt key in match (balance, expected) with - | (Some b, Some eb) -> Assert.equal_int ~loc (Z.to_int b) eb - | (None, Some eb) -> failwith "Expected balance %d" eb - | (Some eb, None) -> failwith "Expected None but got %d" (Z.to_int eb) - | (None, None) -> return () + | Some b, Some eb -> Assert.equal_int ~loc (Z.to_int b) eb + | None, Some eb -> failwith "Expected balance %d" eb + | Some eb, None -> failwith "Expected None but got %d" (Z.to_int eb) + | None, None -> return () let string_ticket ticketer contents amount = let amount = Script_int.abs @@ Script_int.of_int amount in @@ -474,12 +474,12 @@ let string_ticket_token ticketer content = let test_diffs_empty () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_t ~value_type:ticket_string_type in (* Start with an empty big-map *) - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type in assert_ticket_diffs @@ -498,7 +498,7 @@ let test_diffs_empty () = let test_diffs_tickets_in_args () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let arg = string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 in assert_ticket_diffs ctxt @@ -515,7 +515,7 @@ let test_diffs_tickets_in_args () = storage, results in an empty diff. *) let test_diffs_tickets_in_args_and_storage () = let open Lwt_result_syntax in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let arg = string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 in assert_ticket_diffs ctxt @@ -532,7 +532,7 @@ let test_diffs_tickets_in_args_and_storage () = storage results in a negative diff. *) let test_diffs_drop_one_ticket () = let open Lwt_result_syntax in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let arg = boxed_list [ @@ -561,7 +561,7 @@ let test_diffs_drop_one_ticket () = balance. *) let test_diffs_adding_new_ticket_to_storage () = let open Lwt_result_syntax in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let new_storage = boxed_list [string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1] in @@ -580,7 +580,7 @@ let test_diffs_adding_new_ticket_to_storage () = diff. *) let test_diffs_remove_from_storage () = let open Lwt_result_syntax in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let old_storage = boxed_list [ @@ -609,16 +609,16 @@ let test_diffs_remove_from_storage () = let test_diffs_lazy_storage_alloc () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (_contract, ctxt) = init () in + let* _contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_t ~value_type:ticket_string_type in (* Start with an empty big-map *) - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type in (* We add one ticket to the storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = alloc_diff ctxt ~key_type:int_t @@ -643,16 +643,16 @@ let test_diffs_lazy_storage_alloc () = let test_diffs_remove_from_big_map () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (contract, ctxt) = init () in + let* contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_t ~value_type:ticket_string_type in (* Start with an empty big-map *) - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type in (* Remove one ticket from the lazy storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = remove_diff ctxt contract @@ -679,16 +679,16 @@ let test_diffs_remove_from_big_map () = let test_diffs_copy_big_map () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (contract, ctxt) = init () in + let* contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_t ~value_type:ticket_string_type in (* Start with an empty big-map *) - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type in (* We add one ticket to the storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = copy_diff ctxt contract @@ -728,11 +728,11 @@ let test_diffs_copy_big_map () = let test_diffs_add_to_existing_big_map () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (contract, ctxt) = init () in + let* contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_t ~value_type:ticket_string_type in - let* (old_storage, ctxt) = + let* old_storage, ctxt = make_big_map ctxt contract @@ -749,7 +749,7 @@ let test_diffs_add_to_existing_big_map () = ] in (* We add one ticket to the storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = existing_diff ctxt contract @@ -792,7 +792,7 @@ let test_diffs_add_to_existing_big_map () = let test_diffs_args_storage_and_lazy_diffs () = let open Lwt_result_syntax in let open Script_typed_ir in - let* (contract, ctxt) = init () in + let* contract, ctxt = init () in let*? int_ticket_big_map_ty = big_map_type ~key_type:int_t ~value_type:ticket_string_type in @@ -800,7 +800,7 @@ let test_diffs_args_storage_and_lazy_diffs () = Environment.wrap_tzresult @@ pair_t (-1) ticket_string_list_type int_ticket_big_map_ty in - let* (empty_big_map, ctxt) = + let* empty_big_map, ctxt = empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type in (* We send two tickets in the args. *) @@ -812,7 +812,7 @@ let test_diffs_args_storage_and_lazy_diffs () = ] in (* We add three tickets to the storage. *) - let* (lazy_storage_diff, ctxt) = + let* lazy_storage_diff, ctxt = existing_diff ctxt contract @@ -882,8 +882,8 @@ let test_diffs_args_storage_and_lazy_diffs () = (** Test that attempting to transfer a ticket that exceeds the budget fails. *) let test_update_invalid_transfer () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (destination, _script, incr) = + let* baker, src, block = init_for_operation () in + let* destination, _script, incr = originate block ~src @@ -897,7 +897,7 @@ let test_update_invalid_transfer () = let arg = boxed_list [string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1] in - let* (operation, ctxt) = + let* operation, ctxt = transfer_operation ctxt ~src ~destination ~arg_type ~arg in assert_fail_with @@ -916,8 +916,8 @@ let test_update_invalid_transfer () = results in a balance update. *) let test_update_ticket_self_diff () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (self, _script, incr) = + let* baker, src, block = init_for_operation () in + let* self, _script, incr = originate block ~src @@ -929,18 +929,18 @@ let test_update_ticket_self_diff () = let ticketer = Contract.to_b58check self in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt ~merge_overlap:(fun _ -> assert false) [(red_token, Z.of_int 10)]) in - let* (_, ctxt) = + let* _, ctxt = wrap (Ticket_accounting.update_ticket_balances ctxt ~self ~ticket_diffs []) in (* After update, we should have 10 added red tokens. *) - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -952,8 +952,8 @@ let test_update_ticket_self_diff () = (* Test that sending tickets to self succeed (there are no budget constraints). *) let test_update_self_ticket_transfer () = let open Lwt_result_syntax in - let* (baker, self, block) = init_for_operation () in - let* (ticket_receiver, _script, incr) = + let* baker, self, block = init_for_operation () in + let* ticket_receiver, _script, incr = originate block ~src:self @@ -967,7 +967,7 @@ let test_update_self_ticket_transfer () = let ticketer = Contract.to_b58check self in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (operation, ctxt) = + let* operation, ctxt = let arg_type = ticket_string_list_type in let arg = boxed_list @@ -986,7 +986,7 @@ let test_update_self_ticket_transfer () = ~arg_type ~arg in - let* (_, ctxt) = + let* _, ctxt = wrap (Ticket_accounting.update_ticket_balances ctxt @@ -997,7 +997,7 @@ let test_update_self_ticket_transfer () = (* Once we're done with the update, we expect ticket-receiver to have been credited with 10 units of ticket-tokens. *) let* () = - let* (red_receiver_token_hash, ctxt) = + let* red_receiver_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1011,8 +1011,8 @@ let test_update_self_ticket_transfer () = (** Test that transferring a ticket that does not exceed the budget succeeds. *) let test_update_valid_transfer () = let open Lwt_result_syntax in - let* (baker, self, block) = init_for_operation () in - let* (destination, _script, incr) = + let* baker, self, block = init_for_operation () in + let* destination, _script, incr = originate block ~src:self @@ -1025,14 +1025,14 @@ let test_update_valid_transfer () = assert (ticketer <> Contract.to_b58check self) ; let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt ~owner:(Destination.Contract self) red_token in - let* (red_receiver_token_hash, ctxt) = + let* red_receiver_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1040,16 +1040,16 @@ let test_update_valid_transfer () = red_token in (* Set up the balance so that the self contract owns one ticket. *) - let* (_, ctxt) = + let* _, ctxt = wrap @@ Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:Z.one in - let* (operation, ctxt) = + let* operation, ctxt = let arg_type = ticket_string_list_type in let arg = boxed_list [string_ticket ticketer "red" 1] in transfer_operation ctxt ~src:self ~destination ~arg_type ~arg in - let* (_, ctxt) = - let* (ticket_diffs, ctxt) = + let* _, ctxt = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt @@ -1073,8 +1073,8 @@ let test_update_valid_transfer () = the balance. *) let test_update_transfer_tickets_to_self () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (self, _script, incr) = + let* baker, src, block = init_for_operation () in + let* self, _script, incr = originate block ~src @@ -1087,7 +1087,7 @@ let test_update_transfer_tickets_to_self () = assert (ticketer <> Contract.to_b58check self) ; let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1095,21 +1095,21 @@ let test_update_transfer_tickets_to_self () = red_token in (* Set up the balance so that the self contract owns ten tickets. *) - let* (_, ctxt) = + let* _, ctxt = wrap @@ Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:(Z.of_int 10) in - let* (operation, ctxt) = + let* operation, ctxt = let arg_type = ticket_string_list_type in let arg = boxed_list [string_ticket ticketer "red" 1] in transfer_operation ctxt ~src:self ~destination:self ~arg_type ~arg in - let* (_, ctxt) = + let* _, ctxt = (* Ticket diff removes 5 tickets. *) - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt @@ -1132,8 +1132,8 @@ let test_update_transfer_tickets_to_self () = budget fails. *) let test_update_invalid_origination () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (destination, script, incr) = + let* baker, src, block = init_for_operation () in + let* destination, script, incr = let storage = let ticketer = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" in Printf.sprintf @@ -1151,7 +1151,7 @@ let test_update_invalid_origination () = ~forges_tickets:true in let ctxt = Incremental.alpha_ctxt incr in - let* (operation, ctxt) = + let* operation, ctxt = origination_operation ctxt ~src ~orig_contract:destination ~script in assert_fail_with @@ -1169,10 +1169,10 @@ let test_update_invalid_origination () = (** Test update valid origination. *) let test_update_valid_origination () = let open Lwt_result_syntax in - let* (baker, self, block) = init_for_operation () in + let* baker, self, block = init_for_operation () in let ticketer = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" in assert (ticketer <> Contract.to_b58check self) ; - let* (originated, script, incr) = + let* originated, script, incr = let storage = Printf.sprintf {|{ Pair %S "red" 1; }|} ticketer in originate block @@ -1184,7 +1184,7 @@ let test_update_valid_origination () = in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1192,14 +1192,14 @@ let test_update_valid_origination () = red_token in (* Set up the balance so that the self contract owns one ticket. *) - let* (_, ctxt) = + let* _, ctxt = wrap @@ Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:Z.one in - let* (operation, ctxt) = + let* operation, ctxt = origination_operation ctxt ~src:self ~orig_contract:originated ~script in - let* (_, ctxt) = - let* (ticket_diffs, ctxt) = + let* _, ctxt = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt @@ -1215,7 +1215,7 @@ let test_update_valid_origination () = in (* Once we're done with the update, we expect the balance to have been moved from [self] to [destination]. *) - let* (red_originated_token_hash, ctxt) = + let* red_originated_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -1226,9 +1226,9 @@ let test_update_valid_origination () = let test_update_self_origination () = let open Lwt_result_syntax in - let* (baker, self, block) = init_for_operation () in + let* baker, self, block = init_for_operation () in let ticketer = Contract.to_b58check self in - let* (originated, script, incr) = + let* originated, script, incr = let storage = Printf.sprintf {|{ Pair %S "red" 1; }|} ticketer in originate block @@ -1240,17 +1240,17 @@ let test_update_self_origination () = in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (red_originated_token_hash, ctxt) = + let* red_originated_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt ~owner:(Destination.Contract originated) red_token in - let* (operation, ctxt) = + let* operation, ctxt = origination_operation ctxt ~src:self ~orig_contract:originated ~script in - let* (_, ctxt) = + let* _, ctxt = wrap (Ticket_accounting.update_ticket_balances ctxt @@ -1265,8 +1265,8 @@ let test_update_self_origination () = (** Test ticket-token map of list with duplicates. *) let test_ticket_token_map_of_list_with_duplicates () = let open Lwt_result_syntax in - let* (baker, src, block) = init_for_operation () in - let* (self, _script, incr) = + let* baker, src, block = init_for_operation () in + let* self, _script, incr = originate block ~src @@ -1278,18 +1278,18 @@ let test_ticket_token_map_of_list_with_duplicates () = let ticketer = Contract.to_b58check self in let ctxt = Incremental.alpha_ctxt incr in let* red_token = string_ticket_token ticketer "red" in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = wrap (Ticket_token_map.of_list ctxt ~merge_overlap:(fun ctxt v1 v2 -> ok (Z.add v1 v2, ctxt)) [(red_token, Z.of_int 10); (red_token, Z.of_int 5)]) in - let* (_, ctxt) = + let* _, ctxt = wrap (Ticket_accounting.update_ticket_balances ctxt ~self ~ticket_diffs []) in (* After update, we should have 10 + 5 added red tokens. *) - let* (red_self_token_hash, ctxt) = + let* red_self_token_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance.ml index d1dac3359fc7..af27dd965232 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance.ml @@ -45,7 +45,7 @@ type init_env = { } let init_env () = - let* (block, baker, contract, _src2) = Contract_helpers.init () in + let* block, baker, contract, _src2 = Contract_helpers.init () in return {block; baker; contract} let transaction block ~baker ~sender ~entrypoint ~recipient ~parameters = @@ -69,7 +69,7 @@ let transaction block ~baker ~sender ~entrypoint ~recipient ~parameters = let originate = Contract_helpers.originate_contract_from_string let get_balance ctxt ~token ~owner = - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt ~owner token in wrap (Ticket_balance.get_balance ctxt key_hash) @@ -142,15 +142,15 @@ let assert_used_ticket_storage ~loc block expected = let assert_token_balance ~loc block token owner expected = let* incr = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt incr in - let* (balance, _) = + let* balance, _ = get_balance ctxt ~token ~owner:(Destination.Contract owner) in match (balance, expected) with - | (Some b, Some e) -> Assert.equal_int ~loc (Z.to_int b) e - | (Some b, None) -> + | Some b, Some e -> Assert.equal_int ~loc (Z.to_int b) e + | Some b, None -> failwith "%s: Expected no balance but got some %d" loc (Z.to_int b) - | (None, Some b) -> failwith "%s: Expected balance %d but got none" loc b - | (None, None) -> return () + | None, Some b -> failwith "%s: Expected balance %d but got none" loc b + | None, None -> return () let string_token ~ticketer content = let contents = @@ -190,7 +190,7 @@ let get_new_contract before f = let test_add_strict () = let* {block; baker; contract = source_contract} = init_env () in (* Originate *) - let* (contract, _script, block) = + let* contract, _script, block = originate ~baker ~source_contract @@ -243,7 +243,7 @@ let test_add_strict () = let test_add_remove () = let* {block; baker; contract = source_contract} = init_env () in (* Originate *) - let* (contract, _script, block) = + let* contract, _script, block = originate ~baker ~source_contract @@ -299,7 +299,7 @@ let test_add_remove () = (** Test adding multiple tickets to a big-map. *) let test_add_to_big_map () = let* {block; baker; contract = source_contract} = init_env () in - let* (contract, _script, block) = + let* contract, _script, block = originate ~baker ~source_contract @@ -362,7 +362,7 @@ let test_add_to_big_map () = *) let test_swap_big_map () = let* {block; baker; contract = source_contract} = init_env () in - let* (contract, _script, block) = + let* contract, _script, block = originate ~baker ~source_contract @@ -449,7 +449,7 @@ let test_swap_big_map () = let test_send_tickets () = let* {block; baker; contract = source_contract} = init_env () in (* A contract that can receive a ticket and store it in a list. *) - let* (ticket_receiver, _script, block) = + let* ticket_receiver, _script, block = originate ~baker ~source_contract @@ -464,7 +464,7 @@ let test_send_tickets () = in (* A contract that, given an address to a contract that receives tickets, mints a ticket and sends it over. *) - let* (ticket_sender, _script, block) = + let* ticket_sender, _script, block = originate ~baker ~source_contract @@ -512,7 +512,7 @@ let test_send_and_store_zero_amount_tickets () = let* {block; baker; contract = source_contract} = init_env () in (* A contract that, given an address to a contract that receives tickets, mints a ticket and sends it over. *) - let* (ticket_minter, _script, block) = + let* ticket_minter, _script, block = originate ~baker ~source_contract @@ -571,7 +571,7 @@ let test_send_and_store_zero_amount_tickets () = { CONS ; NIL operation ; PAIR } } } |} in - let* (ticket_store_1, _script, block) = + let* ticket_store_1, _script, block = originate ~baker ~source_contract @@ -579,7 +579,7 @@ let test_send_and_store_zero_amount_tickets () = ~storage:"{}" block in - let* (ticket_store_2, _script, block) = + let* ticket_store_2, _script, block = originate ~baker ~source_contract @@ -720,7 +720,7 @@ let test_send_and_store_zero_amount_tickets () = let test_send_tickets_in_big_map () = let* {block; baker; contract = source_contract} = init_env () in (* A contract that can receive a big-map with tickets. *) - let* (ticket_receiver, _script, block) = + let* ticket_receiver, _script, block = originate ~baker ~source_contract @@ -738,7 +738,7 @@ let test_send_tickets_in_big_map () = a big-map. - [send (address)] for transferring the big-map to the given address. *) - let* (ticket_manager, _script, block) = + let* ticket_manager, _script, block = originate ~baker ~source_contract @@ -845,7 +845,7 @@ let test_modify_big_map () = - [Add ((int, string))] for adding a ticket to the big-map. - [Remove(int)] for removing an index from the big-map. *) - let* (ticket_manager, _script, block) = + let* ticket_manager, _script, block = originate ~baker ~source_contract @@ -933,7 +933,7 @@ let test_modify_big_map () = let test_send_tickets_in_big_map_and_drop () = let* {block; baker; contract = source_contract} = init_env () in (* A contract that can receive a big-map with tickets but drops it. *) - let* (ticket_receiver, _script, block) = + let* ticket_receiver, _script, block = originate ~baker ~source_contract @@ -948,7 +948,7 @@ let test_send_tickets_in_big_map_and_drop () = in (* A contract that, given an address, creates a ticket and sends it to the corresponding contract in a big-map. *) - let* (ticket_sender, _script, block) = + let* ticket_sender, _script, block = originate ~baker ~source_contract @@ -1006,7 +1006,7 @@ let test_send_tickets_in_big_map_and_drop () = (* Test create contract with tickets *) let test_create_contract_with_ticket () = let* {block; baker; contract = source_contract} = init_env () in - let* (ticket_creator, _script, block) = + let* ticket_creator, _script, block = originate ~baker ~source_contract @@ -1038,7 +1038,7 @@ let test_create_contract_with_ticket () = in let token_red = string_token ~ticketer:ticket_creator "Red" in (* Call ticket-creator to originate a new contract with one ticket *) - let* (new_contract, block) = + let* new_contract, block = get_new_contract block (fun block -> transaction ~entrypoint:Entrypoint.default @@ -1058,7 +1058,7 @@ let test_create_contract_with_ticket () = let test_join_tickets () = let* {block; baker; contract = source_contract} = init_env () in - let* (ticket_joiner, _script, block) = + let* ticket_joiner, _script, block = originate ~baker ~source_contract @@ -1249,7 +1249,7 @@ let ticket_wallet = (** Test ticket wallet implementation including sending tickets to self. *) let test_ticket_wallet () = let* {block; baker; contract = source_contract} = init_env () in - let* (ticket_builder, _script, block) = + let* ticket_builder, _script, block = originate ~baker ~source_contract @@ -1257,7 +1257,7 @@ let test_ticket_wallet () = ~storage:(Printf.sprintf "%S" @@ Contract.to_b58check source_contract) block in - let* (ticket_wallet, _script, block) = + let* ticket_wallet, _script, block = originate ~baker ~source_contract @@ -1338,7 +1338,7 @@ let test_ticket_storage () = let* {block; baker; contract = source_contract} = init_env () in (* A contract that can receive a ticket and store it. Each new ticket it receives is added to a list. *) - let* (ticket_keeper, _script, block) = + let* ticket_keeper, _script, block = originate ~baker ~source_contract @@ -1353,7 +1353,7 @@ let test_ticket_storage () = in (* A contract that receives a pair of ticket and address and forwards the ticket to the given address. The contract does not store any tickets. *) - let* (ticket_forwarder, _script, block) = + let* ticket_forwarder, _script, block = originate ~baker ~source_contract @@ -1389,7 +1389,7 @@ let test_ticket_storage () = [ticket_minter] ----> [ticket_forwarder] ----> [ticket_receiver] *) - let* (ticket_minter, _script, block) = + let* ticket_minter, _script, block = originate ~baker ~source_contract @@ -1521,7 +1521,7 @@ let test_storage_for_create_and_remove_tickets () = - Create n tickets and add to its storage - Remove all tickets *) - let* (ticket_manager, _script, block) = + let* ticket_manager, _script, block = originate ~baker ~source_contract diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml index 49fbaf045aa0..1d3af7b23ebd 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml @@ -40,28 +40,28 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult let new_ctxt () = - let* (block, _contract) = Context.init1 () in + let* block, _contract = Context.init1 () in let* incr = Incremental.begin_construction block in return @@ Incremental.alpha_ctxt incr let make_contract ticketer = wrap @@ Lwt.return @@ Contract.of_b58check ticketer let make_ex_token ctxt ~ticketer ~ty ~content = - let* (Script_ir_translator.Ex_comparable_ty cty, ctxt) = + let* Script_ir_translator.Ex_comparable_ty cty, ctxt = let node = Micheline.root @@ Expr.from_string ty in wrap @@ Lwt.return @@ Script_ir_translator.parse_comparable_ty ctxt node in let* ticketer = make_contract ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content in wrap @@ Script_ir_translator.parse_comparable_data ctxt cty node in return (Ticket_token.Ex_token {contents_type = cty; ticketer; contents}, ctxt) let make_key ctxt ~ticketer ~ty ~content ~owner = - let* (ex_token, ctxt) = make_ex_token ctxt ~ticketer ~ty ~content in + let* ex_token, ctxt = make_ex_token ctxt ~ticketer ~ty ~content in let* owner = make_contract owner in - let* (key, ctxt) = + let* key, ctxt = wrap @@ Ticket_balance_key.of_ex_token ctxt @@ -79,10 +79,10 @@ let not_equal_script_hash ~loc msg key1 key2 = let assert_keys ~ticketer1 ~ticketer2 ~ty1 ~ty2 ~amount1 ~amount2 ~content1 ~content2 ~owner1 ~owner2 assert_condition = let* ctxt = new_ctxt () in - let* (key1, ctxt) = + let* key1, ctxt = make_key ctxt ~ticketer:ticketer1 ~ty:ty1 ~content:content1 ~owner:owner1 in - let* (key2, _) = + let* key2, _ = make_key ctxt ~ticketer:ticketer2 ~ty:ty2 ~content:content2 ~owner:owner2 in assert_condition (key1, amount1) (key2, amount2) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml index 6cce95cf1cd2..d8c857b49f42 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml @@ -46,7 +46,7 @@ let assert_equal_string_list ~loc msg = let string_list_of_ex_token_diffs ctxt token_diffs = let accum (xs, ctxt) (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = - let* (x, ctxt) = + let* x, ctxt = wrap @@ Script_ir_translator.unparse_comparable_data ~loc:() @@ -67,23 +67,23 @@ let string_list_of_ex_token_diffs ctxt token_diffs = in return (str :: xs, ctxt) in - let* (xs, ctxt) = List.fold_left_es accum ([], ctxt) token_diffs in + let* xs, ctxt = List.fold_left_es accum ([], ctxt) token_diffs in return (List.rev xs, ctxt) let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = - let* (Script_ir_translator.Ex_comparable_ty contents_type, ctxt) = + let* Script_ir_translator.Ex_comparable_ty contents_type, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in wrap @@ Lwt.return @@ Script_ir_translator.parse_comparable_ty ctxt node in let* ticketer = wrap @@ Lwt.return @@ Contract.of_b58check ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in wrap @@ Script_ir_translator.parse_comparable_data ctxt contents_type node in return (Ticket_token.Ex_token {ticketer; contents_type; contents}, ctxt) let assert_equal_balances ~loc ctxt given expected = - let* (ctxt, tbs1) = + let* ctxt, tbs1 = List.fold_left_map_es (fun ctxt ((ticketer, content), delta) -> make_ex_token @@ -95,8 +95,8 @@ let assert_equal_balances ~loc ctxt given expected = ctxt expected in - let* (tbs1, ctxt) = string_list_of_ex_token_diffs ctxt tbs1 in - let* (tbs2, _ctxt) = string_list_of_ex_token_diffs ctxt given in + let* tbs1, ctxt = string_list_of_ex_token_diffs ctxt tbs1 in + let* tbs2, _ctxt = string_list_of_ex_token_diffs ctxt given in assert_equal_string_list ~loc "Compare token balances" @@ -108,7 +108,7 @@ let wrap_result res = wrap (Lwt.return res) let updates_of_key_values ctxt key_values = List.fold_right_es (fun (key, value) (kvs, ctxt) -> - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap (Script_ir_translator.hash_comparable_data ctxt @@ -133,8 +133,8 @@ let make_alloc big_map_id alloc updates = (Update {init = Lazy_storage.Alloc alloc; updates}) let init () = - let* (block, source) = Context.init1 () in - let* (operation, originated) = + let* block, source = Context.init1 () in + let* operation, originated = Op.contract_origination (B block) source ~script:Op.dummy_script in let* block = Block.bake ~operation block in @@ -142,15 +142,15 @@ let init () = return (originated, Incremental.alpha_ctxt inc) let setup ctxt contract ~key_type ~value_type entries = - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in let key_type = Expr.from_string key_type in let value_type = Expr.from_string value_type in - let* (updates, ctxt) = updates_of_key_values ctxt entries in + let* updates, ctxt = updates_of_key_values ctxt entries in let alloc = make_alloc big_map_id Big_map.{key_type; value_type} updates in return (alloc, big_map_id, contract, ctxt) let new_big_map ctxt contract ~key_type ~value_type entries = - let* (alloc, big_map_id, contract, ctxt) = + let* alloc, big_map_id, contract, ctxt = setup ctxt contract ~key_type ~value_type @@ List.map (fun (k, v) -> (k, Some v)) entries in @@ -161,7 +161,7 @@ let new_big_map ctxt contract ~key_type ~value_type entries = return (big_map_id, ctxt) let alloc_diff ctxt contract ~key_type ~value_type entries = - let* (allocations, _, _, ctxt) = + let* allocations, _, _, ctxt = setup ctxt contract @@ -172,17 +172,17 @@ let alloc_diff ctxt contract ~key_type ~value_type entries = return (allocations, ctxt) let remove_diff ctxt contract ~key_type ~value_type ~existing_entries = - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in return (Lazy_storage.make Lazy_storage.Kind.Big_map big_map_id Remove, ctxt) let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in - let* (updates, ctxt) = updates_of_key_values ctxt updates in - let* (ctxt, new_big_map_id) = wrap @@ Big_map.fresh ctxt ~temporary:false in + let* updates, ctxt = updates_of_key_values ctxt updates in + let* ctxt, new_big_map_id = wrap @@ Big_map.fresh ctxt ~temporary:false in return ( Lazy_storage.make Lazy_storage.Kind.Big_map @@ -192,10 +192,10 @@ let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_big_map ctxt contract ~key_type ~value_type existing_entries in - let* (updates, ctxt) = updates_of_key_values ctxt updates in + let* updates, ctxt = updates_of_key_values ctxt updates in return ( Lazy_storage.make Lazy_storage.Kind.Big_map @@ -206,11 +206,11 @@ let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates (** Test that no ticket-tokens are extracted from a diff for allocating an empty big-map. *) let test_allocate_new_empty () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = alloc_diff ctxt contract ~key_type:"int" ~value_type:"ticket string" [] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -219,8 +219,8 @@ let test_allocate_new_empty () = (** Test that no ticket-tokens are extracted from a lazy-diff of a big-map that does not contain tickets. *) let test_allocate_new_no_tickets () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = alloc_diff ctxt contract @@ -228,7 +228,7 @@ let test_allocate_new_no_tickets () = ~value_type:"string" [(1, {|"A"|}); (2, {|"B"|}); (3, {|"C"|})] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -237,8 +237,8 @@ let test_allocate_new_no_tickets () = (** Test that ticket-tokens can be extracted from a lazy-diff for allocating a new big-map. *) let test_allocate_new () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = alloc_diff ctxt contract @@ -250,7 +250,7 @@ let test_allocate_new () = (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -267,8 +267,8 @@ let test_allocate_new () = (** Test that ticket-tokens with negative balances are extracted from a lazy-diff that removes a big-map. *) let test_remove_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = remove_diff ctxt contract @@ -281,7 +281,7 @@ let test_remove_big_map () = (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -298,8 +298,8 @@ let test_remove_big_map () = (** Test that there are no ticket-token balance deltas extracted from a lazy-diff that applies no updates. *) let test_no_updates_to_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -313,7 +313,7 @@ let test_no_updates_to_existing_big_map () = ] ~updates:[] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -323,8 +323,8 @@ let test_no_updates_to_existing_big_map () = extracted from a lazy-diff that modifies an existing big-map. *) let test_update_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -346,7 +346,7 @@ let test_update_existing_big_map () = (4, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "pink" 5|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -366,8 +366,8 @@ let test_update_existing_big_map () = multiple updates to the same key. *) let test_update_same_key_multiple_times_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -383,7 +383,7 @@ let test_update_same_key_multiple_times_existing_big_map () = (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -403,8 +403,8 @@ let test_update_same_key_multiple_times_existing_big_map () = multiple removals of the same item. *) let test_remove_same_key_multiple_times_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -420,7 +420,7 @@ let test_remove_same_key_multiple_times_existing_big_map () = (1, None); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -435,8 +435,8 @@ let test_remove_same_key_multiple_times_existing_big_map () = multiple additions and removals of the same item. *) let test_update_and_remove_same_key_multiple_times_existing_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = existing_diff ctxt contract @@ -456,7 +456,7 @@ let test_update_and_remove_same_key_multiple_times_existing_big_map () = (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -474,8 +474,8 @@ let test_update_and_remove_same_key_multiple_times_existing_big_map () = (** Test that the extracted ticket-tokens from a lazy diff for copying a big-map reflects the tokens of the source as well as the updates. *) let test_copy_big_map () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = copy_diff ctxt contract @@ -489,7 +489,7 @@ let test_copy_big_map () = ] ~updates:[] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -506,8 +506,8 @@ let test_copy_big_map () = (** Test that the extracted ticket-tokens from a lazy diff for copying a big-map reflects the tokens of the source as well as the updates. *) let test_copy_big_map_with_updates () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = copy_diff ctxt contract @@ -529,7 +529,7 @@ let test_copy_big_map_with_updates () = (4, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "pink" 5|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -551,8 +551,8 @@ let test_copy_big_map_with_updates () = with multiple updates to the same key reflects the tokens of the source as well as the updates. *) let test_copy_big_map_with_updates_to_same_key () = - let* (contract, ctxt) = init () in - let* (diff, ctxt) = + let* contract, ctxt = init () in + let* diff, ctxt = copy_diff ctxt contract @@ -570,7 +570,7 @@ let test_copy_big_map_with_updates_to_same_key () = (1, None); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff]) in @@ -591,8 +591,8 @@ let test_copy_big_map_with_updates_to_same_key () = (** Test combinations of lazy-diffs. *) let test_mix_lazy_diffs () = - let* (contract, ctxt) = init () in - let* (diff_copy, ctxt) = + let* contract, ctxt = init () in + let* diff_copy, ctxt = copy_diff ctxt contract @@ -608,7 +608,7 @@ let test_mix_lazy_diffs () = (2, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2|}); ] in - let* (diff_existing, ctxt) = + let* diff_existing, ctxt = existing_diff ctxt contract @@ -624,7 +624,7 @@ let test_mix_lazy_diffs () = (3, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); ] in - let* (diff_remove, ctxt) = + let* diff_remove, ctxt = remove_diff ctxt contract @@ -636,7 +636,7 @@ let test_mix_lazy_diffs () = (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "black" 1|}); ] in - let* (diff, ctxt) = + let* diff, ctxt = wrap (Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml index 7bb0f500951d..59792cdbb07d 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml @@ -51,24 +51,24 @@ type init_env = { } let init_env () = - let* (block, baker, contract, _src2) = Contract_helpers.init () in + let* block, baker, contract, _src2 = Contract_helpers.init () in return {block; baker; contract} let collect_token_amounts ctxt tickets = let accum (tokens, ctxt) ticket = - let (token, amount) = Ticket_token.token_and_amount_of_ex_ticket ticket in + let token, amount = Ticket_token.token_and_amount_of_ex_ticket ticket in let tokens = (token, Script_int.to_zint amount) :: tokens in return (tokens, ctxt) in List.fold_left_es accum ([], ctxt) tickets let tokens_of_value ~include_lazy ctxt ty x = - let*? (has_tickets, ctxt) = Ticket_scanner.type_has_tickets ctxt ty in - let* (tickets, ctxt) = + let*? has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt ty in + let* tickets, ctxt = Ticket_scanner.tickets_of_value ~include_lazy ctxt has_tickets x in - let* (tas, ctxt) = collect_token_amounts ctxt tickets in - let* (bm, ctxt) = + let* tas, ctxt = collect_token_amounts ctxt tickets in + let* bm, ctxt = Ticket_token_map.of_list ctxt ~merge_overlap:(fun ctxt v1 v2 -> ok (Z.add v1 v2, ctxt)) @@ -78,9 +78,7 @@ let tokens_of_value ~include_lazy ctxt ty x = (* Extract ticket-token balance of storage *) let ticket_balance_of_storage ctxt contract = - let* (ctxt, script) = - wrap @@ Alpha_context.Contract.get_script ctxt contract - in + let* ctxt, script = wrap @@ Alpha_context.Contract.get_script ctxt contract in match script with | None -> return ([], ctxt) | Some script -> @@ -93,14 +91,14 @@ let ticket_balance_of_storage ctxt contract = ~allow_forged_in_storage:true script) in - let* (tokens, ctxt) = + let* tokens, ctxt = wrap (tokens_of_value ~include_lazy:true ctxt storage_type storage) in - let* (tokens, ctxt) = + let* tokens, ctxt = wrap @@ List.fold_left_es (fun (acc, ctxt) (ex_token, amount) -> - let* (key, ctxt) = + let* key, ctxt = Ticket_balance_key.of_ex_token ctxt ~owner:(Contract contract) @@ -208,19 +206,19 @@ let validate_ticket_balances block = let* contracts = all_contracts block in let* incr = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt incr in - let* (kvs_storage, ctxt) = + let* kvs_storage, ctxt = List.fold_left_es (fun (acc, ctxt) contract -> - let* (lists, ctxt) = ticket_balance_of_storage ctxt contract in + let* lists, ctxt = ticket_balance_of_storage ctxt contract in return (lists @ acc, ctxt)) ([], ctxt) contracts in - let* (kvs_balance, _ctxt) = + let* kvs_balance, _ctxt = wrap @@ List.fold_left_es (fun (acc, ctxt) (key, _) -> - let* (balance, ctxt) = Ticket_balance.get_balance ctxt key in + let* balance, ctxt = Ticket_balance.get_balance ctxt key in let acc = match balance with None -> acc | Some b -> (key, b) :: acc in @@ -652,9 +650,7 @@ end let setup_test () = let module TM = Ticket_manager in let* {block; baker; contract = originator} = init_env () in - let* (ticket_manager, _script, block) = - TM.originate block ~originator baker - in + let* ticket_manager, _script, block = TM.originate block ~originator baker in let test block parameters = let* b = TM.transaction block ~sender:originator ~ticket_manager ~parameters @@ -667,7 +663,7 @@ let setup_test () = (** Test create new contracts and send tickets to them. *) let test_create_contract_and_send_tickets () = let module TM = Ticket_manager in - let* (test, originator, b) = setup_test () in + let* test, originator, b = setup_test () in (* Call the `create` endpoint that creates two new ticket receiver contracts: - Both contracts accepts a single ticket as an argument. @@ -675,7 +671,7 @@ let test_create_contract_and_send_tickets () = - The second holds a ticket in its storage and only accepts "green" tickets. - The second contract joins all received tickets. *) - let* (ticket_receiver_green_1, ticket_receiver_green_2, b) = + let* ticket_receiver_green_1, ticket_receiver_green_2, b = get_first_two_new_contracts b @@ fun b -> test b @@ TM.create ~content:"Green" ~amount:1 ~originator in @@ -709,7 +705,7 @@ let test_create_contract_and_send_tickets () = (** Tets add and remove tickets from lazy storage. *) let test_add_remove_from_lazy_storage () = let module TM = Ticket_manager in - let* (tm, _, b) = setup_test () in + let* tm, _, b = setup_test () in let* b = tm b @@ TM.add_lazy ~index:1 ~content:"Red" ~amount:10 in let* b = tm b @@ TM.add_lazy ~index:2 ~content:"Green" ~amount:10 in let* b = tm b @@ TM.add_lazy ~index:3 ~content:"Blue" ~amount:10 in @@ -727,7 +723,7 @@ let test_add_remove_from_lazy_storage () = (** Test send to self and replace big-map. *) let test_send_self_replace_big_map () = let module TM = Ticket_manager in - let* (tm, _, b) = setup_test () in + let* tm, _, b = setup_test () in (* Send self replace bigmap *) let* b = tm b @@ TM.add_lazy ~index:1 ~content:"Red" ~amount:1 in let* b = tm b @@ TM.add_lazy ~index:2 ~content:"Green" ~amount:1 in @@ -740,7 +736,7 @@ let test_send_self_replace_big_map () = (** Test add to and remove from strict storage. *) let test_add_remove_strict () = let module TM = Ticket_manager in - let* (tm, _, b) = setup_test () in + let* tm, _, b = setup_test () in (* Add some more strict tickets *) let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:1 in let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:2 in @@ -756,7 +752,7 @@ let test_add_remove_strict () = (** Test mixed operations. *) let test_mixed_operations () = let module TM = Ticket_manager in - let* (tm, _, b) = setup_test () in + let* tm, _, b = setup_test () in (* Add some more strict tickets *) let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:1 in let* b = tm b @@ TM.add_strict ~content:"Green" ~amount:1 in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index 1c1cbc5f5399..6daf3b056664 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -55,7 +55,7 @@ let wrap m = m >|= Environment.wrap_tzresult let big_map_updates_of_key_values ctxt key_values = List.fold_right_es (fun (key, value) (kvs, ctxt) -> - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap (Script_ir_translator.hash_comparable_data ctxt @@ -74,10 +74,10 @@ let big_map_updates_of_key_values ctxt key_values = ([], ctxt) let new_int_key_big_map ctxt contract ~value_type entries = - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in let key_type = Expr.from_string "int" in let value_type = Expr.from_string value_type in - let* (updates, ctxt) = + let* updates, ctxt = big_map_updates_of_key_values ctxt @@ List.map (fun (k, v) -> (k, Some v)) entries in @@ -99,7 +99,7 @@ let assert_equal_string_list ~loc msg = let string_of_ticket_token ctxt (Ticket_token.Ex_token {ticketer; contents_type; contents}) = - let* (x, _) = + let* x, _ = wrap @@ Script_ir_translator.unparse_comparable_data ctxt @@ -191,7 +191,7 @@ let originate block ~script ~storage ~src ~baker ~forges_tickets = let script = Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} in - let* (operation, destination) = + let* operation, destination = Op.contract_origination (B block) src ~fee:(Test_tez.of_int 10) ~script in let* incr = @@ -218,7 +218,7 @@ let one_ticketer block = two_ticketers block >|=? fst let nat n = Script_int.(abs @@ of_int n) let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = - let* (orig_contract, script, block) = + let* orig_contract, script, block = originate block ~script ~storage ~src ~baker ~forges_tickets in let* incr = @@ -267,7 +267,7 @@ let delegation_operation ~src = {source = src; operation = Delegation None; nonce = 1} let originate block ~src ~baker ~script ~storage ~forges_tickets = - let* (orig_contract, _script, block) = + let* orig_contract, _script, block = originate block ~script ~storage ~src ~baker ~forges_tickets in let* incr = @@ -278,7 +278,7 @@ let originate block ~src ~baker ~script ~storage ~forges_tickets = let transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters = let open Lwt_result_syntax in let ctxt = Incremental.alpha_ctxt incr in - let* (params_node, ctxt) = + let* params_node, ctxt = wrap (Script_ir_translator.unparse_data ctxt @@ -310,7 +310,7 @@ let transfer_operation_to_tx_rollup ~incr ~src ~parameters_ty ~parameters ~tx_rollup = let open Lwt_result_syntax in let ctxt = Incremental.alpha_ctxt incr in - let* (params_node, ctxt) = + let* params_node, ctxt = wrap (Script_ir_translator.unparse_data ctxt @@ -383,16 +383,16 @@ let transfer_tickets_operation ~incr ~src ~destination tickets = (** Test that no tickets are returned for operations that do not contain tickets. *) let test_non_ticket_operations () = - let* (_baker, src, block) = init () in + let* _baker, src, block = init () in let* incr = Incremental.begin_construction block in let operations = [delegation_operation ~src] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr operations in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr operations in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer to a contract that does not take tickets. *) let test_transfer_to_non_ticket_contract () = - let* (baker, src, block) = init () in - let* (orig_contract, incr) = + let* baker, src, block = init () in + let* orig_contract, incr = originate block ~src @@ -401,7 +401,7 @@ let test_transfer_to_non_ticket_contract () = ~storage:"Unit" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_operation ~incr ~src @@ -409,13 +409,13 @@ let test_transfer_to_non_ticket_contract () = ~parameters_ty:unit_t ~parameters:() in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer an empty list of tickets. *) let test_transfer_empty_ticket_list () = - let* (baker, src, block) = init () in - let* (orig_contract, incr) = + let* baker, src, block = init () in + let* orig_contract, incr = originate block ~src @@ -424,17 +424,17 @@ let test_transfer_empty_ticket_list () = ~storage:"{}" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_tickets_operation ~incr ~src ~destination:orig_contract [] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer a list of one ticket. *) let test_transfer_one_ticket () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in - let* (orig_contract, incr) = + let* orig_contract, incr = originate block ~src @@ -443,14 +443,14 @@ let test_transfer_one_ticket () = ~storage:"{}" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_tickets_operation ~incr ~src ~destination:orig_contract [(ticketer, "white", 1)] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -466,9 +466,9 @@ let test_transfer_one_ticket () = (** Test transfer a list of multiple tickets. *) let test_transfer_multiple_tickets () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in - let* (orig_contract, incr) = + let* orig_contract, incr = originate block ~src @@ -477,7 +477,7 @@ let test_transfer_multiple_tickets () = ~storage:"{}" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_tickets_operation ~incr ~src @@ -489,7 +489,7 @@ let test_transfer_multiple_tickets () = (ticketer, "red", 4); ] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -515,9 +515,9 @@ let test_transfer_multiple_tickets () = (** Test transfer a list of tickets of different types. *) let test_transfer_different_tickets () = - let* (baker, src, block) = init () in - let* (ticketer1, ticketer2) = two_ticketers block in - let* (destination, incr) = + let* baker, src, block = init () in + let* ticketer1, ticketer2 = two_ticketers block in + let* destination, incr = originate block ~src @@ -526,7 +526,7 @@ let test_transfer_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let* (operation, incr) = + let* operation, incr = transfer_tickets_operation ~incr ~src @@ -543,7 +543,7 @@ let test_transfer_different_tickets () = (ticketer1, "blue", 1); ] in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -584,12 +584,12 @@ let test_transfer_different_tickets () = (** Test transfer to two contracts with different types of tickets. *) let test_transfer_to_two_contracts_with_different_tickets () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let parameters = [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] in - let* (destination1, incr) = + let* destination1, incr = originate block ~src @@ -598,11 +598,11 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let* (operation1, incr) = + let* operation1, incr = transfer_tickets_operation ~incr ~src ~destination:destination1 parameters in let* block = Incremental.finalize_block incr in - let* (destination2, incr) = + let* destination2, incr = originate block ~src @@ -611,10 +611,10 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let* (operation2, incr) = + let* operation2, incr = transfer_tickets_operation ~incr ~src ~destination:destination2 parameters in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation1; operation2] in assert_equal_ticket_token_diffs @@ -654,8 +654,8 @@ let test_transfer_to_two_contracts_with_different_tickets () = (** Test originate a contract that does not contain tickets. *) let test_originate_non_ticket_contract () = - let* (baker, src, block) = init () in - let* (_orig_contract, operation, incr) = + let* baker, src, block = init () in + let* _orig_contract, operation, incr = origination_operation block ~src @@ -664,14 +664,14 @@ let test_originate_non_ticket_contract () = ~storage:"Unit" ~forges_tickets:false in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test originate a contract with an empty list of tickets. *) let test_originate_with_empty_tickets_list () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let storage = "{}" in - let* (_orig_contract, operation, incr) = + let* _orig_contract, operation, incr = origination_operation block ~src @@ -680,17 +680,17 @@ let test_originate_with_empty_tickets_list () = ~storage ~forges_tickets:false in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test originate a contract with a single ticket. *) let test_originate_with_one_ticket () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let storage = Printf.sprintf {|{Pair %S "white" 1}|} (Contract.to_b58check ticketer) in - let* (orig_contract, operation, ctxt) = + let* orig_contract, operation, ctxt = origination_operation block ~src @@ -699,7 +699,7 @@ let test_originate_with_one_ticket () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -715,7 +715,7 @@ let test_originate_with_one_ticket () = (** Test originate a contract with multiple tickets. *) let test_originate_with_multiple_tickets () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let storage = let ticketer_addr = Contract.to_b58check ticketer in @@ -731,7 +731,7 @@ let test_originate_with_multiple_tickets () = ticketer_addr ticketer_addr in - let* (orig_contract, operation, ctxt) = + let* orig_contract, operation, ctxt = origination_operation block ~src @@ -740,7 +740,7 @@ let test_originate_with_multiple_tickets () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -766,8 +766,8 @@ let test_originate_with_multiple_tickets () = (** Test originate a contract with multiple tickets of different types. *) let test_originate_with_different_tickets () = - let* (baker, src, block) = init () in - let* (ticketer1, ticketer2) = two_ticketers block in + let* baker, src, block = init () in + let* ticketer1, ticketer2 = two_ticketers block in let storage = let ticketer1_addr = Contract.to_b58check ticketer1 in let ticketer2_addr = Contract.to_b58check ticketer2 in @@ -793,7 +793,7 @@ let test_originate_with_different_tickets () = ticketer1_addr ticketer1_addr in - let* (orig_contract, operation, ctxt) = + let* orig_contract, operation, ctxt = origination_operation block ~src @@ -802,7 +802,7 @@ let test_originate_with_different_tickets () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -843,7 +843,7 @@ let test_originate_with_different_tickets () = (** Test originate two contracts with multiple tickets of different types. *) let test_originate_two_contracts_with_different_tickets () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let storage = let ticketer_addr = Contract.to_b58check ticketer in @@ -853,7 +853,7 @@ let test_originate_two_contracts_with_different_tickets () = ticketer_addr ticketer_addr in - let* (orig_contract1, operation1, incr) = + let* orig_contract1, operation1, incr = origination_operation block ~src @@ -863,7 +863,7 @@ let test_originate_two_contracts_with_different_tickets () = ~forges_tickets:true in let* block = Incremental.finalize_block incr in - let* (orig_contract2, operations2, incr) = + let* orig_contract2, operations2, incr = origination_operation block ~src @@ -872,7 +872,7 @@ let test_originate_two_contracts_with_different_tickets () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation1; operations2] in assert_equal_ticket_token_diffs @@ -912,7 +912,7 @@ let test_originate_two_contracts_with_different_tickets () = (** Test originate and transfer tickets. *) let test_originate_and_transfer () = - let* (baker, src, block) = init () in + let* baker, src, block = init () in let* ticketer = one_ticketer block in let ticketer_addr = Contract.to_b58check ticketer in let storage = @@ -922,7 +922,7 @@ let test_originate_and_transfer () = ticketer_addr ticketer_addr in - let* (orig_contract1, operation1, incr) = + let* orig_contract1, operation1, incr = origination_operation block ~src @@ -932,7 +932,7 @@ let test_originate_and_transfer () = ~forges_tickets:true in let* block = Incremental.finalize_block incr in - let* (destination2, incr) = + let* destination2, incr = originate block ~src @@ -941,14 +941,14 @@ let test_originate_and_transfer () = ~storage:"{}" ~forges_tickets:false in - let* (operation2, incr) = + let* operation2, incr = transfer_tickets_operation ~incr ~src ~destination:destination2 [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] in - let* (ticket_diffs, ctxt) = + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation1; operation2] in assert_equal_ticket_token_diffs @@ -988,14 +988,14 @@ let test_originate_and_transfer () = (** Test originate a contract with a big-map with tickets inside. *) let test_originate_big_map_with_tickets () = - let* (baker, ticketer, block) = init () in - let* (operation, originated) = + let* baker, ticketer, block = init () in + let* operation, originated = Op.contract_origination (B block) ticketer ~script:Op.dummy_script in let* block = Block.bake ~operation block in let* incr = Incremental.begin_construction block in let ticketer_addr = Contract.to_b58check ticketer in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_int_key_big_map (Incremental.alpha_ctxt incr) originated @@ -1008,7 +1008,7 @@ let test_originate_big_map_with_tickets () = in let incr = Incremental.set_alpha_ctxt incr ctxt in let* block = Incremental.finalize_block incr in - let* (orig_contract, operation, incr) = + let* orig_contract, operation, incr = let storage = Printf.sprintf "%d" @@ Z.to_int (Big_map.Id.unparse_to_z big_map_id) in @@ -1020,7 +1020,7 @@ let test_originate_big_map_with_tickets () = ~storage ~forges_tickets:true in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -1046,14 +1046,14 @@ let test_originate_big_map_with_tickets () = (** Test transfer a big-map with tickets. *) let test_transfer_big_map_with_tickets () = - let* (baker, ticketer_contract, block) = init () in - let* (operation, originated) = + let* baker, ticketer_contract, block = init () in + let* operation, originated = Op.contract_origination (B block) ticketer_contract ~script:Op.dummy_script in let* block = Block.bake ~operation block in let* incr = Incremental.begin_construction block in let ticketer_addr = Contract.to_b58check ticketer_contract in - let* (big_map_id, ctxt) = + let* big_map_id, ctxt = new_int_key_big_map (Incremental.alpha_ctxt incr) originated @@ -1066,7 +1066,7 @@ let test_transfer_big_map_with_tickets () = in let incr = Incremental.set_alpha_ctxt incr ctxt in let* block = Incremental.finalize_block incr in - let* (orig_contract, incr) = + let* orig_contract, incr = originate block ~src:ticketer_contract @@ -1092,7 +1092,7 @@ let test_transfer_big_map_with_tickets () = value_type; } in - let* (operation, incr) = + let* operation, incr = transfer_operation ~incr ~src:ticketer_contract @@ -1100,7 +1100,7 @@ let test_transfer_big_map_with_tickets () = ~parameters_ty ~parameters in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -1127,10 +1127,10 @@ let test_transfer_big_map_with_tickets () = (** Test transfer a ticket to a tx_rollup. *) let test_tx_rollup_deposit_one_ticket () = let open Lwt_result_syntax in - let* (_baker, src, block) = init ~tx_rollup_enable:true () in + let* _baker, src, block = init ~tx_rollup_enable:true () in let* ticketer = one_ticketer block in let* incr = Incremental.begin_construction block in - let* (operation, tx_rollup) = + let* operation, tx_rollup = Op.tx_rollup_origination (I incr) src ~fee:(Test_tez.of_int 10) in let* incr = Incremental.add_operation incr operation in @@ -1159,7 +1159,7 @@ let test_tx_rollup_deposit_one_ticket () = (Script_typed_ir.{ticketer; contents; amount}, l2_destination) in - let* (operation, incr) = + let* operation, incr = transfer_operation_to_tx_rollup ~incr ~src @@ -1167,7 +1167,7 @@ let test_tx_rollup_deposit_one_ticket () = ~parameters_ty ~parameters in - let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index b7203e61048c..ea75ba0e06b7 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -41,7 +41,7 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult let new_ctxt () = - let* (block, _contract) = Context.init1 () in + let* block, _contract = Context.init1 () in let* incr = Incremental.begin_construction block in return @@ Incremental.alpha_ctxt incr @@ -52,7 +52,7 @@ let string_list_of_ex_tickets ctxt tickets = let accum (xs, ctxt) (Ticket_scanner.Ex_ticket (cty, {Script_typed_ir.ticketer; contents; amount})) = - let* (x, ctxt) = + let* x, ctxt = wrap @@ Script_ir_translator.unparse_data ctxt @@ -79,16 +79,16 @@ let string_list_of_ex_tickets ctxt tickets = in return (str :: xs, ctxt) in - let* (xs, ctxt) = List.fold_left_es accum ([], ctxt) tickets in + let* xs, ctxt = List.fold_left_es accum ([], ctxt) tickets in return (List.rev xs, ctxt) let make_ex_ticket ctxt ~ticketer ~type_exp ~content_exp ~amount = - let* (Script_ir_translator.Ex_comparable_ty cty, ctxt) = + let* Script_ir_translator.Ex_comparable_ty cty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in wrap @@ Lwt.return @@ Script_ir_translator.parse_comparable_ty ctxt node in let* ticketer = wrap @@ Lwt.return @@ Contract.of_b58check ticketer in - let* (contents, ctxt) = + let* contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in wrap @@ Script_ir_translator.parse_comparable_data ctxt cty node in @@ -97,10 +97,8 @@ let make_ex_ticket ctxt ~ticketer ~type_exp ~content_exp ~amount = return (Ticket_scanner.Ex_ticket (cty, ticket), ctxt) let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = - let* (str_tickets, ctxt) = string_list_of_ex_tickets ctxt ex_tickets in - let* (str_tickets_expected, _ctxt) = - string_list_of_ex_tickets ctxt expected - in + let* str_tickets, ctxt = string_list_of_ex_tickets ctxt ex_tickets in + let* str_tickets_expected, _ctxt = string_list_of_ex_tickets ctxt expected in assert_equal_string_list ~loc "Compare with expected tickets" @@ -108,14 +106,14 @@ let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = (List.sort String.compare str_tickets_expected) let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = - let (Script_ir_translator.Ex_ty ty, ctxt) = + let Script_ir_translator.Ex_ty ty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in Result.value_f ~default:(fun () -> Stdlib.failwith "Failed to parse") (Script_ir_translator.parse_any_ty ctxt ~legacy:false node) in let node = Micheline.root @@ Expr.from_string value_exp in - let* (value, ctxt) = + let* value, ctxt = wrap @@ Script_ir_translator.parse_data ctxt @@ -124,14 +122,14 @@ let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = ty node in - let* (ht, ctxt) = + let* ht, ctxt = wrap @@ Lwt.return @@ Ticket_scanner.type_has_tickets ctxt ty in wrap @@ Ticket_scanner.tickets_of_value ctxt ~include_lazy ht value let assert_contains_tickets ctxt ~loc ~include_lazy ~type_exp ~value_exp expected = - let* (ex_tickets, _) = + let* ex_tickets, _ = tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp in assert_equals_ex_tickets ctxt ~loc ex_tickets expected @@ -153,7 +151,7 @@ let assert_fail_non_empty_overlay ctxt ~loc ~include_lazy ~type_exp ~value_exp = let make_string_tickets ctxt ticketer_amounts = List.fold_right_es (fun (ticketer, content, amount) (tickets, ctxt) -> - let* (ticket, ctxt) = + let* ticket, ctxt = make_ex_ticket ctxt ~ticketer @@ -166,20 +164,20 @@ let make_string_tickets ctxt ticketer_amounts = ([], ctxt) let tickets_from_big_map_ref ~pre_populated value_exp = - let* (block, source) = Context.init1 () in - let* (operation, originated) = + let* block, source = Context.init1 () in + let* operation, originated = Op.contract_origination (B block) source ~script:Op.dummy_script in let* block = Block.bake ~operation block in let* inc = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt inc in - let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let* ctxt, big_map_id = wrap @@ Big_map.fresh ~temporary:false ctxt in let int_ty_expr = Expr.from_string "int" in - let* (diffs, ctxt) = - let* (updates, ctxt) = + let* diffs, ctxt = + let* updates, ctxt = List.fold_left_es (fun (kvs, ctxt) (key, value) -> - let* (key_hash, ctxt) = + let* key_hash, ctxt = wrap @@ Script_ir_translator.hash_comparable_data ctxt @@ -221,10 +219,8 @@ let tickets_from_big_map_ref ~pre_populated value_exp = let assert_big_map_int_ticket_string_ref ~loc ~pre_populated ~big_map_exp ex_tickets = - let* (value_exp, ctxt) = - tickets_from_big_map_ref ~pre_populated big_map_exp - in - let* (ex_tickets, ctxt) = make_string_tickets ctxt ex_tickets in + let* value_exp, ctxt = tickets_from_big_map_ref ~pre_populated big_map_exp in + let* ex_tickets, ctxt = make_string_tickets ctxt ex_tickets in assert_contains_tickets ctxt ~include_lazy:true @@ -235,9 +231,7 @@ let assert_big_map_int_ticket_string_ref ~loc ~pre_populated ~big_map_exp let assert_fail_non_empty_overlay_with_big_map_ref ~loc ~pre_populated ~big_map_exp = - let* (value_exp, ctxt) = - tickets_from_big_map_ref ~pre_populated big_map_exp - in + let* value_exp, ctxt = tickets_from_big_map_ref ~pre_populated big_map_exp in assert_fail_non_empty_overlay ctxt ~include_lazy:true @@ -250,7 +244,7 @@ let test_tickets_in_unit_ticket () = let* ctxt = new_ctxt () in let type_exp = "ticket(unit)" in let value_exp = {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" Unit 10|} in - let* (ex_ticket, ctxt) = + let* ex_ticket, ctxt = make_ex_ticket ctxt ~ticketer:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" @@ -268,7 +262,7 @@ let test_tickets_in_unit_ticket () = let assert_string_tickets ~loc ~include_lazy ~type_exp ~value_exp ~expected = let* ctxt = new_ctxt () in - let* (ex_tickets, ctxt) = make_string_tickets ctxt expected in + let* ex_tickets, ctxt = make_string_tickets ctxt expected in assert_contains_tickets ctxt ~include_lazy diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_storage.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_storage.ml index 006ce63f75f6..fe0e93271301 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_storage.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_storage.ml @@ -40,7 +40,7 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult let make_context () = - let* (block, _contract) = Context.init1 () in + let* block, _contract = Context.init1 () in let* incr = Incremental.begin_construction block in return (Incremental.alpha_ctxt incr) @@ -54,13 +54,13 @@ let hash_key ctxt ~ticketer ~ty ~contents ~owner = (Alpha_context.Ticket_hash.make ctxt ~ticketer ~ty ~contents ~owner) let assert_balance ctxt ~loc key expected = - let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + let* balance, _ = wrap @@ Ticket_balance.get_balance ctxt key in match balance with | Some b -> Assert.equal_int ~loc (Z.to_int b) expected | None -> failwith "Expected balance %d" expected let assert_no_balance ctxt key = - let* (balance, _) = wrap @@ Ticket_balance.get_balance ctxt key in + let* balance, _ = wrap @@ Ticket_balance.get_balance ctxt key in match balance with | Some b -> failwith "Expected empty (none) balance but got %d" (Z.to_int b) | None -> return () @@ -71,10 +71,10 @@ let adjust_balance ctxt key delta = let assert_non_overlapping_keys ~loc ~ticketer1 ~ticketer2 ~contents1 ~contents2 ~ty1 ~ty2 ~owner1 ~owner2 = let* ctxt = make_context () in - let* (k1, ctxt) = + let* k1, ctxt = hash_key ctxt ~ticketer:ticketer1 ~ty:ty1 ~contents:contents1 ~owner:owner1 in - let* (k2, _ctxt) = + let* k2, _ctxt = hash_key ctxt ~ticketer:ticketer2 ~ty:ty2 ~contents:contents2 ~owner:owner2 in Assert.not_equal @@ -150,18 +150,18 @@ let test_non_overlapping_keys_owner () = *) let test_ticket_balance_single_update () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in assert_balance ctxt ~loc:__LOC__ alice_red 1 (** Test that updating the ticket-balance table with different keys updates both entries. *) let test_ticket_balance_different_owners () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (alice_blue, ctxt) = make_key ctxt "alice_blue" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in - let* (_, ctxt) = adjust_balance ctxt alice_blue 1 in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* alice_blue, ctxt = make_key ctxt "alice_blue" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in + let* _, ctxt = adjust_balance ctxt alice_blue 1 in let* () = assert_balance ctxt ~loc:__LOC__ alice_red 1 in let* () = assert_balance ctxt ~loc:__LOC__ alice_blue 1 in return () @@ -170,33 +170,33 @@ let test_ticket_balance_different_owners () = the net result of all balance updates *) let test_ticket_balance_multiple_updates () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in - let* (_, ctxt) = adjust_balance ctxt alice_red 2 in - let* (_, ctxt) = adjust_balance ctxt alice_red (-1) in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in + let* _, ctxt = adjust_balance ctxt alice_red 2 in + let* _, ctxt = adjust_balance ctxt alice_red (-1) in assert_balance ctxt ~loc:__LOC__ alice_red 2 (** Test that with no updates to the table, no balance is present in the table *) let test_empty_balance () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* alice_red, ctxt = make_key ctxt "alice_red" in assert_no_balance ctxt alice_red (** Test that adding one entry with positive balance and then updating with a negative balance also removes the entry *) let test_empty_balance_after_update () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in - let* (_, ctxt) = adjust_balance ctxt alice_red 1 in - let* (_, ctxt) = adjust_balance ctxt alice_red (-1) in + let* alice_red, ctxt = make_key ctxt "alice_red" in + let* _, ctxt = adjust_balance ctxt alice_red 1 in + let* _, ctxt = adjust_balance ctxt alice_red (-1) in assert_no_balance ctxt alice_red (** Test that attempting to update an entry with a negative balance results in an error. *) let test_negative_balance () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* alice_red, ctxt = make_key ctxt "alice_red" in adjust_balance ctxt alice_red (-1) >>= fun res -> Assert.proto_error ~loc:__LOC__ res (fun _err -> true) @@ -205,20 +205,20 @@ let test_negative_balance () = *) let test_storage_space () = let* ctxt = make_context () in - let* (alice_red, ctxt) = make_key ctxt "alice_red" in + let* alice_red, ctxt = make_key ctxt "alice_red" in (* Space for adding an entry is 65 for the key plus 1 for the value. *) - let* (space, ctxt) = adjust_balance ctxt alice_red 1 in + let* space, ctxt = adjust_balance ctxt alice_red 1 in let* () = Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) in (* Adding one does not consume additional space. *) - let* (space, ctxt) = adjust_balance ctxt alice_red 1 in + let* space, ctxt = adjust_balance ctxt alice_red 1 in let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in (* Adding a big balance costs extra. *) - let* (space, ctxt) = adjust_balance ctxt alice_red 1000 in + let* space, ctxt = adjust_balance ctxt alice_red 1000 in let* () = Assert.equal_int ~loc:__LOC__ 1 (Z.to_int space) in (* Reset balance to zero should free up space. The freed up space is 65 for the key + 2 for the value *) - let* (b, ctxt) = wrap @@ Ticket_balance.get_balance ctxt alice_red in - let* (space, ctxt) = + let* b, ctxt = wrap @@ Ticket_balance.get_balance ctxt alice_red in + let* space, ctxt = wrap (Ticket_balance.adjust_balance ctxt @@ -227,10 +227,10 @@ let test_storage_space () = in let* () = Assert.equal_int ~loc:__LOC__ (-67) (Z.to_int space) in (* Adjusting the space to 0 again should not free anything *) - let* (space, ctxt) = adjust_balance ctxt alice_red 0 in + let* space, ctxt = adjust_balance ctxt alice_red 0 in let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in (* Adding a balance requiers extra space. *) - let* (space, _) = adjust_balance ctxt alice_red 10 in + let* space, _ = adjust_balance ctxt alice_red 10 in Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) let tests = diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_timelock.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_timelock.ml index 4bba8a7ac094..76f0b047940a 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_timelock.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_timelock.ml @@ -36,11 +36,11 @@ open Protocol let wrap e = Lwt.return (Environment.wrap_tzresult e) let simple_test () = - let (public, secret) = Timelock.gen_rsa_keys () in + let public, secret = Timelock.gen_rsa_keys () in let locked_value = Timelock.gen_locked_value public in let time = 1000 in let unlocked_value = Timelock.unlock_with_secret secret ~time locked_value in - let (same_unlocked, proof) = + let same_unlocked, proof = Timelock.unlock_and_prove_without_secret public ~time locked_value in assert (unlocked_value = same_unlocked) ; @@ -77,11 +77,11 @@ let contract_test () = in Context.init3 ~consensus_threshold:0 () >>=? fun (b, (src, _c2, _c3)) -> originate_contract "contracts/timelock.tz" "0xaa" src b >>=? fun (dst, b) -> - let (public, secret) = Timelock.gen_rsa_keys () in + let public, secret = Timelock.gen_rsa_keys () in let locked_value = Timelock.gen_locked_value public in let time = 1000 in let unlocked_value = Timelock.unlock_with_secret secret ~time locked_value in - let (_same_unlocked, proof) = + let _same_unlocked, proof = Timelock.unlock_and_prove_without_secret public ~time locked_value in let sym_key = Timelock.unlocked_value_to_symmetric_key unlocked_value in @@ -138,13 +138,13 @@ let contract_test () = (Hex.show (Hex.of_bytes message)) >>=? fun () -> (* We redo an RSA parameters generation to create incorrect cipher and proof *) - let (public_bogus, secret_bogus) = Timelock.gen_rsa_keys () in + let public_bogus, secret_bogus = Timelock.gen_rsa_keys () in let locked_value_bogus = Timelock.gen_locked_value public_bogus in let time = 1000 in let unlocked_value_bogus = Timelock.unlock_with_secret secret_bogus ~time locked_value_bogus in - let (_same_unlocked, proof_bogus) = + let _same_unlocked, proof_bogus = Timelock.unlock_and_prove_without_secret public ~time locked_value_bogus in let sym_key_bogus = diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index 5b3e4b34c6a1..3b01b3a77c76 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -457,10 +457,10 @@ let test_parse_comb_data () = (a, ac1) Script_typed_ir.ty -> (a, ac2) Script_typed_ir.ty -> bool = fun ty1 ty2 -> match Script_typed_ir.(is_comparable ty1, is_comparable ty2) with - | (Yes, Yes) -> ty1 = ty2 - | (No, No) -> ty1 = ty2 - | (Yes, No) -> assert false - | (No, Yes) -> assert false + | Yes, Yes -> ty1 = ty2 + | No, No -> ty1 = ty2 + | Yes, No -> assert false + | No, Yes -> assert false (* These last two cases can't happen because the comparable character of a type is a function of its concrete type. @@ -624,9 +624,9 @@ let test_optimal_comb () = ty v >>=? fun (unparsed, ctxt) -> - let (unparsed_canonical, unparsed_size) = size_of_micheline unparsed in + let unparsed_canonical, unparsed_size = size_of_micheline unparsed in List.iter_es (fun other_repr -> - let (other_repr_canonical, other_repr_size) = + let other_repr_canonical, other_repr_size = size_of_micheline other_repr in if other_repr_size < unparsed_size then @@ -665,7 +665,7 @@ let test_optimal_comb () = (* Check that UNPACK on contract is forbidden. See https://gitlab.com/tezos/tezos/-/issues/301 for the motivation behind this restriction. - *) +*) let test_contract_not_packable () = let contract_unit = Prim (0, Script.T_contract, [Prim (0, T_unit, [], [])], []) diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_activation.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_activation.ml index fcb83a09cb24..c96449bb68fd 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_activation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_activation.ml @@ -95,7 +95,7 @@ let secrets () = in List.map (fun (mnemonic, secret, amount, pkh, password, email) -> - let (pkh', pk, sk) = read_key mnemonic email password in + let pkh', pk, sk = read_key mnemonic email password in let pkh = Signature.Public_key_hash.of_b58check_exn pkh in assert (Signature.Public_key_hash.equal pkh pkh') ; let account = Account.{pkh; pk; sk} in diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml index ac158b005df2..ea16261ab262 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml @@ -102,7 +102,7 @@ let test_multiple_origination_and_delegation () = >>=? fun originations -> (* These computed originated contracts are not the ones really created *) (* We will extract them from the tickets *) - let (originations_operations, _) = List.split originations in + let originations_operations, _ = List.split originations in Op.combine_operations ~source:c1 (B blk) originations_operations >>=? fun operation -> Incremental.begin_construction blk >>=? fun inc -> @@ -193,9 +193,9 @@ let test_failing_operation_in_the_middle () = (Manager_operation_result {operation_result = Backtracked _; _}) :: Contents_result (Manager_operation_result {operation_result = Failed (_, trace); _}) - :: Contents_result - (Manager_operation_result {operation_result = Skipped _; _}) - :: _ -> + :: Contents_result + (Manager_operation_result {operation_result = Skipped _; _}) + :: _ -> let trace_string = Format.asprintf "%a" Environment.Error_monad.pp_trace trace in @@ -238,9 +238,9 @@ let test_failing_operation_in_the_middle_with_fees () = (Manager_operation_result {operation_result = Backtracked _; _}) :: Contents_result (Manager_operation_result {operation_result = Failed (_, trace); _}) - :: Contents_result - (Manager_operation_result {operation_result = Skipped _; _}) - :: _ -> + :: Contents_result + (Manager_operation_result {operation_result = Skipped _; _}) + :: _ -> let trace_string = Format.asprintf "%a" Environment.Error_monad.pp_trace trace in diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index 7c453ea027f3..907ce5b8d05c 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -57,10 +57,10 @@ let context_init tup = rollup when the feature flag is deactivated and checks that it fails. *) let test_disable_feature_flag () = - let* (b, contract) = Context.init1 () in + let* b, contract = Context.init1 () in let* i = Incremental.begin_construction b in let kind = Sc_rollup.Kind.Example_arith in - let* (op, _) = Op.sc_rollup_origination (I i) contract kind "" in + let* op, _ = Op.sc_rollup_origination (I i) contract kind "" in let expect_failure = function | Environment.Ecoproto_error (Apply.Sc_rollup_feature_disabled as e) :: _ -> Assert.test_error_encodings e ; @@ -106,12 +106,10 @@ let test_sc_rollups_all_well_defined () = (** Initializes the context and originates a SCORU. *) let init_and_originate tup = - let* (ctxt, contracts) = context_init tup in + let* ctxt, contracts = context_init tup in let contract = Context.tup_hd tup contracts in let kind = Sc_rollup.Kind.Example_arith in - let* (operation, rollup) = - Op.sc_rollup_origination (B ctxt) contract kind "" - in + let* operation, rollup = Op.sc_rollup_origination (B ctxt) contract kind "" in let* b = Block.bake ~operation ctxt in return (b, contracts, rollup) @@ -160,8 +158,8 @@ let dummy_commitment ctxt rollup = (** [test_publish_and_cement] creates a rollup, publishes a commitment and then [commitment_freq] blocks later cements that commitment *) let test_publish_and_cement () = - let* (ctxt, contracts, rollup) = init_and_originate Context.T2 in - let (_, contract) = contracts in + let* ctxt, contracts, rollup = init_and_originate Context.T2 in + let _, contract = contracts in let* i = Incremental.begin_construction ctxt in let* c = dummy_commitment i rollup in let* operation = Op.sc_rollup_publish (B ctxt) contract rollup c in @@ -179,8 +177,8 @@ let test_publish_and_cement () = without waiting for the challenge period to elapse. We check that this fails with the correct error. *) let test_cement_fails_if_premature () = - let* (ctxt, contracts, rollup) = init_and_originate Context.T2 in - let (_, contract) = contracts in + let* ctxt, contracts, rollup = init_and_originate Context.T2 in + let _, contract = contracts in let* i = Incremental.begin_construction ctxt in let* c = dummy_commitment i rollup in let* operation = Op.sc_rollup_publish (B ctxt) contract rollup c in @@ -204,8 +202,8 @@ let test_cement_fails_if_premature () = publishes two different commitments with the same staker. We check that the second publish fails. *) let test_publish_fails_on_backtrack () = - let* (ctxt, contracts, rollup) = init_and_originate Context.T2 in - let (_, contract) = contracts in + let* ctxt, contracts, rollup = init_and_originate Context.T2 in + let _, contract = contracts in let* i = Incremental.begin_construction ctxt in let* commitment1 = dummy_commitment i rollup in let commitment2 = @@ -232,8 +230,8 @@ let test_publish_fails_on_backtrack () = cement one of the commitments; it checks that this fails because the commitment is contested. *) let test_cement_fails_on_conflict () = - let* (ctxt, contracts, rollup) = init_and_originate Context.T3 in - let (_, contract1, contract2) = contracts in + let* ctxt, contracts, rollup = init_and_originate Context.T3 in + let _, contract1, contract2 = contracts in let* i = Incremental.begin_construction ctxt in let* commitment1 = dummy_commitment i rollup in let commitment2 = diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml index 9aa4d718d665..2fe0bd7c3db3 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -60,7 +60,8 @@ let check_proto_error e t = check_proto_error_f (( = ) e) t Michelson runtime error and the second one equals [e]. *) let check_runtime_error e = function | Environment.Ecoproto_error (Script_interpreter.Runtime_contract_error _) - :: Environment.Ecoproto_error second :: _ + :: Environment.Ecoproto_error second + :: _ when second = e -> Assert.test_error_encodings e ; return_unit @@ -306,7 +307,7 @@ let gen_l2_account ?rng_state () = Bytes.init 32 (fun _ -> char_of_int @@ Random.State.int rng_state 255)) rng_state in - let (_pkh, public_key, secret_key) = Bls.generate_key ?seed () in + let _pkh, public_key, secret_key = Bls.generate_key ?seed () in (secret_key, public_key, Tx_rollup_l2_address.of_bls_pk public_key) (** [make_ticket_key ty contents ticketer tx_rollup] computes the ticket hash @@ -379,7 +380,7 @@ let make_deposit b tx_rollup l1_src addr = Block.bake ~operation b >>=? fun b -> make_unit_ticket_key (B b) ~ticketer:contract tx_rollup >>=? fun ticket_hash -> - let (deposit, cumulated_size) = + let deposit, cumulated_size = Tx_rollup_message.make_deposit (Context.Contract.pkh l1_src) (Tx_rollup_l2_address.Indexable.value addr) @@ -457,11 +458,11 @@ let assert_ticket_balance ~loc block token owner expected = Ticket_balance_key.of_ex_token ctxt ~owner token >>=?? fun (key_hash, ctxt) -> Ticket_balance.get_balance ctxt key_hash >>=?? fun (balance, _) -> match (balance, expected) with - | (Some b, Some e) -> Assert.equal_int ~loc (Z.to_int b) e - | (Some b, None) -> + | Some b, Some e -> Assert.equal_int ~loc (Z.to_int b) e + | Some b, None -> failwith "%s: Expected no balance but got some %d" loc (Z.to_int b) - | (None, Some b) -> failwith "%s: Expected balance %d but got none" loc b - | (None, None) -> return () + | None, Some b -> failwith "%s: Expected balance %d but got none" loc b + | None, None -> return () module Nat_ticket = struct let ty_str = "nat" @@ -957,7 +958,7 @@ let test_inbox_size_too_big () = (** Try to add enough batches to reach the batch count limit of an inbox. *) let test_inbox_count_too_big () = context_init1 () >>=? fun (b, contract) -> - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in Context.get_constants (B b) >>=? fun constant -> let message_count = constant.parametric.tx_rollup_max_messages_per_inbox in let contents = "some contents" in @@ -1034,7 +1035,7 @@ let test_inbox_count_too_big () = (** [test_valid_deposit] checks that a smart contract can deposit tickets to a transaction rollup. *) let test_valid_deposit () = - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> make_deposit b tx_rollup account addr @@ -1058,7 +1059,7 @@ let test_valid_deposit () = (** [test_additional_space_allocation_for_valid_deposit] originates a tx rollup with small [tx_rollup_origination_size], make a valid deposit and check additional space allocation *) let test_additional_space_allocation_for_valid_deposit () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in let tx_rollup_origination_size = 1 in context_init1 ~tx_rollup_origination_size () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> @@ -1091,7 +1092,7 @@ let test_additional_space_allocation_for_valid_deposit () = interpreter checks the existence of a transaction rollup prior to sending a deposit order. *) let test_valid_deposit_inexistant_rollup () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> Contract_helpers.originate_contract "contracts/tx_rollup_deposit.tz" @@ -1118,7 +1119,7 @@ let test_valid_deposit_inexistant_rollup () = (** [test_invalid_deposit_not_contract] checks a smart contract cannot deposit something that is not a ticket. *) let test_invalid_deposit_not_ticket () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> @@ -1151,7 +1152,7 @@ let string_ticket_of_size expected_size = let ticket_contents_ty = Tezos_micheline.Micheline.Prim (0, Michelson_v1_primitives.T_string, [], []) in - let (_, ticket_contents_ty_size) = + let _, ticket_contents_ty_size = Script_typed_ir_size.node_size ticket_contents_ty in Alcotest.( @@ -1160,7 +1161,7 @@ let string_ticket_of_size expected_size = "Expected size of ticket_contents type" (Saturation_repr.of_int_opt 40) (Some ticket_contents_ty_size)) ; - let (_, empty_string_size) = + let _, empty_string_size = Script_typed_ir_size.node_size (Expr_common.string "") in let ticket_contents = @@ -1171,7 +1172,7 @@ let string_ticket_of_size expected_size = - Saturation_repr.to_int empty_string_size) 'a') in - let (_, ticket_contents_size) = + let _, ticket_contents_size = Script_typed_ir_size.node_size ticket_contents in Alcotest.( @@ -1185,7 +1186,7 @@ let string_ticket_of_size expected_size = (** [test_invalid_deposit_too_big_ticket] tests that depositing a ticket that has a content whose size exceeds [tx_rollup_max_ticket_payload_size] fails.*) let test_invalid_deposit_too_big_ticket () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> Context.get_constants (B b) >>=? fun constant -> let tx_rollup_max_ticket_payload_size = @@ -1236,7 +1237,7 @@ let test_invalid_deposit_too_big_ticket () = ticket that has a content and type whose summed size exceeds [tx_rollup_max_ticket_payload_size] fails.*) let test_invalid_deposit_too_big_ticket_type () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> Context.get_constants (B b) >>=? fun constant -> let tx_rollup_max_ticket_payload_size = @@ -1286,7 +1287,7 @@ let test_invalid_deposit_too_big_ticket_type () = (** [test_valid_deposit_big_ticket] tests that depositing a ticket whose size is exactly [tx_rollup_max_ticket_payload_size] succeeds.*) let test_valid_deposit_big_ticket () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in (* [overhead] is the number of bytes introduced by the wrapping of a string in a ticket. This encompasses the ticketer, amount and ty fields. @@ -1336,7 +1337,7 @@ let test_valid_deposit_big_ticket () = (** [test_invalid_entrypoint] checks that a transaction to an invalid entrypoint of a transaction rollup fails. *) let test_invalid_entrypoint () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> @@ -1390,7 +1391,7 @@ let test_invalid_l2_address () = (** [test_valid_deposit_invalid_amount] checks that a transaction to a transaction rollup fails if the [amount] parameter is not null. *) let test_valid_deposit_invalid_amount () = - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> Contract_helpers.originate_contract @@ -1416,7 +1417,7 @@ let test_valid_deposit_invalid_amount () = too many tickets is rejected *) let test_deposit_too_many_tickets () = let too_many = Z.succ (Z.of_int64 Int64.max_int) in - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (block, account1) -> originate block account1 >>=? fun (block, tx_rollup) -> Nat_ticket.init_deposit too_many block tx_rollup account1 @@ -1455,7 +1456,7 @@ let test_deposit_by_non_internal_operation () = (** Test that block finalization changes gas rates *) let test_finalization () = context_init2 ~tx_rollup_max_inboxes_count:5_000 () >>=? fun (b, contracts) -> - let (contract, _) = contracts in + let contract, _ = contracts in let filler = contract in originate b contract >>=? fun (b, tx_rollup) -> Context.get_constants (B b) @@ -1635,7 +1636,7 @@ let test_commit_current_inbox () = (* In order to have a permissible commitment, we need a transaction. *) Incremental.begin_construction b >>=? fun i -> let contents = "batch" in - let (message, _) = Tx_rollup_message.make_batch contents in + let message, _ = Tx_rollup_message.make_batch contents in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let inbox_hash = Tx_rollup_inbox.Merkle.merklize_list [message_hash] in Op.tx_rollup_submit_batch (I i) contract1 tx_rollup contents @@ -2225,7 +2226,7 @@ module Rejection = struct let run_transaction ctxt l2_parameters msg = let open Prover_context.Syntax in - let* (ctxt, _) = Prover_apply.apply_message ctxt l2_parameters msg in + let* ctxt, _ = Prover_apply.apply_message ctxt l2_parameters msg in return ctxt let time () = @@ -2289,7 +2290,7 @@ module Rejection = struct let open L2_Context.Syntax in let index = C.index store in let* hash = hash_tree_from_store store in - let* (proof, ()) = + let* proof, () = C.produce_stream_proof index (`Node hash) (fun ctxt -> catch (run_transaction ctxt l2_parameters msg) @@ -2301,7 +2302,7 @@ module Rejection = struct let valid_empty_proof l2_parameters = let open L2_Context.Syntax in let* l2_store = init_l2_store () in - let (message, _) = Tx_rollup_message.make_batch "bogus" in + let message, _ = Tx_rollup_message.make_batch "bogus" in make_proof l2_store l2_parameters message let invalid_proof : Tx_rollup_l2_proof.t = @@ -2317,10 +2318,10 @@ module Rejection = struct let replace_commitment ~l2_parameters ~store ~commitment messages = let open L2_Context in let open Syntax in - let* (_, rev_results) = + let* _, rev_results = list_fold_left_m (fun (store, rev_results) msg -> - let* (store, withdraws) = + let* store, withdraws = catch (Apply.apply_message store l2_parameters msg) (fun (store, (_, withdraws)) -> return (store, withdraws)) @@ -2383,7 +2384,7 @@ module Rejection = struct make_proof store l2_parameters deposit >>= fun proof -> Incremental.begin_construction b >>=? fun i -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -2466,13 +2467,13 @@ module Rejection = struct (** Test that we can produce a simple but valid proof. *) let test_valid_proof_on_invalid_commitment () = - let (sk, pk, addr) = gen_l2_account () in + let sk, pk, addr = gen_l2_account () in init_with_deposit addr >>=? fun (b, account, _, tx_rollup, store, ticket_hash) -> hash_tree_from_store store >>= fun l2_context_hash -> (* Create a transfer from [pk] to a new address *) - let (_, _, addr2) = gen_l2_account () in - let (message, batch_bytes) = + let _, _, addr2 = gen_l2_account () in + let message, batch_bytes = make_message_transfer ~signers:[sk] [(bls_pk pk, None, [(addr2, ticket_hash, 1L)])] @@ -2494,7 +2495,7 @@ module Rejection = struct l2_parameters (I i) >>=? fun l2_parameters -> make_proof store l2_parameters message >>= fun proof -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -2516,7 +2517,7 @@ module Rejection = struct (** It is really similar to {!test_valid_proof_on_invalid_commitment} but it tries to reject a valid commitment, thus, fails. *) let test_valid_proof_on_valid_commitment () = - let (sk, pk, addr) = gen_l2_account () in + let sk, pk, addr = gen_l2_account () in init_with_deposit addr >>=? fun (b, account, _, tx_rollup, store, ticket_hash) -> (* init_with_deposit creates a commitment -- we'll just check the bond @@ -2525,8 +2526,8 @@ module Rejection = struct check_bond (Incremental.alpha_ctxt i) tx_rollup account 1 >>=? fun () -> hash_tree_from_store store >>= fun l2_context_hash -> (* Create a transfer from [pk] to a new address *) - let (_, _, addr2) = gen_l2_account () in - let (message, batch_bytes) = + let _, _, addr2 = gen_l2_account () in + let message, batch_bytes = make_message_transfer ~signers:[sk] [(bls_pk pk, None, [(addr2, ticket_hash, 1L)])] @@ -2548,7 +2549,7 @@ module Rejection = struct l2_parameters (B b) >>=? fun l2_parameters -> make_proof store l2_parameters message >>= fun proof -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -2585,7 +2586,7 @@ module Rejection = struct *) let test_rejection_rewards () = let open Error_monad_operators in - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in init_l2_store () >>= fun store -> context_init2 () >>=? fun (b, (contract1, contract2)) -> originate b contract1 >>=? fun (b, tx_rollup) -> @@ -2607,7 +2608,7 @@ module Rejection = struct Block.bake ~operation b >>=? fun b -> Incremental.begin_construction b >>=? fun i -> l2_parameters (B b) >>=? fun l2_parameters -> - let (message, _) = Tx_rollup_message.make_batch "fake" in + let message, _ = Tx_rollup_message.make_batch "fake" in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = single_message_path message_hash in hash_tree_from_store store >>= fun l2_context_hash -> @@ -2646,7 +2647,7 @@ module Rejection = struct (* Now we produce a valid proof rejecting the second commitment *) make_proof store l2_parameters message >>= fun proof -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment1 ~message_position in Op.tx_rollup_reject @@ -2681,7 +2682,7 @@ module Rejection = struct in let message_position = 0 in let message_path = single_message_path message_hash in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment0 ~message_position in Op.tx_rollup_reject @@ -2711,11 +2712,11 @@ module Rejection = struct message whose l2 apply will fail in whatever specific way we wish to test. *) let do_test_proof_with_hard_fail_message make_bad_message = - let (sk, pk, addr) = gen_l2_account () in + let sk, pk, addr = gen_l2_account () in init_with_deposit addr >>=? fun (b, account, _, tx_rollup, store, ticket_hash) -> hash_tree_from_store store >>= fun l2_context_hash -> - let (message, batch_bytes) = make_bad_message sk pk addr ticket_hash in + let message, batch_bytes = make_bad_message sk pk addr ticket_hash in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = single_message_path message_hash in Op.tx_rollup_submit_batch (B b) account tx_rollup batch_bytes @@ -2733,7 +2734,7 @@ module Rejection = struct l2_parameters (B b) >>=? fun l2_parameters -> make_proof store l2_parameters message >>= fun proof -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -2760,7 +2761,7 @@ module Rejection = struct do_test_proof_with_hard_fail_message (fun _sk pk addr ticket_hash -> (* We build a dummy transfer, we don't care about the content, it will hard fail on the check signature. *) - let (random_sk, _, _) = gen_l2_account () in + let random_sk, _, _ = gen_l2_account () in make_message_transfer ~signers:[random_sk] [(Bls_pk pk, None, [(addr, ticket_hash, 1L)])]) @@ -2770,14 +2771,14 @@ module Rejection = struct let test_proof_with_unparsable_batch () = do_test_proof_with_hard_fail_message (fun _sk _pk _addr _ticket_hash -> let message = "wrong" in - let (batch, _) = Tx_rollup_message.make_batch message in + let batch, _ = Tx_rollup_message.make_batch message in (batch, message)) (** Test that proof production and verification can handle an invalid counter *) let test_proof_with_invalid_counter () = do_test_proof_with_hard_fail_message (fun sk pk _addr ticket_hash -> - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in make_message_transfer ~signers:[sk] [(Bls_pk pk, Some 42L, [(addr, ticket_hash, 1L)])]) @@ -2805,13 +2806,13 @@ module Rejection = struct let test_empty_proof_on_invalid_message () = init_with_valid_commitment () >>=? fun (i, contract, tx_rollup, level, message, commitment) -> - let (msg, _) = Tx_rollup_message.make_batch message in + let msg, _ = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated msg in let message_path = single_message_path message_hash in l2_parameters (I i) >>=? fun l2_parameters -> valid_empty_proof l2_parameters >>= fun proof -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -2834,11 +2835,11 @@ module Rejection = struct let test_invalid_proof_on_invalid_commitment () = init_with_valid_commitment () >>=? fun (i, contract, tx_rollup, level, message, commitment) -> - let (msg, _) = Tx_rollup_message.make_batch message in + let msg, _ = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated msg in let message_path = single_message_path message_hash in let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -2867,7 +2868,7 @@ module Rejection = struct let test_invalid_agreed () = init_with_valid_commitment () >>=? fun (i, contract, tx_rollup, level, message, commitment) -> - let (msg, _) = Tx_rollup_message.make_batch message in + let msg, _ = Tx_rollup_message.make_batch message in (* This intentionally does not match *) let previous_message_result : Tx_rollup_message_result.t = { @@ -2879,7 +2880,7 @@ module Rejection = struct let message_hash = Tx_rollup_message_hash.hash_uncarbonated msg in let message_path = single_message_path message_hash in let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -2924,7 +2925,7 @@ module Rejection = struct Block.bake ~operation b >>=? fun b -> Incremental.begin_construction b >>=? fun i -> let level = Tx_rollup_level.root in - let (message, _size) = Tx_rollup_message.make_batch message in + let message, _size = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = single_message_path message_hash in l2_parameters (I i) >>=? fun l2_parameters -> @@ -2970,13 +2971,13 @@ module Rejection = struct Incremental.add_operation i op >>=? fun i -> Op.tx_rollup_finalize (I i) contract tx_rollup >>=? fun op -> Incremental.add_operation i op >>=? fun i -> - let (message, _size) = Tx_rollup_message.make_batch message in + let message, _size = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = single_message_path message_hash in l2_parameters (I i) >>=? fun l2_parameters -> valid_empty_proof l2_parameters >>= fun proof -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -3007,20 +3008,20 @@ module Rejection = struct let test_wrong_message_hash () = init_with_valid_commitment () >>=? fun (i, contract1, tx_rollup, level, prev_message, commitment) -> - let (prev_message, _size) = Tx_rollup_message.make_batch prev_message in + let prev_message, _size = Tx_rollup_message.make_batch prev_message in let prev_message_hash = Tx_rollup_message_hash.hash_uncarbonated prev_message in let expected_root = Tx_rollup_inbox.Merkle.merklize_list [prev_message_hash] in - let (message, _size) = Tx_rollup_message.make_batch "wrong message" in + let message, _size = Tx_rollup_message.make_batch "wrong message" in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = single_message_path message_hash in l2_parameters (I i) >>=? fun l2_parameters -> valid_empty_proof l2_parameters >>= fun proof -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -3050,7 +3051,7 @@ module Rejection = struct let test_wrong_message_position () = init_with_valid_commitment () >>=? fun (i, contract1, tx_rollup, level, message, _commitment) -> - let (message, _size) = Tx_rollup_message.make_batch message in + let message, _size = Tx_rollup_message.make_batch message in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = single_message_path message_hash in l2_parameters (I i) >>=? fun l2_parameters -> @@ -3081,7 +3082,7 @@ module Rejection = struct (** Test rejecting a commitment to a non-trivial message -- that is, not a no-op. *) let test_nontrivial_rejection () = - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in init_l2_store () >>= fun store -> context_init1 () >>=? fun (b, account) -> originate b account >>=? fun (b, tx_rollup) -> @@ -3096,7 +3097,7 @@ module Rejection = struct Incremental.finalize_block i >>=? fun b -> Incremental.begin_construction b >>=? fun i -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -3148,7 +3149,7 @@ module Rejection = struct return ctxt let test_large_rejection size = - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in init_l2_store () >>= fun store -> context_init1 ~tx_rollup_rejection_max_proof_size:size () >>=? fun (b, account) -> @@ -3173,7 +3174,7 @@ module Rejection = struct make_proof store l2_parameters deposit >>= fun proof -> Incremental.begin_construction b >>=? fun i -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -3219,7 +3220,7 @@ module Rejection = struct let rec drop_n x n = if n <= 0 then x else drop_n (drop x) (n - 1) let test_valid_proof_truncated () = - let (_, _, addr) = gen_l2_account () in + let _, _, addr = gen_l2_account () in init_l2_store () >>= fun store -> context_init1 ~tx_rollup_rejection_max_proof_size:100 () >>=? fun (b, account) -> @@ -3248,7 +3249,7 @@ module Rejection = struct size limit. *) Incremental.begin_construction b >>=? fun i -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -3278,7 +3279,7 @@ module Rejection = struct if [n_withdraw <= tx_rollup_max_withdrawals_per_batch] but also must succeed to reject if [n_withdraw > tx_rollup_max_withdrawals_per_batch]. *) let test_reject_withdrawals_helper ?expect_failure n_withdraw = - let (sk, pk, addr) = gen_l2_account () in + let sk, pk, addr = gen_l2_account () in init_with_deposit ~tx_rollup_hard_size_limit_per_message:20_000 addr >>=? fun (b, account, _, tx_rollup, store, ticket_hash) -> hash_tree_from_store store >>= fun l2_context_hash -> @@ -3297,7 +3298,7 @@ module Rejection = struct contents = withdraws; } in - let (message, batch_bytes) = + let message, batch_bytes = make_and_sign_transaction ~signers:[sk] [operation] in @@ -3351,7 +3352,7 @@ module Rejection = struct } in let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -3390,13 +3391,13 @@ module Rejection = struct [Ticket_hash.zero]. *) let fill_store store l2_accounts = let open L2_Context.Syntax in - let* (store, _, tidx) = + let* store, _, tidx = L2_Context.Ticket_index.get_or_associate_index store Ticket_hash.zero in let* store = list_fold_left_m (fun store (_, pk, addr) -> - let* (store, _, aidx) = + let* store, _, aidx = L2_Context.Address_index.get_or_associate_index store addr in let* store = @@ -3455,8 +3456,8 @@ module Rejection = struct in (* Then, we build a real message which is close to the maximum message size limit and produces a proof also close to the maximum proof size limit. *) - let (_sk, _pk, addr) = gen_l2_account ~rng_state () in - let (signers, transfers) = + let _sk, _pk, addr = gen_l2_account ~rng_state () in + let signers, transfers = List.map (fun (sk, pk, _) -> (sk, (bls_pk pk, None, [(addr, Ticket_hash.zero, 1L)]))) @@ -3468,11 +3469,11 @@ module Rejection = struct |> List.split in l2_parameters (B b) >>=? fun l2_parameters -> - let (message1, batch_bytes) = make_message_transfer ~signers transfers in + let message1, batch_bytes = make_message_transfer ~signers transfers in let message1_hash = Tx_rollup_message_hash.hash_uncarbonated message1 in Incremental.begin_construction b >>=? fun i -> (* Submit the two first hand-crafted messages. *) - let (message0, _) = Tx_rollup_message.make_batch "xoxo" in + let message0, _ = Tx_rollup_message.make_batch "xoxo" in let message0_hash = Tx_rollup_message_hash.hash_uncarbonated message0 in Op.tx_rollup_submit_batch ~gas_limit:(Gas.Arith.integral_of_int_exn 2_500) @@ -3526,10 +3527,10 @@ module Rejection = struct let message_path = assert_ok @@ Tx_rollup_inbox.Merkle.compute_path message_hashes 1 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position:1 in - let (_, previous_message_result_path) = + let _, previous_message_result_path = message_result_hash_and_path commitment ~message_position:0 in (* The actual proof size is almost 32Kb, after the drop the truncated @@ -3631,7 +3632,7 @@ end module Single_message_inbox = struct let contents = "bogus" - let (message, _) = Tx_rollup_message.make_batch contents + let message, _ = Tx_rollup_message.make_batch contents let message_hash = Tx_rollup_message_hash.hash_uncarbonated message @@ -3652,7 +3653,7 @@ module Single_message_inbox = struct l2_parameters (B b) >>=? fun l2_parameters -> Rejection.valid_empty_proof l2_parameters >>= fun proof -> let message_position = 0 in - let (message_result_hash, message_result_path) = + let message_result_hash, message_result_path = message_result_hash_and_path commitment ~message_position in Op.tx_rollup_reject @@ -3923,7 +3924,7 @@ let test_state_message_storage_preallocation () = originate b account1 >>=? fun (b, tx_rollup) -> Incremental.begin_construction b >>=? fun i -> let ctxt = Incremental.alpha_ctxt i in - let (message, _) = Tx_rollup_message.make_batch "bogus" in + let message, _ = Tx_rollup_message.make_batch "bogus" in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let _inbox_hash = Tx_rollup_inbox.Merkle.merklize_list [message_hash] in let state = Tx_rollup_state.initial_state ~pre_allocated_storage:Z.zero in @@ -5181,7 +5182,7 @@ module Withdraw = struct withdraw is equal to the deposit, rather than the remainder after we overflow. *) let max = Int64.(sub max_int 1L) in - let (_, _, pkh) = gen_l2_account () in + let _, _, pkh = gen_l2_account () in context_init1 () >>=? fun (b, account1) -> originate b account1 >>=? fun (b, tx_rollup) -> let pkh_str = Tx_rollup_l2_address.to_b58check pkh in @@ -5204,7 +5205,7 @@ module Withdraw = struct >>=? fun (withdraw, _) -> Nat_ticket.ticket_hash (B b) ~ticketer:deposit_contract ~tx_rollup >>=? fun ticket_hash -> - let (deposit1, _) = + let deposit1, _ = Tx_rollup_message.make_deposit deposit_pkh (Tx_rollup_l2_address.Indexable.value pkh) @@ -5260,8 +5261,8 @@ module Withdraw = struct without overflowing. *) let test_deposit_multiple_destinations_at_limit () = let max = Int64.max_int in - let (_, _, pkh1) = gen_l2_account () in - let (_, _, pkh2) = gen_l2_account () in + let _, _, pkh1 = gen_l2_account () in + let _, _, pkh2 = gen_l2_account () in context_init1 () >>=? fun (b, account1) -> originate b account1 >>=? fun (b, tx_rollup) -> Nat_ticket.init_deposit_contract (Z.of_int64 max) b account1 @@ -5283,8 +5284,8 @@ module Withdraw = struct ticket_hash (Tx_rollup_l2_qty.of_int64_exn max) in - let (deposit1, _) = make_deposit pkh1 in - let (deposit2, _) = make_deposit pkh2 in + let deposit1, _ = make_deposit pkh1 in + let deposit2, _ = make_deposit pkh2 in Rejection.init_l2_store () >>= fun store -> (* For the first deposit, we have no withdraws *) make_and_check_correct_commitment diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_voting.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_voting.ml index a57fdbb3bec7..4ea7ebaf3b1b 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_voting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_voting.ml @@ -505,15 +505,15 @@ let get_smallest_prefix_voters_for_quorum active_delegates active_power |> fun active_power_sum -> let rec loop delegates power sum selected = match (delegates, power) with - | ([], []) -> selected - | (del :: delegates, del_power :: power) -> + | [], [] -> selected + | del :: delegates, del_power :: power -> if den * sum < Float.to_int (expected_quorum *. Int64.to_float active_power_sum) then loop delegates power (sum + Int64.to_int del_power) (del :: selected) else selected - | (_, _) -> [] + | _, _ -> [] in loop active_delegates active_power 0 [] @@ -816,8 +816,8 @@ let test_supermajority_in_exploration supermajority () = (* majority/minority vote depending on the [supermajority] parameter *) let num_yays = if supermajority then num_yays else num_yays - 1 in let open Alpha_context in - let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in - let (yays_delegates, _) = List.split_n num_yays rest in + let nays_delegates, rest = List.split_n num_nays delegates_p2 in + let yays_delegates, _ = List.split_n num_yays rest in List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates >>=? fun operations_yays -> List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates diff --git a/src/proto_alpha/lib_protocol/test/integration/test_constants.ml b/src/proto_alpha/lib_protocol/test/integration/test_constants.ml index c836f5948410..648d18bea765 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_constants.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_constants.ml @@ -107,8 +107,8 @@ let test_sc_rollup_max_commitment_storage_cost_lt_deposit () = (* Check that [sc_rollup_commitment_storage_size_in_bytes = commitments_entry_size + - commitment_stake_count_entry_size + commitment_added_entry_size] - + commitment_stake_count_entry_size + commitment_added_entry_size] + Required to ensure [sc_rollup_stake_amount] and [sc_rollup_max_lookahead] are correctly scaled with respect to each other - see {!test_sc_rollup_max_commitment_storage_cost_lt_deposit} diff --git a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml index ecc194564347..dc8e58f9fdb2 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml @@ -74,13 +74,13 @@ let create_context () = delegate's pkh. *) let init_test ~user_is_delegate = create_context () >>=? fun (ctxt, _) -> - let (delegate, delegate_pk, _) = Signature.generate_key () in + let delegate, delegate_pk, _ = Signature.generate_key () in let delegate_contract = Contract.Implicit delegate in let delegate_account = `Contract (Contract.Implicit delegate) in let user_contract = if user_is_delegate then delegate_contract else - let (user, _, _) = Signature.generate_key () in + let user, _, _ = Signature.generate_key () in Contract.Implicit user in let user_account = `Contract user_contract in @@ -115,7 +115,7 @@ let test_delegate_then_freeze_deposit () = (* Fetch staking balance after delegation and before freeze. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance -> (* Freeze a tx-rollup deposit. *) - let (tx_rollup, _) = mk_tx_rollup () in + let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in let deposit_account = `Frozen_bonds (user_contract, bond_id) in @@ -163,7 +163,7 @@ let test_freeze_deposit_then_delegate () = (* Fetch user's initial balance before freeze. *) Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> (* Freeze a tx-rollup deposit. *) - let (tx_rollup, _) = mk_tx_rollup () in + let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in let deposit_account = `Frozen_bonds (user_contract, bond_id) in @@ -217,7 +217,7 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () = Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> Assert.equal_bool ~loc:__LOC__ Tez.(user_balance > zero) true >>=? fun () -> (* Freeze a tx-rollup deposit. *) - let (tx_rollup, _) = mk_tx_rollup () in + let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = user_balance in let deposit_account = `Frozen_bonds (user_contract, bond_id) in @@ -254,9 +254,9 @@ let test_total_stake ~user_is_delegate () = Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> Assert.equal_bool ~loc:__LOC__ Tez.(user_balance > zero) true >>=? fun () -> (* Freeze 2 tx-rollup deposits. *) - let (tx_rollup, nonce) = mk_tx_rollup () in + let tx_rollup, nonce = mk_tx_rollup () in let bond_id1 = Bond_id.Tx_rollup_bond_id tx_rollup in - let (tx_rollup, _) = mk_tx_rollup ~nonce () in + let tx_rollup, _ = mk_tx_rollup ~nonce () in let bond_id2 = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in @@ -320,7 +320,7 @@ let test_rpcs () = let test_scenario scenario = init_test ~user_is_delegate:false >>=? fun (ctxt, user_contract, user_account, delegate1) -> - let (delegate2, delegate_pk2, _) = Signature.generate_key () in + let delegate2, delegate_pk2, _ = Signature.generate_key () in let delegate_contract2 = Contract.Implicit delegate2 in let delegate_account2 = `Contract delegate_contract2 in let delegate_balance2 = big_random_amount () in @@ -330,8 +330,8 @@ let test_scenario scenario = revealing its manager key is a prerequisite. *) Contract.reveal_manager_key ctxt delegate2 delegate_pk2 >>>=? fun ctxt -> Delegate.set ctxt delegate_contract2 (Some delegate2) >>>=? fun ctxt -> - let (tx_rollup1, nonce) = mk_tx_rollup () in - let (tx_rollup2, _) = mk_tx_rollup ~nonce () in + let tx_rollup1, nonce = mk_tx_rollup () in + let tx_rollup2, _ = mk_tx_rollup ~nonce () in let bond_id1 = Bond_id.Tx_rollup_bond_id tx_rollup1 in let bond_id2 = Bond_id.Tx_rollup_bond_id tx_rollup2 in let deposit_amount = Tez.of_mutez_exn 1000L in diff --git a/src/proto_alpha/lib_protocol/test/integration/test_liquidity_baking.ml b/src/proto_alpha/lib_protocol/test/integration/test_liquidity_baking.ml index 5eb5f12b0e22..dfafb5fbecba 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_liquidity_baking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_liquidity_baking.ml @@ -54,7 +54,6 @@ let generate_init_state () = (* The script hash of https://gitlab.com/dexter2tz/dexter2tz/-/blob/d98643881fe14996803997f1283e84ebd2067e35/dexter.liquidity_baking.mligo.tz - *) let expected_cpmm_hash = Script_expr_hash.of_b58check_exn @@ -63,7 +62,6 @@ let expected_cpmm_hash = (* The script hash of https://gitlab.com/dexter2tz/dexter2tz/-/blob/d98643881fe14996803997f1283e84ebd2067e35/lqt_fa12.mligo.tz - *) let expected_lqt_hash = Script_expr_hash.of_b58check_exn @@ -226,7 +224,7 @@ let liquidity_baking_toggle_50 n () = (* Test that the subsidy can restart if LB_on votes regain majority. Bake n_votes with LB_off, check that the subsidy is paused, bake n_votes with LB_on, check that the subsidy flows. - *) +*) let liquidity_baking_restart n_votes n () = Context.init1 ~consensus_threshold:0 () >>=? fun (blk, _contract) -> Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun liquidity_baking -> diff --git a/src/proto_alpha/lib_protocol/test/integration/test_storage_functions.ml b/src/proto_alpha/lib_protocol/test/integration/test_storage_functions.ml index 96415c5a1532..6f6fcab7eafc 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_storage_functions.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_storage_functions.ml @@ -107,13 +107,13 @@ let wrap m = m >|= Environment.wrap_tzresult let test_fold_keys_unaccounted () = let open Lwt_result_syntax in let* ctxt = Context.default_raw_context () in - let* (ctxt, _) = wrap (Table.init ctxt 1) in - let* (ctxt, _) = wrap (Table.init ctxt 2) in + let* ctxt, _ = wrap (Table.init ctxt 1) in + let* ctxt, _ = wrap (Table.init ctxt 2) in let*! items = Table.fold_keys_unaccounted ctxt ~order:`Undefined - ~f:(fun x acc -> Lwt.return @@ x :: acc) + ~f:(fun x acc -> Lwt.return @@ (x :: acc)) ~init:[] in let items = List.sort Compare.Int.compare items in diff --git a/src/proto_alpha/lib_protocol/test/integration/test_token.ml b/src/proto_alpha/lib_protocol/test/integration/test_token.ml index 717b55d4b82e..71b13ab8ccff 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_token.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_token.ml @@ -61,7 +61,7 @@ let test_simple_balances () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> let src = `Contract (Contract.Implicit pkh) in - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = `Contract (Contract.Implicit pkh) in let amount = Tez.one in wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) -> @@ -80,7 +80,7 @@ let test_simple_balance_updates () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> let src = Contract.Implicit pkh in - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.Implicit pkh in let amount = Tez.one in wrap (Token.transfer ctxt (`Contract src) (`Contract dest) amount) @@ -129,7 +129,7 @@ let test_allocated () = create_context () >>=? fun (ctxt, pkh) -> let dest = `Delegate_balance pkh in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = `Contract (Contract.Implicit pkh) in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> let dest = `Collected_commitments Blinded_public_key_hash.zero in @@ -182,7 +182,7 @@ let test_transferring_to_sink ctxt sink amount expected_bupds = Assert.proto_error_with_info ~loc:__LOC__ res "Overflowing tez addition" let test_transferring_to_contract ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.Implicit pkh in let amount = random_amount () in test_transferring_to_sink @@ -201,7 +201,7 @@ let test_transferring_to_collected_commitments ctxt = [(Commitments bpkh, Credited amount, Block_application)] let test_transferring_to_delegate_balance ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.Implicit pkh in let amount = random_amount () in test_transferring_to_sink @@ -211,7 +211,7 @@ let test_transferring_to_delegate_balance ctxt = [(Contract dest, Credited amount, Block_application)] let test_transferring_to_frozen_deposits ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in test_transferring_to_sink ctxt @@ -254,7 +254,7 @@ let test_transferring_to_burned ctxt = true >>=? fun () -> let pkh = Signature.Public_key_hash.zero in - let (p, r) = (Random.bool (), Random.bool ()) in + let p, r = (Random.bool (), Random.bool ()) in wrap (Token.transfer ctxt `Minted (`Lost_endorsing_rewards (pkh, p, r)) amount) >>=? fun (_, bupds) -> @@ -268,7 +268,7 @@ let test_transferring_to_burned ctxt = true let test_transferring_to_frozen_bonds ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let contract = Contract.Implicit pkh in let tx_rollup = mk_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in @@ -368,7 +368,7 @@ let test_transferring_from_bounded_source ctxt src amount expected_bupds = Assert.proto_error_with_info ~loc:__LOC__ res error_title let test_transferring_from_contract ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let src = Contract.Implicit pkh in let amount = random_amount () in test_transferring_from_bounded_source @@ -387,7 +387,7 @@ let test_transferring_from_collected_commitments ctxt = [(Commitments bpkh, Debited amount, Block_application)] let test_transferring_from_delegate_balance ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in let src = Contract.Implicit pkh in test_transferring_from_bounded_source @@ -397,7 +397,7 @@ let test_transferring_from_delegate_balance ctxt = [(Contract src, Debited amount, Block_application)] let test_transferring_from_frozen_deposits ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let amount = random_amount () in test_transferring_from_bounded_source ctxt @@ -414,7 +414,7 @@ let test_transferring_from_collected_fees ctxt = [(Block_fees, Debited amount, Block_application)] let test_transferring_from_frozen_bonds ctxt = - let (pkh, _pk, _sk) = Signature.generate_key () in + let pkh, _pk, _sk = Signature.generate_key () in let contract = Contract.Implicit pkh in let tx_rollup = mk_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in @@ -485,13 +485,13 @@ let cast_to_container_type x = let build_test_cases () = create_context () >>=? fun (ctxt, pkh) -> let origin = `Contract (Contract.Implicit pkh) in - let (user1, _, _) = Signature.generate_key () in + let user1, _, _ = Signature.generate_key () in let user1c = `Contract (Contract.Implicit user1) in - let (user2, _, _) = Signature.generate_key () in + let user2, _, _ = Signature.generate_key () in let user2c = `Contract (Contract.Implicit user2) in - let (baker1, baker1_pk, _) = Signature.generate_key () in + let baker1, baker1_pk, _ = Signature.generate_key () in let baker1c = `Contract (Contract.Implicit baker1) in - let (baker2, baker2_pk, _) = Signature.generate_key () in + let baker2, baker2_pk, _ = Signature.generate_key () in let baker2c = `Contract (Contract.Implicit baker2) in (* Allocate contracts for user1, user2, baker1, and baker2. *) wrap (Token.transfer ctxt origin user1c (random_amount ())) @@ -567,7 +567,7 @@ let check_sink_balances ctxt ctxt' dest amount = let rec check_balances ctxt ctxt' src dest amount = match (cast_to_container_type src, cast_to_container_type dest) with - | (None, None) -> return_unit + | None, None -> return_unit | ( Some (`Delegate_balance d), Some (`Contract (Contract.Implicit c) as contract) ) | ( Some (`Contract (Contract.Implicit c) as contract), @@ -575,14 +575,14 @@ let rec check_balances ctxt ctxt' src dest amount = when d = c -> (* src and dest are in fact referring to the same contract *) check_balances ctxt ctxt' contract contract amount - | (Some src, Some dest) when src = dest -> + | Some src, Some dest when src = dest -> (* src and dest are the same contract *) wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> wrap (Token.balance ctxt' dest) >>=? fun (_, bal_dest') -> Assert.equal_tez ~loc:__LOC__ bal_dest bal_dest' - | (Some src, None) -> check_src_balances ctxt ctxt' src amount - | (None, Some dest) -> check_sink_balances ctxt ctxt' dest amount - | (Some src, Some dest) -> + | Some src, None -> check_src_balances ctxt ctxt' src amount + | None, Some dest -> check_sink_balances ctxt ctxt' dest amount + | Some src, Some dest -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> check_sink_balances ctxt ctxt' dest amount @@ -611,22 +611,22 @@ let test_all_combinations_of_sources_and_sinks () = if one is a credit while the other is a debit. *) let coalesce_balance_updates bu1 bu2 = match (bu1, bu2) with - | ((bu1_bal, bu1_balupd, bu1_origin), (bu2_bal, bu2_balupd, bu2_origin)) -> ( + | (bu1_bal, bu1_balupd, bu1_origin), (bu2_bal, bu2_balupd, bu2_origin) -> ( assert (bu1_bal = bu2_bal) ; assert (bu1_origin = bu2_origin) ; let open Receipt in match (bu1_balupd, bu2_balupd) with - | (Credited bu1_am, Credited bu2_am) -> + | Credited bu1_am, Credited bu2_am -> let bu_am = match bu1_am +? bu2_am with Ok am -> am | _ -> assert false in (bu1_bal, Credited bu_am, bu1_origin) - | (Debited bu1_am, Debited bu2_am) -> + | Debited bu1_am, Debited bu2_am -> let bu_am = match bu1_am +? bu2_am with Ok am -> am | _ -> assert false in (bu1_bal, Debited bu_am, bu1_origin) - | (Credited _, Debited _) | (Debited _, Credited _) -> assert false) + | Credited _, Debited _ | Debited _, Credited _ -> assert false) (** Check that elt has the same balance in ctxt1 and ctxt2. *) let check_balances_are_consistent ctxt1 ctxt2 elt = @@ -655,7 +655,7 @@ let test_transfer_n ctxt src dest = (* remove burning balance updates *) let debit_logs = List.filter - (fun b -> match b with (Receipt.Burned, _, _) -> false | _ -> true) + (fun b -> match b with Receipt.Burned, _, _ -> false | _ -> true) debit_logs in (* Credit the sink for each source. *) @@ -669,7 +669,7 @@ let test_transfer_n ctxt src dest = (* remove minting balance updates *) let credit_logs = List.filter - (fun b -> match b with (Receipt.Minted, _, _) -> false | _ -> true) + (fun b -> match b with Receipt.Minted, _, _ -> false | _ -> true) credit_logs in (* Check equivalence of balance updates. *) @@ -694,13 +694,13 @@ let test_transfer_n_with_non_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> let origin = `Contract (Contract.Implicit pkh) in - let (user1, _, _) = Signature.generate_key () in + let user1, _, _ = Signature.generate_key () in let user1c = `Contract (Contract.Implicit user1) in - let (user2, _, _) = Signature.generate_key () in + let user2, _, _ = Signature.generate_key () in let user2c = `Contract (Contract.Implicit user2) in - let (user3, _, _) = Signature.generate_key () in + let user3, _, _ = Signature.generate_key () in let user3c = `Contract (Contract.Implicit user3) in - let (user4, _, _) = Signature.generate_key () in + let user4, _, _ = Signature.generate_key () in let user4c = `Contract (Contract.Implicit user4) in (* Allocate contracts for user1, user2, user3, and user4. *) let amount = diff --git a/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml b/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml index 0084a8065da8..bf31e359f89e 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml @@ -92,8 +92,8 @@ let get_float_balances env state = fraction of tzbtc and xtz returned to the liquidity provider is lesser or equal than the fraction of lqt burnt. *) let is_remove_liquidity_consistent env state state' = - let (xtz, tzbtc, lqt) = get_float_balances env state in - let (xtz', tzbtc', lqt') = get_float_balances env state' in + let xtz, tzbtc, lqt = get_float_balances env state in + let xtz', tzbtc', lqt' = get_float_balances env state' in if lqt' < lqt then let flqt = (lqt -. lqt') /. lqt in let fxtz = (xtz -. xtz') /. xtz in @@ -106,8 +106,8 @@ let is_remove_liquidity_consistent env state state' = See https://blog.nomadic-labs.com/progress-report-on-the-verification-of-liquidity-baking-smart-contracts.html#evolution-of-the-product-of-supplies *) let is_share_price_increasing env state state' = - let (xtz, tzbtc, lqt) = get_float_balances env state in - let (xtz', tzbtc', lqt') = get_float_balances env state' in + let xtz, tzbtc, lqt = get_float_balances env state in + let xtz', tzbtc', lqt' = get_float_balances env state' in xtz *. tzbtc /. (lqt *. lqt) <= xtz' *. tzbtc' /. (lqt' *. lqt') (** [positive_pools env state] returns [true] iff the three pools of @@ -185,12 +185,10 @@ let validate_consistency : fun env state -> all_true (validate_cpmm_total_liquidity env state - :: - validate_balances env.cpmm_contract env state - :: - List.map - (fun account -> validate_balances account env state) - env.implicit_accounts) + :: validate_balances env.cpmm_contract env state + :: List.map + (fun account -> validate_balances account env state) + env.implicit_accounts) (** [validate_storage env blk] returns [true] iff the storage of the CPMM contract is consistent wrt. to its actual balances (tez, @@ -248,7 +246,7 @@ let machine_validation_tests = (fun (specs, scenario) -> extract_qcheck_tzresult (let invariant = positive_pools in - let (state, env) = SymbolicMachine.build ~invariant specs in + let state, env = SymbolicMachine.build ~invariant specs in let _ = SymbolicMachine.run ~invariant scenario env state in return_unit)); ] @@ -263,7 +261,7 @@ let economic_tests = ~name:"No global gain" (Liquidity_baking_generator.arb_adversary_scenario 1_000_000 1_000_000 50) (fun (specs, attacker, scenario) -> - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (one_balance_decreases attacker env) scenario env state in @@ -273,7 +271,7 @@ let economic_tests = ~name:"Remove liquidities is consistent" (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (is_remove_liquidity_consistent env) scenario env state in @@ -283,7 +281,7 @@ let economic_tests = ~name:"Share price only increases" (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> - let (state, env) = SymbolicMachine.build ~subsidy:0L specs in + let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (is_share_price_increasing env) scenario env state in diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml b/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml index 030c6fea96ef..f58011b6b7c6 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml @@ -39,7 +39,7 @@ let wrap m = m >|= Environment.wrap_tzresult let new_ctxt () = let ( let* ) m f = m >>=? f in - let* (block, _contract) = Context.init1 () in + let* block, _contract = Context.init1 () in let* incr = Incremental.begin_construction block in return @@ Incremental.alpha_ctxt incr @@ -81,7 +81,7 @@ let pp_int_map fmt map = Lwt_main.run (let ( let* ) m f = m >>=? f in let* ctxt = new_ctxt () in - let* (kvs, _) = wrap @@ Lwt.return @@ CM.to_list ctxt map in + let* kvs, _ = wrap @@ Lwt.return @@ CM.to_list ctxt map in return kvs) |> Result.value_f ~default:(fun () -> assert false) |> Format.fprintf fmt "%a" pp @@ -115,11 +115,11 @@ let dummy_fail = Result.error (Environment.Error_monad.trace_of_error Dummy_error) let assert_map_contains ctxt map expected = - let* (kvs, _ctxt) = CM.to_list ctxt map in + let* kvs, _ctxt = CM.to_list ctxt map in Ok (List.sort compare kvs = List.sort compare expected) let assert_equal_map ctxt map expected = - let* (kvs, ctxt) = CM.to_list ctxt expected in + let* kvs, ctxt = CM.to_list ctxt expected in assert_map_contains ctxt map kvs (** Test that the size of an empty map is 0. *) @@ -130,7 +130,7 @@ let test_empty = let test_update_add = unit_test "Update add" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) @@ -139,14 +139,14 @@ let test_update_add = let update_replace ctxt key value map = CM.update ctxt key (fun ctxt _ -> Ok (Some value, ctxt)) map in - let* (map, ctxt) = update_replace ctxt 4 4 map in + let* map, ctxt = update_replace ctxt 4 4 map in assert_map_contains ctxt map [(1, 1); (2, 2); (3, 3); (4, 4)] (** Test replacing an existing element. *) let test_update_replace = unit_test "Update replace" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) @@ -155,14 +155,14 @@ let test_update_replace = let update_replace ctxt key value map = CM.update ctxt key (fun ctxt _ -> Ok (Some value, ctxt)) map in - let* (map, ctxt) = update_replace ctxt 1 42 map in + let* map, ctxt = update_replace ctxt 1 42 map in assert_map_contains ctxt map [(1, 42); (2, 2); (3, 3)] (** Test merging when ignoring new overlapping keys. *) let test_merge_overlaps_left = unit_test "Merge overlap keep existing" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun ctxt left _ -> Ok (left, ctxt)) @@ -174,7 +174,7 @@ let test_merge_overlaps_left = let test_merge_overlaps_right = unit_test "Merge overlap replace" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun ctxt _ right -> Ok (right, ctxt)) @@ -186,7 +186,7 @@ let test_merge_overlaps_right = let test_merge_overlaps_add = unit_test "Merge overlap by adding" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun ctxt left right -> Ok (left + right, ctxt)) @@ -198,7 +198,7 @@ let test_merge_overlaps_add = let test_update_merge = unit_test "Update with merge add" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) @@ -214,27 +214,27 @@ let test_update_merge = | Some old_value -> Ok (Some (new_value + old_value), ctxt)) map in - let* (map, ctxt) = update_merge ctxt 1 1 map in - let* (map, ctxt) = update_merge ctxt 4 4 map in + let* map, ctxt = update_merge ctxt 1 1 map in + let* map, ctxt = update_merge ctxt 4 4 map in assert_map_contains ctxt map [(1, 2); (2, 2); (3, 3); (4, 4)] (** Test merging two maps when keeping the original value for overlapping keys. *) let test_merge_map_keep_existing = unit_test "Merge overlap keep existing" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map1, ctxt) = + let* map1, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) [(1, "a"); (2, "b"); (3, "c")] in - let* (map2, ctxt) = + let* map2, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) [(2, "b'"); (3, "c'"); (4, "d'")] in - let* (map, ctxt) = + let* map, ctxt = CM.merge ctxt ~merge_overlap:(fun ctxt left _ -> Ok (left, ctxt)) map1 map2 in assert_map_contains ctxt map [(1, "a"); (2, "b"); (3, "c"); (4, "d'")] @@ -243,19 +243,19 @@ let test_merge_map_keep_existing = let test_merge_map_replace_existing = unit_test "Merge overlap replace existing" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map1, ctxt) = + let* map1, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) [(1, "a"); (2, "b"); (3, "c")] in - let* (map2, ctxt) = + let* map2, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) [(2, "b'"); (3, "c'"); (4, "d'")] in - let* (map, ctxt) = + let* map, ctxt = CM.merge ctxt ~merge_overlap:(fun ctxt _ right -> Ok (right, ctxt)) @@ -268,7 +268,7 @@ let test_merge_map_replace_existing = let test_update_delete = unit_test "Update delete" @@ fun () -> let ctxt = unsafe_new_context () in - let* (map, ctxt) = + let* map, ctxt = CM.of_list ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) @@ -277,15 +277,15 @@ let test_update_delete = let delete ctxt key map = CM.update ctxt key (fun ctxt _ -> Ok (None, ctxt)) map in - let* (map, ctxt) = delete ctxt 1 map in - let* (map, ctxt) = delete ctxt 4 map in + let* map, ctxt = delete ctxt 1 map in + let* map, ctxt = delete ctxt 4 map in assert_map_contains ctxt map [(2, 2); (3, 3)] (** Test that merging [empty] with a map returns the same map. *) let test_empty_left_identity_for_merge = int_map_test "Empty map is left identity for merge" @@ fun map -> let ctxt = unsafe_new_context () in - let* (map', ctxt) = + let* map', ctxt = CM.merge ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) map CM.empty in assert_equal_map ctxt map map' @@ -294,7 +294,7 @@ let test_empty_left_identity_for_merge = let test_empty_right_identity_for_merge = int_map_test "Empty map is right identity for merge" @@ fun map -> let ctxt = unsafe_new_context () in - let* (map', ctxt) = + let* map', ctxt = CM.merge ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) CM.empty map in assert_equal_map ctxt map map' @@ -303,18 +303,18 @@ let test_empty_right_identity_for_merge = let test_size = int_map_test "Size returns the number of elements" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, _) = CM.to_list ctxt map in + let* kvs, _ = CM.to_list ctxt map in Result.ok Compare.List_length_with.(kvs = CM.size map) (** Test that all keys of a map are found. *) let test_find_existing = int_map_test "Find all elements" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, _) = CM.to_list ctxt map in + let* kvs, _ = CM.to_list ctxt map in let* _ = List.fold_left_e (fun ctxt (k, v) -> - let* (v_opt, ctxt) = CM.find ctxt k map in + let* v_opt, ctxt = CM.find ctxt k map in match v_opt with Some v' when v = v' -> Ok ctxt | _ -> dummy_fail) ctxt kvs @@ -325,9 +325,9 @@ let test_find_existing = let test_find_non_existing = int_map_test "Should not find non-existing" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, _) = CM.to_list ctxt map in + let* kvs, _ = CM.to_list ctxt map in let key = 42 in - let* (v_opt, _) = CM.find ctxt key map in + let* v_opt, _ = CM.find ctxt key map in match List.find_opt (fun (k, _) -> k = key) kvs with | Some (_, value) -> Ok (Some value = v_opt) | None -> Ok (None = v_opt) @@ -337,8 +337,8 @@ let test_to_list_of_list = int_map_test "To-list/of-list roundtrip" @@ fun map -> let ctxt = unsafe_new_context () in let merge_overlap ctxt x y = Ok (x + y, ctxt) in - let* (kvs, ctxt) = CM.to_list ctxt map in - let* (map', ctxt) = CM.of_list ctxt ~merge_overlap kvs in + let* kvs, ctxt = CM.to_list ctxt map in + let* map', ctxt = CM.of_list ctxt ~merge_overlap kvs in assert_equal_map ctxt map map' (** Test that merging two maps is equivalent to merging the concatenated @@ -347,10 +347,10 @@ let test_merge_against_list = int_map_pair_test "Merge compared with list operation" @@ fun map1 map2 -> let ctxt = unsafe_new_context () in let merge_overlap ctxt x y = Ok (x + y, ctxt) in - let* (kvs1, ctxt) = CM.to_list ctxt map1 in - let* (kvs2, ctxt) = CM.to_list ctxt map2 in - let* (map_merged1, ctxt) = CM.merge ctxt ~merge_overlap map1 map2 in - let* (map_merged2, ctxt) = CM.of_list ~merge_overlap ctxt (kvs1 @ kvs2) in + let* kvs1, ctxt = CM.to_list ctxt map1 in + let* kvs2, ctxt = CM.to_list ctxt map2 in + let* map_merged1, ctxt = CM.merge ctxt ~merge_overlap map1 map2 in + let* map_merged2, ctxt = CM.of_list ~merge_overlap ctxt (kvs1 @ kvs2) in assert_equal_map ctxt map_merged1 map_merged2 (** Test that merging a map with itself does not alter its size. *) @@ -359,7 +359,7 @@ let test_size_merge_self = @@ fun map -> let ctxt = unsafe_new_context () in let size1 = CM.size map in - let* (map2, _) = + let* map2, _ = CM.merge ctxt ~merge_overlap:(fun ctxt left right -> Ok (left + right, ctxt)) @@ -385,8 +385,8 @@ let test_size_add_one = int_map_test "Add a new element increases size by one" @@ fun map -> let ctxt = unsafe_new_context () in let key = 42 in - let* (val_opt, ctxt) = CM.find ctxt key map in - let* (map', _ctxt) = + let* val_opt, ctxt = CM.find ctxt key map in + let* map', _ctxt = CM.update ctxt key @@ -416,8 +416,8 @@ let test_size_add_one = let test_map = int_map_test "Test that map commutes with mapping over list" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, ctxt) = CM.to_list ctxt map in - let* (map', ctxt) = CM.map ctxt (fun ctxt _ x -> Ok (x + 1, ctxt)) map in + let* kvs, ctxt = CM.to_list ctxt map in + let* map', ctxt = CM.map ctxt (fun ctxt _ x -> Ok (x + 1, ctxt)) map in let kvs' = List.map (fun (k, v) -> (k, v + 1)) kvs in assert_map_contains ctxt map' kvs' @@ -426,7 +426,7 @@ let test_map = let test_fold_empty = unit_test "Fold empty" @@ fun () -> let ctxt = unsafe_new_context () in - let* (x, _) = CM.fold ctxt (fun _ctxt _acc _k _v -> dummy_fail) 0 CM.empty in + let* x, _ = CM.fold ctxt (fun _ctxt _acc _k _v -> dummy_fail) 0 CM.empty in Ok (x = 0) (** Test that folding over a map is equivalent to folding over the corresponding @@ -441,9 +441,9 @@ let test_fold_empty = let test_fold = int_map_test "Test that fold commutes with folding over a list" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, ctxt) = CM.to_list ctxt map in + let* kvs, ctxt = CM.to_list ctxt map in let sum = List.fold_left (fun sum (k, v) -> k + v + sum) 0 kvs in - let* (sum', _) = + let* sum', _ = CM.fold ctxt (fun ctxt sum k v -> Ok (k + v + sum, ctxt)) 0 map in Ok (sum = sum') @@ -454,8 +454,8 @@ let test_fold_to_list = int_map_test "Test that fold collecting the elements agrees with to-list" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, ctxt) = CM.to_list ctxt map in - let* (kvs', _) = + let* kvs, ctxt = CM.to_list ctxt map in + let* kvs', _ = CM.fold ctxt (fun ctxt kvs k v -> Ok ((k, v) :: kvs, ctxt)) [] map in Ok (kvs = List.rev kvs') @@ -474,10 +474,10 @@ let test_map_fail = let test_size_remove_one = int_map_test "Remove new element decreases size by one" @@ fun map -> let ctxt = unsafe_new_context () in - let* (kvs, ctxt) = CM.to_list ctxt map in + let* kvs, ctxt = CM.to_list ctxt map in let key = match kvs with (k, _) :: _ -> k | _ -> 42 in - let* (val_opt, ctxt) = CM.find ctxt key map in - let* (map', _ctxt) = CM.update ctxt key (fun ctxt _ -> Ok (None, ctxt)) map in + let* val_opt, ctxt = CM.find ctxt key map in + let* map', _ctxt = CM.update ctxt key (fun ctxt _ -> Ok (None, ctxt)) map in let size = CM.size map in let size' = CM.size map' in match val_opt with diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml index fb74fb9289d5..39dccc705269 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml @@ -50,37 +50,35 @@ let rec reference_compare_comparable : type a. a comparable_ty -> a -> a -> int = fun ty x y -> match (ty, x, y) with - | (Unit_t, (), ()) -> 0 - | (Never_t, _, _) -> . - | (Signature_t, x, y) -> normalize_compare @@ Script_signature.compare x y - | (String_t, x, y) -> normalize_compare @@ Script_string.compare x y - | (Bool_t, x, y) -> normalize_compare @@ Compare.Bool.compare x y - | (Mutez_t, x, y) -> normalize_compare @@ Tez.compare x y - | (Key_hash_t, x, y) -> + | Unit_t, (), () -> 0 + | Never_t, _, _ -> . + | Signature_t, x, y -> normalize_compare @@ Script_signature.compare x y + | String_t, x, y -> normalize_compare @@ Script_string.compare x y + | Bool_t, x, y -> normalize_compare @@ Compare.Bool.compare x y + | Mutez_t, x, y -> normalize_compare @@ Tez.compare x y + | Key_hash_t, x, y -> normalize_compare @@ Signature.Public_key_hash.compare x y - | (Key_t, x, y) -> normalize_compare @@ Signature.Public_key.compare x y - | (Int_t, x, y) -> normalize_compare @@ Script_int.compare x y - | (Nat_t, x, y) -> normalize_compare @@ Script_int.compare x y - | (Timestamp_t, x, y) -> normalize_compare @@ Script_timestamp.compare x y - | (Address_t, x, y) -> + | Key_t, x, y -> normalize_compare @@ Signature.Public_key.compare x y + | Int_t, x, y -> normalize_compare @@ Script_int.compare x y + | Nat_t, x, y -> normalize_compare @@ Script_int.compare x y + | Timestamp_t, x, y -> normalize_compare @@ Script_timestamp.compare x y + | Address_t, x, y -> normalize_compare @@ Script_comparable.compare_address x y - | (Tx_rollup_l2_address_t, x, y) -> + | Tx_rollup_l2_address_t, x, y -> normalize_compare @@ Script_comparable.compare_tx_rollup_l2_address x y - | (Bytes_t, x, y) -> normalize_compare @@ Compare.Bytes.compare x y - | (Chain_id_t, x, y) -> normalize_compare @@ Script_chain_id.compare x y - | (Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry)) -> + | Bytes_t, x, y -> normalize_compare @@ Compare.Bytes.compare x y + | Chain_id_t, x, y -> normalize_compare @@ Script_chain_id.compare x y + | Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry) -> let cl = reference_compare_comparable tl lx ly in if Compare.Int.(cl = 0) then reference_compare_comparable tr rx ry else cl - | (Union_t (tl, _, _, YesYes), L x, L y) -> - reference_compare_comparable tl x y - | (Union_t _, L _, R _) -> -1 - | (Union_t _, R _, L _) -> 1 - | (Union_t (_, tr, _, YesYes), R x, R y) -> - reference_compare_comparable tr x y - | (Option_t _, None, None) -> 0 - | (Option_t _, None, Some _) -> -1 - | (Option_t _, Some _, None) -> 1 - | (Option_t (t, _, Yes), Some x, Some y) -> reference_compare_comparable t x y + | Union_t (tl, _, _, YesYes), L x, L y -> reference_compare_comparable tl x y + | Union_t _, L _, R _ -> -1 + | Union_t _, R _, L _ -> 1 + | Union_t (_, tr, _, YesYes), R x, R y -> reference_compare_comparable tr x y + | Option_t _, None, None -> 0 + | Option_t _, None, Some _ -> -1 + | Option_t _, Some _, None -> 1 + | Option_t (t, _, Yes), Some x, Some y -> reference_compare_comparable t x y (* Generation of one to three values of the same comparable type. *) @@ -319,9 +317,9 @@ let test_transitivity = let cxy = Script_comparable.compare_comparable ty x y in let cyz = Script_comparable.compare_comparable ty y z in match (cxy, cyz) with - | (0, n) | (n, 0) -> qcheck_compare_comparable ~expected:n ty x z - | (-1, -1) -> qcheck_compare_comparable ~expected:(-1) ty x z - | (1, 1) -> qcheck_compare_comparable ~expected:1 ty x z + | 0, n | n, 0 -> qcheck_compare_comparable ~expected:n ty x z + | -1, -1 -> qcheck_compare_comparable ~expected:(-1) ty x z + | 1, 1 -> qcheck_compare_comparable ~expected:1 ty x z | _ -> QCheck.assume_fail ()) (* Test. @@ -329,8 +327,7 @@ let test_transitivity = *) let test_pack_unpack = QCheck.Test.make - ~count: - 100_000 + ~count:100_000 (* We run this test on many more cases than the default (100) because this is a very important property. Packing and then unpacking happens each time data is sent from a contract to another and also each time storage diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_tez_repr.ml b/src/proto_alpha/lib_protocol/test/pbt/test_tez_repr.ml index 5d095ca59874..621511c0a4c3 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_tez_repr.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_tez_repr.ml @@ -45,19 +45,19 @@ let z_in_mutez_bounds (z : Z.t) : bool = let compare (c' : Z.t) (c : Tez.t tzresult) : bool = match (z_in_mutez_bounds @@ c', c) with - | (true, Ok c) -> + | true, Ok c -> Lib_test.Qcheck_helpers.qcheck_eq' ~pp:Z.pp_print ~expected:c' ~actual:(tez_to_z c) () - | (true, Error _) -> + | true, Error _ -> QCheck.Test.fail_reportf "@[<h 0>Results are in Z bounds, but tez operation fails.@]" - | (false, Ok _) -> + | false, Ok _ -> QCheck.Test.fail_reportf "@[<h 0>Results are not in Z bounds, but tez operation did not fail.@]" - | (false, Error _) -> true + | false, Error _ -> true (* [prop_binop f f' (a, b)] compares the function [f] in Tez with a model function function [f'] in [Z]. diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml b/src/proto_alpha/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml index d54ee927adaf..c4816bc34f3b 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml @@ -48,7 +48,7 @@ let bls_pk = `Hex "8fee216367c463821f82c942a1cee3a01469b1da782736ca269a2accea6e0cc4" |> Hex.to_bytes_exn in - let (_pkh, public_key, _secret_key) = Bls.generate_key ~seed:ikm () in + let _pkh, public_key, _secret_key = Bls.generate_key ~seed:ikm () in public_key let l2_address = Protocol.Tx_rollup_l2_address.of_bls_pk bls_pk @@ -83,7 +83,7 @@ let public_key_hash = let public_key_hash_gen = let open QCheck2.Gen in let+ seed = seed_gen in - let (pkh, _, _) = Tx_rollup_l2_helpers.gen_l1_address ~seed () in + let pkh, _, _ = Tx_rollup_l2_helpers.gen_l1_address ~seed () in pkh let ticket_hash : Protocol.Alpha_context.Ticket_hash.t = diff --git a/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml b/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml index 31d4dfd25f0b..f51113e7151e 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml @@ -160,7 +160,7 @@ let test_inner_error () = (* Test that no gas-exhaustion error is produced and that no gas is consumed when run in unlimited mode. - *) +*) let test_unlimited () = with_context ~limit:ten_milligas @@ fun ctxt -> let gas_monad = diff --git a/src/proto_alpha/lib_protocol/test/unit/test_round_repr.ml b/src/proto_alpha/lib_protocol/test/unit/test_round_repr.ml index 79ddd3c199ed..0774c3aabd2e 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_round_repr.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_round_repr.ml @@ -600,8 +600,8 @@ let test_round_and_offset_correction = ~level_offset in match (computed, expected) with - | (Error _, Error _) -> return_unit - | (Ok {round; offset}, Ok {round = round'; offset = offset'}) -> + | Error _, Error _ -> return_unit + | Ok {round; offset}, Ok {round = round'; offset = offset'} -> Assert.equal_int32 ~loc:__LOC__ (Round_repr.to_int32 round) @@ -611,8 +611,8 @@ let test_round_and_offset_correction = ~loc:__LOC__ (Period_repr.to_seconds offset) (Period_repr.to_seconds offset') - | (Ok _, Error _) -> failwith "expected error is ok" - | (Error _, Ok _) -> failwith "expected ok is error") + | Ok _, Error _ -> failwith "expected error is ok" + | Error _, Ok _ -> failwith "expected ok is error") let tests = Tztest. diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml index 998f3cd76bc7..cf900a3f16f3 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml @@ -56,7 +56,7 @@ let check_encode_decode_outbox_message ctxt message = Environment.wrap_tzresult @@ Internal_for_tests.bytes_of_outbox_message message in - let* (message', _ctxt) = wrap @@ outbox_message_of_bytes ctxt bytes in + let* message', _ctxt = wrap @@ outbox_message_of_bytes ctxt bytes in let*? bytes' = Environment.wrap_tzresult @@ Internal_for_tests.bytes_of_outbox_message message' @@ -77,7 +77,7 @@ let string_ticket ticketer contents amount = let init_ctxt () = let open Lwt_result_syntax in - let* (block, _baker, _contract, _src2) = Contract_helpers.init () in + let* block, _baker, _contract, _src2 = Contract_helpers.init () in let+ incr = Incremental.begin_construction block in Incremental.alpha_ctxt incr @@ -106,7 +106,7 @@ let test_encode_decode_inbox_message () = ( Script_int.(abs @@ of_int 42), string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ) in - let* (deposit, _ctxt) = + let* deposit, _ctxt = wrap @@ Sc_rollup_management_protocol.make_inbox_message ctxt @@ -131,7 +131,7 @@ let test_encode_decode_outbox_message () = ( Script_int.(abs @@ of_int 42), string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ) in - let* (transaction1, ctxt) = + let* transaction1, ctxt = let*? destination_contract = Environment.wrap_tzresult (Contract.of_b58check "KT1BuEZtb68c1Q4yjtckcNjGELqWt56Xyesc") @@ -145,7 +145,7 @@ let test_encode_decode_outbox_message () = ~destination ~entrypoint:Entrypoint.default in - let* (transaction2, ctxt) = + let* transaction2, ctxt = let*? destination_contract = Environment.wrap_tzresult (Contract.of_b58check "KT1BuEZtb68c1Q4yjtckcNjGELqWt56Xyesc") diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml index 3fe9d7dce765..e209b3818b1b 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -38,7 +38,7 @@ open Lwt_result_syntax let lift k = Lwt.map Environment.wrap_tzresult k let new_context () = - let* (b, _contract) = Context.init1 () in + let* b, _contract = Context.init1 () in Incremental.begin_construction b >|=? fun inc -> let state = Incremental.validation_state inc in let ctxt = state.ctxt in @@ -47,7 +47,7 @@ let new_context () = Alpha_context.Internal_for_tests.to_raw ctxt let new_sc_rollup ctxt = - let+ (rollup, _size, ctxt) = + let+ rollup, _size, ctxt = Sc_rollup_storage.originate ctxt ~kind:Example_arith ~boot_sector:"" in (rollup, ctxt) @@ -55,7 +55,7 @@ let new_sc_rollup ctxt = (** Originate a rollup with one staker and make a deposit to the initial LCC *) let originate_rollup_and_deposit_with_one_staker () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -65,7 +65,7 @@ let originate_rollup_and_deposit_with_one_staker () = (** Originate a rollup with two stakers and make a deposit to the initial LCC *) let originate_rollup_and_deposit_with_two_stakers () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker1 = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -133,8 +133,8 @@ let test_deposit_to_missing_rollup () = let test_initial_state_is_pre_boot () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in - let* (lcc, ctxt) = + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in + let* lcc, ctxt = lift @@ Sc_rollup_storage.last_cemented_commitment ctxt rollup in assert_commitment_hash_equal @@ -146,7 +146,7 @@ let test_initial_state_is_pre_boot () = let test_deposit_to_existing_rollup () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -156,7 +156,7 @@ let test_deposit_to_existing_rollup () = let test_removing_staker_from_lcc_fails () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -170,7 +170,7 @@ let test_removing_staker_from_lcc_fails () = let test_deposit_then_withdraw () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -181,7 +181,7 @@ let test_deposit_then_withdraw () = let test_can_not_stake_twice () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -198,7 +198,7 @@ let test_withdrawal_from_missing_rollup () = let test_withdraw_when_not_staked () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -210,7 +210,7 @@ let test_withdraw_when_not_staked () = let test_withdrawing_twice () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Signature.Public_key_hash.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -244,7 +244,7 @@ let valid_inbox_level ctxt = let test_deposit_then_refine () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -260,14 +260,14 @@ let test_deposit_then_refine () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in assert_true ctxt let test_deposit_then_refine_bad_inbox () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -290,7 +290,7 @@ let test_deposit_then_refine_bad_inbox () = let test_publish () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -305,13 +305,13 @@ let test_publish () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.publish_commitment ctxt rollup staker commitment in assert_true ctxt let test_withdraw_and_cement () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let challenge_window = @@ -327,7 +327,7 @@ let test_withdraw_and_cement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment in let* ctxt = lift @@ Sc_rollup_storage.withdraw_stake ctxt rollup staker2 in @@ -338,7 +338,7 @@ let test_withdraw_and_cement () = let test_deposit_then_publish () = let* ctxt = new_context () in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -354,7 +354,7 @@ let test_deposit_then_publish () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.publish_commitment ctxt rollup staker commitment in assert_true ctxt @@ -382,7 +382,7 @@ let test_cement () = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in lift - @@ let* (rollup, ctxt) = new_sc_rollup ctxt in + @@ let* rollup, ctxt = new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" @@ -398,7 +398,7 @@ let test_cement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = @@ -413,11 +413,9 @@ let test_cement () = This is useful to catch potential issues with de-allocation of [c2], as we deallocate the old LCC when a new LCC is cemented. - *) +*) let test_cement_three_commitments () = - let* (ctxt, rollup, staker) = - originate_rollup_and_deposit_with_one_staker () - in + let* ctxt, rollup, staker = originate_rollup_and_deposit_with_one_staker () in let level = valid_inbox_level ctxt in let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt @@ -434,7 +432,7 @@ let test_cement_three_commitments () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let commitment = @@ -447,7 +445,7 @@ let test_cement_three_commitments () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let commitment = @@ -460,7 +458,7 @@ let test_cement_three_commitments () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c3, ctxt) = + let* c3, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in @@ -474,7 +472,7 @@ let test_cement_then_remove () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -489,7 +487,7 @@ let test_cement_then_remove () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in @@ -504,12 +502,12 @@ let test_cement_consumes_available_messages () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in let* ctxt = lift @@ Sc_rollup_storage.deposit_stake ctxt rollup staker in - let* (inbox, _n, ctxt) = + let* inbox, _n, ctxt = lift @@ Sc_rollup_storage.add_messages ctxt rollup ["one"; "two"; "three"] in let available_messages = @@ -525,12 +523,12 @@ let test_cement_consumes_available_messages () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in let* ctxt = lift @@ Sc_rollup_storage.cement_commitment ctxt rollup c1 in - let* (new_inbox, _ctxt) = lift @@ Sc_rollup_storage.inbox ctxt rollup in + let* new_inbox, _ctxt = lift @@ Sc_rollup_storage.inbox ctxt rollup in let new_available_messages = Sc_rollup_inbox_repr.number_of_available_messages new_inbox in @@ -551,7 +549,7 @@ let test_cement_unknown_commitment_fails () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -571,7 +569,7 @@ let test_cement_with_zero_stakers_fails () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -586,7 +584,7 @@ let test_cement_with_zero_stakers_fails () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in @@ -603,7 +601,7 @@ let test_cement_fail_too_recent () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -618,7 +616,7 @@ let test_cement_fail_too_recent () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let* () = @@ -639,7 +637,7 @@ let test_cement_fail_too_recent () = assert_true ctxt let test_cement_deadline_uses_oldest_add_time () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment = @@ -652,7 +650,7 @@ let test_cement_deadline_uses_oldest_add_time () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment in let challenge_window = @@ -660,7 +658,7 @@ let test_cement_deadline_uses_oldest_add_time () = in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment in let* ctxt = lift @@ Sc_rollup_storage.cement_commitment ctxt rollup c1 in @@ -671,7 +669,7 @@ let test_last_cemented_commitment_hash_with_level () = let challenge_window = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -687,12 +685,12 @@ let test_last_cemented_commitment_hash_with_level () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in let* ctxt = lift @@ Sc_rollup_storage.cement_commitment ctxt rollup c1 in - let* (c1', inbox_level', ctxt) = + let* c1', inbox_level', ctxt = lift @@ Sc_rollup_storage.last_cemented_commitment_hash_with_level ctxt rollup in @@ -704,7 +702,7 @@ let test_last_cemented_commitment_hash_with_level () = let test_withdrawal_fails_when_not_staked_on_lcc () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -719,7 +717,7 @@ let test_withdrawal_fails_when_not_staked_on_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in assert_fails_with @@ -730,7 +728,7 @@ let test_withdrawal_fails_when_not_staked_on_lcc () = let test_initial_level_of_rollup () = let* ctxt = new_context () in let level_before_rollup = (Raw_context.current_level ctxt).level in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let ctxt = Raw_context.Internal_for_tests.add_level ctxt 10 in let* initial_level = lift @@ Sc_rollup_storage.initial_level ctxt rollup in Assert.equal_int32 @@ -739,7 +737,7 @@ let test_initial_level_of_rollup () = (Raw_level_repr.to_int32 initial_level) let test_stake_on_existing_node () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment = @@ -753,16 +751,16 @@ let test_stake_on_existing_node () = } in lift - @@ let* (_node, ctxt) = + @@ let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment in assert_true ctxt let test_cement_with_two_stakers () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -777,7 +775,7 @@ let test_cement_with_two_stakers () = } in lift - @@ let* (c1, ctxt) = + @@ let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -790,7 +788,7 @@ let test_cement_with_two_stakers () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let challenge_window = @@ -804,7 +802,7 @@ let test_cement_with_two_stakers () = assert_true ctxt let test_can_remove_staker () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -819,7 +817,7 @@ let test_can_remove_staker () = } in lift - @@ let* (c1, ctxt) = + @@ let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -832,7 +830,7 @@ let test_can_remove_staker () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let* ctxt = Sc_rollup_storage.remove_staker ctxt rollup staker1 in @@ -846,7 +844,7 @@ let test_can_remove_staker () = assert_true ctxt let test_can_remove_staker2 () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -861,7 +859,7 @@ let test_can_remove_staker2 () = } in lift - @@ let* (c1, ctxt) = + @@ let* c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -874,7 +872,7 @@ let test_can_remove_staker2 () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let* ctxt = Sc_rollup_storage.remove_staker ctxt rollup staker2 in @@ -889,7 +887,7 @@ let test_can_remove_staker2 () = assert_true ctxt let test_removed_staker_can_not_withdraw () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -903,7 +901,7 @@ let test_removed_staker_can_not_withdraw () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -916,7 +914,7 @@ let test_removed_staker_can_not_withdraw () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let* ctxt = lift @@ Sc_rollup_storage.remove_staker ctxt rollup staker2 in @@ -926,7 +924,7 @@ let test_removed_staker_can_not_withdraw () = "Unknown staker." let test_no_cement_on_conflict () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -940,7 +938,7 @@ let test_no_cement_on_conflict () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -953,7 +951,7 @@ let test_no_cement_on_conflict () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let ctxt = Raw_context.Internal_for_tests.add_level ctxt 5000 in @@ -969,7 +967,7 @@ let test_no_cement_on_conflict () = LCC <- [c1] *) let test_no_cement_with_one_staker_at_zero_commitment () = - let* (ctxt, rollup, staker1, _staker2) = + let* ctxt, rollup, staker1, _staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -982,7 +980,7 @@ let test_no_cement_with_one_staker_at_zero_commitment () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let challenge_window = @@ -995,7 +993,7 @@ let test_no_cement_with_one_staker_at_zero_commitment () = "Attempted to cement a disputed commitment." let test_non_cemented_parent () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -1009,7 +1007,7 @@ let test_non_cemented_parent () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1022,7 +1020,7 @@ let test_non_cemented_parent () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let challenge_window = @@ -1035,7 +1033,7 @@ let test_non_cemented_parent () = "Parent is not cemented." let test_finds_conflict_point_at_lcc () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -1049,7 +1047,7 @@ let test_finds_conflict_point_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1062,16 +1060,16 @@ let test_finds_conflict_point_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_c2, ctxt) = + let* _c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in - let* ((left, _right), ctxt) = + let* (left, _right), ctxt = lift @@ Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 in assert_commitment_hash_equal ~loc:__LOC__ ctxt left c1 let test_finds_conflict_point_beneath_lcc () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -1085,7 +1083,7 @@ let test_finds_conflict_point_beneath_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1098,7 +1096,7 @@ let test_finds_conflict_point_beneath_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment2 in let commitment3 = @@ -1111,17 +1109,17 @@ let test_finds_conflict_point_beneath_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c3, ctxt) = + let* c3, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment3 in - let* ((left, right), ctxt) = + let* (left, right), ctxt = lift @@ Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 in let* () = assert_commitment_hash_equal ~loc:__LOC__ ctxt left c2 in assert_commitment_hash_equal ~loc:__LOC__ ctxt right c3 let test_conflict_point_is_first_point_of_disagreement () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -1135,7 +1133,7 @@ let test_conflict_point_is_first_point_of_disagreement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1148,7 +1146,7 @@ let test_conflict_point_is_first_point_of_disagreement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment2 in let commitment3 = @@ -1161,7 +1159,7 @@ let test_conflict_point_is_first_point_of_disagreement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c3, ctxt) = + let* c3, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment3 in let commitment4 = @@ -1174,10 +1172,10 @@ let test_conflict_point_is_first_point_of_disagreement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_c4, ctxt) = + let* _c4, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment4 in - let* ((left, right), ctxt) = + let* (left, right), ctxt = lift @@ Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 in let* () = assert_commitment_hash_equal ~loc:__LOC__ ctxt left c2 in @@ -1186,7 +1184,7 @@ let test_conflict_point_is_first_point_of_disagreement () = let test_conflict_point_computation_fits_in_gas_limit () = (* Worst case of conflict point computation: two branches of maximum length rooted just after the LCC. *) - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -1208,10 +1206,10 @@ let test_conflict_point_computation_fits_in_gas_limit () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (root_commitment_hash, ctxt) = + let* root_commitment_hash, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 root_commitment in - let* (_, ctxt) = + let* _, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 root_commitment in let rec branch ctxt staker_id staker predecessor i max acc = @@ -1225,7 +1223,7 @@ let test_conflict_point_computation_fits_in_gas_limit () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (commitment_hash, ctxt) = + let* commitment_hash, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment in if i = max then @@ -1240,10 +1238,10 @@ let test_conflict_point_computation_fits_in_gas_limit () = max (commitment_hash :: acc) in - let* (branch_1, ctxt) = + let* branch_1, ctxt = branch ctxt 1l staker1 root_commitment_hash 2l max_commits [] in - let* (branch_2, ctxt) = + let* branch_2, ctxt = branch ctxt 2l staker2 root_commitment_hash 2l max_commits [] in let ctxt = @@ -1251,14 +1249,14 @@ let test_conflict_point_computation_fits_in_gas_limit () = ctxt (Constants_storage.hard_gas_limit_per_operation ctxt) in - let* ((left, right), ctxt) = + let* (left, right), ctxt = lift @@ Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 in let* () = assert_commitment_hash_equal ~loc:__LOC__ ctxt left branch_1.(0) in assert_commitment_hash_equal ~loc:__LOC__ ctxt right branch_2.(0) let test_no_conflict_point_one_staker_at_lcc_preboot () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment = @@ -1271,7 +1269,7 @@ let test_no_conflict_point_one_staker_at_lcc_preboot () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_, ctxt) = + let* _, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment in assert_fails_with @@ -1280,7 +1278,7 @@ let test_no_conflict_point_one_staker_at_lcc_preboot () = "No conflict." let test_no_conflict_point_both_stakers_at_lcc_preboot () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in assert_fails_with @@ -1289,7 +1287,7 @@ let test_no_conflict_point_both_stakers_at_lcc_preboot () = "No conflict." let test_no_conflict_point_one_staker_at_lcc () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -1303,7 +1301,7 @@ let test_no_conflict_point_one_staker_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1316,7 +1314,7 @@ let test_no_conflict_point_one_staker_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in let challenge_window = @@ -1330,7 +1328,7 @@ let test_no_conflict_point_one_staker_at_lcc () = "No conflict." let test_no_conflict_point_both_stakers_at_lcc () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment1 = @@ -1343,10 +1341,10 @@ let test_no_conflict_point_both_stakers_at_lcc () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in - let* (_node, ctxt) = + let* _node, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment1 in let challenge_window = @@ -1361,7 +1359,7 @@ let test_no_conflict_point_both_stakers_at_lcc () = let test_staker_cannot_backtrack () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let staker = Sc_rollup_repr.Staker.of_b58check_exn "tz1SdKt9kjPp1HRQFkBmXtBhgMfvdgFhSjmG" in @@ -1377,7 +1375,7 @@ let test_staker_cannot_backtrack () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment1 in let commitment2 = @@ -1390,7 +1388,7 @@ let test_staker_cannot_backtrack () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_, ctxt) = + let* _, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker commitment2 in assert_fails_with @@ -1399,7 +1397,7 @@ let test_staker_cannot_backtrack () = "Staker backtracked." let test_staker_cannot_change_branch () = - let* (ctxt, rollup, staker1, staker2) = + let* ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level ctxt in @@ -1413,7 +1411,7 @@ let test_staker_cannot_change_branch () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, ctxt) = + let* c1, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in let commitment2 = @@ -1426,7 +1424,7 @@ let test_staker_cannot_change_branch () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c2, ctxt) = + let* c2, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment2 in let commitment3 = @@ -1440,7 +1438,7 @@ let test_staker_cannot_change_branch () = } in - let* (_c3, ctxt) = + let* _c3, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment3 in let commitment4 = @@ -1453,7 +1451,7 @@ let test_staker_cannot_change_branch () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (_c4, ctxt) = + let* _c4, ctxt = lift @@ Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment4 in assert_fails_with @@ -1523,7 +1521,7 @@ let test_get_commitment_of_missing_rollup () = let test_get_missing_commitment () = let* ctxt = new_context () in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in let commitment_hash = Sc_rollup_repr.Commitment_hash.zero in assert_fails_with ~loc:__LOC__ @@ -1539,7 +1537,7 @@ let test_initial_level_of_missing_rollup () = assert_fails_with_missing_rollup ~loc:__LOC__ Sc_rollup_storage.initial_level let test_concurrent_refinement_point_of_conflict () = - let* (before_ctxt, rollup, staker1, staker2) = + let* before_ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let level = valid_inbox_level before_ctxt in @@ -1563,22 +1561,22 @@ let test_concurrent_refinement_point_of_conflict () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* ((c1, c2), _ctxt) = + let* (c1, c2), _ctxt = lift - @@ let* (_c1, ctxt) = + @@ let* _c1, ctxt = Sc_rollup_storage.refine_stake before_ctxt rollup staker1 commitment1 in - let* (_c2, ctxt) = + let* _c2, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment2 in Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 in - let* ((c1', c2'), ctxt) = + let* (c1', c2'), ctxt = lift - @@ let* (_c2, ctxt) = + @@ let* _c2, ctxt = Sc_rollup_storage.refine_stake before_ctxt rollup staker2 commitment2 in - let* (_c1, ctxt) = + let* _c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment1 in Sc_rollup_storage.get_conflict_point ctxt rollup staker1 staker2 @@ -1587,7 +1585,7 @@ let test_concurrent_refinement_point_of_conflict () = assert_commitment_hash_equal ~loc:__LOC__ ctxt c2 c2' let test_concurrent_refinement_cement () = - let* (before_ctxt, rollup, staker1, staker2) = + let* before_ctxt, rollup, staker1, staker2 = originate_rollup_and_deposit_with_two_stakers () in let commitment = @@ -1600,12 +1598,12 @@ let test_concurrent_refinement_cement () = compressed_state = Sc_rollup_repr.State_hash.zero; } in - let* (c1, _ctxt) = + let* c1, _ctxt = lift - @@ let* (c1, ctxt) = + @@ let* c1, ctxt = Sc_rollup_storage.refine_stake before_ctxt rollup staker1 commitment in - let* (_c2, ctxt) = + let* _c2, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker2 commitment in let challenge_window = @@ -1617,12 +1615,12 @@ let test_concurrent_refinement_cement () = let* ctxt = Sc_rollup_storage.cement_commitment ctxt rollup c1 in Sc_rollup_storage.last_cemented_commitment ctxt rollup in - let* (c2, ctxt) = + let* c2, ctxt = lift - @@ let* (c2, ctxt) = + @@ let* c2, ctxt = Sc_rollup_storage.refine_stake before_ctxt rollup staker2 commitment in - let* (_c1, ctxt) = + let* _c1, ctxt = Sc_rollup_storage.refine_stake ctxt rollup staker1 commitment in let challenge_window = @@ -1641,8 +1639,8 @@ let check_gas_consumed ~since ~until = let as_cost = Gas_limit_repr.cost_of_gas @@ gas_consumed ~since ~until in Saturation_repr.to_int as_cost -(* Cost of compare key is currently free, which means that the lookup operation - on a map of size 1 will consume 50 gas units (base cost), plus 2 for the +(* Cost of compare key is currently free, which means that the lookup operation + on a map of size 1 will consume 50 gas units (base cost), plus 2 for the traversal overhead, plus 15 for comparing the key, for a total of 67 gas units. *) let test_carbonated_memory_inbox_retrieval () = @@ -1651,21 +1649,21 @@ let test_carbonated_memory_inbox_retrieval () = let ctxt = set_gas_limit ctxt (Gas_limit_repr.Arith.integral_of_int_exn 20_000) in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in - let*? (_, ctxt') = + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in + let*? _, ctxt' = Environment.wrap_tzresult @@ Sc_rollup_in_memory_inbox.current_messages ctxt rollup in let consumed_gas = check_gas_consumed ~since:ctxt ~until:ctxt' in Assert.equal_int ~loc:__LOC__ consumed_gas 67 -(* A bit ugly, as we repeat the logic for setting messages - defined in `Sc_rollup_storage`. However, this is necessary - since we want to capture the context before and after performing +(* A bit ugly, as we repeat the logic for setting messages + defined in `Sc_rollup_storage`. However, this is necessary + since we want to capture the context before and after performing the `set_current_messages` operation on the in-memory map of messages. - Assuming that the cost of compare key is free, - we expect set_messages to consume 67 gas units for finding the key, + Assuming that the cost of compare key is free, + we expect set_messages to consume 67 gas units for finding the key, and 134 gas units for performing the update, for a total of 201 gas units. *) let test_carbonated_memory_inbox_set_messages () = @@ -1674,14 +1672,14 @@ let test_carbonated_memory_inbox_set_messages () = let ctxt = set_gas_limit ctxt (Gas_limit_repr.Arith.integral_of_int_exn 20_000) in - let* (rollup, ctxt) = lift @@ new_sc_rollup ctxt in - let* (inbox, ctxt) = lift @@ Sc_rollup_storage.inbox ctxt rollup in - let*? (current_messages, ctxt) = + let* rollup, ctxt = lift @@ new_sc_rollup ctxt in + let* inbox, ctxt = lift @@ Sc_rollup_storage.inbox ctxt rollup in + let*? current_messages, ctxt = Environment.wrap_tzresult @@ Sc_rollup_in_memory_inbox.current_messages ctxt rollup in let {Level_repr.level; _} = Raw_context.current_level ctxt in - let* (current_messages, _) = + let* current_messages, _ = lift @@ Sc_rollup_inbox_repr.( add_messages_no_history @@ -1902,4 +1900,4 @@ let tests = (* FIXME: https://gitlab.com/tezos/tezos/-/issues/2460 Further tests to be added. - *) +*) diff --git a/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml b/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml index e250076548c8..3e6cc803b0e0 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml @@ -75,7 +75,7 @@ struct let zero = {size = 1; cells = [(0, genesis ())]} let succ list = - let (prev_cell_ptr, prev_cell) = head list in + let prev_cell_ptr, prev_cell = head list in let cell = next ~prev_cell ~prev_cell_ptr () in {size = list.size + 1; cells = (list.size, cell) :: list.cells} diff --git a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml index 2255140f8348..b95ed7e35c17 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml @@ -102,8 +102,8 @@ let context_with_one_addr = let open Context_l2 in let open Syntax in let ctxt = empty_context in - let (_, _, addr1) = gen_l2_address () in - let+ (ctxt, _, idx1) = Address_index.get_or_associate_index ctxt addr1 in + let _, _, addr1 = gen_l2_address () in + let+ ctxt, _, idx1 = Address_index.get_or_associate_index ctxt addr1 in (ctxt, idx1) let ((_, pk, addr) as l2_addr1) = gen_l2_address () @@ -118,7 +118,7 @@ module Test_Address_medata = struct (** Test that an initilized metadata has a counter of zero and is correctly incremented. *) let test_init_and_incr () = - let* (ctxt, idx) = context_with_one_addr in + let* ctxt, idx = context_with_one_addr in let* metadata = get ctxt idx in assert (metadata = None) ; @@ -136,7 +136,7 @@ module Test_Address_medata = struct (** Test that initializing an index to a public key fails if the index has already been initialized. *) let test_init_twice_fails () = - let* (ctxt, idx) = context_with_one_addr in + let* ctxt, idx = context_with_one_addr in let* ctxt = init_with_public_key ctxt idx pk in @@ -164,7 +164,7 @@ module Test_Address_medata = struct (** Test that crediting more than {!Int64.max_int} causes an overflow. *) let test_counter_overflow () = - let* (ctxt, idx) = context_with_one_addr in + let* ctxt, idx = context_with_one_addr in let* ctxt = init_with_public_key ctxt idx pk in let* ctxt = @@ -213,7 +213,7 @@ end module Test_index (Index : S) = struct let init_context_1 () = let open Context_l2.Syntax in - let* (ctxt, values) = Index.init_context_n 1 in + let* ctxt, values = Index.init_context_n 1 in let value = nth_exn values 0 in return (ctxt, value) @@ -221,9 +221,9 @@ module Test_index (Index : S) = struct from the value gives the same index. *) let test_set_and_get () = let open Context_l2.Syntax in - let* (ctxt, value) = init_context_1 () in + let* ctxt, value = init_context_1 () in - let* (ctxt, created, idx1) = Index.get_or_associate_index ctxt value in + let* ctxt, created, idx1 = Index.get_or_associate_index ctxt value in assert (created = `Created) ; let* idx2 = Index.get ctxt value in @@ -235,7 +235,7 @@ module Test_index (Index : S) = struct address increments the count. *) let test_associate_fresh_index () = let open Context_l2.Syntax in - let* (ctxt, value) = init_context_1 () in + let* ctxt, value = init_context_1 () in let* count = Index.count ctxt in assert (count = 0l) ; @@ -243,7 +243,7 @@ module Test_index (Index : S) = struct let* idx = Index.get ctxt value in assert (idx = None) ; - let* (ctxt, created, idx) = Index.get_or_associate_index ctxt value in + let* ctxt, created, idx = Index.get_or_associate_index ctxt value in assert (created = `Created) ; let* count = Index.count ctxt in @@ -255,18 +255,18 @@ module Test_index (Index : S) = struct (** Test that associating twice the same value give the same index. *) let test_associate_value_twice () = let open Context_l2.Syntax in - let* (ctxt, value) = init_context_1 () in + let* ctxt, value = init_context_1 () in let expected = Indexable.index_exn 0l in - let* (ctxt, created, idx) = Index.get_or_associate_index ctxt value in + let* ctxt, created, idx = Index.get_or_associate_index ctxt value in assert (created = `Created) ; assert (idx = expected) ; let* idx = Index.get ctxt value in assert (idx = Some (Indexable.index_exn 0l)) ; - let* (ctxt, existed, idx) = Index.get_or_associate_index ctxt value in + let* ctxt, existed, idx = Index.get_or_associate_index ctxt value in assert (existed = `Existed) ; assert (idx = expected) ; @@ -277,7 +277,7 @@ module Test_index (Index : S) = struct let test_reach_too_many_l2 () = let open Context_l2.Syntax in - let* (ctxt, value) = init_context_1 () in + let* ctxt, value = init_context_1 () in let* ctxt = Index.set_count ctxt Int32.max_int in let* () = @@ -370,7 +370,7 @@ module Test_Ticket_ledger = struct (** Test that crediting a ticket index to an index behaves correctly. *) let test_credit () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* amount = get ctxt ticket_idx1 idx1 in assert (Tx_rollup_l2_qty.(amount = zero)) ; @@ -384,7 +384,7 @@ module Test_Ticket_ledger = struct (** Test that crediting more than {!Int64.max_int} causes an overflow. *) let test_credit_too_much () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* ctxt = credit ctxt ticket_idx1 idx1 (Tx_rollup_l2_qty.of_int64_exn Int64.max_int) @@ -415,7 +415,7 @@ module Test_Ticket_ledger = struct (** Test that spending a ticket from an index to another one behaves correctly *) let test_spend_valid () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* ctxt = credit ctxt ticket_idx1 idx1 (Tx_rollup_l2_qty.of_int64_exn 10L) @@ -435,7 +435,7 @@ module Test_Ticket_ledger = struct (** Test that spending a ticket without the required balance fails. *) let test_spend_without_balance () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* () = expect_error @@ -446,7 +446,7 @@ module Test_Ticket_ledger = struct return_unit let test_remove_empty_balance () = - let* (ctxt, idx1) = context_with_one_addr in + let* ctxt, idx1 = context_with_one_addr in let* ctxt = credit ctxt ticket_idx1 idx1 Tx_rollup_l2_qty.one in let* qty = Internal_for_tests.get_opt ctxt ticket_idx1 idx1 in diff --git a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml index a65d58cc46df..94cccfe10ab9 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml @@ -88,7 +88,7 @@ let aggregate_signature_exn : signature list -> signature = | Some res -> res | None -> raise (Invalid_argument "aggregate_signature_exn") -let (ticket1, ticket2) = +let ticket1, ticket2 = match gen_n_ticket_hash 2 with [x; y] -> (x, y) | _ -> assert false let empty_indexes = {address_indexes = []; ticket_indexes = []} @@ -136,7 +136,7 @@ let check_metadata ctxt name_account description counter pk = let open Syntax in let addr = Tx_rollup_l2_address.of_bls_pk pk in (* We ignore the created [ctxt] because it should be a get only. *) - let* (_ctxt, _, aidx) = Address_index.get_or_associate_index ctxt addr in + let* _ctxt, _, aidx = Address_index.get_or_associate_index ctxt addr in let* metadata = Address_metadata.get ctxt aidx in Alcotest.( check @@ -190,30 +190,28 @@ let with_initial_setup tickets contracts = let open Context_l2.Syntax in let ctxt = empty_context in - let* (ctxt, rev_tidxs) = + let* ctxt, rev_tidxs = list_fold_left_m (fun (ctxt, rev_tidxs) ticket -> - let* (ctxt, _, tidx) = - Ticket_index.get_or_associate_index ctxt ticket - in + let* ctxt, _, tidx = Ticket_index.get_or_associate_index ctxt ticket in return (ctxt, tidx :: rev_tidxs)) (ctxt, []) tickets in let tidxs = List.rev rev_tidxs in - let* (ctxt, rev_contracts) = + let* ctxt, rev_contracts = list_fold_left_m (fun (ctxt, rev_contracts) balances -> - let (pkh, _, _) = gen_l1_address () in - let (sk, pk, addr) = gen_l2_address () in - let* (ctxt, _, idx) = Address_index.get_or_associate_index ctxt addr in + let pkh, _, _ = gen_l1_address () in + let sk, pk, addr = gen_l2_address () in + let* ctxt, _, idx = Address_index.get_or_associate_index ctxt addr in let* ctxt = list_fold_left_m (fun ctxt (ticket, qty) -> let qty = Tx_rollup_l2_qty.of_int64_exn qty in - let* (ctxt, _, tidx) = + let* ctxt, _, tidx = Ticket_index.get_or_associate_index ctxt ticket in Ticket_ledger.credit ctxt tidx idx qty) @@ -322,11 +320,11 @@ let test_simple_deposit () = let deposit = {sender = pkh; destination = value addr1; ticket_hash = ticket1; amount} in - let* (ctxt, result, withdrawal_opt) = apply_deposit ctxt deposit in + let* ctxt, result, withdrawal_opt = apply_deposit ctxt deposit in (* Applying the deposit should create an idx for both [addr1] and [ticket]. *) match (result, withdrawal_opt) with - | (Deposit_success indexes, None) -> + | Deposit_success indexes, None -> let* () = check_indexes [(addr1, 0l)] [(ticket1, 0l)] indexes in let* aidx_opt = Address_index.get ctxt addr1 in let* aidx = get_opt aidx_opt in @@ -344,23 +342,23 @@ let test_simple_deposit () = let test_returned_deposit () = let open Context_l2.Syntax in let balance = Int64.max_int in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1] [[(ticket1, balance)]] in let tidx1 = nth_exn tidxs 0 in - let (_sk1, _pk1, addr1, idx1, pkh) = nth_exn accounts 0 in + let _sk1, _pk1, addr1, idx1, pkh = nth_exn accounts 0 in (* my cup runneth over *) let amount = Tx_rollup_l2_qty.one in let deposit = {sender = pkh; destination = value addr1; ticket_hash = ticket1; amount} in - let* (ctxt, result, withdrawal_opt) = apply_deposit ctxt deposit in + let* ctxt, result, withdrawal_opt = apply_deposit ctxt deposit in (* Applying the deposit will result in a Deposit_failure, an unchanged context and a withdrawal of the deposit *) match (result, withdrawal_opt) with - | (Deposit_failure Tx_rollup_l2_context_sig.Balance_overflow, Some withdrawal) + | Deposit_failure Tx_rollup_l2_context_sig.Balance_overflow, Some withdrawal -> (* balance is unchanged *) let* balance' = Context_l2.Ticket_ledger.get ctxt tidx1 idx1 in @@ -377,7 +375,7 @@ let test_returned_deposit () = withdrawal {claimer = pkh; ticket_hash = ticket1; amount}) ; return_unit - | (Deposit_failure reason, _) -> + | Deposit_failure reason, _ -> let msg = Format.asprintf "Unexpected failure for overflowing deposit: %a" @@ -385,7 +383,7 @@ let test_returned_deposit () = reason in fail_msg msg - | (Deposit_success _result, _) -> + | Deposit_success _result, _ -> fail_msg "Did not expect overflowing deposit to be succesful" let apply_l2_parameters : Protocol.Tx_rollup_l2_apply.parameters = @@ -401,9 +399,9 @@ let test_indexes_creation_bad () = let ctxt = empty_context in let contracts = gen_n_address 3 in - let (sk1, pk1, addr1) = nth_exn contracts 0 in - let (_, _, addr2) = nth_exn contracts 1 in - let (_, _, addr3) = nth_exn contracts 2 in + let sk1, pk1, addr1 = nth_exn contracts 0 in + let _, _, addr2 = nth_exn contracts 1 in + let _, _, addr3 = nth_exn contracts 2 in let deposit = { @@ -413,7 +411,7 @@ let test_indexes_creation_bad () = amount = Tx_rollup_l2_qty.of_int64_exn 20L; } in - let* (ctxt, _, _withdrawal_opt) = apply_deposit ctxt deposit in + let* ctxt, _, _withdrawal_opt = apply_deposit ctxt deposit in let transaction1 = (* This transaction will fail because the number of tickets required is @@ -440,7 +438,7 @@ let test_indexes_creation_bad () = batch (List.concat [signature1; signature2]) [transaction1; transaction2] in - let* (ctxt, Batch_result {results; indexes}, _withdrawals) = + let* ctxt, Batch_result {results; indexes}, _withdrawals = apply_l2_batch ctxt batch in @@ -467,15 +465,15 @@ let test_indexes_creation_bad () = the transaction's status and the balances afterwards. *) let test_simple_l2_transaction () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in - let (sk1, pk1, addr1, idx1, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, idx2, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, idx1, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, idx2, _ = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [addr2] & [addr2] -> [addr1]. *) @@ -488,14 +486,14 @@ let test_simple_l2_transaction () = in let batch = create_batch_v1 [transaction] [[sk1; sk2]] in - let* (ctxt, Batch_result {results; _}, _withdrawals) = + let* ctxt, Batch_result {results; _}, _withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 |> snd in match (status, _withdrawals) with - | (Transaction_success, []) -> + | Transaction_success, [] -> (* Check the balance after the transaction has been applied, we omit the check the indexes to not pollute this test. *) let* () = @@ -540,39 +538,37 @@ let test_simple_l2_transaction () = 20L in return_unit - | (Transaction_success, _) -> fail_msg "Did not expect any withdrawals" - | (Transaction_failure _, _) -> fail_msg "The transaction should be a success" + | Transaction_success, _ -> fail_msg "Did not expect any withdrawals" + | Transaction_failure _, _ -> fail_msg "The transaction should be a success" (** Test that a signer can be layer2 address. *) let test_l2_transaction_l2_addr_signer_good () = let open Context_l2 in let open Syntax in - let* (ctxt, _tidxs, accounts) = - with_initial_setup [] [[(ticket1, 10L)]; []] - in - let (sk1, pk1, addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, addr2, _idx2, _pkh2) = nth_exn accounts 1 in + let* ctxt, _tidxs, accounts = with_initial_setup [] [[(ticket1, 10L)]; []] in + let sk1, pk1, addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, addr2, _idx2, _pkh2 = nth_exn accounts 1 in let* ctxt = Address_metadata.init_with_public_key ctxt idx1 pk1 in let transfer = [transfer ~signer:(signer_addr addr1) ~dest:addr2 ~ticket:ticket1 10L] in let signature = sign_transaction [sk1] transfer in let batch = batch signature [transfer] in - let* (_ctxt, Batch_result {results; indexes = _}, _withdrawals) = + let* _ctxt, Batch_result {results; indexes = _}, _withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 in match status with - | (_, Transaction_success) -> return_unit - | (_, Transaction_failure _) -> fail_msg "The transaction should be a success" + | _, Transaction_success -> return_unit + | _, Transaction_failure _ -> fail_msg "The transaction should be a success" (** Test that signing with a layer2 address needs a proper context. *) let test_l2_transaction_l2_addr_signer_bad () = let open Context_l2 in let open Syntax in let ctxt = empty_context in - let (sk1, pk1, addr1) = gen_l2_address () in - let (_sk2, _pk2, addr2) = gen_l2_address () in + let sk1, pk1, addr1 = gen_l2_address () in + let _sk2, _pk2, addr2 = gen_l2_address () in (* The address has no index in the context *) let transfer = [transfer ~signer:(signer_addr addr1) ~dest:addr2 ~ticket:ticket1 10L] @@ -586,7 +582,7 @@ let test_l2_transaction_l2_addr_signer_bad () = (Tx_rollup_l2_apply.Unknown_address addr1) in (* Now we add the index but the metadata is still missing *) - let* (ctxt, _, idx1) = Address_index.get_or_associate_index ctxt addr1 in + let* ctxt, _, idx1 = Address_index.get_or_associate_index ctxt addr1 in let* () = expect_error ~msg_if_valid:"The check should fail with unknown metadata" @@ -595,30 +591,30 @@ let test_l2_transaction_l2_addr_signer_bad () = in (* Finally we add the metadata and the test pass *) let* ctxt = Address_metadata.init_with_public_key ctxt idx1 pk1 in - let* (ctxt, _, tidx) = Ticket_index.get_or_associate_index ctxt ticket1 in + let* ctxt, _, tidx = Ticket_index.get_or_associate_index ctxt ticket1 in let* ctxt = Ticket_ledger.credit ctxt tidx idx1 (Tx_rollup_l2_qty.of_int64_exn 100L) in - let* (_ctxt, Batch_result {results; indexes = _}, _withdrawals) = + let* _ctxt, Batch_result {results; indexes = _}, _withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 in match status with - | (_, Transaction_success) -> return_unit - | (_, Transaction_failure _) -> fail_msg "The transaction should succeed" + | _, Transaction_success -> return_unit + | _, Transaction_failure _ -> fail_msg "The transaction should succeed" (** The test consists of [pk1] sending [ticket1] to [pkh2]. This results in a withdrawal. *) let test_simple_l1_transaction () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1] [[(ticket1, 10L)]; []] in let tidx1 = nth_exn tidxs 0 in - let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, _idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, _idx2, pkh2 = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [pkh2] *) @@ -628,14 +624,14 @@ let test_simple_l1_transaction () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 |> snd in match (status, withdrawals) with - | (Transaction_success, [withdrawal]) -> + | Transaction_success, [withdrawal] -> (* Check the balance after the transaction has been applied, we omit the check the indexes to not pollute this test. *) let* () = @@ -659,8 +655,8 @@ let test_simple_l1_transaction () = amount = Tx_rollup_l2_qty.of_int64_exn 10L; }) ; return_unit - | (Transaction_success, _) -> fail_msg "Expected exactly one withdrawal" - | (Transaction_failure _, _) -> fail_msg "The transaction should be a success" + | Transaction_success, _ -> fail_msg "Expected exactly one withdrawal" + | Transaction_failure _, _ -> fail_msg "The transaction should be a success" let rec repeat n f acc = if n <= 0 then acc else repeat (n - 1) f (f n acc) @@ -671,17 +667,15 @@ let helper_test_withdrawal_limits_per_batch nb_withdraws ~should_succeed = let open Context_l2.Syntax in (* create sufficiently many accounts *) let accounts = repeat nb_withdraws (fun _i l -> [(ticket1, 2L)] :: l) [] in - let* (ctxt, _tidxs, accounts) = - with_initial_setup [ticket1] ([] :: accounts) - in + let* ctxt, _tidxs, accounts = with_initial_setup [ticket1] ([] :: accounts) in (* destination of withdrawals *) - let (_skD, _pkD, _addrD, _idxD, pkhD) = nth_exn accounts 0 in + let _skD, _pkD, _addrD, _idxD, pkhD = nth_exn accounts 0 in (* transfer 1 ticket from [nb_withdraws] accounts to the dest *) - let (transactions, sks) = + let transactions, sks = repeat nb_withdraws (fun i (transactions, sks) -> - let (sk, pk, _addr, _idx, _pkh) = nth_exn accounts i in + let sk, pk, _addr, _idx, _pkh = nth_exn accounts i in let withdraw = withdraw ~signer:(signer_pk pk) ~dest:pkhD ~ticket:ticket1 1L in @@ -732,10 +726,10 @@ let nb_withdrawals_per_batch_above_limit () = let test_l1_transaction_inexistant_ticket () = let open Context_l2.Syntax in (* empty context *) - let* (ctxt, _tidxs, accounts) = with_initial_setup [] [[]; []] in + let* ctxt, _tidxs, accounts = with_initial_setup [] [[]; []] in - let (sk1, pk1, _addr1, _idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, _idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, _idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, _idx2, pkh2 = nth_exn accounts 1 in (* We build an invalid transaction with: [addr1] -> [pkh2] *) let withdraw = @@ -744,7 +738,7 @@ let test_l1_transaction_inexistant_ticket () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (_ctxt, Batch_result {results; _}, withdrawals) = + let* _ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -768,13 +762,13 @@ let test_l1_transaction_inexistant_ticket () = then batch application fails with Balance_too_low. *) let test_l1_transaction_inexistant_signer () = let open Context_l2.Syntax in - let* (ctxt, _tidxs, accounts) = + let* ctxt, _tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (_sk1, _pk1, _addr1, _idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, _idx2, pkh2) = nth_exn accounts 1 in - let (sk_unknown, pk_unknown, _) = gen_l2_address () in + let _sk1, _pk1, _addr1, _idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, _idx2, pkh2 = nth_exn accounts 1 in + let sk_unknown, pk_unknown, _ = gen_l2_address () in (* Then, we build an invalid transaction with: [pk_unknown] -> [pkh2] *) @@ -784,7 +778,7 @@ let test_l1_transaction_inexistant_signer () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk_unknown]] in - let* (_ctxt, Batch_result {results; _}, withdrawals) = + let* _ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -809,12 +803,12 @@ let test_l1_transaction_inexistant_signer () = let test_l1_transaction_overdraft () = let open Context_l2.Syntax in let initial_balances = [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] initial_balances in - let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, idx2, pkh2 = nth_exn accounts 1 in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in @@ -826,7 +820,7 @@ let test_l1_transaction_overdraft () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -891,12 +885,12 @@ let test_l1_transaction_overdraft () = let test_l1_transaction_zero () = let open Context_l2.Syntax in let initial_balances = [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] initial_balances in - let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, idx2, pkh2 = nth_exn accounts 1 in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in @@ -908,7 +902,7 @@ let test_l1_transaction_zero () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -975,12 +969,12 @@ let test_l1_transaction_zero () = account. *) let test_l1_transaction_partial () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in - let (_sk2, _pk2, _addr2, idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, _addr1, idx1, _pkh1 = nth_exn accounts 0 in + let _sk2, _pk2, _addr2, idx2, pkh2 = nth_exn accounts 1 in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in @@ -992,7 +986,7 @@ let test_l1_transaction_partial () = let transaction = [withdraw] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -1061,15 +1055,15 @@ let test_l1_transaction_partial () = let test_transaction_with_unknown_indexable () = let open Context_l2.Syntax in let open Tx_rollup_l2_batch.V1 in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in - let (sk1, pk1, addr1, aidx1, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, aidx2, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, aidx1, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, aidx2, _ = nth_exn accounts 1 in (* Note that {!with_initial_setup} does not initialize metadatas for the public keys. If it was the case, we could not use this function @@ -1126,14 +1120,14 @@ let test_transaction_with_unknown_indexable () = let signatures = sign_transaction [sk1; sk2] transaction in let batch = batch signatures [transaction] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in let status = nth_exn results 0 |> snd in match (status, withdrawals) with - | (Transaction_success, []) -> + | Transaction_success, [] -> (* Check the balance after the transaction has been applied, we omit the check the indexes to not pollute this test. *) let* () = @@ -1178,8 +1172,8 @@ let test_transaction_with_unknown_indexable () = 20L in return_unit - | (Transaction_success, _) -> fail_msg "Did not expect any withdrawals" - | (Transaction_failure _, _) -> fail_msg "The transaction should be a success" + | Transaction_success, _ -> fail_msg "Did not expect any withdrawals" + | Transaction_failure _, _ -> fail_msg "The transaction should be a success" (** Test that a transaction containing at least one invalid operation fails and does not change the context. It is similar to @@ -1187,14 +1181,14 @@ let test_transaction_with_unknown_indexable () = possess the tickets. *) let test_invalid_transaction () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; []] in let tidx1 = nth_exn tidxs 0 in - let (sk1, pk1, addr1, idx1, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, idx2, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, idx1, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, idx2, _ = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [addr2] & [addr2] -> [addr1]. *) @@ -1207,7 +1201,7 @@ let test_invalid_transaction () = in let batch = create_batch_v1 [transaction] [[sk1; sk2]] in - let* (ctxt, Batch_result {results; _}, _withdrawals) = + let* ctxt, Batch_result {results; _}, _withdrawals = apply_l2_batch ctxt batch in @@ -1246,9 +1240,9 @@ let test_invalid_transaction () = (** Test that submitting an invalid counter fails. *) let test_invalid_counter () = let open Context_l2.Syntax in - let* (ctxt, _, accounts) = with_initial_setup [ticket1] [[]] in + let* ctxt, _, accounts = with_initial_setup [ticket1] [[]] in - let (sk1, pk1, addr1, _idx1, _) = nth_exn accounts 0 in + let sk1, pk1, addr1, _idx1, _ = nth_exn accounts 0 in let counter = 10L in let transaction = @@ -1256,7 +1250,7 @@ let test_invalid_counter () = in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (_ctxt, Batch_result {results; _}, _withdrawals) = + let* _ctxt, Batch_result {results; _}, _withdrawals = apply_l2_batch ctxt batch in @@ -1276,9 +1270,9 @@ let test_invalid_counter () = the batch is incorrectly signed). *) let test_update_counter () = let open Context_l2.Syntax in - let* (ctxt, _, accounts) = with_initial_setup [ticket1] [[]] in + let* ctxt, _, accounts = with_initial_setup [ticket1] [[]] in - let (sk1, pk1, _addr1, _idx1, _) = nth_exn accounts 0 in + let sk1, pk1, _addr1, _idx1, _ = nth_exn accounts 0 in let transactions = transfers @@ -1296,7 +1290,7 @@ let test_update_counter () = create_batch_v1 transactions [[sk1]; [sk1]; [sk1]; [sk1]; [sk1]] in - let* (ctxt, Batch_result {results; _}, withdrawals) = + let* ctxt, Batch_result {results; _}, withdrawals = apply_l2_batch ctxt batch in @@ -1320,12 +1314,12 @@ let test_update_counter () = let test_pre_apply_batch () = let open Context_l2.Syntax in - let* (ctxt, _tidxs, accounts) = + let* ctxt, _tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, addr1, _idx1, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, _idx2, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, _idx1, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, _idx2, _ = nth_exn accounts 1 in let transaction = transfers @@ -1335,7 +1329,7 @@ let test_pre_apply_batch () = ] in let batch1 = create_batch_v1 [transaction] [[sk1; sk2]] in - let* (ctxt, _indexes, _) = Batch_V1.check_signature ctxt batch1 in + let* ctxt, _indexes, _ = Batch_V1.check_signature ctxt batch1 in let* () = check_metadata @@ -1371,12 +1365,12 @@ let test_pre_apply_batch () = let test_apply_message_batch () = let open Context_l2.Syntax in - let* (ctxt, _, accounts) = + let* ctxt, _, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, addr1, _, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, _, _) = nth_exn accounts 1 in + let sk1, pk1, addr1, _, _ = nth_exn accounts 0 in + let sk2, pk2, addr2, _, _ = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [addr2] & [addr2] -> [addr1]. *) @@ -1388,17 +1382,17 @@ let test_apply_message_batch () = ] in let batch = create_batch_v1 [transaction] [[sk1; sk2]] in - let (msg, _) = + let msg, _ = Tx_rollup_message.make_batch (Data_encoding.Binary.to_string_exn Tx_rollup_l2_batch.encoding (V1 batch)) in - let* (_ctxt, result) = apply_l2_message ctxt msg in + let* _ctxt, result = apply_l2_message ctxt msg in match result with - | (Message_result.Batch_V1_result _, []) -> + | Message_result.Batch_V1_result _, [] -> (* We do not check the result inside as we consider it is covered by other tests. *) return_unit @@ -1408,12 +1402,12 @@ let test_apply_message_batch () = withdrawals. *) let test_apply_message_batch_withdrawals () = let open Context_l2.Syntax in - let* (ctxt, tidxs, accounts) = + let* ctxt, tidxs, accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, addr1, idx1, pkh1) = nth_exn accounts 0 in - let (sk2, pk2, addr2, idx2, pkh2) = nth_exn accounts 1 in + let sk1, pk1, addr1, idx1, pkh1 = nth_exn accounts 0 in + let sk2, pk2, addr2, idx2, pkh2 = nth_exn accounts 1 in let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in @@ -1461,14 +1455,14 @@ let test_apply_message_batch_withdrawals () = ] in let batch = create_batch_v1 transactions [[sk1]; [sk1]; [sk2]; [sk2]] in - let (msg, _) = + let msg, _ = Tx_rollup_message.make_batch (Data_encoding.Binary.to_string_exn Tx_rollup_l2_batch.encoding (V1 batch)) in - let* (ctxt, result) = apply_l2_message ctxt msg in + let* ctxt, result = apply_l2_message ctxt msg in match result with | ( Message_result.Batch_V1_result @@ -1555,8 +1549,8 @@ let test_apply_message_batch_withdrawals () = List.iter_es (fun res -> match res with - | (_, Message_result.Transaction_success) -> return_unit - | (_, Transaction_failure {index; reason}) -> + | _, Message_result.Transaction_success -> return_unit + | _, Transaction_failure {index; reason} -> let msg = Format.asprintf "Result at position %d unexpectedly failed: %a" @@ -1573,7 +1567,7 @@ let test_apply_message_deposit () = let ctxt = empty_context in let amount = 50L in - let (msg, _) = + let msg, _ = Tx_rollup_message.make_deposit pkh (value addr1) @@ -1581,10 +1575,10 @@ let test_apply_message_deposit () = (Tx_rollup_l2_qty.of_int64_exn amount) in - let* (_ctxt, result) = apply_l2_message ctxt msg in + let* _ctxt, result = apply_l2_message ctxt msg in match result with - | (Message_result.Deposit_result _, []) -> + | Message_result.Deposit_result _, [] -> (* We do not check the result inside as we consider it is covered by other tests. *) return_unit @@ -1593,10 +1587,10 @@ let test_apply_message_deposit () = (** Test an unparsable message. *) let test_apply_message_unparsable () = let open Context_l2.Syntax in - let* (ctxt, _tidxs, _accounts) = + let* ctxt, _tidxs, _accounts = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (msg, _) = + let msg, _ = Tx_rollup_message.make_batch "Yo, let me bust the funky lyrics (You can't parse this)!" in @@ -1607,14 +1601,14 @@ let test_apply_message_unparsable () = let test_transfer_to_self () = let open Context_l2.Syntax in - let* (ctxt, _, accounts) = with_initial_setup [ticket1] [[(ticket1, 10L)]] in - let (sk1, pk1, addr1, _idx1, _) = nth_exn accounts 0 in + let* ctxt, _, accounts = with_initial_setup [ticket1] [[(ticket1, 10L)]] in + let sk1, pk1, addr1, _idx1, _ = nth_exn accounts 0 in let transaction = [transfer ~signer:(signer_pk pk1) ~dest:addr1 ~ticket:ticket1 1L] in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (_ctxt, Batch_result {results; _}, _withdrawals) = + let* _ctxt, Batch_result {results; _}, _withdrawals = apply_l2_batch ctxt batch in @@ -1625,7 +1619,7 @@ let test_transfer_to_self () = Transaction_failure {index = 0; reason = Tx_rollup_l2_apply.Invalid_self_transfer} ) -> return_unit - | (_, _) -> + | _, _ -> fail_msg "The transaction should have failed with [Invalid_destination]" module Indexes = struct @@ -1633,21 +1627,21 @@ module Indexes = struct indexes should be. *) let test_drop_on_wrong_deposit () = let open Context_l2.Syntax in - let (deposit, _) = + let deposit, _ = make_deposit pkh (value addr1) ticket1 Tx_rollup_l2_qty.one in (* We make the apply fail with an enormous address count *) let* ctxt = Address_index.Internal_for_tests.set_count empty_context Int32.max_int in - let* (ctxt, _) = apply_l2_message ctxt deposit in + let* ctxt, _ = apply_l2_message ctxt deposit in let* ticket_count = Ticket_index.count ctxt in Alcotest.(check int32) "Ticket count should not change" 0l ticket_count ; (* We make the apply fail with an enormous ticket count *) let* ctxt = Ticket_index.Internal_for_tests.set_count empty_context Int32.max_int in - let* (ctxt, _) = apply_l2_message ctxt deposit in + let* ctxt, _ = apply_l2_message ctxt deposit in let* address_count = Address_index.count ctxt in Alcotest.(check int32) "Address count should not change" 0l address_count ; return_unit @@ -1656,10 +1650,10 @@ module Indexes = struct and the destination. *) let test_creation_on_deposit () = let open Context_l2.Syntax in - let (deposit, _) = + let deposit, _ = make_deposit pkh (value addr1) ticket1 Tx_rollup_l2_qty.one in - let* (ctxt, (result, _)) = apply_l2_message empty_context deposit in + let* ctxt, (result, _) = apply_l2_message empty_context deposit in let* ticket_count = Ticket_index.count ctxt in Alcotest.(check int32) "Ticket count should change" 1l ticket_count ; let* address_count = Address_index.count ctxt in @@ -1673,14 +1667,14 @@ module Indexes = struct existed. *) let test_deposit_with_existing_indexes () = let open Context_l2.Syntax in - let* (ctxt, _, _) = + let* ctxt, _, _ = Address_index.get_or_associate_index empty_context addr1 in - let* (ctxt, _, _) = Ticket_index.get_or_associate_index ctxt ticket1 in - let (deposit, _) = + let* ctxt, _, _ = Ticket_index.get_or_associate_index ctxt ticket1 in + let deposit, _ = make_deposit pkh (value addr1) ticket1 Tx_rollup_l2_qty.one in - let* (_, (result, _)) = apply_l2_message ctxt deposit in + let* _, (result, _) = apply_l2_message ctxt deposit in match result with | Deposit_result (Deposit_success indexes) -> check_indexes [] [] indexes | _ -> fail_msg "Should be a success" @@ -1688,17 +1682,17 @@ module Indexes = struct let test_creation_on_valid_batch () = let open Context_l2.Syntax in let contracts = gen_n_address 3 in - let (sk1, pk1, addr1) = nth_exn contracts 0 in - let (_, _, addr2) = nth_exn contracts 1 in - let (_, _, addr3) = nth_exn contracts 2 in - let (deposit, _) = + let sk1, pk1, addr1 = nth_exn contracts 0 in + let _, _, addr2 = nth_exn contracts 1 in + let _, _, addr3 = nth_exn contracts 2 in + let deposit, _ = make_deposit (Obj.magic pk1) (value addr1) ticket1 (Tx_rollup_l2_qty.of_int64_exn 10L) in - let* (ctxt, _) = apply_l2_message empty_context deposit in + let* ctxt, _ = apply_l2_message empty_context deposit in let batch = batch_from_transfers [ @@ -1706,7 +1700,7 @@ module Indexes = struct [(sk1, pk1, addr3, ticket1, 1L, Some 2L)]; ] in - let* (_, (result, _)) = apply_l2_message ctxt batch in + let* _, (result, _) = apply_l2_message ctxt batch in match result with | Batch_V1_result (Batch_result {indexes; _}) -> check_indexes [(addr2, 1l); (addr3, 2l)] [] indexes @@ -1715,18 +1709,18 @@ module Indexes = struct let test_drop_on_wrong_batch () = let open Context_l2.Syntax in let contracts = gen_n_address 4 in - let (sk1, pk1, addr1) = nth_exn contracts 0 in - let (sk2, pk2, addr2) = nth_exn contracts 1 in - let (_, _, addr3) = nth_exn contracts 2 in - let (_, _, addr4) = nth_exn contracts 3 in - let (deposit, _) = + let sk1, pk1, addr1 = nth_exn contracts 0 in + let sk2, pk2, addr2 = nth_exn contracts 1 in + let _, _, addr3 = nth_exn contracts 2 in + let _, _, addr4 = nth_exn contracts 3 in + let deposit, _ = make_deposit (Obj.magic pk1) (value addr1) ticket1 (Tx_rollup_l2_qty.of_int64_exn 10L) in - let* (ctxt, _) = apply_l2_message empty_context deposit in + let* ctxt, _ = apply_l2_message empty_context deposit in let batch = batch_from_transfers [ @@ -1742,7 +1736,7 @@ module Indexes = struct ]; ] in - let* (_ctxt, (result, _)) = apply_l2_message ctxt batch in + let* _ctxt, (result, _) = apply_l2_message ctxt batch in match result with | Batch_V1_result (Batch_result {indexes; _}) -> check_indexes [(addr2, 1l)] [] indexes diff --git a/src/proto_alpha/lib_protocol/tez_repr.ml b/src/proto_alpha/lib_protocol/tez_repr.ml index e80c732071c5..99bbe0b87d09 100644 --- a/src/proto_alpha/lib_protocol/tez_repr.ml +++ b/src/proto_alpha/lib_protocol/tez_repr.ml @@ -98,7 +98,7 @@ let of_string s = let pp ppf (Tez_tag amount) = let mult_int = 1_000_000L in let[@coq_struct "amount"] rec left ppf amount = - let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in + let d, r = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in if d > 0L then Format.fprintf ppf "%a%03Ld" left d r else Format.fprintf ppf "%Ld" r in @@ -108,11 +108,11 @@ let pp ppf (Tez_tag amount) = else if Compare.Int.(v mod 100 > 0) then Format.fprintf ppf "%02d" (v / 10) else Format.fprintf ppf "%d" (v / 100) in - let (hi, lo) = (amount / 1000, amount mod 1000) in + let hi, lo = (amount / 1000, amount mod 1000) in if Compare.Int.(lo = 0) then Format.fprintf ppf "%a" triplet hi else Format.fprintf ppf "%03d%a" hi triplet lo in - let (ints, decs) = + let ints, decs = (Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int))) in left ppf ints ; diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.ml b/src/proto_alpha/lib_protocol/ticket_accounting.ml index e04e6c5c19fb..eff0753f365a 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/ticket_accounting.ml @@ -78,7 +78,7 @@ let ticket_balances_of_value ctxt ~include_lazy ty value = >>=? fun (tickets, ctxt) -> List.fold_left_e (fun (acc, ctxt) ticket -> - let (token, amount) = Ticket_token.token_and_amount_of_ex_ticket ticket in + let token, amount = Ticket_token.token_and_amount_of_ex_ticket ticket in Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step >|? fun ctxt -> ((token, Script_int.to_zint amount) :: acc, ctxt)) ([], ctxt) @@ -139,7 +139,7 @@ let ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets Move the docs from HackMd to [docs/alpha] folder. The documentation referenced here should be moved to a permanent place and the comment below should be updated. - *) +*) (** Description here: https://hackmd.io/lutm_5JNRVW-nNFSFkCXLQ?view#Implementation diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml index f77a1cd82870..850f7789d45c 100644 --- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml @@ -51,7 +51,7 @@ let () = let token_and_amount ctxt ex_ticket = Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step >|? fun ctxt -> - let (token, amount) = Ticket_token.token_and_amount_of_ex_ticket ex_ticket in + let token, amount = Ticket_token.token_and_amount_of_ex_ticket ex_ticket in ((token, Script_int.to_zint amount), ctxt) (** Extracts the ticket-token and amount from an ex_ticket value and returns diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index b3584e951cb2..22a4adde45df 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -156,7 +156,7 @@ let parse_and_cache_script ctxt ~destination ~get_non_cached_script = >>=? fun (ex_script, ctxt) -> (* Add the parsed script to the script-cache in order to avoid having to re-parse when applying the operation at a later stage. *) - let (size, cost) = Script_ir_translator.script_size ex_script in + let size, cost = Script_ir_translator.script_size ex_script in Gas.consume ctxt cost >>?= fun ctxt -> Script_cache.insert ctxt destination (script, ex_script) size >>?= fun ctxt -> return (ex_script, ctxt) @@ -279,7 +279,7 @@ let tickets_of_operation ctxt let add_transfer_to_token_map ctxt token_map {destination; tickets} = List.fold_left_es (fun (token_map, ctxt) ticket -> - let (ticket_token, amount) = + let ticket_token, amount = Ticket_token.token_and_amount_of_ex_ticket ticket in Ticket_token_map.add ctxt ~ticket_token ~destination ~amount token_map) diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index 2956a01816d1..d203e4ee0c91 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -132,7 +132,7 @@ module Ticket_inspection = struct If neither left nor right branch contains a ticket, [False_ht] is returned. *) let pair_has_tickets pair ht1 ht2 = - match (ht1, ht2) with (False_ht, False_ht) -> False_ht | _ -> pair ht1 ht2 + match (ht1, ht2) with False_ht, False_ht -> False_ht | _ -> pair ht1 ht2 let map_has_tickets map ht = match ht with False_ht -> False_ht | _ -> map ht @@ -321,9 +321,9 @@ module Ticket_collection = struct let open Script_typed_ir in consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> match (hty, ty) with - | (False_ht, _) -> (k [@ocaml.tailcall]) ctxt acc - | (Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _)) -> - let (l, r) = x in + | False_ht, _ -> (k [@ocaml.tailcall]) ctxt acc + | Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _) -> + let l, r = x in (tickets_of_value [@ocaml.tailcall]) ~include_lazy ctxt @@ -340,7 +340,7 @@ module Ticket_collection = struct r acc k) - | (Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _)) -> ( + | Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _) -> ( match x with | L v -> (tickets_of_value [@ocaml.tailcall]) @@ -360,7 +360,7 @@ module Ticket_collection = struct v acc k) - | (Option_ht el_hty, Option_t (el_ty, _, _)) -> ( + | Option_ht el_hty, Option_t (el_ty, _, _) -> ( match x with | Some x -> (tickets_of_value [@ocaml.tailcall]) @@ -372,7 +372,7 @@ module Ticket_collection = struct acc k | None -> (k [@ocaml.tailcall]) ctxt acc) - | (List_ht el_hty, List_t (el_ty, _)) -> + | List_ht el_hty, List_t (el_ty, _) -> let {elements; _} = x in (tickets_of_list [@ocaml.tailcall]) ctxt @@ -382,9 +382,9 @@ module Ticket_collection = struct elements acc k - | (Set_ht _, Set_t (key_ty, _)) -> + | Set_ht _, Set_t (key_ty, _) -> (tickets_of_set [@ocaml.tailcall]) ctxt key_ty x acc k - | (Map_ht (_, val_hty), Map_t (key_ty, val_ty, _)) -> + | Map_ht (_, val_hty), Map_t (key_ty, val_ty, _) -> (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty @@ -398,11 +398,11 @@ module Ticket_collection = struct x acc k) - | (Big_map_ht (_, val_hty), Big_map_t (key_ty, _, _)) -> + | Big_map_ht (_, val_hty), Big_map_t (key_ty, _, _) -> if include_lazy then (tickets_of_big_map [@ocaml.tailcall]) ctxt val_hty key_ty x acc k else (k [@ocaml.tailcall]) ctxt acc - | (True_ht, Ticket_t (comp_ty, _)) -> + | True_ht, Ticket_t (comp_ty, _) -> (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc) and tickets_of_list : diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml index 7276ef13939e..6d6d94eb9305 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml @@ -183,11 +183,10 @@ let check_commitment_predecessor ctxt state commitment = ( commitment.predecessor, Tx_rollup_state_repr.next_commitment_predecessor state ) with - | (Some pred_hash, Some expected_hash) when Hash.(pred_hash = expected_hash) - -> + | Some pred_hash, Some expected_hash when Hash.(pred_hash = expected_hash) -> return ctxt - | (None, None) -> return ctxt - | (provided, expected) -> fail (Wrong_predecessor_hash {provided; expected}) + | None, None -> return ctxt + | provided, expected -> fail (Wrong_predecessor_hash {provided; expected}) let check_commitment_batches_and_merkle_root ctxt state inbox commitment = let Tx_rollup_inbox_repr.{inbox_length; merkle_root; _} = inbox in diff --git a/src/proto_alpha/lib_protocol/tx_rollup_inbox_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_inbox_storage.ml index 7ab42bf80984..330f6fdd2e5d 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_inbox_storage.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_inbox_storage.ml @@ -42,8 +42,8 @@ let get : (Raw_context.t * Tx_rollup_inbox_repr.t) tzresult Lwt.t = fun ctxt level tx_rollup -> find ctxt level tx_rollup >>=? function - | (_, None) -> fail (Inbox_does_not_exist (tx_rollup, level)) - | (ctxt, Some inbox) -> return (ctxt, inbox) + | _, None -> fail (Inbox_does_not_exist (tx_rollup, level)) + | ctxt, Some inbox -> return (ctxt, inbox) (** [prepare_inbox ctxt rollup state level] prepares the metadata for an inbox at [level], which may imply creating it if it does @@ -173,7 +173,7 @@ let append_message : >>=? fun () -> Tx_rollup_hash_builder.message ctxt message >>?= fun (ctxt, message_hash) -> Tx_rollup_gas.consume_add_message_cost ctxt >>?= fun ctxt -> - let (ctxt, inbox_merkle_root) = + let ctxt, inbox_merkle_root = Raw_context.Tx_rollup.add_message ctxt rollup message_hash in let new_inbox = update_inbox inbox message_size inbox_merkle_root in diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index a0aa2e90516e..cf2c1dd815a7 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml @@ -334,7 +334,7 @@ module Make (Context : CONTEXT) = struct let open Indexable in match destruct indexable with | Right v -> ( - let+ (ctxt, created, idx) = get_or_associate_index ctxt v in + let+ ctxt, created, idx = get_or_associate_index ctxt v in match created with | `Existed -> (ctxt, indexes, idx) | `Created -> (ctxt, add_index indexes (v, idx), idx)) @@ -428,7 +428,7 @@ module Make (Context : CONTEXT) = struct * Bls_signature.pk) m = fun ctxt indexes op -> - let* (ctxt, indexes, pk, idx) = + let* ctxt, indexes, pk, idx = match Indexable.destruct op.signer with | Left signer_index -> (* Get the public key from the index. *) @@ -439,7 +439,7 @@ module Make (Context : CONTEXT) = struct | Right (Bls_pk signer_pk) -> ( (* Initialize the ctxt with public_key if it's necessary. *) let addr = Tx_rollup_l2_address.of_bls_pk signer_pk in - let* (ctxt, created, idx) = + let* ctxt, created, idx = Address_index.get_or_associate_index ctxt addr in @@ -515,10 +515,10 @@ module Make (Context : CONTEXT) = struct | Some buf -> return buf | None -> fail Invalid_transaction_encoding in - let* (ctxt, indexes, transmitted, _, rev_ops) = + let* ctxt, indexes, transmitted, _, rev_ops = list_fold_left_m (fun (ctxt, indexes, transmitted, signers, ops) op -> - let* (ctxt, indexes, op, pk) = + let* ctxt, indexes, op, pk = operation_with_signer_index ctxt indexes op in let compare x y = @@ -546,13 +546,13 @@ module Make (Context : CONTEXT) = struct ('signer, 'content) t -> (ctxt * indexes * (Indexable.index_only, 'content) t) m = fun ctxt ({contents = transactions; aggregated_signature} as batch) -> - let* (ctxt, indexes, transmitted, rev_new_transactions) = + let* ctxt, indexes, transmitted, rev_new_transactions = list_fold_left_m (fun (ctxt, indexes, transmitted, new_transactions) transaction -> (* To check the signature, we need the list of [buf] each signer signed. That is, the [buf] is the binary encoding of the [transaction]. *) - let* (ctxt, indexes, transmitted, transaction) = + let* ctxt, indexes, transmitted, transaction = check_transaction ctxt indexes transmitted transaction in return (ctxt, indexes, transmitted, transaction :: new_transactions)) @@ -603,10 +603,10 @@ module Make (Context : CONTEXT) = struct let withdrawal = Tx_rollup_withdraw.{claimer; ticket_hash; amount} in return (ctxt, indexes, Some withdrawal) | Transfer {destination; ticket_hash; qty} -> - let* (ctxt, indexes, dest_idx) = + let* ctxt, indexes, dest_idx = address_index ctxt indexes destination in - let* (ctxt, indexes, tidx) = ticket_index ctxt indexes ticket_hash in + let* ctxt, indexes, tidx = ticket_index ctxt indexes ticket_hash in let source_idx = address_of_signer_index source_idx in let* ctxt = transfer ctxt source_idx dest_idx tidx qty in return (ctxt, indexes, None) @@ -636,10 +636,10 @@ module Make (Context : CONTEXT) = struct fun ctxt indexes {signer; counter; contents} -> (* Before applying any operation, we check the counter *) let* () = check_counter ctxt signer counter in - let* (ctxt, indexes, rev_withdrawals) = + let* ctxt, indexes, rev_withdrawals = list_fold_left_m (fun (ctxt, indexes, withdrawals) content -> - let* (ctxt, indexes, withdrawal_opt) = + let* ctxt, indexes, withdrawal_opt = apply_operation_content ctxt indexes signer content in return (ctxt, indexes, Option.to_list withdrawal_opt @ withdrawals)) @@ -664,7 +664,7 @@ module Make (Context : CONTEXT) = struct match ops with | [] -> return (ctxt, prev_indexes, Transaction_success, withdrawals) | op :: rst -> - let* (ctxt, indexes, status, withdrawals) = + let* ctxt, indexes, status, withdrawals = catch (apply_operation ctxt prev_indexes op) (fun (ctxt, indexes, op_withdrawals) -> @@ -705,12 +705,12 @@ module Make (Context : CONTEXT) = struct (Indexable.unknown, Indexable.unknown) t -> (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m = fun ctxt parameters batch -> - let* (ctxt, indexes, batch) = check_signature ctxt batch in + let* ctxt, indexes, batch = check_signature ctxt batch in let {contents; _} = batch in - let* (ctxt, indexes, rev_results, withdrawals) = + let* ctxt, indexes, rev_results, withdrawals = list_fold_left_m (fun (prev_ctxt, prev_indexes, results, withdrawals) transaction -> - let* (new_ctxt, new_indexes, status, transaction_withdrawals) = + let* new_ctxt, new_indexes, status, transaction_withdrawals = apply_transaction prev_ctxt prev_indexes transaction in let* new_ctxt = update_counters new_ctxt status transaction in @@ -741,10 +741,10 @@ module Make (Context : CONTEXT) = struct (ctxt * deposit_result * Tx_rollup_withdraw.t option) m = fun initial_ctxt Tx_rollup_message.{sender; destination; ticket_hash; amount} -> let apply_deposit () = - let* (ctxt, indexes, aidx) = + let* ctxt, indexes, aidx = address_index initial_ctxt empty_indexes destination in - let* (ctxt, indexes, tidx) = + let* ctxt, indexes, tidx = ticket_index ctxt indexes Indexable.(value ticket_hash) in let* ctxt = deposit ctxt aidx tidx amount in @@ -768,7 +768,7 @@ module Make (Context : CONTEXT) = struct let open Tx_rollup_message in match msg with | Deposit deposit -> - let* (ctxt, result, withdrawl_opt) = apply_deposit ctxt deposit in + let* ctxt, result, withdrawl_opt = apply_deposit ctxt deposit in return (ctxt, (Deposit_result result, Option.to_list withdrawl_opt)) | Batch str -> ( let batch = @@ -776,7 +776,7 @@ module Make (Context : CONTEXT) = struct in match batch with | Some (V1 batch) -> - let* (ctxt, result, withdrawals) = + let* ctxt, result, withdrawals = Batch_V1.apply_batch ctxt parameters batch in return (ctxt, (Batch_V1_result result, withdrawals)) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml index 210668f9a984..37379c6fd0e9 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml @@ -50,13 +50,13 @@ module Signer_indexable = Indexable.Make (struct let compare x y = match (x, y) with - | (Bls_pk pk1, Bls_pk pk2) -> + | Bls_pk pk1, Bls_pk pk2 -> Bytes.compare (Bls_signature.pk_to_bytes pk1) (Bls_signature.pk_to_bytes pk2) - | (L2_addr addr1, L2_addr addr2) -> Tx_rollup_l2_address.compare addr1 addr2 - | (L2_addr _, Bls_pk _) -> -1 - | (Bls_pk _, L2_addr _) -> 1 + | L2_addr addr1, L2_addr addr2 -> Tx_rollup_l2_address.compare addr1 addr2 + | L2_addr _, Bls_pk _ -> -1 + | Bls_pk _, L2_addr _ -> 1 let encoding = let open Data_encoding in diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml index ae06d5b2330a..453e1588df77 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml @@ -303,7 +303,7 @@ struct match index_opt with | Some idx -> return (ctxt, `Existed, idx) | None -> - let+ (ctxt, idx) = associate_index ctxt addr in + let+ ctxt, idx = associate_index ctxt addr in (ctxt, `Created, idx) module Internal_for_tests = struct @@ -340,7 +340,7 @@ struct match index_opt with | Some idx -> return (ctxt, `Existed, idx) | None -> - let+ (ctxt, idx) = associate_index ctxt ticket in + let+ ctxt, idx = associate_index ctxt ticket in (ctxt, `Created, idx) module Internal_for_tests = struct diff --git a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml index c1a50a995be8..a393b22676f9 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml @@ -76,7 +76,7 @@ let pp fmt = function | Batch str -> let subsize = 10 in - let (str, ellipsis) = + let str, ellipsis = if Compare.Int.(subsize < String.length str) then let substring = String.sub str 0 subsize in (substring, "...") diff --git a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml index d7a7409c6f5a..104b9f1e00d1 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml @@ -471,7 +471,7 @@ let record_inbox_creation t level = (Internal_error "Trying to create an inbox in the past") | None -> ok ()) >>? fun () -> - let (uncommitted_inboxes, new_level) = extend t.uncommitted_inboxes in + let uncommitted_inboxes, new_level = extend t.uncommitted_inboxes in adjust_storage_allocation t ~delta:Tx_rollup_inbox_repr.size >>? fun (t, diff) -> ok @@ -489,7 +489,7 @@ let next_commitment_level state current_level = ( range_oldest state.uncommitted_inboxes, range_newest state.uncommitted_inboxes ) with - | (Some oldest_level, Some newest_level) -> ( + | Some oldest_level, Some newest_level -> ( if (* We want to return an error if there is only one inbox in the storage, and this inbox has been created in the current @@ -510,8 +510,8 @@ let next_commitment_level state current_level = >>? fun () -> ok oldest_level | None -> error (Internal_error "tezos_head_level was not properly set") ) - | (None, None) -> error No_uncommitted_inbox - | (Some _, None) | (None, Some _) -> + | None, None -> error No_uncommitted_inbox + | Some _, None | None, Some _ -> error (Internal_error "rollup state is inconsistent") let next_commitment_to_finalize state = @@ -523,7 +523,7 @@ let record_inbox_deletion state candidate = match range_oldest state.unfinalized_commitments with | Some level when Tx_rollup_level_repr.(candidate = level) -> shrink state.unfinalized_commitments >>? fun unfinalized_commitments -> - let (finalized_commitments, _) = extend state.finalized_commitments in + let finalized_commitments, _ = extend state.finalized_commitments in ok {state with unfinalized_commitments; finalized_commitments} | _ -> error (Internal_error "Trying to delete the wrong inbox") @@ -535,7 +535,7 @@ let record_commitment_creation state level hash = (Internal_error "Trying to create the wrong commitment") >>? fun () -> shrink state.uncommitted_inboxes >>? fun uncommitted_inboxes -> - let (unfinalized_commitments, _) = extend state.unfinalized_commitments in + let unfinalized_commitments, _ = extend state.unfinalized_commitments in let state = { state with @@ -623,7 +623,7 @@ let finalized_commitments_range state = ( range_oldest state.finalized_commitments, range_newest state.finalized_commitments ) with - | (Some oldest, Some newest) -> Some (oldest, newest) + | Some oldest, Some newest -> Some (oldest, newest) | _ -> None let check_level_can_be_rejected state level = @@ -631,7 +631,7 @@ let check_level_can_be_rejected state level = ( range_oldest state.unfinalized_commitments, range_newest state.unfinalized_commitments ) with - | (Some oldest, Some newest) -> + | Some oldest, Some newest -> error_unless Tx_rollup_level_repr.(oldest <= level && level <= newest) @@ Cannot_reject_level {provided = level; accepted_range = Some (oldest, newest)} @@ -641,9 +641,9 @@ let last_removed_commitment_hashes state = state.last_removed_commitment_hashes let head_levels state = match (state.uncommitted_inboxes, state.tezos_head_level) with - | (Empty {next = l}, Some tz_level) -> + | Empty {next = l}, Some tz_level -> Option.map (fun l -> (l, tz_level)) (Tx_rollup_level_repr.pred l) - | (Interval {newest; _}, Some tz_level) -> Some (newest, tz_level) + | Interval {newest; _}, Some tz_level -> Some (newest, tz_level) | _ -> None module Internal_for_tests = struct diff --git a/src/proto_alpha/lib_protocol/vote_repr.ml b/src/proto_alpha/lib_protocol/vote_repr.ml index fd4543942af0..493b5b194683 100644 --- a/src/proto_alpha/lib_protocol/vote_repr.ml +++ b/src/proto_alpha/lib_protocol/vote_repr.ml @@ -42,9 +42,7 @@ let ballot_encoding = ~json:(string_enum [("yay", Yay); ("nay", Nay); ("pass", Pass)]) let equal_ballot a b = - match (a, b) with - | (Yay, Yay) | (Nay, Nay) | (Pass, Pass) -> true - | _ -> false + match (a, b) with Yay, Yay | Nay, Nay | Pass, Pass -> true | _ -> false let pp_ballot ppf = function | Yay -> Format.fprintf ppf "yay" diff --git a/src/proto_alpha/lib_tx_rollup/RPC.ml b/src/proto_alpha/lib_tx_rollup/RPC.ml index 56515a323a52..41d8743abf7e 100644 --- a/src/proto_alpha/lib_tx_rollup/RPC.ml +++ b/src/proto_alpha/lib_tx_rollup/RPC.ml @@ -457,8 +457,8 @@ module Context_RPC = struct let* ticket_id = get_ticket_index c ticket in let* address_id = get_address_index c address in match (ticket_id, address_id) with - | (None, _) | (_, None) -> return Tx_rollup_l2_qty.zero - | (Some ticket_id, Some address_id) -> + | None, _ | _, None -> return Tx_rollup_l2_qty.zero + | Some ticket_id, Some address_id -> Context.Ticket_ledger.get c ticket_id address_id let () = @@ -620,7 +620,7 @@ let launch ~host ~acl ~node ~dir () = let start configuration state = let open Lwt_result_syntax in let Node_config.{rpc_addr; _} = configuration in - let (host, rpc_port) = rpc_addr in + let host, rpc_port = rpc_addr in let host = P2p_addr.to_string host in let dir = register state in let node = `TCP (`Port rpc_port) in diff --git a/src/proto_alpha/lib_tx_rollup/accuser.ml b/src/proto_alpha/lib_tx_rollup/accuser.ml index 1d023364c8c6..b41d31bf4c5a 100644 --- a/src/proto_alpha/lib_tx_rollup/accuser.ml +++ b/src/proto_alpha/lib_tx_rollup/accuser.ml @@ -142,21 +142,20 @@ let build_rejection state ~(reject_commitment : Tx_rollup_commitment.Full.t) let tree = List.fold_left snoc nil reject_commitment.messages in Environment.wrap_tzresult @@ compute_path tree position in - let* (previous_message_result, previous_message_result_path, previous_context) - = + let* previous_message_result, previous_message_result_path, previous_context = match (block.header.predecessor, position) with - | (None, 0) -> + | None, 0 -> (* Rejecting first message of first level, no predecessor *) let*! context = Context.init_context state.State.context_index in return ( Tx_rollup_message_result.init, Tx_rollup_commitment.Merkle.dummy_path, context ) - | (predecessor, _) -> - let* (inbox_of_previous_message, previous_message_position) = + | predecessor, _ -> + let* inbox_of_previous_message, previous_message_position = match (predecessor, position) with - | (None, 0) -> assert false (* handled above *) - | (Some predecessor_hash, 0) -> + | None, 0 -> assert false (* handled above *) + | Some predecessor_hash, 0 -> let*! predecessor = State.get_block state predecessor_hash in let*? predecessor = Result.of_option @@ -212,7 +211,7 @@ let build_rejection state ~(reject_commitment : Tx_rollup_commitment.Full.t) state.constants.parametric.tx_rollup_max_withdrawals_per_batch; } in - let+ (proof, _) = + let+ proof, _ = Prover_apply.apply_message previous_context l2_parameters message in Tx_rollup_rejection diff --git a/src/proto_alpha/lib_tx_rollup/batcher.ml b/src/proto_alpha/lib_tx_rollup/batcher.ml index 9164fb89a0e0..2968205df8f6 100644 --- a/src/proto_alpha/lib_tx_rollup/batcher.ml +++ b/src/proto_alpha/lib_tx_rollup/batcher.ml @@ -121,7 +121,7 @@ let get_batches ctxt constants queue = } in try - let* (rev_batches, rev_current_trs, to_remove) = + let* rev_batches, rev_current_trs, to_remove = Tx_queue.fold_es (fun tr_hash tr (batches, rev_current_trs, to_remove) -> let new_trs = tr :: rev_current_trs in @@ -169,7 +169,7 @@ let get_batches ctxt constants queue = let on_batch state = let open Lwt_result_syntax in - let* (batches, to_remove) = + let* batches, to_remove = get_batches state.incr_context state.constants state.transactions in match batches with @@ -199,7 +199,7 @@ let on_register state ~apply (tr : L2_transaction.t) = let batch_string = Data_encoding.Binary.to_string_exn Tx_rollup_l2_batch.encoding (V1 batch) in - let (_msg, msg_size) = Tx_rollup_message.make_batch batch_string in + let _msg, msg_size = Tx_rollup_message.make_batch batch_string in let* () = fail_when (msg_size @@ -215,7 +215,7 @@ let on_register state ~apply (tr : L2_transaction.t) = let prev_context = context in let* context = if apply then - let* (new_context, result, _withdrawals) = + let* new_context, result, _withdrawals = let parameters = Tx_rollup_l2_apply. { @@ -325,7 +325,7 @@ end let table = Worker.create_table Queue -let (worker_promise, worker_waker) = Lwt.task () +let worker_promise, worker_waker = Lwt.task () let init ~rollup ~signer ~batch_burn_limit index constants = let open Lwt_result_syntax in diff --git a/src/proto_alpha/lib_tx_rollup/common.ml b/src/proto_alpha/lib_tx_rollup/common.ml index 491478b2c1c7..298419e40eba 100644 --- a/src/proto_alpha/lib_tx_rollup/common.ml +++ b/src/proto_alpha/lib_tx_rollup/common.ml @@ -32,7 +32,7 @@ type signer = { let get_signer cctxt pkh = let open Lwt_result_syntax in - let* (alias, pk, sk) = Client_keys.get_key cctxt pkh in + let* alias, pk, sk = Client_keys.get_key cctxt pkh in return {alias; pkh; pk; sk} type 'block reorg = { diff --git a/src/proto_alpha/lib_tx_rollup/context.ml b/src/proto_alpha/lib_tx_rollup/context.ml index 36afb000be28..ec1cc9eea59b 100644 --- a/src/proto_alpha/lib_tx_rollup/context.ml +++ b/src/proto_alpha/lib_tx_rollup/context.ml @@ -186,7 +186,7 @@ let produce_proof ctxt f = | Some kinded_key -> return kinded_key | None -> fail [Error.Tx_rollup_tree_kinded_key_not_found] in - let*! (proof, result) = + let*! proof, result = Raw.produce_stream_proof index kinded_key (fun tree -> let*! res = f tree in Lwt.return (res.tree, res)) @@ -223,7 +223,7 @@ let init_context index = assert ( Context_hash.( tree_hash = Protocol.Tx_rollup_message_result_repr.empty_l2_context_hash)) ; - let* (ctxt, _) = add_tree ctxt tree in + let* ctxt, _ = add_tree ctxt tree in return ctxt (** {2 Sub-context for tickets } *) diff --git a/src/proto_alpha/lib_tx_rollup/daemon.ml b/src/proto_alpha/lib_tx_rollup/daemon.ml index 29ccb20eb09d..b000c958d4f4 100644 --- a/src/proto_alpha/lib_tx_rollup/daemon.ml +++ b/src/proto_alpha/lib_tx_rollup/daemon.ml @@ -153,7 +153,7 @@ let extract_messages_from_block block_info rollup_id = amount in (deposit, Some (ticket_hash, ticket)) - | (_, _) -> None + | _, _ -> None in let acc = match message_size_ticket with @@ -220,14 +220,14 @@ let extract_messages_from_block block_info rollup_id = | None -> (* Should not happen *) ok acc) - | (_, Receipt No_operation_metadata) | (_, Empty) | (_, Too_large) -> + | _, Receipt No_operation_metadata | _, Empty | _, Too_large -> error (Tx_rollup_no_operation_metadata operation.hash) in match managed_operation with | None -> ok ([], Ticket_hash_map.empty) | Some managed_operations -> let open Result_syntax in - let+ (rev_messages, new_tickets) = + let+ rev_messages, new_tickets = List.fold_left_e finalize_receipt ([], Ticket_hash_map.empty) @@ -266,7 +266,7 @@ let process_messages_and_inboxes (state : State.t) ~(predecessor : L2block.t option) ?predecessor_context block_info = let open Lwt_result_syntax in let current_hash = block_info.Alpha_block_services.hash in - let*? (messages, new_tickets) = + let*? messages, new_tickets = extract_messages_from_block block_info state.State.rollup_info.rollup_id in let*! () = Event.(emit messages_application) (List.length messages) in @@ -289,7 +289,7 @@ let process_messages_and_inboxes (state : State.t) } in let context = predecessor_context in - let* (context, contents) = + let* context, contents = Interpreter.interpret_messages context parameters @@ -320,7 +320,7 @@ let process_messages_and_inboxes (state : State.t) return (`Old predecessor, predecessor_context) | Some inbox -> let*! context_hash = Context.commit context in - let (level, predecessor_hash) = + let level, predecessor_hash = match predecessor with | None -> (Tx_rollup_level.root, None) | Some {hash; header = {level; _}; _} -> @@ -414,7 +414,7 @@ let rec process_block state current_hash = Event.(emit processing_block_predecessor) (predecessor_hash, Int32.pred block_level) in - let* (l2_predecessor, predecessor_context, blocks_to_commit) = + let* l2_predecessor, predecessor_context, blocks_to_commit = if originated_in_block rollup_id block_info then let*! () = Event.(emit detected_origination) (rollup_id, current_hash) @@ -428,7 +428,7 @@ let rec process_block state current_hash = let*! () = Event.(emit processing_block) (current_hash, predecessor_hash) in - let* (l2_block, context) = + let* l2_block, context = process_messages_and_inboxes state ~predecessor:l2_predecessor @@ -573,13 +573,13 @@ let fail_when_slashed (type kind) state l1_operation balance_updates | _ -> [] in - let (frozen_debit, punish) = + let frozen_debit, punish = List.fold_left (fun (frozen_debit, punish) -> function | Receipt.(Tx_rollup_rejection_punishments, Credited _, _) -> (* Someone was punished *) (frozen_debit, true) - | (Frozen_bonds (committer, _), Debited _, _) + | Frozen_bonds (committer, _), Debited _, _ when Contract.(committer = Implicit operator) -> (* Our frozen bonds are gone *) (true, punish) @@ -621,7 +621,7 @@ let process_op (type kind) (state : State.t) l1_block l1_operation ~source:_ when is_my_rollup tx_rollup -> let* () = dispatch_withdrawals_on_l1 state level in State.set_finalized_level state level - | (_, _) -> return acc + | _, _ -> return acc let rollback_op (type kind) (state : State.t) _l1_block _l1_operation ~source:_ (op : kind manager_operation) (result : kind manager_operation_result) @@ -647,7 +647,7 @@ let rollback_op (type kind) (state : State.t) _l1_block _l1_operation ~source:_ let*! () = State.delete_finalized_level state in return_unit | Some level -> State.set_finalized_level state level) - | (_, _) -> return acc + | _, _ -> return acc let handle_l1_operation direction (block : Alpha_block_services.block_info) state acc (operation : Alpha_block_services.operation) = @@ -700,7 +700,7 @@ let handle_l1_operation direction (block : Alpha_block_services.block_info) handle_list acc rest in match (operation.protocol_data, operation.receipt) with - | (_, Receipt No_operation_metadata) | (_, Empty) | (_, Too_large) -> + | _, Receipt No_operation_metadata | _, Empty | _, Too_large -> fail [Tx_rollup_no_operation_metadata operation.hash] | ( Operation_data {contents = operation_contents; _}, Receipt (Operation_metadata {contents = result_contents}) ) -> ( @@ -739,7 +739,7 @@ let handle_l1_reorg state acc reorg = let process_head state (current_hash, current_header) = let open Lwt_result_syntax in let*! () = Event.(emit new_block) current_hash in - let* (_, _, blocks_to_commit) = process_block state current_hash in + let* _, _, blocks_to_commit = process_block state current_hash in let* l1_reorg = State.set_tezos_head state current_hash in let* () = handle_l1_reorg state () l1_reorg in let* () = List.iter_es (commit_block_on_l1 state) blocks_to_commit in @@ -882,8 +882,8 @@ let run configuration cctxt = ~signers: (List.filter_map (function - | (None, _, _) -> None - | (Some x, strategy, tags) -> Some (x, strategy, tags)) + | None, _, _ -> None + | Some x, strategy, tags -> Some (x, strategy, tags)) [ (signers.operator, Injector.Each_block, [`Commitment]); (* Batches of L2 operations are submitted with a delay after each @@ -918,7 +918,7 @@ let run configuration cctxt = let* () = Lwt.catch (fun () -> - let* (block_stream, interupt) = + let* block_stream, interupt = connect ~delay:reconnection_delay cctxt in let*! () = diff --git a/src/proto_alpha/lib_tx_rollup/dispatcher.ml b/src/proto_alpha/lib_tx_rollup/dispatcher.ml index 786d107ffa9b..e2a41ddc9e76 100644 --- a/src/proto_alpha/lib_tx_rollup/dispatcher.ml +++ b/src/proto_alpha/lib_tx_rollup/dispatcher.ml @@ -75,7 +75,7 @@ let dispatch_operations_of_block (state : State.t) (block : L2block.t) = let* ctxt = Context.checkout state.context_index block.header.context in let tx_rollup = state.rollup_info.rollup_id in let commitment = block.commitment in - let+ (rev_ops, _) = + let+ rev_ops, _ = List.fold_left_es (fun (acc, message_index) msg -> let context_hash = msg.Inbox.l2_context_hash.tree_hash in @@ -101,7 +101,7 @@ let dispatch_operations_of_block (state : State.t) (block : L2block.t) = message_result_path; tickets_info; } - :: acc) + :: acc) in (acc, message_index + 1)) ([], 0) diff --git a/src/proto_alpha/lib_tx_rollup/injector.ml b/src/proto_alpha/lib_tx_rollup/injector.ml index ef869d791d1f..b4b66cf53d0f 100644 --- a/src/proto_alpha/lib_tx_rollup/injector.ml +++ b/src/proto_alpha/lib_tx_rollup/injector.ml @@ -361,7 +361,7 @@ let simulate_operations ~must_succeed state signer let (Manager_list annot_op) = Annotated_manager_operation.manager_of_list operations in - let* (oph, op, result) = + let* oph, op, result = Injection.inject_manager_operation state.cctxt ~simulation:true (* Only simulation here *) @@ -371,8 +371,8 @@ let simulate_operations ~must_succeed state signer ~source:signer.pkh ~src_pk:signer.pk ~src_sk:signer.sk - ~successor_level: - true (* Needed to simulate tx_rollup operations in the next block *) + ~successor_level:true + (* Needed to simulate tx_rollup operations in the next block *) ~fee:Limit.unknown ~gas_limit:Limit.unknown ~storage_limit:Limit.unknown @@ -430,7 +430,7 @@ let inject_on_node state packed_contents = let rec inject_operations ~must_succeed state (operations : L1_operation.t list) = let open Lwt_result_syntax in - let* (_oph, packed_contents, result) = + let* _oph, packed_contents, result = simulate_operations ~must_succeed state state.signer operations in let results = Apply_results.to_list result in @@ -802,14 +802,14 @@ let init rollup_node_state ~signers = List.fold_left (fun acc (signer, strategy, tags) -> let tags = Tags.of_list tags in - let (strategy, tags) = + let strategy, tags = match Signature.Public_key_hash.Map.find_opt signer acc with | None -> (strategy, tags) | Some (other_strategy, other_tags) -> let strategy = match (strategy, other_strategy) with - | (Each_block, Each_block) -> Each_block - | (Delay_block, _) | (_, Delay_block) -> + | Each_block, Each_block -> Each_block + | Delay_block, _ | _, Delay_block -> (* Delay_block strategy takes over because we can always wait a little bit more to inject operation which are to be injected "each block". *) diff --git a/src/proto_alpha/lib_tx_rollup/interpreter.ml b/src/proto_alpha/lib_tx_rollup/interpreter.ml index 797da4adff83..fae917c5f5e8 100644 --- a/src/proto_alpha/lib_tx_rollup/interpreter.ml +++ b/src/proto_alpha/lib_tx_rollup/interpreter.ml @@ -50,7 +50,7 @@ let () = the proof size boundaries. *) let interpret_message ~rejection_max_proof_size ctxt l2_parameters message = let open Lwt_result_syntax in - let* (proof, res) = Prover_apply.apply_message ctxt l2_parameters message in + let* proof, res = Prover_apply.apply_message ctxt l2_parameters message in let proof_size = Prover_apply.proof_size proof in let result = if proof_size > rejection_max_proof_size then @@ -69,20 +69,20 @@ let interpret_messages ~rejection_max_proof_size ctxt l2_parameters messages = let open Lwt_result_syntax in let ctxt_hash = Context.hash ctxt in let* tree_hash = Context.tree_hash_of_context ctxt in - let+ (ctxt, _ctxt_hash, _tree_hash, rev_contents) = + let+ ctxt, _ctxt_hash, _tree_hash, rev_contents = List.fold_left_es (fun (ctxt, ctxt_hash, tree_hash, acc) message -> - let* (tree, result) = + let* tree, result = interpret_message ~rejection_max_proof_size ctxt l2_parameters message in - let* (ctxt, ctxt_hash, tree_hash) = + let* ctxt, ctxt_hash, tree_hash = match result with | Inbox.Interpreted _ -> (* The message was successfully interpreted but the status in [result] may indicate that the application failed. The context may have been modified with e.g. updated counters. *) let tree_hash = Context.hash_tree tree in - let*! (ctxt, ctxt_hash) = Context.add_tree ctxt tree in + let*! ctxt, ctxt_hash = Context.add_tree ctxt tree in return (ctxt, ctxt_hash, tree_hash) | Inbox.Discarded _ -> (* The message was discarded before attempting to interpret it. The @@ -115,10 +115,10 @@ let interpret_batch ~rejection_max_proof_size ctxt l2_parameters batch = Protocol.Tx_rollup_l2_batch.encoding batch in - let (message, _) = + let message, _ = Protocol.Alpha_context.Tx_rollup_message.make_batch batch_bytes in - let* (_tree, result) = + let* _tree, result = interpret_message ~rejection_max_proof_size ctxt l2_parameters message in match result with Inbox.Discarded trace -> fail trace | _ -> return () diff --git a/src/proto_alpha/lib_tx_rollup/prover_apply.ml b/src/proto_alpha/lib_tx_rollup/prover_apply.ml index 51e49fdb133b..a4dc4136f5de 100644 --- a/src/proto_alpha/lib_tx_rollup/prover_apply.ml +++ b/src/proto_alpha/lib_tx_rollup/prover_apply.ml @@ -42,5 +42,5 @@ let apply_message ctxt parameters message = Context. {tree; result = Inbox.Discarded [Environment.wrap_tzerror err]}) in - let* (proof, result) = Context.produce_proof ctxt f in + let* proof, result = Context.produce_proof ctxt f in return (proof, result) diff --git a/src/proto_alpha/lib_tx_rollup/state.ml b/src/proto_alpha/lib_tx_rollup/state.ml index db4be059edad..855919b75358 100644 --- a/src/proto_alpha/lib_tx_rollup/state.ml +++ b/src/proto_alpha/lib_tx_rollup/state.ml @@ -99,7 +99,7 @@ let tezos_reorg state ~old_head_hash ~new_head_hash = let old_level = old_head.header.shell.level in let new_level = new_head.header.shell.level in let diff = Int32.sub new_level old_level in - let (old_chain, new_chain, old, new_) = + let old_chain, new_chain, old, new_ = if diff = 0l then (* Heads at same level *) let new_chain = new_head :: new_chain in @@ -212,14 +212,14 @@ let rollup_reorg state ~old_head ~new_head = in let rec loop old_chain new_chain old_head new_head = match (old_head, new_head) with - | (None, _) | (_, None) -> + | None, _ | _, None -> return { ancestor = None; old_chain = List.rev old_chain; new_chain = List.rev new_chain; } - | (Some old_head, Some new_head) -> + | Some old_head, Some new_head -> if L2block.Hash.(old_head.L2block.hash = new_head.L2block.hash) then return { @@ -233,7 +233,7 @@ let rollup_reorg state ~old_head ~new_head = old_head.L2block.header.level new_head.L2block.header.level in - let* (old_chain, new_chain, old, new_) = + let* old_chain, new_chain, old, new_ = if diff = 0l then (* Heads at same level *) let new_chain = new_head :: new_chain in @@ -392,7 +392,7 @@ let init (cctxt : #Protocol_client_context.full) ?(readonly = false) let*! stores = Stores.init ~data_dir ~readonly ~blocks_cache_size:l2_blocks_cache_size in - let* (rollup_info, context_index) = + let* rollup_info, context_index = both (init_rollup_info stores ?origination_level rollup_id) (init_context ~data_dir) diff --git a/src/proto_alpha/lib_tx_rollup/stores.ml b/src/proto_alpha/lib_tx_rollup/stores.ml index 73f56b03a007..afb316174d22 100644 --- a/src/proto_alpha/lib_tx_rollup/stores.ml +++ b/src/proto_alpha/lib_tx_rollup/stores.ml @@ -207,7 +207,7 @@ struct let encode v = let dst = Bytes.create encoded_size in - let (tag, value_bytes) = + let tag, value_bytes = match v with | None -> (0, Bytes.make V.encoded_size '\000') | Some v -> (1, V.encode v |> Bytes.unsafe_of_string) @@ -217,7 +217,7 @@ struct Bytes.unsafe_to_string dst let decode str offset = - let (tag, offset) = read_int8 str offset in + let tag, offset = read_int8 str offset in match tag with | 0 -> None | 1 -> @@ -438,14 +438,14 @@ module L2_block_info = struct Bytes.unsafe_to_string dst let decode str offset = - let (file_offset, offset) = read_int64 str offset in - let (predecessor, offset) = + let file_offset, offset = read_int64 str offset in + let predecessor, offset = read_str str ~offset ~len:L2block.Hash.size L2block.Hash.of_string_exn in let predecessor = if L2block.Hash.(predecessor = zero) then None else Some predecessor in - let (context, _) = + let context, _ = read_str str ~offset @@ -477,11 +477,11 @@ module Tezos_block_info = struct Bytes.unsafe_to_string dst let decode str offset = - let (l2_block, offset) = + let l2_block, offset = read_str str ~offset ~len:L2block.Hash.size L2block.Hash.of_string_exn in - let (level, offset) = read_int32 str offset in - let (predecessor, _) = + let level, offset = read_int32 str offset in + let predecessor, _ = read_str str ~offset ~len:Block_hash.size Block_hash.of_string_exn in {l2_block; level; predecessor} @@ -506,10 +506,10 @@ module Commitment_info = struct Bytes.unsafe_to_string dst let decode str offset = - let (block, offset) = + let block, offset = read_str str ~offset ~len:Block_hash.size Block_hash.of_string_exn in - let (operation, _) = + let operation, _ = read_str str ~offset ~len:Operation_hash.size Operation_hash.of_string_exn in {block; operation} @@ -666,7 +666,7 @@ module L2_block_store = struct let init ~data_dir ~readonly ~cache_size = let open Lwt_syntax in - let (flag, perms) = + let flag, perms = if readonly then (Unix.O_RDONLY, 0o444) else (Unix.O_RDWR, 0o644) in let* fd = diff --git a/src/tooling/run_js_inline_tests.ml b/src/tooling/run_js_inline_tests.ml index fe567acc2970..feecd74211fe 100644 --- a/src/tooling/run_js_inline_tests.ml +++ b/src/tooling/run_js_inline_tests.ml @@ -51,13 +51,11 @@ let add_inline_tests_mode_js fields = | Sexp.List (Sexp.Atom "inline_tests" :: p) -> Sexp.List (Sexp.Atom "inline_tests" - :: - Sexp.List [Sexp.Atom "modes"; Sexp.Atom "js"] - :: - List.filter - (function - | Sexp.List (Sexp.Atom "modes" :: _) -> false | _ -> true) - p) + :: Sexp.List [Sexp.Atom "modes"; Sexp.Atom "js"] + :: List.filter + (function + | Sexp.List (Sexp.Atom "modes" :: _) -> false | _ -> true) + p) | x -> x) fields diff --git a/tezt/lib/base.ml b/tezt/lib/base.ml index 1e51f1888a81..b0f701215076 100644 --- a/tezt/lib/base.ml +++ b/tezt/lib/base.ml @@ -43,7 +43,7 @@ let ( let* ) = Lwt.bind let ( and* ) = Lwt.both let lwt_both_fail_early a b = - let (main_promise, main_awakener) = Lwt.task () in + let main_promise, main_awakener = Lwt.task () in let already_woke_up = ref false in Lwt.on_failure a (fun exn -> if not !already_woke_up then ( diff --git a/tezt/lib/check.ml b/tezt/lib/check.ml index 24dbb281c7c9..7dca31c327c1 100644 --- a/tezt/lib/check.ml +++ b/tezt/lib/check.ml @@ -93,17 +93,17 @@ let pp_list ?(left = "[") ?(right = "]") pp_item fmt list = (* Note: available as List.equal in OCaml 4.12. *) let rec equal_lists eq_items a b = match (a, b) with - | ([], []) -> true - | ([], _ :: _) | (_ :: _, []) -> false - | (hda :: tla, hdb :: tlb) -> eq_items hda hdb && equal_lists eq_items tla tlb + | [], [] -> true + | [], _ :: _ | _ :: _, [] -> false + | hda :: tla, hdb :: tlb -> eq_items hda hdb && equal_lists eq_items tla tlb (* Note: available as List.compare in OCaml 4.12. *) let rec compare_lists cmp_items a b = match (a, b) with - | ([], []) -> 0 - | ([], _ :: _) -> -1 - | (_ :: _, []) -> 1 - | (hda :: tla, hdb :: tlb) -> + | [], [] -> 0 + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | hda :: tla, hdb :: tlb -> let c = cmp_items hda hdb in if c = 0 then compare_lists cmp_items tla tlb else c @@ -134,16 +134,16 @@ let compare_arrays cmp_items a b = let rec loop i = (* All items up to [i - 1] are equal. *) match (i >= len_a, i >= len_b) with - | (true, true) -> + | true, true -> (* Both arrays have the same size. *) 0 - | (true, false) -> + | true, false -> (* [a] is smaller than [b]. *) -1 - | (false, true) -> + | false, true -> (* [a] is longer than [b]. *) 1 - | (false, false) -> + | false, false -> let c = cmp_items a.(i) b.(i) in if c = 0 then loop (i + 1) else c in diff --git a/tezt/lib/cli.ml b/tezt/lib/cli.ml index cb8c5a863d48..61a08a6fe965 100644 --- a/tezt/lib/cli.ml +++ b/tezt/lib/cli.ml @@ -193,7 +193,7 @@ let init ?args () = else if value.[i] = '=' then Some i else find_equal (i + 1) in - let (parameter, value) = + let parameter, value = match find_equal 0 with | None -> (value, "true") | Some i -> (String.sub value 0 i, String.sub value (i + 1) (len - i - 1)) diff --git a/tezt/lib/log.ml b/tezt/lib/log.ml index 760bcc63e937..9c5a95b202fa 100644 --- a/tezt/lib/log.ml +++ b/tezt/lib/log.ml @@ -241,19 +241,19 @@ let log_string ~(level : Cli.log_level) ?color ?prefix ?prefix_color in Option.iter (log_line_to ~use_colors:false line) Cli.options.log_file ; match (Cli.options.log_level, level) with - | (_, Quiet) -> invalid_arg "Log.log_string: level cannot be Quiet" - | (Error, Error) - | (Warn, (Error | Warn)) - | (Report, (Error | Warn | Report)) - | (Info, (Error | Warn | Report | Info)) - | (Debug, (Error | Warn | Report | Info | Debug)) -> + | _, Quiet -> invalid_arg "Log.log_string: level cannot be Quiet" + | Error, Error + | Warn, (Error | Warn) + | Report, (Error | Warn | Report) + | Info, (Error | Warn | Report | Info) + | Debug, (Error | Warn | Report | Info | Debug) -> (if level = Error then Log_buffer.iter @@ fun line -> log_line_to ~use_colors:Cli.options.color line channel) ; Log_buffer.reset () ; log_line_to ~use_colors:Cli.options.color line channel ; flush channel - | ((Quiet | Error | Warn | Report | Info), _) -> Log_buffer.push line + | (Quiet | Error | Warn | Report | Info), _ -> Log_buffer.push line in List.iter log_line lines @@ -274,7 +274,7 @@ type test_result = Successful | Failed of string | Aborted let test_result ~test_index ~test_count ~failure_count ~iteration test_result test_name = - let (prefix, prefix_color) = + let prefix, prefix_color = match test_result with | Successful -> ("SUCCESS", Color.(FG.green ++ bold)) | Failed _ -> ("FAILURE", Color.(FG.red ++ bold)) diff --git a/tezt/lib/process.ml b/tezt/lib/process.ml index 9e3ef149269c..e8ebbb331d1b 100644 --- a/tezt/lib/process.ml +++ b/tezt/lib/process.ml @@ -70,7 +70,7 @@ let create_echo () = if echo.closed then return 0 else (* Nothing to read, for now. *) - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in echo.pending <- resolver :: echo.pending ; let* () = promise in read bytes ofs len @@ -324,7 +324,7 @@ let spawn_with_stdin ?runner ?(log_command = true) ?(log_status_on_exit = true) | None -> (command, Array.of_list (command :: arguments)) | Some runner -> let local_env = String_map.bindings env in - let (ssh, ssh_args) = + let ssh, ssh_args = Runner.wrap_with_ssh_pid runner {local_env; name = command; arguments} in (ssh, Array.of_list (ssh :: ssh_args)) @@ -388,7 +388,7 @@ let spawn_with_stdin ?runner ?(log_command = true) ?(log_status_on_exit = true) let spawn ?runner ?log_command ?log_status_on_exit ?log_output ?name ?color ?env ?hooks command arguments = - let (process, stdin) = + let process, stdin = spawn_with_stdin ?runner ?log_command diff --git a/tezt/lib/runner.ml b/tezt/lib/runner.ml index a481294f7339..1e04426358c2 100644 --- a/tezt/lib/runner.ml +++ b/tezt/lib/runner.ml @@ -47,17 +47,17 @@ let create ?ssh_alias ?ssh_user ?ssh_port ?ssh_id ~address () = let address ?(hostname = false) ?from runner = match (from, runner) with - | (None, None) -> if hostname then "localhost" else "127.0.0.1" - | (None, Some host) -> host.address - | (Some _peer, None) -> get_local_public_ip () - | (Some peer, Some host) -> + | None, None -> if hostname then "localhost" else "127.0.0.1" + | None, Some host -> host.address + | Some _peer, None -> get_local_public_ip () + | Some peer, Some host -> if peer.address = host.address then "127.0.0.1" else host.address (* With ssh-agent, the environment variables SSH_AGENT_PID and SSH_AUTH_SOCK must be added in the environment. *) let ssh_env () = match (Sys.getenv_opt "SSH_AGENT_PID", Sys.getenv_opt "SSH_AUTH_SOCK") with - | (Some agent, Some sock) -> + | Some agent, Some sock -> [|"SSH_AGENT_PID=" ^ agent; "SSH_AUTH_SOCK=" ^ sock|] | _ -> (* Here, we assume we don't have an agent running. *) @@ -175,7 +175,7 @@ module Sys = struct (* WARNING: synchronous method so it can block. *) let run_unix_with_ssh runner shell = - let (ssh, ssh_args) = wrap_with_ssh runner shell in + let ssh, ssh_args = wrap_with_ssh runner shell in let unix_cmd = String.concat " " (ssh :: ssh_args) in let ssh_env = ssh_env () in Unix.open_process_full unix_cmd ssh_env diff --git a/tezt/lib/test.ml b/tezt/lib/test.ml index 533a07e383fa..4da428dd3b29 100644 --- a/tezt/lib/test.ml +++ b/tezt/lib/test.ml @@ -43,7 +43,7 @@ let sigint = fun () -> if !received_sigint then unit else - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in Sys.(set_signal sigint) (Signal_handle (fun _ -> @@ -163,11 +163,10 @@ let really_run test = | None -> test.result <- Some new_result | Some old_result -> ( match (old_result, new_result) with - | (Successful, _) | (Failed _, Aborted) -> - test.result <- Some new_result - | (Failed _, (Successful | Failed _)) | (Aborted, _) -> ()) + | Successful, _ | Failed _, Aborted -> test.result <- Some new_result + | Failed _, (Successful | Failed _) | Aborted, _ -> ()) in - let (fail_promise, fail_awakener) = Lwt.task () in + let fail_promise, fail_awakener = Lwt.task () in (* Ensure that errors raised from background promises are logged and cause the test to fail immediately. *) let already_woke_up_fail_promise = ref false in @@ -233,7 +232,7 @@ let really_run test = Lwt.catch (fun () -> Lwt.pick - (run_test () :: handle_sigint () :: fail_promise :: global_timeout + ((run_test () :: handle_sigint () :: fail_promise :: global_timeout) @ test_timeout)) handle_exception in @@ -372,7 +371,7 @@ let list_tests format = (file, title, String.concat ", " tags) in (* Compute the size of each column. *) - let (file_size, title_size, tags_size) = + let file_size, title_size, tags_size = List.fold_left (fun (max_file, max_title, max_tags) (file, title, tags) -> ( max max_file (String.length file), @@ -580,14 +579,14 @@ let knapsack (type a) bag_count (items : (int64 * a) list) : let best_index = ref 0 in let best_weight = ref Int64.max_int in for i = 0 to bag_count - 1 do - let (bag_weight, _) = bags.(i) in + let bag_weight, _ = bags.(i) in if bag_weight < !best_weight then ( best_index := i ; best_weight := bag_weight) done ; !best_index in - let (bag_weight, bag_items) = bags.(smallest_bag) in + let bag_weight, bag_items = bags.(smallest_bag) in bags.(smallest_bag) <- (Int64.add bag_weight item_weight, item :: bag_items) in let longest_first (a, _) (b, _) = Int64.compare b a in @@ -619,7 +618,7 @@ let select_job () = (* [Cli] ensures that [1 <= job_index <= job_count], and [split_tests_into_balanced_jobs] ensures that its result has length [job_count] if [job_count >= 1]. *) - let (_, job_tests) = jobs.(job_index - 1) in + let _, job_tests = jobs.(job_index - 1) in (* Reset the list of tests to run to re-fill it with the requested job. *) registered := String_map.empty ; List.iter @@ -688,7 +687,7 @@ let output_junit filename = output_char ch '\n') x in - let (count, fail_count, skipped_count, total_time) = + let count, fail_count, skipped_count, total_time = fold_registered (0, 0, 0, 0.) @@ fun (count, fail_count, skipped_count, total_time) test -> ( count + 1, @@ -887,8 +886,8 @@ end = struct let spawn_worker () = let worker_id = !next_worker_id in incr next_worker_id ; - let (pipe_to_worker_exit, pipe_to_worker_entrance) = Unix.pipe () in - let (pipe_from_worker_exit, pipe_from_worker_entrance) = Unix.pipe () in + let pipe_to_worker_exit, pipe_to_worker_entrance = Unix.pipe () in + let pipe_from_worker_exit, pipe_from_worker_entrance = Unix.pipe () in let pid = Lwt_unix.fork () in if pid = 0 then ( (* This is now a worker process. *) @@ -978,7 +977,7 @@ end = struct So if there is no working worker, we can stop the loop. *) () | _ :: _ -> - let (ready, _, _) = + let ready, _, _ = (* In case of SIGINT, this returns EINTR. *) try Unix.select file_descriptors_to_read [] [] (-1.) with Unix.Unix_error (EINTR, _, _) -> ([], [], []) @@ -1071,12 +1070,12 @@ let run () = skip_test () ; (* Actually run the tests (or list them). *) match (Cli.options.list, Cli.options.suggest_jobs) with - | (Some format, false) -> list_tests format - | (None, true) -> suggest_jobs () - | (Some _, true) -> + | Some format, false -> list_tests format + | None, true -> suggest_jobs () + | Some _, true -> prerr_endline "Cannot use both --list and --suggest-jobs at the same time." - | (None, false) -> + | None, false -> let test_count = String_map.cardinal !registered in let failure_count = ref 0 in let test_queue = Queue.create () in diff --git a/tezt/lib_performance_regression/grafana.ml b/tezt/lib_performance_regression/grafana.ml index ffb1fa08446c..0aad67d7b369 100644 --- a/tezt/lib_performance_regression/grafana.ml +++ b/tezt/lib_performance_regression/grafana.ml @@ -267,7 +267,7 @@ let update_dashboard config dashboard = body = None; } in - let* (response, body) = http_call delete_request config in + let* response, body = http_call delete_request config in match response.status with | #Cohttp.Code.success_status | `Not_found -> Cohttp_lwt.Body.drain_body body @@ -283,11 +283,11 @@ let update_dashboard config dashboard = meth = `POST; headers = Cohttp.Header.of_list - @@ ("Content-Type", "application/json") :: authorization; + @@ (("Content-Type", "application/json") :: authorization); body = Option.some @@ Cohttp_lwt.Body.of_string body; } in - let* (response, body) = http_call create_request config in + let* response, body = http_call create_request config in match response.status with | #Cohttp.Code.success_status -> Cohttp_lwt.Body.drain_body body | status -> handle_http_error status body create_request diff --git a/tezt/lib_performance_regression/influxDB.ml b/tezt/lib_performance_regression/influxDB.ml index d7a182cbab81..90bd921d08ba 100644 --- a/tezt/lib_performance_regression/influxDB.ml +++ b/tezt/lib_performance_regression/influxDB.ml @@ -130,7 +130,7 @@ let make_url (V1_8 {url; database; credentials; _}) path = in Uri.with_path url path in - Uri.add_query_params' url @@ ("db", database) :: creds_as_uri_params + Uri.add_query_params' url @@ (("db", database) :: creds_as_uri_params) (* https://docs.influxdata.com/influxdb/v1.8/write_protocols/line_protocol_reference *) module Line_protocol = struct @@ -188,7 +188,7 @@ module Line_protocol = struct { measurement; tags; - first_field = (first_field_key, first_field_value); + first_field = first_field_key, first_field_value; other_fields; timestamp; } = @@ -252,7 +252,7 @@ let write (V1_8 cfg as config) data_points = ( with_buffer 256 @@ fun buffer -> Line_protocol.write_data_points buffer data_points ) in - let* (response, body) = + let* response, body = with_timeout config @@ Cohttp_lwt_unix.Client.call ~body `POST (make_url config "write") in @@ -618,7 +618,7 @@ let raw_query config select = let select = prefix_measurement config select in let query = show_select select in let url = Uri.add_query_param' (make_url config "query") ("q", query) in - let* (response, body) = + let* response, body = with_timeout config @@ Cohttp_lwt_unix.Client.call `GET url in let* body = Cohttp_lwt.Body.to_string body in @@ -660,7 +660,7 @@ let query config select = with Not_supported -> None in match (select.from, supported_aggregate_functions) with - | (Select sub_query, Some functions) -> + | Select sub_query, Some functions -> let* sub_query_results = raw_query config sub_query in let aggregate (results : result_data_point list) : result_data_point = let get_field field = List.map (get field JSON.as_float) results in diff --git a/tezt/lib_performance_regression/long_test.ml b/tezt/lib_performance_regression/long_test.ml index fccd847feaf1..bab28a87405b 100644 --- a/tezt/lib_performance_regression/long_test.ml +++ b/tezt/lib_performance_regression/long_test.ml @@ -316,7 +316,7 @@ module Slack = struct in let body = `O [("text", `String message)] in let send () = - let* (response, body) = http_post_json ~timeout webhook_url body in + let* response, body = http_post_json ~timeout webhook_url body in match response.status with | #Cohttp.Code.success_status -> Cohttp_lwt.Body.drain_body body | status -> @@ -466,8 +466,8 @@ let add_data_point data_point = let send_data_points () = match (!current_test, !config.influxdb) with - | (None, _) | (_, None) -> unit - | (Some test, Some config) -> + | None, _ | _, None -> unit + | Some test, Some config -> let write () = let data_points = test.data_points |> String_map.bindings |> List.map snd @@ -591,7 +591,7 @@ module Stats = struct | Float func -> [(InfluxDB.column_name_of_func func, string_of_float values)] | Pair (a, b) -> - let (v, w) = values in + let v, w = values in gather a v @ gather b w | Convert (stats, encode, _) -> gather stats (encode values) in @@ -648,7 +648,7 @@ let get_previous_stats ?limit ?(minimum_count = 3) ?(tags = []) measurement | [] -> None | _ :: _ :: _ -> failwith "InfluxDB result contains multiple series" | [[]] -> failwith "InfluxDB result contains no values" - | [(_ :: _ :: _)] -> failwith "InfluxDB result contains multiple values" + | [_ :: _ :: _] -> failwith "InfluxDB result contains multiple values" | [[value]] -> let ((count, _) as stats) = Stats.get value stats in if count < minimum_count then None else Some stats diff --git a/tezt/lib_tezos/account.ml b/tezt/lib_tezos/account.ml index b15bc808155d..85cebfeb6157 100644 --- a/tezt/lib_tezos/account.ml +++ b/tezt/lib_tezos/account.ml @@ -137,7 +137,7 @@ let parse_client_output_public_keys ~client_output = (public_key_hash, public_key) let parse_client_output ~alias ~client_output = - let (public_key_hash, public_key) = + let public_key_hash, public_key = parse_client_output_public_keys ~client_output in let secret_key = @@ -153,7 +153,7 @@ let parse_client_output ~alias ~client_output = {alias; public_key_hash; public_key; secret_key} let parse_client_output_aggregate ~alias ~client_output = - let (aggregate_public_key_hash, aggregate_public_key) = + let aggregate_public_key_hash, aggregate_public_key = parse_client_output_public_keys ~client_output in let aggregate_secret_key = diff --git a/tezt/lib_tezos/accuser.ml b/tezt/lib_tezos/accuser.ml index 886281efa610..77672a59a356 100644 --- a/tezt/lib_tezos/accuser.ml +++ b/tezt/lib_tezos/accuser.ml @@ -112,7 +112,7 @@ let wait_for_ready accuser = match accuser.status with | Running {session_state = {ready = true; _}; _} -> unit | Not_running | Running {session_state = {ready = false; _}; _} -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in accuser.persistent_state.pending_ready <- resolver :: accuser.persistent_state.pending_ready ; check_event accuser "Accuser started." promise diff --git a/tezt/lib_tezos/baker.ml b/tezt/lib_tezos/baker.ml index 5d2b770cfcbd..b2d3be242be3 100644 --- a/tezt/lib_tezos/baker.ml +++ b/tezt/lib_tezos/baker.ml @@ -116,7 +116,7 @@ let wait_for_ready baker = match baker.status with | Running {session_state = {ready = true; _}; _} -> unit | Not_running | Running {session_state = {ready = false; _}; _} -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in baker.persistent_state.pending_ready <- resolver :: baker.persistent_state.pending_ready ; check_event baker "Baker started." promise diff --git a/tezt/lib_tezos/client.ml b/tezt/lib_tezos/client.ml index a99e1d201657..dafd4d1b18d9 100644 --- a/tezt/lib_tezos/client.ml +++ b/tezt/lib_tezos/client.ml @@ -138,7 +138,7 @@ let mode_to_endpoint = function that contains a list of endpoints. *) let endpoint_arg ?(endpoint : endpoint option) client = - let either o1 o2 = match (o1, o2) with (Some _, _) -> o1 | _ -> o2 in + let either o1 o2 = match (o1, o2) with Some _, _ -> o1 | _ -> o2 in (* pass [?endpoint] first: it has precedence over client.mode *) match either endpoint (mode_to_endpoint client.mode) with | None -> [] @@ -190,7 +190,7 @@ let url_encode str = Buffer.add_char buffer c | c -> Buffer.add_char buffer '%' ; - let (c1, c2) = Hex.of_char c in + let c1, c2 = Hex.of_char c in Buffer.add_char buffer c1 ; Buffer.add_char buffer c2 done ; @@ -618,7 +618,7 @@ let spawn_gen_keys ?alias client = (spawn_command client ["gen"; "keys"; alias], alias) let gen_keys ?alias client = - let (p, alias) = spawn_gen_keys ?alias client in + let p, alias = spawn_gen_keys ?alias client in let* () = Process.check p in return alias @@ -650,7 +650,7 @@ let spawn_bls_gen_keys ?hooks ?(force = false) ?alias client = alias ) let bls_gen_keys ?hooks ?force ?alias client = - let (p, alias) = spawn_bls_gen_keys ?hooks ?force ?alias client in + let p, alias = spawn_bls_gen_keys ?hooks ?force ?alias client in let* () = Process.check p in return alias @@ -1772,7 +1772,7 @@ let init_with_node ?path ?admin_path ?name ?color ?base_dir ?event_level Account.write keys ~base_dir:client.base_dir ; return (node, client) | `Light -> - let* (client, node1, _) = + let* client, node1, _ = init_light ?path ?admin_path ?name ?color ?base_dir ~nodes_args () in return (node1, client) @@ -1781,7 +1781,7 @@ let init_with_protocol ?path ?admin_path ?name ?color ?base_dir ?event_level ?event_sections_levels ?nodes_args ?additional_bootstrap_account_count ?default_accounts_balance ?parameter_file ?timestamp ?keys tag ~protocol () = - let* (node, client) = + let* node, client = init_with_node ?path ?admin_path diff --git a/tezt/lib_tezos/cluster.ml b/tezt/lib_tezos/cluster.ml index 0da498e9ca7d..0766b862d713 100644 --- a/tezt/lib_tezos/cluster.ml +++ b/tezt/lib_tezos/cluster.ml @@ -76,7 +76,7 @@ let star = meta_star symmetric_add_peer let wait_for_connections node connections = let counter = ref 0 in - let (waiter, resolver) = Lwt.task () in + let waiter, resolver = Lwt.task () in Node.on_event node (fun {name; value} -> if name = "node_chain_validator.v0" then match JSON.(value |=> 1 |-> "event" |-> "kind" |> as_string_opt) with diff --git a/tezt/lib_tezos/daemon.ml b/tezt/lib_tezos/daemon.ml index ea1dd544ea31..b52ba09c44f4 100644 --- a/tezt/lib_tezos/daemon.ml +++ b/tezt/lib_tezos/daemon.ml @@ -332,7 +332,7 @@ module Make (X : PARAMETERS) = struct unit let wait_for_full ?where daemon name filter = - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in let current_events = String_map.find_opt name daemon.one_shot_event_handlers |> Option.value ~default:[] @@ -389,8 +389,8 @@ module Make (X : PARAMETERS) = struct let* perf = Process.program_path "perf" in let* heaptrack_print = Process.program_path "heaptrack_print" in match (perf, heaptrack_print) with - | (None, _) | (_, None) -> cannot_observe - | (Some perf, Some heaptrack_print) -> ( + | None, _ | _, None -> cannot_observe + | Some perf, Some heaptrack_print -> ( try let pid = Process.pid process |> string_of_int in let get_trace = diff --git a/tezt/lib_tezos/node.ml b/tezt/lib_tezos/node.ml index 812b4e813115..d85db3cba0fa 100644 --- a/tezt/lib_tezos/node.ml +++ b/tezt/lib_tezos/node.ml @@ -176,11 +176,8 @@ let spawn_config_init node arguments = in spawn_command node - ("config" - :: - "init" - :: - "--data-dir" :: node.persistent_state.data_dir :: make_arguments arguments) + ("config" :: "init" :: "--data-dir" :: node.persistent_state.data_dir + :: make_arguments arguments) let config_init node arguments = spawn_config_init node arguments |> Process.check @@ -367,7 +364,7 @@ let wait_for_ready node = match node.status with | Running {session_state = {ready = true; _}; _} -> unit | Not_running | Running {session_state = {ready = false; _}; _} -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in node.persistent_state.pending_ready <- resolver :: node.persistent_state.pending_ready ; check_event node "node_is_ready.v0" promise @@ -378,7 +375,7 @@ let wait_for_level node level = when current_level >= level -> return current_level | Not_running | Running _ -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in node.persistent_state.pending_level <- (level, resolver) :: node.persistent_state.pending_level ; check_event @@ -397,7 +394,7 @@ let wait_for_identity node = | Running {session_state = {identity = Known identity; _}; _} -> return identity | Not_running | Running _ -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in node.persistent_state.pending_identity <- resolver :: node.persistent_state.pending_identity ; check_event node "read_identity.v0" promise @@ -504,7 +501,7 @@ let get_peers node = line arguments needed to spawn a [command] like [run] or [replay] for the given [node] and extra [arguments]. *) let runlike_command_arguments node command arguments = - let (net_addr, rpc_addr) = + let net_addr, rpc_addr = match node.persistent_state.runner with | None -> ("127.0.0.1:", node.persistent_state.rpc_host ^ ":") | Some _ -> @@ -519,18 +516,11 @@ let runlike_command_arguments node command arguments = | None -> command_args | Some port -> "--advertised-net-port" :: string_of_int port :: command_args in - command - :: - "--data-dir" - :: - node.persistent_state.data_dir - :: - "--net-addr" - :: - (net_addr ^ string_of_int node.persistent_state.net_port) - :: - "--rpc-addr" - :: (rpc_addr ^ string_of_int node.persistent_state.rpc_port) :: command_args + command :: "--data-dir" :: node.persistent_state.data_dir :: "--net-addr" + :: (net_addr ^ string_of_int node.persistent_state.net_port) + :: "--rpc-addr" + :: (rpc_addr ^ string_of_int node.persistent_state.rpc_port) + :: command_args let do_runlike_command ?(on_terminate = fun _ -> ()) ?event_level ?event_sections_levels node arguments = diff --git a/tezt/lib_tezos/protocol.ml b/tezt/lib_tezos/protocol.ml index 676ea06a9292..e6f0df14aa9d 100644 --- a/tezt/lib_tezos/protocol.ml +++ b/tezt/lib_tezos/protocol.ml @@ -179,20 +179,20 @@ let add_to_test_parameters protocol title tags = let register_test ~__FILE__ ~title ~tags ?supports body protocols = iter_on_supported_protocols ~title ~protocols ?supports @@ fun protocol -> - let (title, tags) = add_to_test_parameters protocol title tags in + let title, tags = add_to_test_parameters protocol title tags in Test.register ~__FILE__ ~title ~tags (fun () -> body protocol) let register_long_test ~__FILE__ ~title ~tags ?supports ?team ~executors ~timeout body protocols = iter_on_supported_protocols ~title ~protocols ?supports @@ fun protocol -> - let (title, tags) = add_to_test_parameters protocol title tags in + let title, tags = add_to_test_parameters protocol title tags in Long_test.register ~__FILE__ ~title ~tags ?team ~executors ~timeout (fun () -> body protocol) let register_regression_test ~__FILE__ ~title ~tags ?supports ~output_file body protocols = iter_on_supported_protocols ~title ~protocols ?supports @@ fun protocol -> - let (title, tags) = add_to_test_parameters protocol title tags in + let title, tags = add_to_test_parameters protocol title tags in Regression.register ~__FILE__ ~title diff --git a/tezt/lib_tezos/proxy_server.ml b/tezt/lib_tezos/proxy_server.ml index 44b9f8e29587..facd109fb70a 100644 --- a/tezt/lib_tezos/proxy_server.ml +++ b/tezt/lib_tezos/proxy_server.ml @@ -101,7 +101,7 @@ let create ?runner ?name ?rpc_port ?(args = []) node = args |> List.concat in - let (arguments, rpc_port) = + let arguments, rpc_port = connection_arguments_and_port ?rpc_port node |> fun (args, rpc_port) -> (args @ user_arguments, rpc_port) in @@ -141,7 +141,7 @@ let wait_for_ready t = match t.status with | Running {session_state = {ready = true}; _} -> unit | Not_running | Running {session_state = {ready = false}; _} -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in t.persistent_state.pending_ready <- resolver :: t.persistent_state.pending_ready ; check_event t "starting_proxy_rpc_server.v0" promise diff --git a/tezt/lib_tezos/sc_rollup_client.ml b/tezt/lib_tezos/sc_rollup_client.ml index 2dac9bf60929..3c224ed9eacc 100644 --- a/tezt/lib_tezos/sc_rollup_client.ml +++ b/tezt/lib_tezos/sc_rollup_client.ml @@ -59,7 +59,7 @@ let commitment_from_json json = } let commitment_with_hash_from_json json = - let (hash, commitment_json) = + let hash, commitment_json = (JSON.get "hash" json, JSON.get "commitment" json) in Option.map @@ -160,8 +160,8 @@ let parse_list_keys output = |> List.fold_left (fun acc k -> match (k, acc) with - | (None, _) | (_, None) -> None - | (Some k, Some acc) -> Some (k :: acc)) + | None, _ | _, None -> None + | Some k, Some acc -> Some (k :: acc)) (Some []) |> function | None -> diff --git a/tezt/lib_tezos/sc_rollup_node.ml b/tezt/lib_tezos/sc_rollup_node.ml index f3307b647ad5..b56c759af77c 100644 --- a/tezt/lib_tezos/sc_rollup_node.ml +++ b/tezt/lib_tezos/sc_rollup_node.ml @@ -149,7 +149,7 @@ let wait_for_ready sc_node = match sc_node.status with | Running {session_state = {ready = true; _}; _} -> unit | Not_running | Running {session_state = {ready = false; _}; _} -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in sc_node.persistent_state.pending_ready <- resolver :: sc_node.persistent_state.pending_ready ; check_event sc_node "sc_rollup_node_is_ready.v0" promise @@ -179,7 +179,7 @@ let wait_for_level sc_node level = when current_level >= level -> return current_level | Not_running | Running _ -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in sc_node.persistent_state.pending_level <- (level, resolver) :: sc_node.persistent_state.pending_level ; check_event diff --git a/tezt/lib_tezos/signer.ml b/tezt/lib_tezos/signer.ml index 4718960db023..bc0358499c6a 100644 --- a/tezt/lib_tezos/signer.ml +++ b/tezt/lib_tezos/signer.ml @@ -155,7 +155,7 @@ let wait_for_ready signer = match signer.status with | Running {session_state = {ready = true; _}; _} -> unit | Not_running | Running {session_state = {ready = false; _}; _} -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in signer.persistent_state.pending_ready <- resolver :: signer.persistent_state.pending_ready ; check_event signer "Signer started." promise diff --git a/tezt/lib_tezos/tez.ml b/tezt/lib_tezos/tez.ml index 4d22e76b99fb..9d4de7c32182 100644 --- a/tezt/lib_tezos/tez.ml +++ b/tezt/lib_tezos/tez.ml @@ -38,7 +38,7 @@ let mutez_int64 t = t let to_string amount = let mult_int = 1_000_000L in let rec left amount = - let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in + let d, r = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in if d > 0L then Format.asprintf "%s%03Ld" (left d) r else Format.asprintf "%Ld" r in @@ -48,11 +48,11 @@ let to_string amount = else if v mod 100 > 0 then Format.asprintf "%02d" (v / 10) else Format.asprintf "%d" (v / 100) in - let (hi, lo) = (amount / 1000, amount mod 1000) in + let hi, lo = (amount / 1000, amount mod 1000) in if lo = 0 then Format.asprintf "%s" (triplet hi) else Format.asprintf "%03d%s" hi (triplet lo) in - let (ints, decs) = + let ints, decs = (Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int))) in if decs > 0 then Format.asprintf "%s.%s" (left ints) (right decs) @@ -72,7 +72,7 @@ let parse_floating tez_string = let parse_int s = match int_of_string_opt s with None -> fail () | Some i -> i in - let (integral, decimal) = + let integral, decimal = match tez_string =~** re with None -> fail () | Some (i, d) -> (i, d) in let integral = parse_int integral in diff --git a/tezt/lib_tezos/tezos_regression.ml b/tezt/lib_tezos/tezos_regression.ml index 4cd78546a745..a2e9057ca0c4 100644 --- a/tezt/lib_tezos/tezos_regression.ml +++ b/tezt/lib_tezos/tezos_regression.ml @@ -58,7 +58,7 @@ let hooks = in let on_spawn command arguments = (* Remove arguments that shouldn't be captured in regression output. *) - let (arguments, _) = + let arguments, _ = List.fold_left (fun (acc, scrub_next) arg -> if scrub_next then (acc, false) diff --git a/tezt/lib_tezos/tx_rollup_node.ml b/tezt/lib_tezos/tx_rollup_node.ml index 4da30610948c..0573c4522bf2 100644 --- a/tezt/lib_tezos/tx_rollup_node.ml +++ b/tezt/lib_tezos/tx_rollup_node.ml @@ -170,7 +170,7 @@ let wait_for_ready node = match node.status with | Running {session_state = {ready = true; _}; _} -> unit | Not_running | Running {session_state = {ready = false; _}; _} -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in node.persistent_state.pending_ready <- resolver :: node.persistent_state.pending_ready ; check_event node "tx_rollup_node_is_ready.v0" promise @@ -186,7 +186,7 @@ let wait_for_tezos_level node level = when current_level >= level -> return current_level | Not_running | Running _ -> - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in node.persistent_state.pending_level <- (level, resolver) :: node.persistent_state.pending_level ; check_event @@ -196,7 +196,7 @@ let wait_for_tezos_level node level = promise let wait_for_full ?where node name filter = - let (promise, resolver) = Lwt.task () in + let promise, resolver = Lwt.task () in let current_events = String_map.find_opt name node.one_shot_event_handlers |> Option.value ~default:[] diff --git a/tezt/long_tests/block_validation.ml b/tezt/long_tests/block_validation.ml index 139d363eabaf..1cfdb610d337 100644 --- a/tezt/long_tests/block_validation.ml +++ b/tezt/long_tests/block_validation.ml @@ -246,7 +246,7 @@ module Node = struct command to start the validation of the given [blocks] on the given [node]. It then waits for the [node] to stop properly. *) let replay_and_wait_for_termination blocks node = - let (callback, resolver) = Lwt.wait () in + let callback, resolver = Lwt.wait () in let on_terminate status = match Process.validate_status status with | Ok () -> Lwt.wakeup_later resolver () diff --git a/tezt/long_tests/prt_client.ml b/tezt/long_tests/prt_client.ml index 123b0323feca..dcbeab686fe5 100644 --- a/tezt/long_tests/prt_client.ml +++ b/tezt/long_tests/prt_client.ml @@ -70,7 +70,7 @@ let get_blocks_response_time ~executors () = ~timeout:(Seconds 20) ~executors @@ fun () -> - let* (_node, client) = Client.init_with_protocol `Client ~protocol:Alpha () in + let* _node, client = Client.init_with_protocol `Client ~protocol:Alpha () in Long_test.time_lwt response_time_measurement @@ fun () -> let* _ = RPC.get_block client in unit diff --git a/tezt/long_tests/qcheck_rpc.ml b/tezt/long_tests/qcheck_rpc.ml index 40ae7d6f9a60..e7f094c94004 100644 --- a/tezt/long_tests/qcheck_rpc.ml +++ b/tezt/long_tests/qcheck_rpc.ml @@ -28,7 +28,7 @@ Component: Node Invocation: dune exec tezt/long_tests/main.exe -- --file qcheck_rpc.ml Subject: Property testing the RPC server - *) +*) (* {0 Description} @@ -63,7 +63,7 @@ let protocol = Protocol.Alpha Note: this is not exhaustive; it includes the inputs that are easy to generate (e.g., excluding a ["sapling_state_id"]) - *) +*) type path_input = | Chain_ID | Block_hash @@ -287,7 +287,7 @@ module RPC_Index = struct let proto_url = url_prefix ^ "chains/main/blocks/head?recurse=yes" in let mempool_url = url_prefix ^ "chains/main/mempool?recurse=yes" in let urls = [shell_url; proto_url; mempool_url] in - let* (envs, endpts) = Lwt.(get_endpoints port urls >|= List.split) in + let* envs, endpts = Lwt.(get_endpoints port urls >|= List.split) in let env = Convert.merge_env_list envs in return @@ parse_endpoints env endpts end @@ -340,9 +340,9 @@ module Gen = struct let rec take n xs : 'a list = match (n, xs) with - | (0, _) -> [] - | (_, []) -> [] - | (n, y :: ys) -> y :: take (n - 1) ys + | 0, _ -> [] + | _, [] -> [] + | n, y :: ys -> y :: take (n - 1) ys let pick_some_elems xs : 'a list t = let open QCheck.Gen in @@ -497,7 +497,7 @@ module Test = struct (* Log description of RPC *) let () = Log.info "%s\n\n" rpc_description.description in (* Start node and client *) - let* (node, client) = Client.init_with_protocol `Client ~protocol () in + let* node, client = Client.init_with_protocol `Client ~protocol () in (* Generate and test instances *) let* () = rpc_description |> Gen.instance_gen diff --git a/tezt/long_tests/script_cache.ml b/tezt/long_tests/script_cache.ml index 9f94de9e44c6..fed93ad761c9 100644 --- a/tezt/long_tests/script_cache.ml +++ b/tezt/long_tests/script_cache.ml @@ -33,7 +33,6 @@ fast machine. This is why this test is in the "long test" category. If at some point the cache layout can be set through protocol parameters, then we may consider duplicating these tests in the CI too. - *) (* @@ -288,7 +287,7 @@ let check ?(tags = []) label test ~protocol ~executors = *) let check_contract_cache_lowers_gas_consumption ~protocol = check "contract cache lowers gas consumption" ~protocol @@ fun () -> - let* (_, client) = init1 ~protocol in + let* _, client = init1 ~protocol in let* contract_id = originate_str_id_contract client "" in let* gas1 = call_contract contract_id "Left 1" client in let* gas2 = call_contract contract_id "Left 1" client in @@ -312,7 +311,7 @@ let check_contract_cache_lowers_gas_consumption ~protocol = let check_full_cache ~protocol = check "contract cache does not go beyond its size limit" ~protocol @@ fun () -> - let* (_, client) = init1 ~protocol in + let* _, client = init1 ~protocol in let s = String.make 1024 'x' in let* counter = get_counter client in @@ -358,7 +357,7 @@ let check_full_cache ~protocol = let check_block_impact_on_cache ~protocol = check "one cannot violate the cache size limit" ~protocol ~tags:["memory"] @@ fun () -> - let* (node, client) = init1 ~protocol in + let* node, client = init1 ~protocol in let* (Node.Observe memory_consumption) = Node.memory_consumption node in @@ -385,7 +384,7 @@ let check_block_impact_on_cache ~protocol = let* gas = call_contracts (str_id_calls red_contracts) client in let* cached_contracts = get_cached_contracts client in - let (greens, reds) = + let greens, reds = List.partition (fun c -> List.mem c green_contracts) cached_contracts in if List.(exists (fun c -> mem c green_contracts) cached_contracts) then ( @@ -518,7 +517,7 @@ let check_cache_backtracking_during_chain_reorganization ~protocol = *) let check_reloading_efficiency ~protocol body = - let* (nodeA, clientA) = init1 ~protocol in + let* nodeA, clientA = init1 ~protocol in let* _ = body clientA in let* () = Client.bake_for clientA in Log.info "Contracts are in the cache" ; @@ -618,7 +617,7 @@ let check_simulation_takes_cache_into_account ~protocol = ~tags:["simulation"] ~protocol @@ fun () -> - let* (_, client) = init1 ~protocol in + let* _, client = init1 ~protocol in let* chain_id = RPC.get_chain_id client in let* contract_id = originate_very_small_contract client in let* () = Client.bake_for client in diff --git a/tezt/manual_tests/migration_voting.ml b/tezt/manual_tests/migration_voting.ml index c7196719a20f..0fcdfcca8a92 100644 --- a/tezt/manual_tests/migration_voting.ml +++ b/tezt/manual_tests/migration_voting.ml @@ -288,7 +288,7 @@ let migration ?yes_node_path ?yes_wallet context protocol levels_till_migration ~tags: ["node"; "activate"; "user_activated"; "protocol"; "migration"; "voting"] @@ fun from_protocol -> - let* (node, client, level) = + let* node, client, level = prepare_migration ?yes_node_path ?yes_wallet diff --git a/tezt/snoop/perform_benchmarks.ml b/tezt/snoop/perform_benchmarks.ml index 94daebe0e298..70213d68d694 100644 --- a/tezt/snoop/perform_benchmarks.ml +++ b/tezt/snoop/perform_benchmarks.ml @@ -133,10 +133,8 @@ let perform_benchmarks (patches : patch_rule list) snoop benchmarks = save_to ; return ()) else - let* (bench_num, nsamples, config) = - let* (patch, override) = - patch_benchmark_config ~patches ~bench_name - in + let* bench_num, nsamples, config = + let* patch, override = patch_benchmark_config ~patches ~bench_name in let* config = match patch with | No_patch -> return None diff --git a/tezt/snoop/prepare_data.ml b/tezt/snoop/prepare_data.ml index 7d2ee569b3a7..7f920a3029aa 100644 --- a/tezt/snoop/prepare_data.ml +++ b/tezt/snoop/prepare_data.ml @@ -153,7 +153,7 @@ let concat snoop protocol tmp_files target = and concat the results *) let prepare_michelson kind snoop cfg protocol = - let (target, terms_count) = + let target, terms_count = match kind with | Snoop.Code -> ( Files.(working_dir // michelson_data_dir // michelson_code_file), diff --git a/tezt/tests/RPC_test.ml b/tezt/tests/RPC_test.ml index 2badc7cc0c1f..f8b44e992a97 100644 --- a/tezt/tests/RPC_test.ml +++ b/tezt/tests/RPC_test.ml @@ -37,7 +37,7 @@ Subject: RPC regression tests capture the output of RPC calls and compare it with the output from the previous run. The test passes only if the outputs match exactly. - *) +*) (* These hooks must be attached to every process that should be captured for regression testing *) @@ -56,7 +56,7 @@ let hooks = Tezos_regression.hooks implicit argument to specify the list of protocols to test. *) let check_rpc ~test_mode_tag ~test_function ?parameter_overrides ?node_parameters sub_group = - let (client_mode_tag, title_tag) = + let client_mode_tag, title_tag = match test_mode_tag with | `Client -> (`Client, "client") | `Client_data_dir_proxy_server -> (`Client, "proxy_server_data_dir") @@ -91,7 +91,7 @@ let check_rpc ~test_mode_tag ~test_function ?parameter_overrides true | `Client | `Light | `Proxy -> false in - let* (node, client) = + let* node, client = Client.init_with_protocol ?parameter_file ?nodes_args:node_parameters @@ -633,9 +633,9 @@ let mempool_node_flags = Synchronisation_threshold 0; (* Node does not need to be synchronized with peers before being bootstrapped *) - Connections 1; + Connections 1 (* Number of connection allowed for each of our 2 nodes used in the - mempool tests *) + mempool tests *); ] let bake_empty_block ?endpoint client = diff --git a/tezt/tests/baker_test.ml b/tezt/tests/baker_test.ml index 586e865a5e6a..8de7b12f8725 100644 --- a/tezt/tests/baker_test.ml +++ b/tezt/tests/baker_test.ml @@ -32,7 +32,7 @@ let baker_test ~title ~tags = Protocol.register_test ~__FILE__ ~title ~tags @@ fun protocol -> - let* (node, client) = + let* node, client = Client.init_with_protocol `Client ~protocol ~timestamp:Now () in let level_2_promise = Node.wait_for_level node 2 in @@ -52,7 +52,7 @@ let baker_stresstest = ~title:"baker stresstest" ~tags:["node"; "baker"; "stresstest"] @@ fun protocol -> - let* (node, client) = + let* node, client = Client.init_with_protocol `Client ~protocol () ~timestamp:Now in let* _ = Baker.init ~protocol node client in diff --git a/tezt/tests/baking.ml b/tezt/tests/baking.ml index 06765e91cd59..f4bd43dedb00 100644 --- a/tezt/tests/baking.ml +++ b/tezt/tests/baking.ml @@ -291,7 +291,7 @@ let mempool_from_list_of_ops client protocol operations = match operations with | [] -> return (List.rev acc) | (account, op) :: tl -> - let* (mempool_op, binary_proto_data) = + let* mempool_op, binary_proto_data = mempool_operation_from_op client protocol account op in let shell_op = @@ -586,7 +586,7 @@ let baking_operation_exception_ithaca = ~tags:["baking"; "exception"] ~supports:Protocol.(Between_protocols (number Ithaca, number Ithaca)) @@ fun protocol -> - let* (node, client) = Client.init_with_protocol `Client ~protocol () in + let* node, client = Client.init_with_protocol `Client ~protocol () in let data_dir = Node.data_dir node in let wait_injection = Node.wait_for_request ~request:`Inject node in let* new_account = Client.gen_and_show_keys client in @@ -656,7 +656,7 @@ let baking_operation_exception = ~tags:["baking"; "exception"] ~supports:Protocol.(From_protocol (number Alpha)) @@ fun protocol -> - let* (node, client) = Client.init_with_protocol `Client ~protocol () in + let* node, client = Client.init_with_protocol `Client ~protocol () in let data_dir = Node.data_dir node in let wait_injection = Node.wait_for_request ~request:`Inject node in let* new_account = Client.gen_and_show_keys client in diff --git a/tezt/tests/big_map_all.ml b/tezt/tests/big_map_all.ml index 1f244644c0ef..3bf805870ebd 100644 --- a/tezt/tests/big_map_all.ml +++ b/tezt/tests/big_map_all.ml @@ -29,8 +29,7 @@ Invocation: dune exec tezt/tests/main.exe -- big_map_all Subject: Check that RPC [/chain/<chain_id>/blocks/<block_id>/context/big_maps] behaves correctly with and without pagination - - *) +*) let init ~protocol = let* node = Node.init [Synchronisation_threshold 0; Connections 0] in @@ -185,7 +184,7 @@ let test_wrapper ~protocol = (Protocol.name protocol)) ~tags:["big_map_all"; "rpc"] @@ fun () -> - let* (_, client) = init ~protocol in + let* _, client = init ~protocol in let entries : (string * int) list = List.map (fun i -> (Format.sprintf "\"%04i\"" i, i)) all_values in diff --git a/tezt/tests/bootstrap.ml b/tezt/tests/bootstrap.ml index 7395889e48bc..eaacd39f65b0 100644 --- a/tezt/tests/bootstrap.ml +++ b/tezt/tests/bootstrap.ml @@ -307,7 +307,7 @@ let check_rpc_force_bootstrapped () = Log.info "Start a node." ; let* node = Node.init [Synchronisation_threshold 255] in let* client = Client.init ~endpoint:(Node node) () in - let (bootstrapped_promise, bootstrapped_resolver) = Lwt.task () in + let bootstrapped_promise, bootstrapped_resolver = Lwt.task () in Node.on_event node (bootstrapped_event bootstrapped_resolver) ; Log.info "Force the node to be bootstrapped." ; let* _ = RPC.force_bootstrapped client in diff --git a/tezt/tests/cache_cache.ml b/tezt/tests/cache_cache.ml index 6d6e5cec1f6f..49be35aeb78c 100644 --- a/tezt/tests/cache_cache.ml +++ b/tezt/tests/cache_cache.ml @@ -55,7 +55,7 @@ let register = ~title:"cache cache" ~tags:["cache"; "node"; "baker"] @@ fun protocol -> - let* (node, client) = Client.init_with_protocol `Client ~protocol () in + let* node, client = Client.init_with_protocol `Client ~protocol () in let data_dir = Node.data_dir node in let wait_injection = Node.wait_for_request ~request:`Inject node in let* contract_hash = diff --git a/tezt/tests/cli_tezos.ml b/tezt/tests/cli_tezos.ml index bfd7ccdab0df..1430066c37ec 100644 --- a/tezt/tests/cli_tezos.ml +++ b/tezt/tests/cli_tezos.ml @@ -64,7 +64,7 @@ let check_connections_above_cap () = ~title:"CLI above connections cap" ~tags:["cli"; "connections"; "bad"] @@ fun () -> - let (has_failed, on_failure) = Lwt.task () in + let has_failed, on_failure = Lwt.task () in let node = Node.create [] in let* _node = Node.run diff --git a/tezt/tests/client_commands.ml b/tezt/tests/client_commands.ml index cf02da671e39..c4648cf573d4 100644 --- a/tezt/tests/client_commands.ml +++ b/tezt/tests/client_commands.ml @@ -51,7 +51,7 @@ end module Simulation = struct let transfer ~arg ?simulation ?force k protocol = - let* (_node, client) = Client.init_with_protocol `Client ~protocol () in + let* _node, client = Client.init_with_protocol `Client ~protocol () in let* contract = Helpers.originate_fail_on_false client in Client.spawn_transfer ~amount:(Tez.of_int 2) diff --git a/tezt/tests/client_config.ml b/tezt/tests/client_config.ml index d15b3bbe5a9c..c4dcdd5d2839 100644 --- a/tezt/tests/client_config.ml +++ b/tezt/tests/client_config.ml @@ -36,7 +36,7 @@ let additional_bootstrap_accounts = ~title:"additional bootstrap accounts" ~tags:["client"; "bootstrap"; "accounts"] @@ fun protocol -> - let* (_node, client) = + let* _node, client = Client.init_with_protocol ~additional_bootstrap_account_count:2 `Client diff --git a/tezt/tests/client_run_view.ml b/tezt/tests/client_run_view.ml index d25f3e9deb74..9750680dd727 100644 --- a/tezt/tests/client_run_view.ml +++ b/tezt/tests/client_run_view.ml @@ -28,7 +28,7 @@ Component: Client Invocation: dune exec tezt/tests/main.exe -- --file client_run_view.ml Subject: Check that run view command to tezos-client behaves correctly - *) +*) let viewable_script = {| @@ -105,7 +105,7 @@ let init_with_contract ?(alias = "viewable_script") ?(prg = viewable_script) Lwt.return (client, contract) let test_run_view_generic ?unlimited_gas ~protocol ~view ~input ~expected () = - let* (client, contract) = init_with_contract ~protocol () in + let* client, contract = init_with_contract ~protocol () in let* view = Client.run_view ?unlimited_gas ~view ~contract ?input client in if String.equal (String.trim view) expected then unit else Test.fail ~__LOC__ "Unexpected view result: %s" view @@ -161,7 +161,7 @@ let check_storage_is contract client expected = contract that implements the desired interface. It could be 'SELF' or another deployed contract, as tested below. *) let test_run_external_nested_view ~protocol () = - let* (client, contract) = + let* client, contract = init_with_contract ~prg:viewable_script ~alias:"contract1" ~protocol () in let* contract' = @@ -220,7 +220,7 @@ let test_run_view_unknown_contract ~protocol () = (* Runs view `unknown` on the viewable_contract and fails *) let test_run_view_unknown_view ~protocol () = - let* (client, contract) = init_with_contract ~protocol () in + let* client, contract = init_with_contract ~protocol () in let failed_command = Client.spawn_run_view ~view:"unknown" ~contract ~input:"10" client in @@ -230,7 +230,7 @@ let test_run_view_unknown_view ~protocol () = (* Runs high consumption view `loop` with 961 as input and default gas limit, and fails because of gas exhaustion. *) let test_run_view_loop_default_limit ~protocol () = - let* (client, contract) = init_with_contract ~protocol () in + let* client, contract = init_with_contract ~protocol () in let failed_command = Client.spawn_run_view ~view:"loop" ~contract ~input:"961" client in diff --git a/tezt/tests/demo_counter.ml b/tezt/tests/demo_counter.ml index eea0a657c341..89ada3511d42 100644 --- a/tezt/tests/demo_counter.ml +++ b/tezt/tests/demo_counter.ml @@ -28,8 +28,7 @@ Component: Protocol demo counter Invocation: dune exec tezt/tests/main.exe -- --file demo_counter.ml Subject: Minimal test for the protocol demo counter - - *) +*) let check_a ?__LOC__ client expected = let* a = Demo_client.get_a client in diff --git a/tezt/tests/deposits_limit.ml b/tezt/tests/deposits_limit.ml index d64e5da14dd9..dd7892c696f1 100644 --- a/tezt/tests/deposits_limit.ml +++ b/tezt/tests/deposits_limit.ml @@ -36,7 +36,7 @@ let test_set_deposits_limit = ~title:"set deposits limit" ~tags:["deposits_limit"] @@ fun protocol -> - let* (_, client) = Client.init_with_protocol ~protocol `Client () in + let* _, client = Client.init_with_protocol ~protocol `Client () in let src = Constant.bootstrap1.alias in let* result = Client.set_deposits_limit ~src ~limit:"1000" client in Regression.capture result ; @@ -49,7 +49,7 @@ let test_unset_deposits_limit = ~title:"unset deposits limit" ~tags:["deposits_limit"] @@ fun protocol -> - let* (_, client) = Client.init_with_protocol ~protocol `Client () in + let* _, client = Client.init_with_protocol ~protocol `Client () in let src = Constant.bootstrap1.alias in let* result = Client.unset_deposits_limit ~src client in Regression.capture result ; diff --git a/tezt/tests/double_bake.ml b/tezt/tests/double_bake.ml index 4b1da1fcc72a..e8bb159acbdd 100644 --- a/tezt/tests/double_bake.ml +++ b/tezt/tests/double_bake.ml @@ -53,7 +53,7 @@ let is_operation_in_applied_mempool mempool oph = "bytes": "..." } } - *) +*) let wait_for_denunciation accuser = let filter json = JSON.(json |-> "hash" |> as_string_opt) in Accuser.wait_for accuser "double_baking_denounced.v0" filter @@ -83,7 +83,7 @@ let wait_for_denunciation accuser = } ] } - *) +*) let wait_for_denunciation_injection node client accuser = let filter json = match JSON.(json |-> "view" |-> "request" |> as_string_opt) with diff --git a/tezt/tests/encoding.ml b/tezt/tests/encoding.ml index a3d08014d4f8..2fbc43fe0342 100644 --- a/tezt/tests/encoding.ml +++ b/tezt/tests/encoding.ml @@ -55,7 +55,7 @@ let check_dump_encodings () = let rec equal_json (a : JSON.u) (b : JSON.u) = match (a, b) with - | (`O object_a, `O object_b) -> + | `O object_a, `O object_b -> let sort_object = List.sort (fun (key_a, _) (key_b, _) -> compare key_a key_b) in @@ -65,11 +65,11 @@ let rec equal_json (a : JSON.u) (b : JSON.u) = key_a = key_b && equal_json val_a val_b) (sort_object object_a) (sort_object object_b) - | (`Bool bool_a, `Bool bool_b) -> bool_a = bool_b - | (`Float float_a, `Float float_b) -> Float.equal float_a float_b - | (`A array_a, `A array_b) -> List.for_all2 equal_json array_a array_b - | (`Null, `Null) -> true - | (`String string_a, `String string_b) -> string_a = string_b + | `Bool bool_a, `Bool bool_b -> bool_a = bool_b + | `Float float_a, `Float float_b -> Float.equal float_a float_b + | `A array_a, `A array_b -> List.for_all2 equal_json array_a array_b + | `Null, `Null -> true + | `String string_a, `String string_b -> string_a = string_b | _ -> false let check_sample ~name ~file = diff --git a/tezt/tests/forge.ml b/tezt/tests/forge.ml index 3641497b961f..9661425447c2 100644 --- a/tezt/tests/forge.ml +++ b/tezt/tests/forge.ml @@ -31,12 +31,12 @@ Note that it can be run with [dune exec tezt/tests/main.exe -- -f forge.ml --commands] to see the commands that are run. - *) +*) let forge = Protocol.register_test ~__FILE__ ~title:"forge" ~tags:["forge"; "transfer"] @@ fun protocol -> - let* (_node, client) = Client.init_with_protocol `Client ~protocol () in + let* _node, client = Client.init_with_protocol `Client ~protocol () in let* (`OpHash _str) = Operation.inject_transfer ~source:Constant.bootstrap1 diff --git a/tezt/tests/global_constants.ml b/tezt/tests/global_constants.ml index 32c4a0530426..f2ce4e4974d2 100644 --- a/tezt/tests/global_constants.ml +++ b/tezt/tests/global_constants.ml @@ -33,7 +33,7 @@ let test_large_flat_contract = ~title:"Originate a large, flat contract" ~tags:["global_constant"] @@ fun protocol -> - let* (_, client) = Client.init_with_protocol ~protocol `Client () in + let* _, client = Client.init_with_protocol ~protocol `Client () in let* _ = Client.originate_contract ~alias:"large_flat_contract" @@ -62,7 +62,7 @@ let test_billion_laughs_contract = ~title:"Global constants billion laughs attack" ~tags:["billion_laughs"; "global_constant"] @@ fun protocol -> - let* (_, client) = Client.init_with_protocol ~protocol `Client () in + let* _, client = Client.init_with_protocol ~protocol `Client () in let repeat_n_times n str start finish = start ^ (List.init n (fun _ -> str) |> String.concat " ") ^ finish in @@ -130,7 +130,7 @@ let test_entrypoint_expansion = ~title:"Global constants are expanded on entrypoints RPC" ~tags:["global_constant"; "rpc"] @@ fun protocol -> - let* (_, client) = Client.init_with_protocol ~protocol `Client () in + let* _, client = Client.init_with_protocol ~protocol `Client () in (* Register the expression *) let* _ = Client.register_global_constant diff --git a/tezt/tests/hash_data.ml b/tezt/tests/hash_data.ml index 2f3f29b1e27a..219f4266ef3c 100644 --- a/tezt/tests/hash_data.ml +++ b/tezt/tests/hash_data.ml @@ -38,7 +38,7 @@ with the output from the previous run. The test passes only if the outputs match exactly. It is important that return values of `hash data` remain constant over time. - *) +*) (* These hooks must be attached to every process that should be captured for regression testing. Not plugged for negative tests, since tezos-client diff --git a/tezt/tests/large_metadata.ml b/tezt/tests/large_metadata.ml index 14f0c9e72018..edd4d2156275 100644 --- a/tezt/tests/large_metadata.ml +++ b/tezt/tests/large_metadata.ml @@ -108,7 +108,7 @@ let check_default_limit_metadata = ~title:"Large metadata with default limit" ~tags:["large_metadata"; "default"] @@ fun protocol -> - let* (contract_id, client, _node) = setup_node ~limit:None protocol in + let* contract_id, client, _node = setup_node ~limit:None protocol in let small_exponent = 23 in (* Call the contract with a small exponent to make sure that the metadata is allowed. As the metadata cap is set to 10_000_000 bytes @@ -158,7 +158,7 @@ let check_limit_metadata = ~title:"Large metadata with a small limit" ~tags:["large_metadata"; "limit"] @@ fun protocol -> - let* (contract_id, client, _node) = + let* contract_id, client, _node = setup_node ~limit:(Some (Node.Metadata_size_limit (Some 10_000))) protocol in let small_exponent = 13 in @@ -209,7 +209,7 @@ let check_unlimited_metadata = ~title:"Large metadata without limit" ~tags:["large_metadata"; "unlimited"] @@ fun protocol -> - let* (contract_id, client, _node) = + let* contract_id, client, _node = setup_node ~limit:(Some (Node.Metadata_size_limit None)) protocol in (* We call the contract with a bigger exponent to exceed the @@ -239,7 +239,7 @@ let check_metadata_force_recompute = ~title:"Force recompute large metadata" ~tags:["large_metadata"; "force"; "recompute"] @@ fun protocol -> - let* (contract_id, client, _node) = + let* contract_id, client, _node = setup_node ~limit:(Some (Node.Metadata_size_limit (Some 10_000))) protocol in let small_exponent = 13 in diff --git a/tezt/tests/light.ml b/tezt/tests/light.ml index 689e8e34ae5f..855408d5cd02 100644 --- a/tezt/tests/light.ml +++ b/tezt/tests/light.ml @@ -29,7 +29,7 @@ Invokation: dune exec tezt/tests/main.exe -- --file light.ml Subject: Tests of the client's --mode light option Dependencies: tezt/tests/proxy.ml - *) +*) let init_light ~protocol = let get_current_level = @@ -41,7 +41,7 @@ let init_light ~protocol = because it uses RPC.*.get_current_level, which depends on client.ml already. In other words, putting this code in client.ml would create a cyclic dependency *) - let* (client, node0, node1) = Client.init_light () in + let* client, node0, node1 = Client.init_light () in Log.info "Activating protocol %s" @@ Protocol.tag protocol ; let endpoint = Client.(Node node0) in let* () = Client.activate_protocol ~endpoint ~protocol client in @@ -138,7 +138,7 @@ let test_transfer = ~title:"(Light) transfer" ~tags:["light"; "client"; "transfer"] @@ fun protocol -> - let* (_, client) = init_light ~protocol in + let* _, client = init_light ~protocol in do_transfer client let test_bake = @@ -147,7 +147,7 @@ let test_bake = ~title:"(Light) bake" ~tags:["light"; "client"; "bake"] @@ fun protocol -> - let* (_, client) = init_light ~protocol in + let* _, client = init_light ~protocol in let giver = Constant.bootstrap1.alias in let* () = do_transfer ~giver client in Client.bake_for_and_wait ~keys:[giver] client @@ -220,7 +220,7 @@ module NoUselessRpc = struct ~title:"(Light) No useless RPC call" ~tags:["light"; "rpc"; "get"] @@ fun protocol -> - let* (_, client) = init_light ~protocol in + let* _, client = init_light ~protocol in let paths = [ (["helpers"; "baking_rights"], []); @@ -256,7 +256,7 @@ let test_wrong_proto = ~title:"(Light) Wrong proto" ~tags:["light"; "proto"] @@ fun protocol -> - let* (_, client) = init_light ~protocol in + let* _, client = init_light ~protocol in Proxy.wrong_proto protocol client let test_locations = @@ -267,7 +267,7 @@ let test_locations = ~title:"(Light) RPC get's location" ~tags:(locations_tags alt_mode) @@ fun protocol -> - let* (_, client) = init_light ~protocol in + let* _, client = init_light ~protocol in check_locations alt_mode client let test_compare_light = @@ -278,7 +278,7 @@ let test_compare_light = ~title:"(Light) Compare RPC get" ~tags:(compare_tags alt_mode) @@ fun protocol -> - let* (node, light_client) = init_light ~protocol in + let* node, light_client = init_light ~protocol in let* vanilla = Client.init ~endpoint:(Node node) () in let clients = {vanilla; alternative = light_client} in let tz_log = diff --git a/tezt/tests/main.ml b/tezt/tests/main.ml index d72fa15a7c43..a5a676ef87cc 100644 --- a/tezt/tests/main.ml +++ b/tezt/tests/main.ml @@ -30,7 +30,7 @@ Invocation: make test-tezt Subject: This file is the entrypoint of all Tezt tests. It dispatches to other files. - *) +*) let protocols = [Protocol.Alpha; Protocol.Jakarta; Protocol.Ithaca] diff --git a/tezt/tests/manager_operations.ml b/tezt/tests/manager_operations.ml index 8ae8230327ae..7f674aa8fe7a 100644 --- a/tezt/tests/manager_operations.ml +++ b/tezt/tests/manager_operations.ml @@ -99,8 +99,8 @@ module Events = struct json |-> "view" |-> "mempool" |-> "known_valid" |> as_list_opt, json |-> "view" |-> "mempool" |-> "pending" |> as_list_opt ) with - | (Some "notify", Some [], Some []) -> None - | (Some "notify", Some known_valid, Some pending) -> + | Some "notify", Some [], Some [] -> None + | Some "notify", Some known_valid, Some pending -> let known_valid = List.map JSON.as_string known_valid in let pending = List.map JSON.as_string pending in Some (known_valid, pending) @@ -156,8 +156,8 @@ module Operation = struct let inject_transfers = inject_transfers - ~gas_limit: - 1520 (* We make transfers to non allocated contracts in these tests *) + ~gas_limit:1520 + (* We make transfers to non allocated contracts in these tests *) ~async:true ~force:true @@ -570,7 +570,7 @@ module Memchecks = struct Log.info "- Waiting for observer to be notified of operation." ; let* observer_result = wait_observer in Log.info "- Checking observer received operations." ; - let (known_valid, pending) = observer_result in + let known_valid, pending = observer_result in if List.mem oph known_valid then Log.ok " - %s was propagated to observer node as valid." oph else if List.mem oph pending then @@ -1341,8 +1341,8 @@ module Simple_transfers = struct ~dest:Constant.bootstrap3 ~fee:(fee + 1) ~amount:(bal - fee) - ~counter: - (counter + 5) (* Counter too large (aka "in the future"): wrong *) + ~counter:(counter + 5) + (* Counter too large (aka "in the future"): wrong *) nodes.main.client in let* () = @@ -1939,8 +1939,7 @@ module Tx_rollup = struct Operation.inject_transfer_ticket ~protocol ~source:Constant.bootstrap1 - ~gas_limit: - (min_deserialization_gas + 1000) + ~gas_limit:(min_deserialization_gas + 1000) (* we add 1000 (the gas for manager operation) to avoid failing with gas_exhausted right after precheck *) ~contents:(`Json (`O [("bytes", `String (make_zero_hex ~size_kB))])) diff --git a/tezt/tests/mockup.ml b/tezt/tests/mockup.ml index b2f4fede80d9..a574f9b5b584 100644 --- a/tezt/tests/mockup.ml +++ b/tezt/tests/mockup.ml @@ -32,11 +32,11 @@ because most tests of the mockup are written with the python framework for now. It was important, though, to provide the mockup's API in tezt; for other tests that use the mockup. - *) +*) (* Test. Call `tezos-client rpc list` and check that return code is 0. - *) +*) let test_rpc_list = Protocol.register_test ~__FILE__ @@ -49,7 +49,7 @@ let test_rpc_list = (* Test. Call `tezos-client rpc /chains/<chain_id>/blocks/<block_id>/header/shell` and check that return code is 0. - *) +*) let test_rpc_header_shell = Protocol.register_test ~__FILE__ @@ -64,8 +64,8 @@ let transfer_data = (Constant.bootstrap1.alias, Tez.one, Constant.bootstrap2.alias) let test_balances_after_transfer giver amount receiver = - let (giver_balance_before, giver_balance_after) = giver in - let (receiver_balance_before, receiver_balance_after) = receiver in + let giver_balance_before, giver_balance_after = giver in + let receiver_balance_before, receiver_balance_after = receiver in if not Tez.(giver_balance_after < giver_balance_before - amount) then Test.fail "Invalid balance of giver after transfer: %s (before it was %s)" @@ -86,14 +86,14 @@ let test_balances_after_transfer giver amount receiver = (* Test. Transfer some tz and check balance changes are as expected. - *) +*) let test_transfer = Protocol.register_test ~__FILE__ ~title:"(Mockup) Transfer" ~tags:["mockup"; "client"; "transfer"] @@ fun protocol -> - let (giver, amount, receiver) = transfer_data in + let giver, amount, receiver = transfer_data in let* client = Client.init_mockup ~protocol () in let* giver_balance_before = Client.get_balance_for ~account:giver client in let* receiver_balance_before = @@ -121,7 +121,7 @@ let test_calling_contract_with_global_constant_success = ~title:"(Mockup) Calling a contract with a global constant success" ~tags:["mockup"; "client"; "global_constant"] @@ fun protocol -> - let (src, _, _) = transfer_data in + let src, _, _ = transfer_data in let* client = Client.init_mockup ~protocol () in let value = "999" in let burn_cap = Some (Tez.of_int 1) in @@ -157,7 +157,7 @@ let test_register_global_constant_success = ~title:"(Mockup) Register Global Constant success" ~tags:["mockup"; "client"; "global_constant"] @@ fun protocol -> - let (src, _, _) = transfer_data in + let src, _, _ = transfer_data in let* client = Client.init_mockup ~protocol () in let value = "999" in let burn_cap = Some (Tez.of_int 1) in @@ -171,7 +171,7 @@ let test_register_global_constant_failure = ~title:"(Mockup) Register Global Constant failure" ~tags:["mockup"; "client"; "global_constant"] @@ fun protocol -> - let (src, _, _) = transfer_data in + let src, _, _ = transfer_data in let* client = Client.init_mockup ~protocol () in let value = "Pair 1 (constant \"foobar\")" in let burn_cap = Some (Tez.of_int 1) in @@ -189,7 +189,7 @@ let test_originate_contract_with_global_constant_success = ~title:"(Mockup) Originate Contract with Global Constant success" ~tags:["mockup"; "client"; "global_constant"] @@ fun protocol -> - let (src, _, _) = transfer_data in + let src, _, _ = transfer_data in let* client = Client.init_mockup ~protocol () in let value = "999" in let burn_cap = Some (Tez.of_int 1) in @@ -213,7 +213,7 @@ let test_typechecking_and_normalization_work_with_constants = ~title:"(Mockup) Typechecking and normalization work with constants" ~tags:["mockup"; "client"; "global_constant"] @@ fun protocol -> - let (src, _, _) = transfer_data in + let src, _, _ = transfer_data in let* client = Client.init_mockup ~protocol () in (* Register the type *) let value = "unit" in @@ -233,7 +233,7 @@ let test_simple_baking_event = ~title:"(Mockup) Transfer (asynchronous)" ~tags:["mockup"; "client"; "transfer"; "asynchronous"] @@ fun protocol -> - let (giver, amount, receiver) = transfer_data in + let giver, amount, receiver = transfer_data in let* client = Client.init_mockup ~sync_mode:Client.Asynchronous ~protocol () in @@ -255,7 +255,7 @@ let test_same_transfer_twice = ~title:"(Mockup) Same transfer twice (asynchronous)" ~tags:["mockup"; "client"; "transfer"; "asynchronous"] @@ fun protocol -> - let (giver, amount, receiver) = transfer_data in + let giver, amount, receiver = transfer_data in let* client = Client.init_mockup ~sync_mode:Client.Asynchronous ~protocol () in @@ -280,7 +280,7 @@ let test_transfer_same_participants = ~title:"(Mockup) Transfer same participants (asynchronous)" ~tags:["mockup"; "client"; "transfer"; "asynchronous"] @@ fun protocol -> - let (giver, amount, receiver) = transfer_data in + let giver, amount, receiver = transfer_data in let* client = Client.init_mockup ~sync_mode:Client.Asynchronous ~protocol () in @@ -316,7 +316,7 @@ let test_multiple_baking = (* For the equality test below to hold, alice, bob and baker must be different accounts. Here, alice is bootstrap1, bob is bootstrap2 and baker is bootstrap3. *) - let (alice, _amount, bob) = transfer_data and baker = "bootstrap3" in + let alice, _amount, bob = transfer_data and baker = "bootstrap3" in if String.(equal alice bob || equal bob baker || equal baker alice) then Test.fail "alice, bob and baker need to be different accounts" ; let* client = @@ -409,7 +409,7 @@ let test_migration ?(migration_spec : (Protocol.t * Protocol.t) option) ~post_migration) let test_migration_transfer ?migration_spec () = - let (giver, amount, receiver) = ("alice", Tez.of_int 1, "bob") in + let giver, amount, receiver = ("alice", Tez.of_int 1, "bob") in test_migration ?migration_spec ~pre_migration:(fun client -> @@ -577,7 +577,7 @@ let test_empty_block_baking = ~title:"(Mockup) Transfer (empty, asynchronous)" ~tags:["mockup"; "client"; "empty"; "bake_for"; "asynchronous"] @@ fun protocol -> - let (giver, _amount, _receiver) = transfer_data in + let giver, _amount, _receiver = transfer_data in let* client = Client.init_mockup ~sync_mode:Client.Asynchronous ~protocol () in diff --git a/tezt/tests/monitor_operations.ml b/tezt/tests/monitor_operations.ml index 42b8fec64e6e..1b0b672599ed 100644 --- a/tezt/tests/monitor_operations.ml +++ b/tezt/tests/monitor_operations.ml @@ -79,7 +79,7 @@ let monitor_operations = @@ fun protocol -> (* Step 1 *) (* initialize the node and the client *) - let* (node, client) = Client.init_with_protocol `Client ~protocol () in + let* node, client = Client.init_with_protocol `Client ~protocol () in (* Step 2 *) (* call the monitor_operations RPC *) let monitor_path = diff --git a/tezt/tests/normalize.ml b/tezt/tests/normalize.ml index f78d165d3014..08f5fdf595bd 100644 --- a/tezt/tests/normalize.ml +++ b/tezt/tests/normalize.ml @@ -28,7 +28,7 @@ Component: Client - normalize command Invocation: dune exec tezt/tests/main.exe -- --file normalize.ml Subject: Test the client's command 'normalize data .. of type ...' - *) +*) let data = "{Pair 0 3 6 9; Pair 1 (Pair 4 (Pair 7 10)); {2; 5; 8; 11}}" @@ -72,7 +72,7 @@ let test_normalize_proxy = ~title:"normalize data (proxy)" ~tags:["proxy"; "normalize"; "data"] @@ fun protocol -> - let* (_, client) = Proxy.init ~protocol () in + let* _, client = Proxy.init ~protocol () in let* _ = execute_all_modes client in Lwt.return_unit diff --git a/tezt/tests/prevalidator.ml b/tezt/tests/prevalidator.ml index b9fc8978638f..48e308856202 100644 --- a/tezt/tests/prevalidator.ml +++ b/tezt/tests/prevalidator.ml @@ -99,7 +99,7 @@ module Revamped = struct JSON. (json |-> "origin" |> as_string_opt, json |-> "oph" |> as_string_opt) with - | (Some "injected", Some h) when String.equal h oph -> Some () + | Some "injected", Some h when String.equal h oph -> Some () | _ -> None in Node.wait_for node "banned_operation_encountered.v0" filter @@ -424,7 +424,7 @@ module Revamped = struct ~tags:["mempool"; "ban"; "branch_delayed"] @@ fun protocol -> log_step 1 "Initialize a node and a client." ; - let* (node, client) = Client.init_with_protocol ~protocol `Client () in + let* node, client = Client.init_with_protocol ~protocol `Client () in log_step 2 "Forge and inject an operation on the node." ; let* (`OpHash oph1) = @@ -484,14 +484,14 @@ module Revamped = struct ~tags:["mempool"; "manager_restriction"; "injection"] @@ fun protocol -> log_step 1 "Initialize two nodes and connect them." ; - let* (node1, client1) = + let* node1, client1 = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0] ~protocol `Client () in - let* (node2, client2) = + let* node2, client2 = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0] ~protocol @@ -558,21 +558,21 @@ module Revamped = struct ~tags:["mempool"; "manager_restriction"; "propagation"] @@ fun protocol -> log_step 1 "Initialize three nodes with the protocol." ; - let* (node1, client1) = + let* node1, client1 = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0; Private_mode] ~protocol `Client () in - let* (node2, client2) = + let* node2, client2 = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0; Private_mode] ~protocol `Client () in - let* (node3, client3) = + let* node3, client3 = Client.init_with_protocol ~event_sections_levels:[("prevalidator", `Debug)] ~nodes_args:[Synchronisation_threshold 0] @@ -635,7 +635,7 @@ module Revamped = struct log_step 1 "Initialize a node, with the precheck of operation disable and a client." ; - let* (node, client) = + let* node, client = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0; Disable_operations_precheck] ~protocol @@ -722,7 +722,7 @@ module Revamped = struct ~tags:["mempool"; "manager_restriction"; "flush"] @@ fun protocol -> log_step 1 "Initialize a node and a client." ; - let* (node, client) = + let* node, client = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0] ~protocol @@ -825,7 +825,7 @@ module Revamped = struct ~tags:["mempool"; "manager_restriction"; "inject"] @@ fun protocol -> log_step 1 "Initialize a node and a client." ; - let* (node, client) = + let* node, client = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0] ~protocol @@ -897,7 +897,7 @@ module Revamped = struct ~tags:["mempool"; "wrong"; "signature"] @@ fun protocol -> log_step 1 "Initialize a node and a client." ; - let* (node, client) = + let* node, client = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0] ~protocol @@ -996,7 +996,7 @@ module Revamped = struct ~tags:["mempool"; "manager_restriction"; "ban"] @@ fun protocol -> log_step 1 "Initialize a node and a client." ; - let* (node, client) = + let* node, client = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0] ~protocol @@ -1071,7 +1071,7 @@ module Revamped = struct ~tags:["mempool"; "manager_restriction"; "flush"; "ban"] @@ fun protocol -> log_step 1 "Initialize a node and a client." ; - let* (node, client) = + let* node, client = Client.init_with_protocol ~event_sections_levels:[("prevalidator", `Debug)] ~nodes_args:[Synchronisation_threshold 0] @@ -1269,7 +1269,7 @@ module Revamped = struct string_of_classification ; let* _ = bake_for ~empty:true ~protocol ~wait_for_flush:true node client in let* mempool = Mempool.get_mempool client in - let (mempool_classification, mempool_without_classification) = + let mempool_classification, mempool_without_classification = match classification with | `Branch_delayed -> (mempool.branch_delayed, {Mempool.empty with branch_delayed = []}) @@ -1391,13 +1391,13 @@ module Revamped = struct log_step 1 "Node 1 activates the protocol and Node 2 catches up with Node 1." ; - let* (node1, client1) = + let* node1, client1 = Client.init_with_node ~nodes_args:[Synchronisation_threshold 0; Connections 1] `Client () in - let* (node2, client2) = + let* node2, client2 = Client.init_with_node ~event_sections_levels:[("prevalidator", `Debug)] ~nodes_args:[Synchronisation_threshold 0; Connections 2] @@ -1439,7 +1439,7 @@ module Revamped = struct let* () = check_mempool ~applied:[oph2] client2 in log_step 5 "Add node3 connected only to node2." ; - let* (node3, client3) = + let* node3, client3 = Client.init_with_node ~event_sections_levels:[("prevalidator", `Debug)] ~nodes_args:[Synchronisation_threshold 0; Connections 1] @@ -1480,7 +1480,7 @@ module Revamped = struct ~tags:["mempool"; "node"; "ban"; "reinject"] @@ fun protocol -> log_step 1 "Start a single node and activate the protocol." ; - let* (node1, client1) = + let* node1, client1 = Client.init_with_node ~nodes_args:[Synchronisation_threshold 0; Connections 0] `Client @@ -1571,14 +1571,14 @@ module Revamped = struct ~tags:["mempool"; "node"; "ban"] @@ fun protocol -> log_step 1 "Start two nodes, connect them, activate the protocol." ; - let* (node1, client1) = + let* node1, client1 = Client.init_with_node ~event_sections_levels:[("prevalidator", `Debug)] ~nodes_args:[Synchronisation_threshold 0; Connections 1] `Client () in - let* (node2, client2) = + let* node2, client2 = Client.init_with_node ~event_sections_levels:[("prevalidator", `Debug)] ~nodes_args:[Synchronisation_threshold 0; Connections 1] @@ -1768,7 +1768,7 @@ module Revamped = struct 9 "Check that this extra operation is applied and replaces one with lower \ fees." ; - let (removed_oph, kept_ops) = + let removed_oph, kept_ops = match ops with | [] -> assert false | removed :: applied -> (removed, applied) @@ -1935,7 +1935,7 @@ module Revamped = struct ~title:"Precheck refused an operation which empties a balance" ~tags:["mempool"; "precheck"; "empty"; "balance"] @@ fun protocol -> - let* (_node, client) = Client.init_with_protocol ~protocol `Client () in + let* _node, client = Client.init_with_protocol ~protocol `Client () in let*! json_balance = RPC.Contracts.get_balance ~contract_id:Constant.bootstrap1.public_key_hash @@ -2507,7 +2507,7 @@ let propagation_future_endorsement = let* () = Client.endorse_for client_1 ~force:true ~protocol in let* () = endorser_waiter in Log.info "%s" step4_msg ; - let* (bytes, hash) = get_endorsement_has_bytes ~protocol client_1 in + let* bytes, hash = get_endorsement_has_bytes ~protocol client_1 in Log.info "%s" step5_msg ; let* _ = RPC.mempool_ban_operation ~data:(`String hash) client_1 in Log.info "%s" step6_msg ; @@ -2869,8 +2869,8 @@ let ban_operation_and_check_applied = Log.info "Step 1: Start two nodes, connect them, activate the protocol." ; let* node_1 = Node.init - ~event_sections_levels: - [("prevalidator", `Debug)] (* to witness operation arrival events *) + ~event_sections_levels:[("prevalidator", `Debug)] + (* to witness operation arrival events *) [Synchronisation_threshold 0; Connections 1] and* node_2 = Node.init [Synchronisation_threshold 0; Connections 1] in let* client_1 = Client.init ~endpoint:Client.(Node node_1) () @@ -2955,7 +2955,7 @@ let wait_for_arrival_of_ophash ophash node = ( json |-> "view" |-> "request" |> as_string_opt, json |-> "view" |-> "operation_hash" |> as_string_opt ) with - | (Some "arrived", Some s) when String.equal s ophash -> + | Some "arrived", Some s when String.equal s ophash -> Log.info "Witnessed arrival of operation %s." ophash ; Some () | _ -> None @@ -3708,7 +3708,7 @@ let test_get_post_mempool_filter = Protocol.register_test ~__FILE__ ~title ~tags @@ fun protocol -> let open Filter_config in log_step 1 step1_msg ; - let* (node1, client1) = + let* node1, client1 = (* We need event level [debug] for event [invalid_mempool_filter_configuration]. *) init_single_node_and_activate_protocol @@ -3958,7 +3958,7 @@ let test_mempool_filter_operation_arrival = in Protocol.register_test ~__FILE__ ~title ~tags @@ fun protocol -> log_step 1 step1 ; - let* (node1, client1, node2, client2) = + let* node1, client1, node2, client2 = init_two_connected_nodes_and_activate_protocol (* Need event level [debug] to receive operation arrival events in [node1]. *) ~event_sections_levels1:[("prevalidator", `Debug)] diff --git a/tezt/tests/protocol_migration.ml b/tezt/tests/protocol_migration.ml index dd60c574c205..820e3f20b416 100644 --- a/tezt/tests/protocol_migration.ml +++ b/tezt/tests/protocol_migration.ml @@ -31,7 +31,7 @@ *) (* Migration to Tenderbake is only supported after the first cycle, - therefore at [migration_level >= blocks_per_cycle]. *) + therefore at [migration_level >= blocks_per_cycle]. *) let test_protocol_migration ~blocks_per_cycle ~migration_level ~migrate_from ~migrate_to = Test.register @@ -274,9 +274,7 @@ let test_migration_with_bakers ?(migration_level = 4) "to_" ^ Protocol.tag migrate_to; ] @@ fun () -> - let* (client, node) = - user_migratable_node_init ~migration_level ~migrate_to - in + let* client, node = user_migratable_node_init ~migration_level ~migrate_to in let* () = start_protocol ~expected_bake_for_blocks:migration_level diff --git a/tezt/tests/protocol_table_update.ml b/tezt/tests/protocol_table_update.ml index 9b434831eb77..c7275f97b8e8 100644 --- a/tezt/tests/protocol_table_update.ml +++ b/tezt/tests/protocol_table_update.ml @@ -49,7 +49,7 @@ let wait_for_protocol_table_update node = let proto_hash = JSON.(json |-> "proto_hash" |> as_string_opt) in let block_hash = JSON.(json |-> "block_hash" |> as_string_opt) in match (proto_hash, block_hash) with - | (Some ph, Some bh) -> Some (ph, bh) + | Some ph, Some bh -> Some (ph, bh) | _ -> None in let* activation_block = @@ -127,7 +127,7 @@ let test_protocol_table_update ~migrate_from ~migrate_to = ~block:migration_block client_1 in - let* (ph_n1_alt, bh_n1_alt) = activation_promise_node_1 in + let* ph_n1_alt, bh_n1_alt = activation_promise_node_1 in Log.info "Node 1 activates protocol %s on block %s" ph_n1_alt bh_n1_alt ; (* Shutdown node_1 and make an alternate activation on node_2. *) let* () = Node.terminate node_1 in @@ -147,7 +147,7 @@ let test_protocol_table_update ~migrate_from ~migrate_to = ~block:migration_block client_2 in - let* (ph_n2, bh_n2) = activation_promise_node_2 in + let* ph_n2, bh_n2 = activation_promise_node_2 in Log.info "Node 2 activates protocol %s on block %s" ph_n2 bh_n2 ; if String.equal bh_n1_alt bh_n2 then Test.fail "Activation block must differ." ; (* Bake a few blocks (eg [num_blocks]) to increase the fitness of node's 2 chain. *) @@ -168,7 +168,7 @@ let test_protocol_table_update ~migrate_from ~migrate_to = let* _ = Node.wait_for_level node_1 target_level and* _ = Node.wait_for_level node_2 8 in Log.info "Both nodes are at level %d." target_level ; - let* (ph_n1, bh_n1) = activation_promise_switch in + let* ph_n1, bh_n1 = activation_promise_switch in Log.info "Node 1 updated its protocol table activation block for protocol %s at \ block %s" diff --git a/tezt/tests/proxy.ml b/tezt/tests/proxy.ml index 758b5f72fbd1..f2040f829903 100644 --- a/tezt/tests/proxy.ml +++ b/tezt/tests/proxy.ml @@ -28,7 +28,7 @@ Component: Client - proxy mode Invocation: dune exec tezt/tests/main.exe -- --file proxy.ml Subject: Tests of the client's --mode proxy. - *) +*) let ( >|= ) = Lwt.( >|= ) @@ -59,7 +59,7 @@ let test_cache_at_most_once ?query_string path = (Client.rpc_path_query_to_string ?query_string path)) ~tags:["proxy"; "rpc"; "get"] @@ fun protocol -> - let* (_, client) = init ~protocol () in + let* _, client = init ~protocol () in let env = [("TEZOS_LOG", Protocol.daemon_name protocol ^ ".proxy_rpc->debug")] |> List.to_seq |> String_map.of_seq @@ -83,8 +83,8 @@ let test_cache_at_most_once ?query_string path = let find_duplicate l = let rec go with_duplicates without_duplicates = match (with_duplicates, without_duplicates) with - | ([], []) -> None - | (hd_dup :: tl_dup, hd_nodup :: tl_nodup) -> + | [], [] -> None + | hd_dup :: tl_dup, hd_nodup :: tl_nodup -> if hd_dup = hd_nodup then go tl_dup tl_nodup else Some hd_dup | _ -> assert false in @@ -175,7 +175,7 @@ let test_context_suffix_no_rpc ?query_string path = (Client.rpc_path_query_to_string ?query_string path)) ~tags:["proxy"; "rpc"; "get"] @@ fun protocol -> - let* (_, client) = init ~protocol () in + let* _, client = init ~protocol () in let env = String_map.singleton "TEZOS_LOG" @@ -282,7 +282,7 @@ let test_wrong_proto = ~title:"(Proxy) Wrong proto" ~tags:["proxy"; "initialization"] @@ fun protocol -> - let* (_, client) = init ~protocol () in + let* _, client = init ~protocol () in wrong_proto protocol client (** Test. @@ -311,7 +311,7 @@ let test_transfer = ~title:"(Proxy) Transfer" ~tags:["proxy"; "transfer"] @@ fun protocol -> - let* (_, client) = init ~protocol () in + let* _, client = init ~protocol () in let* () = Client.transfer ~wait:"none" @@ -399,7 +399,7 @@ module Location = struct printed to output. [tz_log] can be used to augment TEZOS_LOG (useful for debugging). *) let rpc_get ?(tz_log = []) ?query_string client rpc_path = - let (proxy_key, proxy_value) = ("proxy_rpc_ctxt", "debug") in + let proxy_key, proxy_value = ("proxy_rpc_ctxt", "debug") in List.iter (fun (k, v) -> if k = proxy_key && v = proxy_value then @@ -424,7 +424,7 @@ module Location = struct to be executed on the given location ([expected_loc]). [tz_log] can be used to augment TEZOS_LOG (useful for debugging). *) let check_location ?tz_log alt_mode client rpc_path expected_loc = - let* (_, stderr) = rpc_get ?tz_log client rpc_path in + let* _, stderr = rpc_get ?tz_log client rpc_path in let actual_loc = parse_rpc_exec_location stderr rpc_path in if actual_loc <> expected_loc then Test.fail @@ -461,7 +461,7 @@ module Location = struct ~title:"(Proxy) RPC get's location" ~tags:(locations_tags alt_mode) @@ fun protocol -> - let* (_, client) = init ~protocol () in + let* _, client = init ~protocol () in check_locations alt_mode client (** Check the output of [rpc get] on a number on RPC between two @@ -500,9 +500,9 @@ module Location = struct ] in let perform (rpc_path, query_string) = - let* (vanilla_out, vanilla_err) = + let* vanilla_out, vanilla_err = rpc_get ?tz_log ~query_string vanilla rpc_path - and* (alt_out, alt_err) = + and* alt_out, alt_err = rpc_get ?tz_log ~query_string alternative rpc_path in if vanilla_out <> alt_out then @@ -530,17 +530,17 @@ module Location = struct (* Unknown matches on the left-hand side: there should be no match in the vanilla output, because the vanilla client doesn't deal with alternative stuff. That is why [Unknown] is matched here. *) - | (Unknown, Unknown) when not (executes_locally alt_mode) -> + | Unknown, Unknown when not (executes_locally alt_mode) -> log_same_answer () ; Lwt.return_unit - | (Unknown, Local) -> + | Unknown, Local -> log_same_answer () ; Log.info "%s client, %s: done locally ✓" alt_mode_string (Client.rpc_path_query_to_string ~query_string rpc_path) ; Lwt.return_unit - | (loc, Local) -> + | loc, Local -> Test.fail "Vanilla client should not output whether an RPC (here: %s) is \ executed locally or delegated to the endpoint. Expected %s but \ @@ -550,7 +550,7 @@ module Location = struct (location_to_string Unknown) (location_to_string loc) vanilla_err - | (_, loc) -> + | _, loc -> Test.fail "%s client should execute RPC %s locally: expected %s but found \ %s. Inspected log:\n\ @@ -575,7 +575,7 @@ module Location = struct ~title:"(Proxy) Compare RPC get" ~tags:(compare_tags alt_mode) @@ fun protocol -> - let* (node, alternative) = init ~protocol () in + let* node, alternative = init ~protocol () in let* vanilla = Client.init ~endpoint:(Node node) () in let clients = {vanilla; alternative} in check_equivalence alt_mode clients @@ -696,7 +696,7 @@ let test_split_key_heuristic = ~title:"(Proxy) split_key heuristic" ~tags:["proxy"; "rpc"; "get"] @@ fun protocol -> - let* (_, client) = init ~protocol () in + let* _, client = init ~protocol () in let test_one (path, query_string) = let full_path = "chains" :: "main" :: "blocks" :: "head" :: path in let* stderr = diff --git a/tezt/tests/proxy_server_test.ml b/tezt/tests/proxy_server_test.ml index 58dd2bcbab94..66ff4d973177 100644 --- a/tezt/tests/proxy_server_test.ml +++ b/tezt/tests/proxy_server_test.ml @@ -31,12 +31,12 @@ big map RPC and comparing performances with a node. Other tests test the proxy server alone. Dependencies: tezt/tests/proxy.ml - *) +*) (** Creates a client that uses a [tezos-proxy-server] as its endpoint. Also returns the node backing the proxy server, and the proxy server itself. *) let init ?nodes_args ?parameter_file ~protocol () = - let* (node, client) = + let* node, client = Client.init_with_protocol ?nodes_args ?parameter_file `Client ~protocol () in let* () = Client.bake_for_and_wait client in @@ -101,7 +101,7 @@ let big_map_get ?(big_map_size = 10) ?nb_gets ~protocol mode () = ~base:(Either.right (protocol, None)) [(["hard_storage_limit_per_operation"], Some "\"99999999\"")] in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file ~protocol `Client () in let* (endpoint : Client.endpoint option) = @@ -197,7 +197,7 @@ let test_equivalence = ~title:"(Vanilla, proxy_server endpoint) Compare RPC get" ~tags:(compare_tags alt_mode) @@ fun protocol -> - let* (node, _, alternative) = init ~protocol () in + let* node, _, alternative = init ~protocol () in let vanilla = Client.create ~endpoint:(Node node) () in let clients = {vanilla; alternative} in let tz_log = [("alpha.proxy_rpc", "debug"); ("proxy_getter", "debug")] in @@ -209,7 +209,7 @@ let test_wrong_data_dir = ~title:"proxy_server wrong data_dir" ~tags:["data_dir"] @@ fun protocol -> - let* (node, _client) = Client.init_with_protocol `Client ~protocol () in + let* node, _client = Client.init_with_protocol `Client ~protocol () in let wrong_data_dir = Temp.dir "empty" in let args = ["--data-dir"; wrong_data_dir] in let process = Proxy_server.spawn ~args node in diff --git a/tezt/tests/reject_malformed_micheline.ml b/tezt/tests/reject_malformed_micheline.ml index 4acada4eb4bd..0a4c7596deb6 100644 --- a/tezt/tests/reject_malformed_micheline.ml +++ b/tezt/tests/reject_malformed_micheline.ml @@ -66,7 +66,7 @@ let make_data s = let reject_malformed_micheline = Protocol.register_test ~__FILE__ ~title:"Reject malformed micheline" ~tags:[] @@ fun protocol -> - let* (node, _client) = Client.init_with_protocol `Client ~protocol () in + let* node, _client = Client.init_with_protocol `Client ~protocol () in let send_operation data = (* This RPC path is used because it doesn't require valid signatures. *) let rpc_path = diff --git a/tezt/tests/replace_by_fees.ml b/tezt/tests/replace_by_fees.ml index 3a67f75eb72d..37e66e32f71a 100644 --- a/tezt/tests/replace_by_fees.ml +++ b/tezt/tests/replace_by_fees.ml @@ -228,8 +228,8 @@ let replacement_test_helper ~title ~__LOC__ ~op1 ?(size1 = 1) ~op2 ?(size2 = 1) in let* () = postcheck2 nodes oph1 oph2 in match (op3, incheck3, postcheck3) with - | (None, None, None) -> unit - | (Some op3, Some incheck3, Some postcheck3) -> + | None, None, None -> unit + | Some op3, Some incheck3, Some postcheck3 -> let* oph3 = let* batch = mk_batch client op3 size3 in incheck3 ~__LOC__ nodes @@ fun () -> diff --git a/tezt/tests/run_script.ml b/tezt/tests/run_script.ml index c1bd942a7b57..c7bf4f928305 100644 --- a/tezt/tests/run_script.ml +++ b/tezt/tests/run_script.ml @@ -28,7 +28,7 @@ Component: Client Invocation: dune exec tezt/tests/main.exe -- --file run_script.ml Subject: Check that run script command to tezos-client behaves correctly - *) +*) (* This script checks result of some arbitrary instruction against the expected value. Return type and name of the instruction should be diff --git a/tezt/tests/sapling.ml b/tezt/tests/sapling.ml index 8e7a7bc25fd1..7fa8e0130964 100644 --- a/tezt/tests/sapling.ml +++ b/tezt/tests/sapling.ml @@ -309,7 +309,7 @@ let successful_roundtrip = let* () = assert_balance c "alice" 0 in let* () = assert_balance c "bob" 0 in let* balance_alice_tz1_before = balance_tz1 c alice_tz1.public_key_hash in - let* (amount, fees) = shield c alice_tz1 alice_address 10 in + let* amount, fees = shield c alice_tz1 alice_address 10 in let* balance_alice_tz1_after = balance_tz1 c alice_tz1.public_key_hash in assert (amount = 10_000_000) ; assert (balance_alice_tz1_after = balance_alice_tz1_before - 10_000_000 - fees) ; @@ -323,7 +323,7 @@ let successful_roundtrip = let* () = assert_balance c "alice" 0 in let* () = assert_balance c "bob" 10 in let* balance_alice_tz1_before = balance_tz1 c alice_tz1.public_key_hash in - let* (amount, fees) = unshield c "bob" alice_tz1 10 in + let* amount, fees = unshield c "bob" alice_tz1 10 in let* balance_alice_tz1_after = balance_tz1 c alice_tz1.public_key_hash in assert (amount = -10_000_000) ; assert (balance_alice_tz1_after = balance_alice_tz1_before + 10_000_000 - fees) ; diff --git a/tezt/tests/sc_rollup.ml b/tezt/tests/sc_rollup.ml index b7eefe49e8e6..d132b759eb22 100644 --- a/tezt/tests/sc_rollup.ml +++ b/tezt/tests/sc_rollup.ml @@ -58,7 +58,7 @@ let setup f ~protocol = Synchronisation_threshold 0; History_mode (Full None); No_bootstrap_peers; ] in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol ~nodes_args () in let bootstrap1_key = Constant.bootstrap1.public_key_hash in @@ -108,7 +108,7 @@ let with_fresh_rollup f tezos_node tezos_client bootstrap1_key = f rollup_address sc_rollup_node configuration_filename (* TODO: create and insert issue number. Many tests -can be refactored using test_scenario.*) + can be refactored using test_scenario.*) let test_scenario {output_file_prefix; variant; tags; description} scenario = let output_file _ = output_file_prefix ^ "_" ^ variant in let tags = tags @ [variant] in @@ -151,7 +151,6 @@ let hash (hash, (_ : Sc_rollup_client.commitment)) = hash -------------------------------------------- - Rollup addresses are fully determined by operation hashes and origination nonce. - *) let test_origination = let output_file _ = "sc_rollup_origination" in @@ -176,7 +175,6 @@ let test_origination = ------------------------------ A rollup node has a configuration file that must be initialized. - *) let with_fresh_rollup ?(boot_sector = "") f tezos_node tezos_client bootstrap1_key = @@ -241,7 +239,6 @@ let test_rollup_node_configuration = A running rollup node can be asked the address of the rollup it is interacting with. - *) let test_rollup_node_running = test @@ -277,7 +274,6 @@ let test_rollup_node_running = When a rollup node is running, a rollup client can ask this node its rollup address. - *) let test_rollup_client_gets_address = let output_file _ = "sc_rollup_client_gets_address" in @@ -304,10 +300,10 @@ let test_rollup_client_gets_address = return ()) (* Fetching the initial level of a sc rollup - ----------------------------------------- + ----------------------------------------- - We can fetch the level when a smart contract rollup was - originated from the context. + We can fetch the level when a smart contract rollup was + originated from the context. *) let test_rollup_get_initial_level = let output_file _ = "sc_rollup_get_initial_level" in @@ -339,10 +335,10 @@ let test_rollup_get_initial_level = bootstrap) (* Fetching the last cemented commitment info for a sc rollup - ---------------------------------------------------------- + ---------------------------------------------------------- - We can fetch the hash and level of the last cemented commitment. Initially, - this corresponds to `(Sc_rollup.Commitment_hash.zero, origination_level)`. + We can fetch the hash and level of the last cemented commitment. Initially, + this corresponds to `(Sc_rollup.Commitment_hash.zero, origination_level)`. *) (* TODO: https://gitlab.com/tezos/tezos/-/issues/2944 @@ -367,7 +363,7 @@ let test_rollup_get_last_cemented_commitment_hash_with_level = ~sc_rollup_address client in - let (hash, level) = + let hash, level = last_cemented_commitment_hash_with_level lcc_info_json in (* The hardcoded value of `Sc_rollup.Commitment.zero` is @@ -463,7 +459,7 @@ let test_rollup_inbox_size = ( with_fresh_rollup @@ fun sc_rollup_address _sc_rollup_node _filename -> let n = 10 in let* () = send_messages n sc_rollup_address client in - let* (_, inbox_size) = + let* _, inbox_size = get_inbox_from_tezos_node sc_rollup_address client in return @@ -555,7 +551,7 @@ let test_rollup_inbox_current_messages_hash = in let open Tezos_crypto.Context_hash in (* no messages have been sent *) - let* (pristine_hash, _) = + let* pristine_hash, _ = get_inbox_from_tezos_node sc_rollup_address client in let* expected = Sc_rollup_inbox.predict_current_messages_hash [] in @@ -574,7 +570,7 @@ let test_rollup_inbox_current_messages_hash = let* () = send_message client sc_rollup_address @@ prepare_batch fst_batch in - let* (fst_batch_hash, _) = + let* fst_batch_hash, _ = get_inbox_from_tezos_node sc_rollup_address client in let () = @@ -609,7 +605,7 @@ let test_rollup_inbox_current_messages_hash = (list string) ~error_msg:"expected messages:\n%R\nretrieved:\n%L") in - let* (snd_batch_hash, _) = + let* snd_batch_hash, _ = get_inbox_from_tezos_node sc_rollup_address client in let* expected = @@ -626,7 +622,7 @@ let test_rollup_inbox_current_messages_hash = - the hash matches the 'pristine' hash: a.k.a there are no 'current messages' *) let* () = send_message client sc_rollup_address @@ prepare_batch [] in - let* (empty_batch_hash, _) = + let* empty_batch_hash, _ = get_inbox_from_tezos_node sc_rollup_address client in let () = @@ -651,7 +647,6 @@ let test_rollup_inbox_current_messages_hash = In addition, this maintenance includes the computation of a Merkle tree which must have the same root hash as the one stored by the protocol in the context. - *) let test_rollup_inbox_of_rollup_node variant scenario = let output_file _ = "sc_rollup_inbox_of_rollup_node_" ^ variant in @@ -798,7 +793,6 @@ let test_rollup_list = When a rollup node starts, we want to make sure that in the absence of messages it will boot into the initial state. - *) let test_rollup_node_boots_into_initial_state = let go client sc_rollup_address sc_rollup_node = @@ -847,7 +841,6 @@ let test_rollup_node_boots_into_initial_state = When the rollup node receives messages, we like to see evidence that the PVM has advanced. - *) let test_rollup_node_advances_pvm_state = let go client sc_rollup_address sc_rollup_node = @@ -1311,7 +1304,6 @@ let commitments_reorgs protocol sc_rollup_node sc_rollup_address node client = ------------------------------------------------------- Originate a rollup with a custom boot sector and check if the RPC returns it. - *) let test_rollup_origination_boot_sector = let boot_sector = "10 10 10 + +" in @@ -1347,7 +1339,6 @@ let test_rollup_origination_boot_sector = Originate 2 rollups with different boot sectors to check if the are actually different. - *) let test_rollup_node_uses_boot_sector = let go_boot client sc_rollup_address sc_rollup_node = @@ -1410,7 +1401,7 @@ let test_rollup_client_show_address = ~tags:["run"; "client"] "Shows the address of a registered account" (fun protocol -> - let* (sc_client, account) = client_with_initial_keys ~protocol in + let* sc_client, account = client_with_initial_keys ~protocol in let* shown_account = Sc_rollup_client.show_address ~alias:account.Account.aggregate_alias @@ -1463,7 +1454,7 @@ let test_rollup_client_list_keys = ~tags:["run"; "client"] "Lists known aliases in the client" (fun protocol -> - let* (sc_client, account) = client_with_initial_keys ~protocol in + let* sc_client, account = client_with_initial_keys ~protocol in let* maybe_keys = Sc_rollup_client.list_keys sc_client in let expected_keys = [(account.aggregate_alias, account.aggregate_public_key_hash)] diff --git a/tezt/tests/signer_test.ml b/tezt/tests/signer_test.ml index 5bd0fe05a94b..9f7ec6cf562f 100644 --- a/tezt/tests/signer_test.ml +++ b/tezt/tests/signer_test.ml @@ -35,7 +35,7 @@ let signer_simple_test ~title ~tags ~keys = Protocol.register_test ~__FILE__ ~title ~tags @@ fun protocol -> (* init the signer and import all the bootstrap_keys *) let* signer = Signer.init ~keys () in - let* (node, client) = + let* node, client = Client.init_with_protocol ~keys:[Constant.activator] `Client diff --git a/tezt/tests/stresstest_command.ml b/tezt/tests/stresstest_command.ml index ef423ae7cedb..f09e29f4e431 100644 --- a/tezt/tests/stresstest_command.ml +++ b/tezt/tests/stresstest_command.ml @@ -142,7 +142,7 @@ let test_stresstest_sources_format = let additional_bootstrap_account_count = max 0 (n_bootstraps_total - (Account.Bootstrap.keys |> Array.length)) in - let* (node, client) = + let* node, client = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0; Connections 0] ~additional_bootstrap_account_count @@ -181,11 +181,10 @@ let test_stresstest_sources_format = in let source_accounts = List.hd bootstraps_to_use - :: - sublist_bounds_included - source_pkhs_cutoff - (n_bootstraps_to_use - 1) - bootstraps_to_use + :: sublist_bounds_included + source_pkhs_cutoff + (n_bootstraps_to_use - 1) + bootstraps_to_use in (* Helpers to check that operations (from the mempool or the last block) have the right sources. *) @@ -287,7 +286,7 @@ let test_stresstest_n_transfers = let additional_bootstrap_account_count = max 0 (n_bootstraps - (Account.Bootstrap.keys |> Array.length)) in - let* (_node, client) = + let* _node, client = Client.init_with_protocol ~nodes_args:[Synchronisation_threshold 0; Connections 0] ~additional_bootstrap_account_count @@ -353,11 +352,11 @@ let test_stresstest_multiple_nodes = let additional_bootstrap_account_count = max 0 (n_bootstraps_total - (Account.Bootstrap.keys |> Array.length)) in - let* (central_node, central_client) = + let* central_node, central_client = Client.init_with_protocol ~nodes_args:Node.[Synchronisation_threshold 0; Connections (n_nodes - 1)] - ~event_sections_levels: - [("prevalidator", `Debug)] (* for "arrived" request events *) + ~event_sections_levels:[("prevalidator", `Debug)] + (* for "arrived" request events *) ~additional_bootstrap_account_count `Client ~protocol @@ -386,7 +385,7 @@ let test_stresstest_multiple_nodes = (((i + 1) * n_bootstraps_per_node) + 1) ((i + 2) * n_bootstraps_per_node) in - let* (node, client) = + let* node, client = Client.init_with_node ~nodes_args:Node.[Synchronisation_threshold 0; Connections 1] ~keys:accounts diff --git a/tezt/tests/tenderbake.ml b/tezt/tests/tenderbake.ml index 7333cf8413fc..3379a85564bd 100644 --- a/tezt/tests/tenderbake.ml +++ b/tezt/tests/tenderbake.ml @@ -84,7 +84,7 @@ let test_bake_two = ~title:"Tenderbake transfer - baking 2" ~tags:["baking"; "tenderbake"] @@ fun protocol -> - let* (_proto_hash, endpoint, client) = init protocol in + let* _proto_hash, endpoint, client = init protocol in let end_idx = List.length bootstrap_accounts in let rec loop i = if i = end_idx then Lwt.return_unit @@ -115,7 +115,7 @@ let test_low_level_commands = ~title:"Tenderbake low level commands" ~tags:["propose"; "endorse"; "preendorse"; "tenderbake"; "low_level"] @@ fun protocol -> - let* (_proto_hash, endpoint, client) = init protocol in + let* _proto_hash, endpoint, client = init protocol in Log.info "Doing a propose -> preendorse -> endorse cycle" ; let proposer = endorsers in let preendorsers = endorsers in @@ -156,7 +156,7 @@ let test_repropose = "repropose"; ] @@ fun protocol -> - let* (_proto_hash, endpoint, client) = init protocol in + let* _proto_hash, endpoint, client = init protocol in Log.info "Doing a propose -> preendorse -> endorse cycle" ; let proposer = endorsers in let preendorsers = endorsers in diff --git a/tezt/tests/tx_rollup.ml b/tezt/tests/tx_rollup.ml index 0f0d9509e643..470b7fb0d1d0 100644 --- a/tezt/tests/tx_rollup.ml +++ b/tezt/tests/tx_rollup.ml @@ -46,7 +46,7 @@ let assert_some res = match res with Some r -> r | None -> assert false let init_with_tx_rollup ?additional_bootstrap_account_count ?(parameters = Parameters.default) ~protocol () = let* parameter_file = Parameters.parameter_file ~parameters protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ?additional_bootstrap_account_count ~parameter_file @@ -183,7 +183,7 @@ module Regressions = struct ~title:"RPC (tx_rollups, regression) - inbox message hash" ~tags:["tx_rollup"; "rpc"; "inbox"; "message"] @@ fun protocol -> - let* (_node, client) = Client.init_with_protocol `Client ~protocol () in + let* _node, client = Client.init_with_protocol `Client ~protocol () in let message = Rollup.make_batch "blob" in let*! _hash = Rollup.message_hash ~hooks ~message client in unit @@ -195,7 +195,7 @@ module Regressions = struct ~title:"RPC (tx_rollups, regression) - inbox merkle tree hash" ~tags:["tx_rollup"; "rpc"; "inbox"; "merkle_tree_hash"] @@ fun protocol -> - let* (_node, client) = Client.init_with_protocol `Client ~protocol () in + let* _node, client = Client.init_with_protocol `Client ~protocol () in let messages = List.map Rollup.make_batch ["blob"; "gloubiboulga"] in let* message_hashes = Lwt_list.map_p @@ -216,7 +216,7 @@ module Regressions = struct ~title:"RPC (tx_rollups, regression) - inbox merkle tree path" ~tags:["tx_rollup"; "rpc"; "inbox"; "merkle_tree_path"] @@ fun protocol -> - let* (_node, client) = Client.init_with_protocol `Client ~protocol () in + let* _node, client = Client.init_with_protocol `Client ~protocol () in let messages = List.map Rollup.make_batch @@ -532,7 +532,7 @@ module Regressions = struct let* old_parameter_file = Parameters.(parameter_file ~parameters:default protocol) in - let* (_, old_client) = + let* _, old_client = Client.init_with_protocol ~parameter_file:old_parameter_file `Client @@ -582,7 +582,7 @@ module Regressions = struct ~tags:["tx_rollup"; "client"; "fail"; "batch"] @@ fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (_node, client) = + let* _node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let invalid_address = "this is an invalid tx rollup address" in @@ -759,7 +759,7 @@ let test_submit_batches_in_several_blocks = ~tags:["tx_rollup"] @@ fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let*! rollup = @@ -851,7 +851,7 @@ let test_submit_from_originated_source = ~tags:["tx_rollup"; "client"] @@ fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (_node, client) = + let* _node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in (* We begin by originating a contract *) diff --git a/tezt/tests/tx_rollup_node.ml b/tezt/tests/tx_rollup_node.ml index aa9dbe9d6cfa..4cf8c4be692c 100644 --- a/tezt/tests/tx_rollup_node.ml +++ b/tezt/tests/tx_rollup_node.ml @@ -222,7 +222,7 @@ let test_node_configuration = ~tags:["tx_rollup"; "configuration"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let operator = Constant.bootstrap1.public_key_hash in @@ -297,7 +297,7 @@ let test_tx_node_origination = ~tags:["tx_rollup"; "ready"; "originate"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in @@ -312,7 +312,7 @@ let test_not_allow_deposit = ~tags:["tx_rollup"; "node"; "allow"; "deposit"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in @@ -356,7 +356,7 @@ let test_allow_deposit = ~tags:["tx_rollup"; "node"; "allow"; "deposit"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in @@ -410,7 +410,7 @@ let test_tx_node_store_inbox = ~tags:["tx_rollup"; "store"; "inbox"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let operator = Constant.bootstrap1.public_key_hash in @@ -501,7 +501,7 @@ let test_node_cannot_connect = ~tags:["tx_rollup"; "node"; "connect"] @@ fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in @@ -538,11 +538,11 @@ let test_node_disconnect = ~tags:["tx_rollup"; "node"; "disconnect"] @@ fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in - let* (rollup, tx_node) = init_and_run_rollup_node ~originator node client in + let* rollup, tx_node = init_and_run_rollup_node ~originator node client in (* Submit a batch *) let (`Batch content) = Rollup.make_batch "tezos_l2_batch_1" in let*! () = @@ -744,7 +744,7 @@ let build_rejection ~tx_level ~tx_node ~message_pos ~client ?agreed_context_hash in return (JSON.encode message_path) in - let* (agreed_context_hash, agreed_message_result_path) = + let* agreed_context_hash, agreed_message_result_path = if message_pos = 0 && tx_level = 0 then return (Constant.tx_rollup_empty_l2_context, "[]") else if message_pos = 0 then @@ -832,11 +832,11 @@ let test_ticket_deposit_from_l1_to_l2 = ~tags:["tx_rollup"; "deposit"; "ticket"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let operator = Constant.bootstrap1.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator:operator node client in let tx_client = @@ -955,7 +955,7 @@ let craft_withdraw_and_sign ?counter tx_client ~qty ~signer ~dest ~ticket = return (transaction, signature) let craft_batch_for_one_tx ?counter tx_client ~qty ~signer ~dest ~ticket = - let* (transaction, signature) = + let* transaction, signature = craft_tx_and_sign ?counter tx_client ~qty ~signer ~dest ~ticket in let transactions_and_sig = @@ -996,11 +996,11 @@ let test_l2_to_l2_transaction = ~tags:["tx_rollup"; "rollup"; "internal"; "transaction"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator node client in let tx_client = @@ -1139,7 +1139,7 @@ let tx_client_inject_transaction ~tx_client ?failswith transaction signature = signature in let expect_failure = Option.is_some failswith in - let* (stdout, stderr) = + let* stdout, stderr = Tx_rollup_client.inject_batcher_transaction ~expect_failure tx_client @@ -1160,7 +1160,7 @@ let tx_client_inject_transaction ~tx_client ?failswith transaction signature = let craft_tx_and_inject ?failswith ?counter tx_client ~qty ~signer ~dest ~ticket = - let* (transaction, signature) = + let* transaction, signature = craft_tx_and_sign ?counter tx_client ~qty ~signer ~dest ~ticket in tx_client_inject_transaction ~tx_client ?failswith transaction [signature] @@ -1263,12 +1263,12 @@ let test_batcher = ~tags:["tx_rollup"; "node"; "batcher"; "transaction"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let operator = Constant.bootstrap1.public_key_hash in let originator = Constant.bootstrap2.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator ~operator @@ -1286,7 +1286,7 @@ let test_batcher = let bls_pkh_1 = bls_key_1.aggregate_public_key_hash in let* bls_key_2 = Client.bls_gen_and_show_keys client in let bls_pkh_2 = bls_key_2.aggregate_public_key_hash in - let* (_level, _contract_id) = + let* _level, _contract_id = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -1356,7 +1356,7 @@ let test_batcher = Log.info "Crafting a l2 transaction with wrong signature" ; let* _txh = (* craft a transaction, but ignore the signature *) - let* (transaction, _signature) = + let* transaction, _signature = craft_tx_and_sign tx_client ~qty:1L @@ -1365,7 +1365,7 @@ let test_batcher = ~ticket:ticket_id in (* craft a signature, for an ignored transaction *) - let* (_transaction, signature) = + let* _transaction, signature = craft_tx_and_sign tx_client ~qty:2L @@ -1493,7 +1493,7 @@ let test_reorganization = (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in let nodes_args = Node.[Connections 2; Synchronisation_threshold 0] in - let* (node1, client1) = + let* node1, client1 = Client.init_with_protocol ~nodes_args ~parameter_file @@ -1502,7 +1502,7 @@ let test_reorganization = () in let operator = Constant.bootstrap1.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator:operator node1 client1 in let tx_client = @@ -1513,7 +1513,7 @@ let test_reorganization = let bls_pkh_1 = bls_key_1.aggregate_public_key_hash in let* bls_key_2 = Client.bls_gen_and_show_keys client1 in let bls_pkh_2 = bls_key_2.aggregate_public_key_hash in - let* (_level, _contract_id) = + let* _level, _contract_id = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -1613,12 +1613,12 @@ let test_l2_proof_rpc_position = ~tags:["tx_rollup"; "node"; "proofs"; "rejection"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let operator = Constant.bootstrap1.public_key_hash in let originator = Constant.bootstrap2.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator node client in let tx_client = @@ -1629,7 +1629,7 @@ let test_l2_proof_rpc_position = let bls_pkh_1 = bls_key_1.aggregate_public_key_hash in let* bls_key_2 = Client.bls_gen_and_show_keys client in let bls_pkh_2 = bls_key_2.aggregate_public_key_hash in - let* (_level, _contract_id) = + let* _level, _contract_id = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -1822,18 +1822,18 @@ let test_reject_bad_commitment = ~tags:["tx_rollup"; "node"; "proofs"; "rejection"; "slashed"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in let operator = Constant.bootstrap3.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator node client in (* Generating some identities *) let* bls_key1 = Client.bls_gen_and_show_keys client in let pkh1_str = bls_key1.aggregate_public_key_hash in - let* (_level, _contract_id) = + let* _level, _contract_id = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -1915,12 +1915,12 @@ let test_committer = ~tags:["tx_rollup"; "node"; "commitments"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let operator = Constant.bootstrap1.public_key_hash in let originator = Constant.bootstrap2.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator ~operator @@ -1936,7 +1936,7 @@ let test_committer = let bls_pkh_1 = bls_key_1.aggregate_public_key_hash in let* bls_key_2 = Client.bls_gen_and_show_keys client in let bls_pkh_2 = bls_key_2.aggregate_public_key_hash in - let* (tzlevel, _) = + let* tzlevel, _ = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -2023,11 +2023,11 @@ let test_tickets_context = ~tags:["tx_rollup"; "tickets"; "context"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator ~batch_signer:Constant.bootstrap5.public_key_hash @@ -2042,7 +2042,7 @@ let test_tickets_context = let bls_pkh_1 = bls_key_1.aggregate_public_key_hash in let* bls_key_2 = Client.bls_gen_and_show_keys client in let bls_pkh_2 = bls_key_2.aggregate_public_key_hash in - let* (_level, contract_id) = + let* _level, contract_id = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -2141,12 +2141,12 @@ let test_withdrawals = ~parameters:Parameters.{finality_period = 2; withdraw_period = 2} protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap2.public_key_hash in let operator = Constant.bootstrap1.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator ~operator @@ -2170,7 +2170,7 @@ let test_withdrawals = let bls_pkh_1 = bls_key_1.aggregate_public_key_hash in let* bls_key_2 = Client.bls_gen_and_show_keys client in let bls_pkh_2 = bls_key_2.aggregate_public_key_hash in - let* (_level, deposit_contract) = + let* _level, deposit_contract = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -2221,7 +2221,7 @@ let test_withdrawals = ~expected_balance:5 in Log.info "Submitting withdrawals to queue" ; - let* (tx, signature) = + let* tx, signature = craft_withdraw_and_sign tx_client ~signer:bls_key_2 @@ -2230,7 +2230,7 @@ let test_withdrawals = ~qty:5L in let* _ = tx_client_inject_transaction ~tx_client tx [signature] in - let* (tx, signature) = + let* tx, signature = craft_withdraw_and_sign tx_client ~signer:bls_key_1 @@ -2320,12 +2320,12 @@ let test_accuser = ~parameters:Parameters.{finality_period = 5; withdraw_period = 5} protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap2.public_key_hash in let operator = Constant.bootstrap1.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = (* Starting without committer/operator *) init_and_run_rollup_node ~originator @@ -2337,7 +2337,7 @@ let test_accuser = (* Generating one identity *) let* bls_key_1 = Client.bls_gen_and_show_keys client in let bls_pkh_1 = bls_key_1.aggregate_public_key_hash in - let* (_level, _deposit_contract) = + let* _level, _deposit_contract = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -2387,11 +2387,11 @@ let test_batcher_large_message = ~parameters:Parameters.{finality_period = 5; withdraw_period = 5} protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in - let* (_tx_rollup_hash, tx_node) = + let* _tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator ~batch_signer:Constant.bootstrap5.public_key_hash @@ -2415,7 +2415,7 @@ let test_batcher_large_message = in List.init 200 (fun _ -> transfer_content) in - let* (tx, signature) = + let* tx, signature = craft_tx_transfers_and_sign ~counter:1L ~signer:bls_key @@ -2438,11 +2438,11 @@ let test_transfer_command = ~tags:["tx_rollup"; "client"; "transfer"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator ~batch_signer:Constant.bootstrap5.public_key_hash @@ -2455,7 +2455,7 @@ let test_transfer_command = (* Generating some identities *) let* bls_key_1 = Client.bls_gen_and_show_keys client in let* bls_key_2 = Client.bls_gen_and_show_keys client in - let* (_level, _contract_id) = + let* _level, _contract_id = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -2502,11 +2502,11 @@ let test_withdraw_command = ~tags:["tx_rollup"; "client"; "withdraw"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap1.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = init_and_run_rollup_node ~originator ~batch_signer:Constant.bootstrap5.public_key_hash @@ -2518,7 +2518,7 @@ let test_withdraw_command = in (* Generating some identities *) let* bls_key_1 = Client.bls_gen_and_show_keys client in - let* (_level, _contract_id) = + let* _level, _contract_id = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -2569,12 +2569,12 @@ let test_catch_up = ~parameters:Parameters.{finality_period = 5; withdraw_period = 5} protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let originator = Constant.bootstrap2.public_key_hash in let operator = Constant.bootstrap1.public_key_hash in - let* (tx_rollup_hash, tx_node) = + let* tx_rollup_hash, tx_node = (* Starting without committer/operator *) init_and_run_rollup_node ~originator @@ -2590,7 +2590,7 @@ let test_catch_up = let bls_pkh_1 = bls_key_1.aggregate_public_key_hash in let* bls_key_2 = Client.bls_gen_and_show_keys client in let bls_pkh_2 = bls_key_2.aggregate_public_key_hash in - let* (tzlevel, _deposit_contract) = + let* tzlevel, _deposit_contract = make_deposit ~source:Constant.bootstrap2.public_key_hash ~tx_rollup_hash @@ -2662,7 +2662,7 @@ let test_origination_deposit_same_block = ~tags:["tx_rollup"; "origination"; "genesis"; "deposit"] (fun protocol -> let* parameter_file = Parameters.parameter_file protocol in - let* (node, client) = + let* node, client = Client.init_with_protocol ~parameter_file `Client ~protocol () in let* contract_id = @@ -2683,8 +2683,7 @@ let test_origination_deposit_same_block = Log.info "Originating rollup" ; let*! tx_rollup_hash = Client.Tx_rollup.originate - ~fee: - (Tez.of_int 100) + ~fee:(Tez.of_int 100) (* High fee to ensure the origination appears in the block before the deposit *) ~src:originator diff --git a/tezt/tests/views.ml b/tezt/tests/views.ml index 89ecfeb35b37..01bd0ec2fc63 100644 --- a/tezt/tests/views.ml +++ b/tezt/tests/views.ml @@ -28,7 +28,7 @@ Component: Michelson Invocation: dune exec tezt/tests/main.exe -- --file views.ml Subject: Call smart contract views to catch performance regressions. - *) +*) (* This contract registers all SOURCE addresses that ever call it. It has views that return registered callers count and the last caller address respectively. *) diff --git a/tezt/tests/voting.ml b/tezt/tests/voting.ml index e852793e0c9e..c557bb4b38bd 100644 --- a/tezt/tests/voting.ml +++ b/tezt/tests/voting.ml @@ -272,10 +272,8 @@ let test_voting ~from_protocol ~(to_protocol : target_protocol) ~loser_protocols (String.concat ", " (List.map Protocol.tag loser_protocols))) ~tags: ("amendment" - :: - ("from_" ^ Protocol.tag from_protocol) - :: - ("to_" ^ target_protocol_tag to_protocol) + :: ("from_" ^ Protocol.tag from_protocol) + :: ("to_" ^ target_protocol_tag to_protocol) :: List.map (fun p -> "loser_" ^ Protocol.tag p) loser_protocols @ [ (match to_protocol with diff --git a/tezt/vesting_contract_test/main.ml b/tezt/vesting_contract_test/main.ml index eaf5773aab4c..ea2f4fab7734 100644 --- a/tezt/vesting_contract_test/main.ml +++ b/tezt/vesting_contract_test/main.ml @@ -39,7 +39,7 @@ migration patches legacy contracts, there's little point in having these tests run in CI. Instead, it should be run manually whenever a change is suspected to break it. - *) +*) let tests = let open Vesting_test in diff --git a/tezt/vesting_contract_test/state.ml b/tezt/vesting_contract_test/state.ml index 87bd4ea65bed..edadd6d1785f 100644 --- a/tezt/vesting_contract_test/state.ml +++ b/tezt/vesting_contract_test/state.ml @@ -35,12 +35,12 @@ let update : ('s -> 's) -> (unit, 's) t = fun f s -> ((), f s) let map : ('a -> 'b) -> ('a, 's) t -> ('b, 's) t = fun f m s -> - let (a, s') = m s in + let a, s' = m s in (f a, s') let bind : ('a -> ('b, 's) t) -> ('a, 's) t -> ('b, 's) t = fun f m s -> - let (a, s') = m s in + let a, s' = m s in f a s' module type MONAD = sig diff --git a/tezt/vesting_contract_test/test_michelson.ml b/tezt/vesting_contract_test/test_michelson.ml index e00785f08b39..b98624344aa2 100644 --- a/tezt/vesting_contract_test/test_michelson.ml +++ b/tezt/vesting_contract_test/test_michelson.ml @@ -101,11 +101,11 @@ let encoding = Data_encoding.string let parse code = - let (tokens, errors) = Micheline_parser.tokenize code in + let tokens, errors = Micheline_parser.tokenize code in let* () = if List.compare_length_with errors 0 >= 0 then Lwt.return () else Test.fail "Couldn't tokenize Micheline!" in - let (expr, errors) = Micheline_parser.parse_expression tokens in + let expr, errors = Micheline_parser.parse_expression tokens in if List.compare_length_with errors 0 >= 0 then Lwt.return expr else Test.fail "Couldn't parse Micheline!" diff --git a/tezt/vesting_contract_test/vesting_test.ml b/tezt/vesting_contract_test/vesting_test.ml index 6ff54b52eb8e..d46bd9604adb 100644 --- a/tezt/vesting_contract_test/vesting_test.ml +++ b/tezt/vesting_contract_test/vesting_test.ml @@ -699,8 +699,7 @@ let vesting_3_keys_2s = let open StateMonad in let* () = activate_alpha in Log.info - "For 4 first users (ids 0-3) give each ꜩ100 and register him as a \ - delegate." ; + "For 4 first users (ids 0-3) give each ꜩ100 and register him as a delegate." ; Log.info "This action automatically starts tracking their balances." ; let* () = iter_int make_delegate 4 in @@ -1145,11 +1144,9 @@ let test_full_contract = in let* () = initialise_vesting_state - ~vesting_increment: - (Tez.of_mutez_int 636089108075) + ~vesting_increment:(Tez.of_mutez_int 636089108075) (* 1/12th of the total initial balance. *) - ~payout_interval: - Ptime.Span.(of_int_s (60 * 60 * 24 * 365 / 12)) + ~payout_interval:Ptime.Span.(of_int_s (60 * 60 * 24 * 365 / 12)) (* Approximately one month. *) ~overall_threshold:4 [ -- GitLab