diff --git a/.gitignore b/.gitignore index 682093b54..cf5ed1f94 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ Version.ml /_opam/ /*.pp.ligo **/.DS_Store +.vscode/ \ No newline at end of file diff --git a/gitlab-pages/docs/contributors/ligo_test_guide.md b/gitlab-pages/docs/contributors/ligo_test_guide.md new file mode 100644 index 000000000..114b662c1 --- /dev/null +++ b/gitlab-pages/docs/contributors/ligo_test_guide.md @@ -0,0 +1,78 @@ +# Testing LIGO + +Adding to the LIGO test suite is one of the more accessible ways to contribute. It exposes you to the compiler structure and primitives without necessarily demanding a deep understanding of OCaml or compiler development. And you'll probably become more familiar with LIGO itself in the process, which is helpful. + +Unfortunately right now LIGO itself doesn't have a good way to do automated testing. So the tests are written in OCaml, outside of the LIGO language. Thankfully the test code is typically less demanding than the features being tested. These tests are currently contained in [src/test](https://gitlab.com/ligolang/ligo/tree/dev/src/test), but the bulk are integration tests which rely on test contracts kept in [src/test/contracts](https://gitlab.com/ligolang/ligo/tree/dev/src/test/contracts). If you're new to LIGO, reading these contracts can be a useful introduction to a given syntax. In the future we plan +to have detailed documentation for each syntax, but at the moment we only have a reference manual for [PascaLIGO](https://gitlab.com/ligolang/ligo/blob/dev/src/passes/1-parser/pascaligo/Doc/pascaligo.md) + +## How To Find Good Test Cases + +Your first question is probably "If I'm not already experienced, how do I know what to test?". There's a handful of things you can do to systematically find good test cases. All of them will either get you more familiar with the LIGO code base or LIGO itself. + +### Extending Existing Test Cases + +The fastest way to improve LIGO's test coverage is to extend existing test cases. This means considering the test cases that already exist, and thinking of things they don't cover or situations they'll fail on. A good deal of inference is required for this, but it requires minimal experience with the existing code. + +### Studying The Parsers For Gaps In Coverage + +LIGO is divided into a **front end** which handles syntax and a **backend** which optimizes and compiles a core language shared between syntaxes. You can find basic test cases for a particular LIGO syntax by studying its parser. You will find these under [src/passes/1-parser](https://gitlab.com/ligolang/ligo/tree/dev/src/passes/1-parser). One kind of useful test focuses on **coverage**, whether we have any testing at all for a particular aspect of a syntax. You can find these by carefully going over the syntax tree for a syntax (probably best read by looking at its `Parser.mly`) and comparing each branch to the test suite. While these tests are plentiful at the time of writing, they will eventually be filled in reliably as part of writing a new syntax. + +### Creating Interesting Test Cases By Using LIGO + +Another kind of useful test focuses on **depth**, whether the features are put through a wide variety of complex scenarios to make sure they stand up to real world use. One of the best ways to write these +is to use LIGO for a real project. This will require some time and energy, not just to learn LIGO but to write projects complex enough to stretch the limits of what the language can do. At the same time however it will get you used to engaging with LIGO from a developers perspective, asking how things could be better or what features are underdeveloped. If your project has practical uses, you will also be contributing to the Tezos/LIGO ecosystem while you learn. Note that because LIGO is open source, in under for us to incorporate your work as a test case it needs to be licensed in a way that's compatible with LIGO. + +### Fuzzing (Speculative) + +In the future you'll be able to [use fuzzing](https://en.wikipedia.org/wiki/Fuzzing) to generate test cases for LIGO. Fuzzing is often useful for finding 'weird' bugs on code paths that humans normally wouldn't stumble into. This makes it a useful supplement to human testing. + +## Structure of LIGO Tests + +LIGO's OCaml-based tests are written in [alcotest](https://github.com/mirage/alcotest/). However the tests you encounter in [src/test/integration_tests.ml](https://gitlab.com/ligolang/ligo/blob/dev/src/test/integration_tests.ml) are built on top of some abstractions, currently defined in [src/test/test_helpers.ml](https://gitlab.com/ligolang/ligo/blob/dev/src/test/test_helpers.ml). The use of these can be inferred fairly well from looking at existing tests, but lets break a few of them down for analysis. We'll first analyze a short integration test for assignment: + +### Assignment Test + let assign () : unit result = + let%bind program = type_file "./contracts/assign.ligo" in + let make_expect = fun n -> n + 1 in + expect_eq_n_int program "main" make_expect + +### assign.ligo + function main (const i : int) : int is + begin + i := i + 1 ; + end with i + + +So what's going on here? We have a function which takes no arguments and returns a `unit result`. We then define two variables, a `program` which is read from disk and fed to the LIGO compiler; and a comparison function `make_expect` which takes an integer and adds one to it. Using `expect_eq_n_int` the `program`'s main function is run and compared to the result of providing the same input to `make_expect`. This gives us some flavor of what to expect from these integration tests. Notice that the `main` argument given to `expect_eq_n_int` corresponds to the name of the function in `assign.ligo`. We can see in more complex tests that we're able to pull the values of arbitrary expressions or function calls from LIGO test contracts. Consider: + +### Annotation Test + let annotation () : unit result = + let%bind program = type_file "./contracts/annotation.ligo" in + let%bind () = + expect_eq_evaluate program "lst" (e_list []) + in + let%bind () = + expect_eq_evaluate program "address" (e_address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") + in + let%bind () = + expect_eq_evaluate program "address_2" (e_address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") + in + ok () + +### annotation.ligo + const lst : list(int) = list [] ; + + const address : address = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" ; + + const address_2 : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ; + +Here what's going on is similar to the last program; `expect_eq_evaluate` runs a program and then pulls a particular named value from the final program state. For example, once the program stops running the value of `address` is `"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"`. The *comparison* however is made to a constructed expression. Remember that we're testing from OCaml, but the program is written and evaluated as LIGO. In order to provide a proper comparison, we convert our expected test values into LIGO expressions and data. Constructors such as `e_list` and `e_address` provide a bridge between LIGO and OCaml. Their definitions can be found in files such as [src/stages/ast_simplified/combinators.ml](https://gitlab.com/ligolang/ligo/blob/dev/src/stages/ast_simplified/combinators.ml), or using [Merlin's definition point finder](https://github.com/ocaml/merlin/wiki). These same functions are used during the simplification stage of LIGO compilation, so becoming familiar with them will help prepare you to work on the [front end](contributors/big-picture/front-end/). + +## How To Write A Test For LIGO + +What if we want to write a test of our own? If the test is in the integration test vein (which it probably is if you're testing new syntax or features), then the process looks something like: + +1. Write a test contract which uses the new syntax or feature in [src/test/contracts](https://gitlab.com/ligolang/ligo/tree/dev/src/test/contracts). +2. Write an integration test in [src/test/integration_tests.ml](https://gitlab.com/ligolang/ligo/blob/dev/src/test/integration_tests.ml) in the vein of existing tests, make sure you add it to the test runner that is currently located at the bottom of the file. +3. Write the feature, assuming it doesn't already exist. Build the resulting version of LIGO without errors. +4. Run the test suite, see if your test(s) pass. If they do, you're probably done. If not it's time to go debugging. diff --git a/gitlab-pages/docs/language-basics/cheat-sheet.md b/gitlab-pages/docs/language-basics/cheat-sheet.md index c754d039f..a93cd6efd 100644 --- a/gitlab-pages/docs/language-basics/cheat-sheet.md +++ b/gitlab-pages/docs/language-basics/cheat-sheet.md @@ -17,7 +17,7 @@ title: Cheat Sheet |Unit| `unit`| |Boolean|
const hasDriversLicense: bool = False;
const adult: bool = True;
| |Boolean Logic|
(not True) == False == (False and True) == (False or False)
| -|Mutez (micro tez)| `42mtz`, `7mtz` | +|Mutez (micro tez)| `42mutez`, `7mutez` | |Address | `"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"`, `"KT1JepfBfMSqkQyf9B1ndvURghGsSB8YCLMD"`| |Addition |`3 + 4`, `3n + 4n`| |Multiplication & Division| `3 * 4`, `3n * 4n`, `10 / 5`, `10n / 5n`| @@ -35,11 +35,12 @@ title: Cheat Sheet |Variants|
type action is
| Increment of int
| Decrement of int
| |Variant *(pattern)* matching|
const a: action = Increment(5);
case a of
| Increment(n) -> n + 1
| Decrement(n) -> n - 1
end
| |Records|
type person is record
  age: int ;
  name: string ;
end

const john : person = record
  age = 18;
  name = "John Doe";
end

const name: string = john.name;
| -|Maps|
type prices is map(nat, tez);

const prices : prices = map
  10n -> 60mtz;
  50n -> 30mtz;
  100n -> 10mtz;
end

const price: option(tez) = prices[50n];

prices[200n] := 5mtz;
| +|Maps|
type prices is map(nat, tez);

const prices : prices = map
  10n -> 60mutez;
  50n -> 30mutez;
  100n -> 10mutez;
end

const price: option(tez) = prices[50n];

prices[200n] := 5mutez;
| |Contracts & Accounts|
const destinationAddress : address = "tz1...";
const contract : contract(unit) = get_contract(destinationAddress);
| |Transactions|
const payment : operation = transaction(unit, amount, receiver);
| |Exception/Failure|`fail("Your descriptive error message for the user goes here.")`| + - \ No newline at end of file + diff --git a/gitlab-pages/docs/language-basics/types.md b/gitlab-pages/docs/language-basics/types.md index 957b6b6c8..501f77544 100644 --- a/gitlab-pages/docs/language-basics/types.md +++ b/gitlab-pages/docs/language-basics/types.md @@ -31,7 +31,7 @@ const dogBreed: animalBreed = "Saluki"; type accountBalances is map(address, tez); const ledger: accountBalances = map - ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address) -> 10mtz + ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address) -> 10mutez end ``` @@ -60,10 +60,10 @@ end type accountBalances is map(account, accountData); // pseudo-JSON representation of our map -// { "tz1...": {balance: 10mtz, numberOfTransactions: 5n} } +// { "tz1...": {balance: 10mutez, numberOfTransactions: 5n} } const ledger: accountBalances = map ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address) -> record - balance = 10mtz; + balance = 10mutez; numberOfTransactions = 5n; end end diff --git a/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.md b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.md index f0d70fe4a..ffc6e5687 100644 --- a/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.md +++ b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.md @@ -134,11 +134,11 @@ To confirm that our contract is valid, we can dry run it. As a result we see a * ligo dry-run taco-shop.ligo --syntax pascaligo --amount 1 buy_taco 1n "map 1n -> record current_stock = 50n; - max_price = 50000000mtz; + max_price = 50000000mutez; end; 2n -> record current_stock = 20n; - max_price = 75000000mtz; + max_price = 75000000mutez; end; end" ``` diff --git a/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.md b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.md index 8dadb49cd..59ea39198 100644 --- a/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.md +++ b/gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.md @@ -28,8 +28,8 @@ Each taco kind, has its own `max_price` that it sells for, and a finite supply f |**kind** |id |**available_stock**| **max_price**| |---|---|---|---| -|el clásico | `1n` | `50n` | `50000000mtz` | -|especial del chef | `2n` | `20n` | `75000000mtz` | +|el clásico | `1n` | `50n` | `50000000mutez` | +|especial del chef | `2n` | `20n` | `75000000mutez` | ### Calculating the current purchase price @@ -42,16 +42,16 @@ current_purchase_price = max_price / available_stock #### El clásico |**available_stock**|**max_price**|**current_purchase_price**| |---|---|---| -| `50n` | `50000000mtz` | `1tz`| -| `20n` | `50000000mtz` | `2.5tz` | -| `5n` | `50000000mtz` | `10tz` | +| `50n` | `50000000mutez` | `1tz`| +| `20n` | `50000000mutez` | `2.5tz` | +| `5n` | `50000000mutez` | `10tz` | #### Especial del chef |**available_stock**|**max_price**|**current_purchase_price**| |---|---|---| -| `20n` | `75000000mtz` | `3.75tz` | -| `10n` | `75000000mtz` | `7.5tz`| -| `5n` | `75000000mtz` | `15tz` | +| `20n` | `75000000mutez` | `3.75tz` | +| `10n` | `75000000mutez` | `7.5tz`| +| `5n` | `75000000mutez` | `15tz` | --- @@ -161,11 +161,11 @@ When dry-running a contract, it's crucial to provide a correct initial storage v map 1n -> record current_stock = 50n; - max_price = 50000000mtz; + max_price = 50000000mutez; end; 2n -> record current_stock = 20n; - max_price = 75000000mtz; + max_price = 75000000mutez; end; end ``` @@ -177,11 +177,11 @@ end ligo dry-run taco-shop.ligo --syntax pascaligo main unit "map 1n -> record current_stock = 50n; - max_price = 50000000mtz; + max_price = 50000000mutez; end; 2n -> record current_stock = 20n; - max_price = 75000000mtz; + max_price = 75000000mutez; end; end" ``` @@ -298,11 +298,11 @@ In order to test the `amount` sent, we'll use the `--amount` option of `dry-run` ligo dry-run taco-shop.ligo --syntax pascaligo --amount 1 buy_taco 1n "map 1n -> record current_stock = 50n; - max_price = 50000000mtz; + max_price = 50000000mutez; end; 2n -> record current_stock = 20n; - max_price = 75000000mtz; + max_price = 75000000mutez; end; end" ``` diff --git a/gitlab-pages/website/pages/en/index.js b/gitlab-pages/website/pages/en/index.js index bd86da348..6fa3459de 100644 --- a/gitlab-pages/website/pages/en/index.js +++ b/gitlab-pages/website/pages/en/index.js @@ -190,7 +190,7 @@ class HomeSplash extends React.Component {

{siteConfig.tagline}

{siteConfig.taglineSub}

Try Online diff --git a/scripts/install_build_environment.sh b/scripts/install_build_environment.sh index 958f855b1..0dd33f068 100755 --- a/scripts/install_build_environment.sh +++ b/scripts/install_build_environment.sh @@ -18,50 +18,76 @@ then fi fi +echo "Installing dependencies.." +if [ -n "`uname -a | grep -i arch`" ] +then + sudo pacman -Sy --noconfirm \ + make \ + m4 \ + gcc \ + patch \ + bubblewrap \ + rsync \ + curl +fi + +if [ -n "`uname -a | grep -i ubuntu`" ] +then sudo apt-get install -y make \ m4 \ gcc \ patch \ bubblewrap \ rsync \ - curl \ + curl +fi if [ -n "`uname -a | grep -i ubuntu`" ] then + echo "ubuntu" sudo add-apt-repository -y ppa:avsm/ppa sudo apt-get update sudo apt-get install opam else - # I'm going to assume here that we're on x86_64, 32-bit users should be basically - # extinct at this point right? - curl -L https://github.com/ocaml/opam/releases/download/2.0.4/opam-2.0.4-x86_64-linux \ - --output opam_temp_version_2_0_4.bin - if [ "`openssl sha256 -r opam_temp_version_2_0_4.bin`" = "373e34f92f282273d482537f8103caad0d17b6f2699ff504bed77f474cb0c951 *opam_temp_version_2_0_4.bin" ] + if [ -n "`uname -a | grep -i arch`" ] then - # Stay paranoid, in case other checks fail don't want to overrwrite - # user's opam on accident - chmod +x opam_temp_version_2_0_4.bin # Set execute so we can get version - if [ -e /usr/local/bin/opam ] - then - opam_old_v=`/usr/local/bin/opam --version` - opam_new_v=`opam_temp_version_2_0_4.bin --version` - read -p "This will overrwrite the opam you have in /usr/local/bin (version $opam_old_v) with version $opam_new_v, do you actually want to do that? Type yes. (yes/n)" choice2 - else - choice2="yes" - fi - if [ $choice2 = "yes" ] - then - sudo mv opam_temp_version_2_0_4.bin /usr/local/bin/opam - else - rm opam_temp_version_2_0_4.bin - exit - fi + echo "arch" + sudo pacman -Sy --noconfirm opam else - echo "opam file hash doesn't match what was recorded at time of signature verification!" - echo "(If you actually get this message, you should probably file an issue)" - echo "https://gitlab.com/ligolang/ligo/issues" - exit 1 - fi + echo "unknown distro" + #I'm going to assume here that we're on x86_64, 32-bit users should be basically + #extinct at this point right? + curl -L https://github.com/ocaml/opam/releases/download/2.0.4/opam-2.0.4-x86_64-linux \ + --output opam_temp_version_2_0_4.bin + if [ "`openssl sha256 -r opam_temp_version_2_0_4.bin`" = "373e34f92f282273d482537f8103caad0d17b6f2699ff504bed77f474cb0c951 *opam_temp_version_2_0_4.bin" ] + then + # Stay paranoid, in case other checks fail don't want to overrwrite + # user's opam on accident + chmod +x opam_temp_version_2_0_4.bin # Set execute so we can get version + if [ -e /usr/local/bin/opam ] + then + opam_old_v=`/usr/local/bin/opam --version` + opam_new_v=`opam_temp_version_2_0_4.bin --version` + read -p "This will overrwrite the opam you have in /usr/local/bin (version $opam_old_v) with version $opam_new_v, do you actually want to do that? Type yes. (yes/n)" choice2 + else + choice2="yes" + fi + if [ $choice2 = "yes" ] + then + sudo mv opam_temp_version_2_0_4.bin /usr/local/bin/opam + else + rm opam_temp_version_2_0_4.bin + exit + fi + else + echo "opam file hash doesn't match what was recorded at time of signature verification!" + echo "(If you actually get this message, you should probably file an issue)" + echo "https://gitlab.com/ligolang/ligo/issues" + exit 1 + fi + fi fi opam init -a --bare + + diff --git a/scripts/install_native_dependencies.sh b/scripts/install_native_dependencies.sh index 6b06f51ad..46e354711 100755 --- a/scripts/install_native_dependencies.sh +++ b/scripts/install_native_dependencies.sh @@ -1,14 +1,31 @@ #!/bin/sh set -e +. /etc/os-release -apt-get update -qq -apt-get -y -qq install \ - libev-dev \ - perl \ - pkg-config \ - libgmp-dev \ - libhidapi-dev \ - m4 \ - libcap-dev \ - bubblewrap \ - rsync +if [ $ID = arch ] +then + pacman -Sy + sudo pacman -S --noconfirm \ + libevdev \ + perl \ + pkg-config \ + gmp \ + hidapi \ + m4 \ + libcap \ + bubblewrap \ + rsync + +else + apt-get update -qq + apt-get -y -qq install \ + libev-dev \ + perl \ + pkg-config \ + libgmp-dev \ + libhidapi-dev \ + m4 \ + libcap-dev \ + bubblewrap \ + rsync +fi diff --git a/scripts/setup_switch.sh b/scripts/setup_switch.sh index ed1e839b2..ee1179109 100755 --- a/scripts/setup_switch.sh +++ b/scripts/setup_switch.sh @@ -2,5 +2,5 @@ set -e set -x -printf '' | opam switch create . 4.07.1 # toto ocaml-base-compiler.4.06.1 +printf '' | opam switch create . ocaml-base-compiler.4.07.1 # toto ocaml-base-compiler.4.06.1 eval $(opam config env) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 36b54b926..5515780a6 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -75,20 +75,26 @@ let display_format = let docv = "DISPLAY_FORMAT" in let doc = "$(docv) is the format that will be used by the CLI. Available formats are 'dev', 'json', and 'human-readable' (default). When human-readable lacks details (we are still tweaking it), please contact us and use another format in the meanwhile." in info ~docv ~doc ["format" ; "display-format"] in - value @@ opt string "human-readable" info + value @@ + opt + (enum [("human-readable", `Human_readable); ("dev", `Dev); ("json", `Json)]) + `Human_readable + info let michelson_code_format = let open Arg in let info = let docv = "MICHELSON_FORMAT" in - let doc = "$(docv) is the format that will be used by compile-contract for the resulting Michelson. Available formats are 'micheline', and 'michelson' (default). Micheline is the format used by [XXX]." in + let doc = "$(docv) is the format that will be used by compile-contract for the resulting Michelson. Available formats are 'text' (default), 'json' and 'hex'." in info ~docv ~doc ["michelson-format"] in - value @@ opt string "michelson" info + value @@ + opt + (enum [("text", `Text); ("json", `Json); ("hex", `Hex)]) + `Text info let compile_file = let f source_file entry_point syntax display_format michelson_format = toplevel ~display_format @@ - let%bind michelson_format = Main.Display.michelson_format_of_string michelson_format in let%bind contract = trace (simple_info "compiling contract to michelson") @@ Ligo.Compile.Of_source.compile_file_contract_entry source_file entry_point (Syntax_name syntax) in @@ -101,29 +107,29 @@ let compile_file = (term , Term.info ~docs cmdname) let compile_parameter = - let f source_file entry_point expression syntax display_format = + let f source_file entry_point expression syntax display_format michelson_format = toplevel ~display_format @@ let%bind value = trace (simple_error "compile-input") @@ Ligo.Run.Of_source.compile_file_contract_parameter source_file entry_point expression (Syntax_name syntax) in - ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value + ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in let term = - Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ display_format) in + Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ display_format $ michelson_code_format) in let cmdname = "compile-parameter" in let docs = "Subcommand: compile parameters to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which calls a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let compile_storage = - let f source_file entry_point expression syntax display_format bigmap = + let f source_file entry_point expression syntax display_format michelson_format bigmap = toplevel ~display_format @@ let%bind value = trace (simple_error "compile-storage") @@ Ligo.Run.Of_source.compile_file_contract_storage ~value:bigmap source_file entry_point expression (Syntax_name syntax) in - ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value + ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in let term = - Term.(const f $ source_file 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ display_format $ bigmap) in + Term.(const f $ source_file 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ display_format $ michelson_code_format $ bigmap) in let cmdname = "compile-storage" in let docs = "Subcommand: compile an initial storage in ligo syntax to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which originates a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) @@ -175,17 +181,17 @@ let evaluate_value = (term , Term.info ~docs cmdname) let compile_expression = - let f expression syntax display_format = + let f expression syntax display_format michelson_format = toplevel ~display_format @@ (* This is an actual compiler entry-point, so we start with a blank state *) let state = Typer.Solver.initial_state in let%bind value = trace (simple_error "compile-input") @@ Ligo.Run.Of_source.compile_expression expression state (Syntax_name syntax) in - ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value + ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in let term = - Term.(const f $ expression "" 0 $ syntax $ display_format) in + Term.(const f $ expression "" 0 $ syntax $ display_format $ michelson_code_format) in let cmdname = "compile-expression" in let docs = "Subcommand: compile to a michelson value." in (term , Term.info ~docs cmdname) diff --git a/src/bin/cli_helpers.ml b/src/bin/cli_helpers.ml index 7057e0975..cb25dd084 100644 --- a/src/bin/cli_helpers.ml +++ b/src/bin/cli_helpers.ml @@ -1,16 +1,9 @@ open Trace open Main.Display -let toplevel ~(display_format : string) (x : string result) = - let display_format = - try display_format_of_string display_format - with _ -> ( - Format.printf "bad display format %s, try looking at DISPLAY_FORMAT in the man (--help)." display_format ; - failwith "Display format" - ) - in +let toplevel ~(display_format : display_format) (x : string result) = match x with - | Ok _ -> Format.printf "%a\n%!" (formatted_string_result_pp display_format) x + | Ok _ -> Format.printf "%a%!" (formatted_string_result_pp display_format) x | Error _ -> - Format.eprintf "%a\n%!" (formatted_string_result_pp display_format) x ; + Format.eprintf "%a%!" (formatted_string_result_pp display_format) x ; exit 1 diff --git a/src/bin/cli_helpers.mli b/src/bin/cli_helpers.mli index 18fce0b58..e3e57f0a5 100644 --- a/src/bin/cli_helpers.mli +++ b/src/bin/cli_helpers.mli @@ -1,3 +1,3 @@ open Trace -val toplevel : display_format : string -> string result -> unit +val toplevel : display_format : Main.Display.display_format -> string result -> unit diff --git a/src/main/display.ml b/src/main/display.ml index 614ca60c7..da22fa883 100644 --- a/src/main/display.ml +++ b/src/main/display.ml @@ -87,13 +87,6 @@ type display_format = [ | `Dev ] -let display_format_of_string = fun s : display_format -> - match s with - | "dev" -> `Dev - | "json" -> `Json - | "human-readable" -> `Human_readable - | _ -> failwith "bad display_format" - let formatted_string_result_pp (display_format : display_format) = match display_format with | `Human_readable -> string_result_pp_hr @@ -101,16 +94,12 @@ let formatted_string_result_pp (display_format : display_format) = | `Json -> string_result_pp_json type michelson_format = [ - | `Michelson - | `Micheline + | `Text + | `Json + | `Hex ] -let michelson_format_of_string = fun s : michelson_format result -> - match s with - | "michelson" -> ok `Michelson - | "micheline" -> ok `Micheline - | _ -> simple_fail "bad michelson format" - let michelson_pp (mf : michelson_format) = match mf with - | `Michelson -> Michelson.pp - | `Micheline -> Michelson.pp_json + | `Text -> Michelson.pp + | `Json -> Michelson.pp_json + | `Hex -> Michelson.pp_hex diff --git a/src/main/display.mli b/src/main/display.mli index dc6cc2408..9dea6d65c 100644 --- a/src/main/display.mli +++ b/src/main/display.mli @@ -21,15 +21,12 @@ type display_format = [ | `Dev ] -val display_format_of_string : string -> display_format - val formatted_string_result_pp : display_format -> Format.formatter -> string Simple_utils.Trace.result -> unit type michelson_format = [ - | `Michelson - | `Micheline + | `Text + | `Json + | `Hex ] -val michelson_format_of_string : string -> michelson_format Simple_utils.Trace.result - val michelson_pp : michelson_format -> Format.formatter -> Tezos_utils.Michelson.michelson -> unit diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 37a9b7e20..41e49c7f3 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -11,15 +11,15 @@ let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (inp let (Ex_ty input_ty) = input in let (Ex_ty output_ty) = output in (* let%bind input_ty_mich = - * Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@ - * Memory_proto_alpha.unparse_michelson_ty input_ty in - * let%bind output_ty_mich = - * Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@ - * Memory_proto_alpha.unparse_michelson_ty output_ty in - * Format.printf "code: %a\n" Michelson.pp program.body ; - * Format.printf "input_ty: %a\n" Michelson.pp input_ty_mich ; - * Format.printf "output_ty: %a\n" Michelson.pp output_ty_mich ; - * Format.printf "input: %a\n" Michelson.pp input_michelson ; *) + Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@ + Memory_proto_alpha.unparse_michelson_ty input_ty in + let%bind output_ty_mich = + Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@ + Memory_proto_alpha.unparse_michelson_ty output_ty in + Format.printf "code: %a\n" Michelson.pp program.body ; + Format.printf "input_ty: %a\n" Michelson.pp input_ty_mich ; + Format.printf "output_ty: %a\n" Michelson.pp output_ty_mich ; + Format.printf "input: %a\n" Michelson.pp input_michelson ; *) let%bind input = Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ Memory_proto_alpha.parse_michelson_data input_michelson input_ty diff --git a/src/passes/1-parser/ligodity/AST.ml b/src/passes/1-parser/ligodity/AST.ml index ae4729117..94c26b736 100644 --- a/src/passes/1-parser/ligodity/AST.ml +++ b/src/passes/1-parser/ligodity/AST.ml @@ -260,7 +260,7 @@ and arith_expr = | Neg of minus un_op reg | Int of (string * Z.t) reg | Nat of (string * Z.t) reg -| Mtz of (string * Z.t) reg +| Mutez of (string * Z.t) reg and logic_expr = BoolExpr of bool_expr @@ -391,7 +391,7 @@ let logic_expr_to_region = function let arith_expr_to_region = function Add {region;_} | Sub {region;_} | Mult {region;_} | Div {region;_} | Mod {region;_} | Neg {region;_} -| Int {region;_} | Mtz {region; _} +| Int {region;_} | Mutez {region; _} | Nat {region; _} -> region let string_expr_to_region = function diff --git a/src/passes/1-parser/ligodity/AST.mli b/src/passes/1-parser/ligodity/AST.mli index 3e4001536..39eed2441 100644 --- a/src/passes/1-parser/ligodity/AST.mli +++ b/src/passes/1-parser/ligodity/AST.mli @@ -265,7 +265,7 @@ and arith_expr = | Neg of minus un_op reg (* -e *) | Int of (string * Z.t) reg (* 12345 *) | Nat of (string * Z.t) reg (* 3p *) -| Mtz of (string * Z.t) reg (* 1.00tz 3tz *) +| Mutez of (string * Z.t) reg (* 1.00tz 3tz *) and logic_expr = BoolExpr of bool_expr diff --git a/src/passes/1-parser/ligodity/LexToken.mli b/src/passes/1-parser/ligodity/LexToken.mli index a30c41714..b58bcece1 100644 --- a/src/passes/1-parser/ligodity/LexToken.mli +++ b/src/passes/1-parser/ligodity/LexToken.mli @@ -31,50 +31,50 @@ type lexeme = string type t = (* Symbols *) - ARROW of Region.t (* "->" *) -| CONS of Region.t (* "::" *) -| CAT of Region.t (* "^" *) - (*| APPEND (* "@" *)*) + ARROW of Region.t (* "->" *) +| CONS of Region.t (* "::" *) +| CAT of Region.t (* "^" *) +(*| APPEND (* "@" *)*) (* Arithmetics *) | MINUS of Region.t (* "-" *) -| PLUS of Region.t (* "+" *) +| PLUS of Region.t (* "+" *) | SLASH of Region.t (* "/" *) -| TIMES of Region.t (* "*" *) +| TIMES of Region.t (* "*" *) (* Compounds *) -| LPAR of Region.t (* "(" *) -| RPAR of Region.t (* ")" *) -| LBRACKET of Region.t (* "[" *) -| RBRACKET of Region.t (* "]" *) -| LBRACE of Region.t (* "{" *) -| RBRACE of Region.t (* "}" *) +| LPAR of Region.t (* "(" *) +| RPAR of Region.t (* ")" *) +| LBRACKET of Region.t (* "[" *) +| RBRACKET of Region.t (* "]" *) +| LBRACE of Region.t (* "{" *) +| RBRACE of Region.t (* "}" *) (* Separators *) -| COMMA of Region.t (* "," *) -| SEMI of Region.t (* ";" *) -| VBAR of Region.t (* "|" *) -| COLON of Region.t (* ":" *) -| DOT of Region.t (* "." *) +| COMMA of Region.t (* "," *) +| SEMI of Region.t (* ";" *) +| VBAR of Region.t (* "|" *) +| COLON of Region.t (* ":" *) +| DOT of Region.t (* "." *) (* Wildcard *) -| WILD of Region.t (* "_" *) +| WILD of Region.t (* "_" *) (* Comparisons *) | EQ of Region.t (* "=" *) -| NE of Region.t (* "<>" *) -| LT of Region.t (* "<" *) -| GT of Region.t (* ">" *) +| NE of Region.t (* "<>" *) +| LT of Region.t (* "<" *) +| GT of Region.t (* ">" *) | LE of Region.t (* "=<" *) -| GE of Region.t (* ">=" *) +| GE of Region.t (* ">=" *) -| BOOL_OR of Region.t (* "||" *) -| BOOL_AND of Region.t(* "&&" *) +| BOOL_OR of Region.t (* "||" *) +| BOOL_AND of Region.t (* "&&" *) (* Identifiers, labels, numbers and strings *) @@ -82,7 +82,7 @@ type t = | Constr of string Region.reg | Int of (string * Z.t) Region.reg | Nat of (string * Z.t) Region.reg -| Mtz of (string * Z.t) Region.reg +| Mutez of (string * Z.t) Region.reg | Str of string Region.reg | Bytes of (string * Hex.t) Region.reg @@ -90,24 +90,24 @@ type t = (*| And*) | Begin of Region.t -| Else of Region.t -| End of Region.t +| Else of Region.t +| End of Region.t | False of Region.t -| Fun of Region.t -| If of Region.t -| In of Region.t -| Let of Region.t +| Fun of Region.t +| If of Region.t +| In of Region.t +| Let of Region.t | Match of Region.t -| Mod of Region.t -| Not of Region.t -| Of of Region.t -| Or of Region.t -| Then of Region.t -| True of Region.t -| Type of Region.t -| With of Region.t +| Mod of Region.t +| Not of Region.t +| Of of Region.t +| Or of Region.t +| Then of Region.t +| True of Region.t +| Type of Region.t +| With of Region.t - (* Liquidity specific *) + (* Liquidity-specific *) | LetEntry of Region.t | MatchNat of Region.t @@ -137,23 +137,20 @@ val to_region : token -> Region.t (* Injections *) -type int_err = - Non_canonical_zero - +type int_err = Non_canonical_zero type ident_err = Reserved_name +type nat_err = Invalid_natural + | Non_canonical_zero_nat +type sym_err = Invalid_symbol -type invalid_natural = - | Invalid_natural - | Non_canonical_zero_nat - +val mk_int : lexeme -> Region.t -> (token, int_err) result +val mk_nat : lexeme -> Region.t -> (token, nat_err) result +val mk_mutez : lexeme -> Region.t -> (token, int_err) result +val mk_ident : lexeme -> Region.t -> (token, ident_err) result +val mk_sym : lexeme -> Region.t -> (token, sym_err) result val mk_string : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token -val mk_int : lexeme -> Region.t -> (token, int_err) result -val mk_nat : lexeme -> Region.t -> (token, invalid_natural) result -val mk_mtz : lexeme -> Region.t -> (token, int_err) result -val mk_ident : lexeme -> Region.t -> (token, ident_err) result val mk_constr : lexeme -> Region.t -> token -val mk_sym : lexeme -> Region.t -> token val eof : Region.t -> token (* Predicates *) diff --git a/src/passes/1-parser/ligodity/LexToken.mll b/src/passes/1-parser/ligodity/LexToken.mll index 74c32cd1a..45794559c 100644 --- a/src/passes/1-parser/ligodity/LexToken.mll +++ b/src/passes/1-parser/ligodity/LexToken.mll @@ -13,50 +13,50 @@ module SSet = Utils.String.Set type t = (* Symbols *) - ARROW of Region.t (* "->" *) -| CONS of Region.t (* "::" *) -| CAT of Region.t (* "^" *) - (*| APPEND (* "@" *)*) + ARROW of Region.t (* "->" *) +| CONS of Region.t (* "::" *) +| CAT of Region.t (* "^" *) +(*| APPEND (* "@" *)*) (* Arithmetics *) -| MINUS of Region.t (* "-" *) -| PLUS of Region.t (* "+" *) -| SLASH of Region.t (* "/" *) -| TIMES of Region.t (* "*" *) +| MINUS of Region.t (* "-" *) +| PLUS of Region.t (* "+" *) +| SLASH of Region.t (* "/" *) +| TIMES of Region.t (* "*" *) (* Compounds *) -| LPAR of Region.t (* "(" *) -| RPAR of Region.t (* ")" *) +| LPAR of Region.t (* "(" *) +| RPAR of Region.t (* ")" *) | LBRACKET of Region.t (* "[" *) | RBRACKET of Region.t (* "]" *) -| LBRACE of Region.t (* "{" *) -| RBRACE of Region.t (* "}" *) +| LBRACE of Region.t (* "{" *) +| RBRACE of Region.t (* "}" *) (* Separators *) -| COMMA of Region.t (* "," *) -| SEMI of Region.t (* ";" *) -| VBAR of Region.t (* "|" *) -| COLON of Region.t (* ":" *) -| DOT of Region.t (* "." *) +| COMMA of Region.t (* "," *) +| SEMI of Region.t (* ";" *) +| VBAR of Region.t (* "|" *) +| COLON of Region.t (* ":" *) +| DOT of Region.t (* "." *) (* Wildcard *) -| WILD of Region.t (* "_" *) +| WILD of Region.t (* "_" *) (* Comparisons *) -| EQ of Region.t (* "=" *) -| NE of Region.t (* "<>" *) -| LT of Region.t (* "<" *) -| GT of Region.t (* ">" *) -| LE of Region.t (* "=<" *) -| GE of Region.t (* ">=" *) +| EQ of Region.t (* "=" *) +| NE of Region.t (* "<>" *) +| LT of Region.t (* "<" *) +| GT of Region.t (* ">" *) +| LE of Region.t (* "=<" *) +| GE of Region.t (* ">=" *) -| BOOL_OR of Region.t (* "||" *) -| BOOL_AND of Region.t (* "&&" *) +| BOOL_OR of Region.t (* "||" *) +| BOOL_AND of Region.t (* "&&" *) (* Identifiers, labels, numbers and strings *) @@ -64,7 +64,7 @@ type t = | Constr of string Region.reg | Int of (string * Z.t) Region.reg | Nat of (string * Z.t) Region.reg -| Mtz of (string * Z.t) Region.reg +| Mutez of (string * Z.t) Region.reg | Str of string Region.reg | Bytes of (string * Hex.t) Region.reg @@ -72,24 +72,24 @@ type t = (*| And*) | Begin of Region.t -| Else of Region.t -| End of Region.t +| Else of Region.t +| End of Region.t | False of Region.t -| Fun of Region.t -| If of Region.t -| In of Region.t -| Let of Region.t +| Fun of Region.t +| If of Region.t +| In of Region.t +| Let of Region.t | Match of Region.t -| Mod of Region.t -| Not of Region.t -| Of of Region.t -| Or of Region.t -| Then of Region.t -| True of Region.t -| Type of Region.t -| With of Region.t +| Mod of Region.t +| Not of Region.t +| Of of Region.t +| Or of Region.t +| Then of Region.t +| True of Region.t +| Type of Region.t +| With of Region.t - (* Liquidity specific *) + (* Liquidity-specific *) | LetEntry of Region.t | MatchNat of Region.t @@ -99,7 +99,7 @@ type t = | Struct *) -(* Virtual tokens *) + (* Virtual tokens *) | EOF of Region.t (* End of file *) @@ -141,8 +141,8 @@ let proj_token = function region, sprintf "Int (\"%s\", %s)" s (Z.to_string n) | Nat Region.{region; value = s,n} -> region, sprintf "Nat (\"%s\", %s)" s (Z.to_string n) - | Mtz Region.{region; value = s,n} -> - region, sprintf "Mtz (\"%s\", %s)" s (Z.to_string n) + | Mutez Region.{region; value = s,n} -> + region, sprintf "Mutez (\"%s\", %s)" s (Z.to_string n) | Str Region.{region; value} -> region, sprintf "Str %s" value | Bytes Region.{region; value = s,b} -> @@ -200,9 +200,9 @@ let to_lexeme = function | BOOL_AND _ -> "&&" | Ident id -> id.Region.value | Constr id -> id.Region.value - | Int i - | Nat i - | Mtz i -> fst i.Region.value + | Int i + | Nat i + | Mutez i -> fst i.Region.value | Str s -> s.Region.value | Bytes b -> fst b.Region.value | Begin _ -> "begin" @@ -264,7 +264,7 @@ let keywords = [ let reserved = let open SSet in - empty + empty |> add "and" |> add "as" |> add "asr" @@ -280,12 +280,9 @@ let reserved = |> add "functor" |> add "inherit" |> add "initializer" - |> add "land" |> add "lazy" - |> add "lor" |> add "lsl" - |> add "lsr" - |> add "lxor" + |> add "lsr" |> add "method" |> add "module" |> add "mutable" @@ -306,7 +303,7 @@ let reserved = let constructors = [ (fun reg -> False reg); - (fun reg -> True reg); + (fun reg -> True reg); ] let add map (key, value) = SMap.add key value map @@ -379,15 +376,14 @@ let mk_int lexeme region = then Error Non_canonical_zero else Ok (Int Region.{region; value = lexeme, z}) -type invalid_natural = - | Invalid_natural - | Non_canonical_zero_nat - +type nat_err = + Invalid_natural +| Non_canonical_zero_nat let mk_nat lexeme region = - match (String.index_opt lexeme 'p') with + match (String.index_opt lexeme 'p') with | None -> Error Invalid_natural - | Some _ -> ( + | Some _ -> ( let z = Str.(global_replace (regexp "_") "" lexeme) |> Str.(global_replace (regexp "p") "") |> @@ -397,46 +393,52 @@ let mk_nat lexeme region = else Ok (Nat Region.{region; value = lexeme, z}) ) -let mk_mtz lexeme region = +let mk_mutez lexeme region = let z = Str.(global_replace (regexp "_") "" lexeme) |> - Str.(global_replace (regexp "mtz") "") |> + Str.(global_replace (regexp "mutez") "") |> Z.of_string in - if Z.equal z Z.zero && lexeme <> "0mtz" + if Z.equal z Z.zero && lexeme <> "0mutez" then Error Non_canonical_zero - else Ok (Mtz Region.{region; value = lexeme, z}) + else Ok (Mutez Region.{region; value = lexeme, z}) let eof region = EOF region +type sym_err = Invalid_symbol + let mk_sym lexeme region = match lexeme with - "->" -> ARROW region - | "::" -> CONS region - | "^" -> CAT region - | "-" -> MINUS region - | "+" -> PLUS region - | "/" -> SLASH region - | "*" -> TIMES region - | "[" -> LBRACKET region - | "]" -> RBRACKET region - | "{" -> LBRACE region - | "}" -> RBRACE region - | "," -> COMMA region - | ";" -> SEMI region - | "|" -> VBAR region - | ":" -> COLON region - | "." -> DOT region - | "_" -> WILD region - | "=" -> EQ region - | "<>" -> NE region - | "<" -> LT region - | ">" -> GT region - | "=<" -> LE region - | ">=" -> GE region - | "||" -> BOOL_OR region - | "&&" -> BOOL_AND region - | "(" -> LPAR region - | ")" -> RPAR region + (* Lexemes in common with all concrete syntaxes *) + ";" -> Ok (SEMI region) + | "," -> Ok (COMMA region) + | "(" -> Ok (LPAR region) + | ")" -> Ok (RPAR region) + | "[" -> Ok (LBRACKET region) + | "]" -> Ok (RBRACKET region) + | "{" -> Ok (LBRACE region) + | "}" -> Ok (RBRACE region) + | "=" -> Ok (EQ region) + | ":" -> Ok (COLON region) + | "|" -> Ok (VBAR region) + | "->" -> Ok (ARROW region) + | "." -> Ok (DOT region) + | "_" -> Ok (WILD region) + | "^" -> Ok (CAT region) + | "+" -> Ok (PLUS region) + | "-" -> Ok (MINUS region) + | "*" -> Ok (TIMES region) + | "/" -> Ok (SLASH region) + | "<" -> Ok (LT region) + | "<=" -> Ok (LE region) + | ">" -> Ok (GT region) + | ">=" -> Ok (GE region) + + + | "<>" -> Ok (NE region) + | "::" -> Ok (CONS region) + | "||" -> Ok (BOOL_OR region) + | "&&" -> Ok (BOOL_AND region) + | a -> failwith ("Not understood token: " ^ a) (* Identifiers *) @@ -533,4 +535,4 @@ let is_sym = function let is_eof = function EOF _ -> true | _ -> false (* END TRAILER *) -} \ No newline at end of file +} diff --git a/src/passes/1-parser/ligodity/ParToken.mly b/src/passes/1-parser/ligodity/ParToken.mly index 342f36953..b64d1ca3a 100644 --- a/src/passes/1-parser/ligodity/ParToken.mly +++ b/src/passes/1-parser/ligodity/ParToken.mly @@ -42,7 +42,7 @@ %token <(string * Z.t) Region.reg> Int %token <(string * Z.t) Region.reg> Nat -%token <(string * Z.t) Region.reg> Mtz +%token <(string * Z.t) Region.reg> Mutez (*%token And*) %token Begin diff --git a/src/passes/1-parser/ligodity/Parser.mly b/src/passes/1-parser/ligodity/Parser.mly index 0c8a5fbac..be1baced3 100644 --- a/src/passes/1-parser/ligodity/Parser.mly +++ b/src/passes/1-parser/ligodity/Parser.mly @@ -761,7 +761,7 @@ call_expr: core_expr: Int { EArith (Int $1) } -| Mtz { EArith (Mtz $1) } +| Mutez { EArith (Mutez $1) } | Nat { EArith (Nat $1) } | Ident | module_field { EVar $1 } | projection { EProj $1 } diff --git a/src/passes/1-parser/ligodity/ParserLog.ml b/src/passes/1-parser/ligodity/ParserLog.ml index 299b2a392..29c13e6ad 100644 --- a/src/passes/1-parser/ligodity/ParserLog.ml +++ b/src/passes/1-parser/ligodity/ParserLog.ml @@ -321,8 +321,8 @@ and print_arith_expr buffer = function | Int {region; value=lex,z} -> let line = sprintf "Int %s (%s)" lex (Z.to_string z) in print_token buffer region line -| Mtz {region; value=lex,z} -> - let line = sprintf "Mtz %s (%s)" lex (Z.to_string z) +| Mutez {region; value=lex,z} -> + let line = sprintf "Mutez %s (%s)" lex (Z.to_string z) in print_token buffer region line | Nat {region; value=lex,z} -> let line = sprintf "Nat %s (%s)" lex (Z.to_string z) diff --git a/src/passes/1-parser/pascaligo.mli b/src/passes/1-parser/pascaligo.mli new file mode 100644 index 000000000..e82d6ab35 --- /dev/null +++ b/src/passes/1-parser/pascaligo.mli @@ -0,0 +1,21 @@ +(* This file provides an interface to the PascaLIGO parser. *) + +open Trace + +module Parser = Parser_pascaligo.Parser +module AST = Parser_pascaligo.AST +module ParserLog = Parser_pascaligo.ParserLog +module LexToken = Parser_pascaligo.LexToken + + +(** Open a PascaLIGO filename given by string and convert into an abstract syntax tree. *) +val parse_file : string -> (AST.t result) + +(** Convert a given string into a PascaLIGO abstract syntax tree *) +val parse_string : string -> AST.t result + +(** Parse a given string as a PascaLIGO expression and return an expression AST. + +This is intended to be used for interactive interpreters, or other scenarios +where you would want to parse a PascaLIGO expression outside of a contract. *) +val parse_expression : string -> AST.expr result diff --git a/src/passes/1-parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml index 44c6c0734..14d2e02e1 100644 --- a/src/passes/1-parser/pascaligo/AST.ml +++ b/src/passes/1-parser/pascaligo/AST.ml @@ -63,7 +63,6 @@ type kwd_not = Region.t type kwd_of = Region.t type kwd_or = Region.t type kwd_patch = Region.t -type kwd_procedure = Region.t type kwd_record = Region.t type kwd_remove = Region.t type kwd_set = Region.t @@ -161,9 +160,9 @@ type t = { and ast = t and declaration = - TypeDecl of type_decl reg -| ConstDecl of const_decl reg -| LambdaDecl of lambda_decl + TypeDecl of type_decl reg +| ConstDecl of const_decl reg +| FunDecl of fun_decl reg and const_decl = { kwd_const : kwd_const; @@ -188,7 +187,7 @@ and type_decl = { and type_expr = TProd of cartesian | TSum of (variant reg, vbar) nsepseq reg -| TRecord of record_type +| TRecord of field_decl reg ne_injection reg | TApp of (type_name * type_tuple) reg | TFun of (type_expr * arrow * type_expr) reg | TPar of type_expr par reg @@ -198,11 +197,9 @@ and cartesian = (type_expr, times) nsepseq reg and variant = { constr : constr; - args : (kwd_of * cartesian) option + args : (kwd_of * type_expr) option } -and record_type = field_decl reg injection reg - and field_decl = { field_name : field_name; colon : colon; @@ -213,33 +210,18 @@ and type_tuple = (type_expr, comma) nsepseq par reg (* Function and procedure declarations *) -and lambda_decl = - FunDecl of fun_decl reg -| ProcDecl of proc_decl reg - and fun_decl = { - kwd_function : kwd_function; - name : variable; - param : parameters; - colon : colon; - ret_type : type_expr; - kwd_is : kwd_is; - local_decls : local_decl list; - block : block reg; - kwd_with : kwd_with; - return : expr; - terminator : semi option -} - -and proc_decl = { - kwd_procedure : kwd_procedure; - name : variable; - param : parameters; - kwd_is : kwd_is; - local_decls : local_decl list; - block : block reg; - terminator : semi option -} + kwd_function : kwd_function; + name : variable; + param : parameters; + colon : colon; + ret_type : type_expr; + kwd_is : kwd_is; + local_decls : local_decl list; + block : block reg option; + kwd_with : kwd_with option; + return : expr; + terminator : semi option } and parameters = (param_decl, semi) nsepseq par reg @@ -284,7 +266,6 @@ and statement = and local_decl = LocalFun of fun_decl reg -| LocalProc of proc_decl reg | LocalData of data_decl and data_decl = @@ -302,12 +283,8 @@ and var_decl = { } and instruction = - Single of single_instr -| Block of block reg - -and single_instr = Cond of conditional reg -| CaseInstr of instruction case reg +| CaseInstr of if_clause case reg | Assign of assignment reg | Loop of loop | ProcCall of fun_call @@ -338,14 +315,14 @@ and set_patch = { kwd_patch : kwd_patch; path : path; kwd_with : kwd_with; - set_inj : expr injection reg + set_inj : expr ne_injection reg } and map_patch = { kwd_patch : kwd_patch; path : path; kwd_with : kwd_with; - map_inj : binding reg injection reg + map_inj : binding reg ne_injection reg } and binding = { @@ -358,7 +335,17 @@ and record_patch = { kwd_patch : kwd_patch; path : path; kwd_with : kwd_with; - record_inj : record_expr + record_inj : field_assign reg ne_injection reg +} + +and cond_expr = { + kwd_if : kwd_if; + test : expr; + kwd_then : kwd_then; + ifso : expr; + terminator : semi option; + kwd_else : kwd_else; + ifnot : expr } and conditional = { @@ -373,7 +360,11 @@ and conditional = { and if_clause = ClauseInstr of instruction -| ClauseBlock of (statements * semi option) braces reg +| ClauseBlock of clause_block + +and clause_block = + LongBlock of block reg +| ShortBlock of (statements * semi option) braces reg and set_membership = { set : expr; @@ -425,10 +416,8 @@ and for_loop = and for_int = { kwd_for : kwd_for; assign : var_assign reg; - down : kwd_down option; kwd_to : kwd_to; bound : expr; - step : (kwd_step * expr) option; block : block reg } @@ -439,18 +428,27 @@ and var_assign = { } and for_collect = { - kwd_for : kwd_for; - var : variable; - bind_to : (arrow * variable) option; - kwd_in : kwd_in; - expr : expr; - block : block reg + kwd_for : kwd_for; + var : variable; + bind_to : (arrow * variable) option; + colon : colon; + elt_type : type_expr; + kwd_in : kwd_in; + collection : collection; + expr : expr; + block : block reg } +and collection = + Map of kwd_map +| Set of kwd_set +| List of kwd_list + (* Expressions *) and expr = -| ECase of expr case reg + ECase of expr case reg +| ECond of cond_expr reg | EAnnot of annot_expr reg | ELogic of logic_expr | EArith of arith_expr @@ -481,6 +479,13 @@ and 'a injection = { closing : closing } +and 'a ne_injection = { + opening : opening; + ne_elements : ('a, semi) nsepseq; + terminator : semi option; + closing : closing +} + and opening = Kwd of keyword | KwdBracket of keyword * lbracket @@ -492,6 +497,7 @@ and closing = and map_expr = MapLookUp of map_lookup reg | MapInj of binding reg injection reg +| BigMapInj of binding reg injection reg and map_lookup = { path : path; @@ -541,7 +547,7 @@ and arith_expr = | Neg of minus un_op reg | Int of (Lexer.lexeme * Z.t) reg | Nat of (Lexer.lexeme * Z.t) reg -| Mtz of (Lexer.lexeme * Z.t) reg +| Mutez of (Lexer.lexeme * Z.t) reg and string_expr = Cat of cat bin_op reg @@ -577,16 +583,13 @@ and selection = FieldName of field_name | Component of (Lexer.lexeme * Z.t) reg -and tuple_expr = - TupleInj of tuple_injection - -and tuple_injection = (expr, comma) nsepseq par reg +and tuple_expr = (expr, comma) nsepseq par reg and none_expr = c_None and fun_call = (fun_name * arguments) reg -and arguments = tuple_injection +and arguments = tuple_expr (* Patterns *) @@ -596,6 +599,7 @@ and pattern = | PVar of Lexer.lexeme reg | PWild of wild | PInt of (Lexer.lexeme * Z.t) reg +| PNat of (Lexer.lexeme * Z.t) reg | PBytes of (Lexer.lexeme * Hex.t) reg | PString of Lexer.lexeme reg | PUnit of c_Unit @@ -643,14 +647,15 @@ let rec expr_to_region = function | EBytes {region; _} | EUnit region | ECase {region;_} +| ECond {region; _} | EPar {region; _} -> region -and tuple_expr_to_region = function - TupleInj {region; _} -> region +and tuple_expr_to_region {region; _} = region and map_expr_to_region = function MapLookUp {region; _} | MapInj {region; _} -> region +| BigMapInj {region; _} -> region and set_expr_to_region = function SetInj {region; _} @@ -676,7 +681,7 @@ and comp_expr_to_region = function | Neq {region; _} -> region and arith_expr_to_region = function -| Add {region; _} + Add {region; _} | Sub {region; _} | Mult {region; _} | Div {region; _} @@ -684,13 +689,13 @@ and arith_expr_to_region = function | Neg {region; _} | Int {region; _} | Nat {region; _} -| Mtz {region; _} -> region +| Mutez {region; _} -> region and string_expr_to_region = function Cat {region; _} | String {region; _} -> region -and annot_expr_to_region ({region; _}) = region +and annot_expr_to_region {region; _} = region and list_expr_to_region = function Cons {region; _} @@ -709,30 +714,34 @@ let path_to_region = function | Path {region; _} -> region let instr_to_region = function - Single Cond {region; _} -| Single CaseInstr {region; _} -| Single Assign {region; _} -| Single Loop While {region; _} -| Single Loop For ForInt {region; _} -| Single Loop For ForCollect {region; _} -| Single ProcCall {region; _} -| Single Skip region -| Single RecordPatch {region; _} -| Single MapPatch {region; _} -| Single SetPatch {region; _} -| Single MapRemove {region; _} -| Single SetRemove {region; _} -| Block {region; _} -> region + Cond {region; _} +| CaseInstr {region; _} +| Assign {region; _} +| Loop While {region; _} +| Loop For ForInt {region; _} +| Loop For ForCollect {region; _} +| ProcCall {region; _} +| Skip region +| RecordPatch {region; _} +| MapPatch {region; _} +| SetPatch {region; _} +| MapRemove {region; _} +| SetRemove {region; _} -> region + +let clause_block_to_region = function + LongBlock {region; _} +| ShortBlock {region; _} -> region let if_clause_to_region = function ClauseInstr instr -> instr_to_region instr -| ClauseBlock {region; _} -> region +| ClauseBlock clause_block -> clause_block_to_region clause_block let pattern_to_region = function PCons {region; _} | PVar {region; _} | PWild region | PInt {region; _} +| PNat {region; _} | PBytes {region; _} | PString {region; _} | PUnit region @@ -748,7 +757,6 @@ let pattern_to_region = function let local_decl_to_region = function LocalFun {region; _} -| LocalProc {region; _} | LocalData LocalConst {region; _} | LocalData LocalVar {region; _} -> region diff --git a/src/passes/1-parser/pascaligo/AST.mli b/src/passes/1-parser/pascaligo/AST.mli index 4984830e0..418d422d3 100644 --- a/src/passes/1-parser/pascaligo/AST.mli +++ b/src/passes/1-parser/pascaligo/AST.mli @@ -47,7 +47,6 @@ type kwd_not = Region.t type kwd_of = Region.t type kwd_or = Region.t type kwd_patch = Region.t -type kwd_procedure = Region.t type kwd_record = Region.t type kwd_remove = Region.t type kwd_set = Region.t @@ -135,8 +134,15 @@ type 'a braces = { rbrace : rbrace } -(* The Abstract Syntax Tree *) +(** The Abstract Syntax Tree +The AST mirrors the contents of Parser.mly, which defines a tree of parsing +productions that are used to make a syntax tree from a given program input. + +This file defines the concrete AST for PascaLIGO, which is used to associate +regions of the source code text with the contents of the syntax tree. + +*) type t = { decl : declaration nseq; eof : eof @@ -145,9 +151,9 @@ type t = { and ast = t and declaration = - TypeDecl of type_decl reg -| ConstDecl of const_decl reg -| LambdaDecl of lambda_decl + TypeDecl of type_decl reg +| ConstDecl of const_decl reg +| FunDecl of fun_decl reg and const_decl = { kwd_const : kwd_const; @@ -172,7 +178,7 @@ and type_decl = { and type_expr = TProd of cartesian | TSum of (variant reg, vbar) nsepseq reg -| TRecord of record_type +| TRecord of field_decl reg ne_injection reg | TApp of (type_name * type_tuple) reg | TFun of (type_expr * arrow * type_expr) reg | TPar of type_expr par reg @@ -182,11 +188,9 @@ and cartesian = (type_expr, times) nsepseq reg and variant = { constr : constr; - args : (kwd_of * cartesian) option + args : (kwd_of * type_expr) option } -and record_type = field_decl reg injection reg - and field_decl = { field_name : field_name; colon : colon; @@ -195,35 +199,20 @@ and field_decl = { and type_tuple = (type_expr, comma) nsepseq par reg -(* Function and procedure declarations *) +(* Function declarations *) -and lambda_decl = - FunDecl of fun_decl reg -| ProcDecl of proc_decl reg - -and fun_decl = { - kwd_function : kwd_function; - name : variable; - param : parameters; - colon : colon; - ret_type : type_expr; - kwd_is : kwd_is; - local_decls : local_decl list; - block : block reg; - kwd_with : kwd_with; - return : expr; - terminator : semi option -} - -and proc_decl = { - kwd_procedure : kwd_procedure; - name : variable; - param : parameters; - kwd_is : kwd_is; - local_decls : local_decl list; - block : block reg; - terminator : semi option -} +and fun_decl ={ + kwd_function : kwd_function; + name : variable; + param : parameters; + colon : colon; + ret_type : type_expr; + kwd_is : kwd_is; + local_decls : local_decl list; + block : block reg option; + kwd_with : kwd_with option; + return : expr; + terminator : semi option } and parameters = (param_decl, semi) nsepseq par reg @@ -268,7 +257,6 @@ and statement = and local_decl = LocalFun of fun_decl reg -| LocalProc of proc_decl reg | LocalData of data_decl and data_decl = @@ -286,12 +274,8 @@ and var_decl = { } and instruction = - Single of single_instr -| Block of block reg - -and single_instr = Cond of conditional reg -| CaseInstr of instruction case reg +| CaseInstr of if_clause case reg | Assign of assignment reg | Loop of loop | ProcCall of fun_call @@ -322,14 +306,14 @@ and set_patch = { kwd_patch : kwd_patch; path : path; kwd_with : kwd_with; - set_inj : expr injection reg + set_inj : expr ne_injection reg } and map_patch = { kwd_patch : kwd_patch; path : path; kwd_with : kwd_with; - map_inj : binding reg injection reg + map_inj : binding reg ne_injection reg } and binding = { @@ -342,7 +326,17 @@ and record_patch = { kwd_patch : kwd_patch; path : path; kwd_with : kwd_with; - record_inj : field_assign reg injection reg + record_inj : field_assign reg ne_injection reg +} + +and cond_expr = { + kwd_if : kwd_if; + test : expr; + kwd_then : kwd_then; + ifso : expr; + terminator : semi option; + kwd_else : kwd_else; + ifnot : expr } and conditional = { @@ -357,7 +351,11 @@ and conditional = { and if_clause = ClauseInstr of instruction -| ClauseBlock of (statements * semi option) braces reg +| ClauseBlock of clause_block + +and clause_block = + LongBlock of block reg +| ShortBlock of (statements * semi option) braces reg and set_membership = { set : expr; @@ -409,10 +407,8 @@ and for_loop = and for_int = { kwd_for : kwd_for; assign : var_assign reg; - down : kwd_down option; kwd_to : kwd_to; bound : expr; - step : (kwd_step * expr) option; block : block reg } @@ -423,18 +419,27 @@ and var_assign = { } and for_collect = { - kwd_for : kwd_for; - var : variable; - bind_to : (arrow * variable) option; - kwd_in : kwd_in; - expr : expr; - block : block reg + kwd_for : kwd_for; + var : variable; + bind_to : (arrow * variable) option; + colon : colon; + elt_type : type_expr; + kwd_in : kwd_in; + collection : collection; + expr : expr; + block : block reg } +and collection = + Map of kwd_map +| Set of kwd_set +| List of kwd_list + (* Expressions *) and expr = -| ECase of expr case reg + ECase of expr case reg +| ECond of cond_expr reg | EAnnot of annot_expr reg | ELogic of logic_expr | EArith of arith_expr @@ -465,6 +470,13 @@ and 'a injection = { closing : closing } +and 'a ne_injection = { + opening : opening; + ne_elements : ('a, semi) nsepseq; + terminator : semi option; + closing : closing +} + and opening = Kwd of keyword | KwdBracket of keyword * lbracket @@ -476,6 +488,7 @@ and closing = and map_expr = MapLookUp of map_lookup reg | MapInj of binding reg injection reg +| BigMapInj of binding reg injection reg and map_lookup = { path : path; @@ -525,7 +538,7 @@ and arith_expr = | Neg of minus un_op reg | Int of (Lexer.lexeme * Z.t) reg | Nat of (Lexer.lexeme * Z.t) reg -| Mtz of (Lexer.lexeme * Z.t) reg +| Mutez of (Lexer.lexeme * Z.t) reg and string_expr = Cat of cat bin_op reg @@ -561,16 +574,13 @@ and selection = FieldName of field_name | Component of (Lexer.lexeme * Z.t) reg -and tuple_expr = - TupleInj of tuple_injection - -and tuple_injection = (expr, comma) nsepseq par reg +and tuple_expr = (expr, comma) nsepseq par reg and none_expr = c_None and fun_call = (fun_name * arguments) reg -and arguments = tuple_injection +and arguments = tuple_expr (* Patterns *) @@ -580,6 +590,7 @@ and pattern = | PVar of Lexer.lexeme reg | PWild of wild | PInt of (Lexer.lexeme * Z.t) reg +| PNat of (Lexer.lexeme * Z.t) reg | PBytes of (Lexer.lexeme * Hex.t) reg | PString of Lexer.lexeme reg | PUnit of c_Unit diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo.md b/src/passes/1-parser/pascaligo/Doc/pascaligo.md index e9802ebab..5bb9044c3 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo.md +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo.md @@ -327,23 +327,23 @@ expression, typically performing a side effect. There are three kinds of native numerical types in PascaLIGO: `int`, `nat` and `tez`. - * The first is the type of signed integers, e.g., `-4`, `0` or +* The first is the type of signed integers, e.g., `-4`, `0` or `13`. Note that the value zero has a canonical form, `0`, and no other, for example `00` is invalid. Also, for the sake of convenience, underscores are allowed in the literals, like `1_000_000`. - * The second numerical type is the type of the natural numbers, -e.g., `0n` or `13n`. Note that the `nat` literals must be annotated -with the suffix `n`, which distinguishes them from `int` literals. The -same convenient use of underscores as with integer literals is allowed -too and the canonical form of zero is `0n`. +* The second numerical type is the type of the natural numbers, e.g., +`0n` or `13n`. Note that the `nat` literals must be annotated with the +suffix `n`, which distinguishes them from `int` literals. The same +convenient use of underscores as with integer literals is allowed too +and the canonical form of zero is `0n`. - * The last kind of native numerical type is `tez`, which is a unit -of measure of the amounts (fees, accounts). Beware: the literals of -the type `tez` are annotated with the suffix `mtz`, which stands for -millionth of Tez, for instance, `0mtz` or `1200000mtz`. The same handy -use of underscores as in natural literals help in the writing, like -`1_200_000mtz`. +* The last kind of native numerical type is `tez`, which is a unit of +measure of the amounts (fees, accounts). Beware: the literals of the +type `tez` are annotated with the suffix `mutez`, which stands for +millionth of Tez, for instance, `0mutez` or `1200000mutez`. The same +handy use of underscores as in natural literals help in the writing, +like `1_200_000mutez`. To see how numerical types can be used in expressions see the sections "Predefined operators" and "Predefined values". @@ -533,14 +533,13 @@ in terse style (see section "Predefined types and values/Lists"). Given a tuple `t` with _n_ components, the `i`th component is - t.(i) + t.i -where `t.(0)` is the first component. For example, given the -declaration +where `t.0` is the first component. For example, given the declaration const t : int * string = (4, "four") -the expression `t.(1)` has the value `"four"`. +the expression `t.1` has the value `"four"`. #### Records @@ -833,7 +832,7 @@ example, in verbose style: A value of that type could be record - goal = 10mtz; + goal = 10mutez; deadline = "..."; backers = map end; funded = False diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_01.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_01.bnf index d7c05f76d..169764eff 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_01.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_01.bnf @@ -331,7 +331,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | var | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_02.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_02.bnf index a8fd7f688..7abf65aa1 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_02.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_02.bnf @@ -337,7 +337,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | var | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_03.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_03.bnf index f7893cf6d..bc52b864d 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_03.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_03.bnf @@ -317,7 +317,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_04.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_04.bnf index 5f344787a..dac66db62 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_04.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_04.bnf @@ -295,7 +295,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_05.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_05.bnf index d88b74f78..9dd951d94 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_05.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_05.bnf @@ -289,7 +289,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_06.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_06.bnf index f16a91dba..cd4c7751d 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_06.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_06.bnf @@ -292,7 +292,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_07.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_07.bnf index a6d801368..d972db4ae 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_07.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_07.bnf @@ -279,7 +279,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_08.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_08.bnf index f459f2193..5d3bbe886 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_08.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_08.bnf @@ -284,7 +284,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_09.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_09.bnf index 0b15db3ac..1576befbc 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_09.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_09.bnf @@ -288,7 +288,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_10.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_10.bnf index ae956b3c7..b167eb01a 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_10.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_10.bnf @@ -283,7 +283,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_11.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_11.bnf index 569b16392..ede2ceacd 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_11.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_11.bnf @@ -281,7 +281,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) brackets(expr) (* lookup *) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_12.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_12.bnf index 47c399337..bded0f013 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_12.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_12.bnf @@ -285,7 +285,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) option(brackets(expr)) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_13.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_13.bnf index 7b8146e1c..52ac22ba0 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_13.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_13.bnf @@ -285,7 +285,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) option(brackets(expr)) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_14.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_14.bnf index 4973e59b6..69a710b79 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_14.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_14.bnf @@ -285,7 +285,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) option(brackets(expr)) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_15.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_15.bnf index 3f26f6494..b3713e285 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_15.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_15.bnf @@ -285,7 +285,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) option(brackets(expr)) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_16.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_16.bnf index ab6844335..e50db4584 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_16.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_16.bnf @@ -285,7 +285,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) option(brackets(expr)) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_17.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_17.bnf index 7a1f4c926..09cefcc77 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_17.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_17.bnf @@ -285,7 +285,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) option(brackets(expr)) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_18.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_18.bnf index 6d7911a23..0cd754062 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_18.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_18.bnf @@ -285,7 +285,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) option(brackets(expr)) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_19.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_19.bnf index 937290d18..8ca3db982 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_19.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_19.bnf @@ -285,7 +285,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) option(brackets(expr)) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_20.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_20.bnf index 3afe57b98..cdb3cb15a 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_20.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_20.bnf @@ -270,7 +270,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident (* var *) | Ident (* var *) brackets(expr) (* lookup *) | Ident (* struct_name *) DOT nsepseq(selection,DOT) option(brackets(expr)) diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_21.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_21.bnf index d99ef835b..a9a825601 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_21.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_21.bnf @@ -291,7 +291,7 @@ unary_expr ::= core_expr ::= Int | Nat -| Mtz +| Mutez | Ident option(core_suffix) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo_22.bnf b/src/passes/1-parser/pascaligo/Doc/pascaligo_22.bnf index 6eb0e8dc1..93924bb5c 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo_22.bnf +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo_22.bnf @@ -349,7 +349,7 @@ XXX core_expr ::= Int | Nat -| Mtz +| Mutez | Ident option(core_suffix) | String | Bytes diff --git a/src/passes/1-parser/pascaligo/LexToken.mli b/src/passes/1-parser/pascaligo/LexToken.mli index 49998a2e1..f569dc6a2 100644 --- a/src/passes/1-parser/pascaligo/LexToken.mli +++ b/src/passes/1-parser/pascaligo/LexToken.mli @@ -1,4 +1,4 @@ -(* This signature defines the lexical tokens for LIGO +(** This signature defines the lexical tokens for LIGO _Tokens_ are the abstract units which are used by the parser to build the abstract syntax tree (AST), in other words, the stream of @@ -35,7 +35,7 @@ type t = | Bytes of (lexeme * Hex.t) Region.reg | Int of (lexeme * Z.t) Region.reg | Nat of (lexeme * Z.t) Region.reg -| Mtz of (lexeme * Z.t) Region.reg +| Mutez of (lexeme * Z.t) Region.reg | Ident of lexeme Region.reg | Constr of lexeme Region.reg @@ -53,13 +53,13 @@ type t = | VBAR of Region.t (* "|" *) | ARROW of Region.t (* "->" *) | ASS of Region.t (* ":=" *) -| EQUAL of Region.t (* "=" *) +| EQ of Region.t (* "=" *) | COLON of Region.t (* ":" *) | LT of Region.t (* "<" *) -| LEQ of Region.t (* "<=" *) +| LE of Region.t (* "<=" *) | GT of Region.t (* ">" *) -| GEQ of Region.t (* ">=" *) -| NEQ of Region.t (* "=/=" *) +| GE of Region.t (* ">=" *) +| NE of Region.t (* "=/=" *) | PLUS of Region.t (* "+" *) | MINUS of Region.t (* "-" *) | SLASH of Region.t (* "/" *) @@ -137,23 +137,20 @@ val to_region : token -> Region.t (* Injections *) -type int_err = - Non_canonical_zero - +type int_err = Non_canonical_zero type ident_err = Reserved_name +type nat_err = Invalid_natural + | Non_canonical_zero_nat +type sym_err = Invalid_symbol -type invalid_natural = - | Invalid_natural - | Non_canonical_zero_nat - +val mk_int : lexeme -> Region.t -> (token, int_err) result +val mk_nat : lexeme -> Region.t -> (token, nat_err) result +val mk_mutez : lexeme -> Region.t -> (token, int_err) result +val mk_ident : lexeme -> Region.t -> (token, ident_err) result +val mk_sym : lexeme -> Region.t -> (token, sym_err) result val mk_string : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token -val mk_int : lexeme -> Region.t -> (token, int_err) result -val mk_nat : lexeme -> Region.t -> (token, invalid_natural) result -val mk_mtz : lexeme -> Region.t -> (token, int_err) result -val mk_ident : lexeme -> Region.t -> (token, ident_err) result val mk_constr : lexeme -> Region.t -> token -val mk_sym : lexeme -> Region.t -> token val eof : Region.t -> token (* Predicates *) diff --git a/src/passes/1-parser/pascaligo/LexToken.mll b/src/passes/1-parser/pascaligo/LexToken.mll index b92ae7edd..44922ee8c 100644 --- a/src/passes/1-parser/pascaligo/LexToken.mll +++ b/src/passes/1-parser/pascaligo/LexToken.mll @@ -33,7 +33,7 @@ type t = | Bytes of (lexeme * Hex.t) Region.reg | Int of (lexeme * Z.t) Region.reg | Nat of (lexeme * Z.t) Region.reg -| Mtz of (lexeme * Z.t) Region.reg +| Mutez of (lexeme * Z.t) Region.reg | Ident of lexeme Region.reg | Constr of lexeme Region.reg @@ -51,13 +51,13 @@ type t = | VBAR of Region.t | ARROW of Region.t | ASS of Region.t -| EQUAL of Region.t +| EQ of Region.t | COLON of Region.t | LT of Region.t -| LEQ of Region.t +| LE of Region.t | GT of Region.t -| GEQ of Region.t -| NEQ of Region.t +| GE of Region.t +| NE of Region.t | PLUS of Region.t | MINUS of Region.t | SLASH of Region.t @@ -160,8 +160,8 @@ let proj_token = function | Nat Region.{region; value = s,n} -> region, sprintf "Nat (\"%s\", %s)" s (Z.to_string n) -| Mtz Region.{region; value = s,n} -> - region, sprintf "Mtz (\"%s\", %s)" s (Z.to_string n) +| Mutez Region.{region; value = s,n} -> + region, sprintf "Mutez (\"%s\", %s)" s (Z.to_string n) | Ident Region.{region; value} -> region, sprintf "Ident \"%s\"" value @@ -183,13 +183,13 @@ let proj_token = function | VBAR region -> region, "VBAR" | ARROW region -> region, "ARROW" | ASS region -> region, "ASS" -| EQUAL region -> region, "EQUAL" +| EQ region -> region, "EQ" | COLON region -> region, "COLON" | LT region -> region, "LT" -| LEQ region -> region, "LEQ" +| LE region -> region, "LE" | GT region -> region, "GT" -| GEQ region -> region, "GEQ" -| NEQ region -> region, "NEQ" +| GE region -> region, "GE" +| NE region -> region, "NE" | PLUS region -> region, "PLUS" | MINUS region -> region, "MINUS" | SLASH region -> region, "SLASH" @@ -258,7 +258,7 @@ let to_lexeme = function | Bytes b -> fst b.Region.value | Int i | Nat i -| Mtz i -> fst i.Region.value +| Mutez i -> fst i.Region.value | Ident id | Constr id -> id.Region.value @@ -276,13 +276,13 @@ let to_lexeme = function | VBAR _ -> "|" | ARROW _ -> "->" | ASS _ -> ":=" -| EQUAL _ -> "=" +| EQ _ -> "=" | COLON _ -> ":" | LT _ -> "<" -| LEQ _ -> "<=" +| LE _ -> "<=" | GT _ -> ">" -| GEQ _ -> ">=" -| NEQ _ -> "=/=" +| GE _ -> ">=" +| NE _ -> "=/=" | PLUS _ -> "+" | MINUS _ -> "-" | SLASH _ -> "/" @@ -480,9 +480,9 @@ let mk_int lexeme region = then Error Non_canonical_zero else Ok (Int Region.{region; value = lexeme, z}) -type invalid_natural = - | Invalid_natural - | Non_canonical_zero_nat +type nat_err = + Invalid_natural +| Non_canonical_zero_nat let mk_nat lexeme region = match (String.index_opt lexeme 'n') with @@ -497,46 +497,53 @@ let mk_nat lexeme region = else Ok (Nat Region.{region; value = lexeme, z}) ) -let mk_mtz lexeme region = +let mk_mutez lexeme region = let z = Str.(global_replace (regexp "_") "" lexeme) |> - Str.(global_replace (regexp "mtz") "") |> + Str.(global_replace (regexp "mutez") "") |> Z.of_string in - if Z.equal z Z.zero && lexeme <> "0mtz" + if Z.equal z Z.zero && lexeme <> "0mutez" then Error Non_canonical_zero - else Ok (Mtz Region.{region; value = lexeme, z}) + else Ok (Mutez Region.{region; value = lexeme, z}) let eof region = EOF region +type sym_err = Invalid_symbol + let mk_sym lexeme region = match lexeme with - ";" -> SEMI region - | "," -> COMMA region - | "(" -> LPAR region - | ")" -> RPAR region - | "{" -> LBRACE region - | "}" -> RBRACE region - | "[" -> LBRACKET region - | "]" -> RBRACKET region - | "#" -> CONS region - | "|" -> VBAR region - | "->" -> ARROW region - | ":=" -> ASS region - | "=" -> EQUAL region - | ":" -> COLON region - | "<" -> LT region - | "<=" -> LEQ region - | ">" -> GT region - | ">=" -> GEQ region - | "=/=" -> NEQ region - | "+" -> PLUS region - | "-" -> MINUS region - | "/" -> SLASH region - | "*" -> TIMES region - | "." -> DOT region - | "_" -> WILD region - | "^" -> CAT region - | _ -> assert false + (* Lexemes in common with all concrete syntaxes *) + ";" -> Ok (SEMI region) + | "," -> Ok (COMMA region) + | "(" -> Ok (LPAR region) + | ")" -> Ok (RPAR region) + | "[" -> Ok (LBRACKET region) + | "]" -> Ok (RBRACKET region) + | "{" -> Ok (LBRACE region) + | "}" -> Ok (RBRACE region) + | "=" -> Ok (EQ region) + | ":" -> Ok (COLON region) + | "|" -> Ok (VBAR region) + | "->" -> Ok (ARROW region) + | "." -> Ok (DOT region) + | "_" -> Ok (WILD region) + | "^" -> Ok (CAT region) + | "+" -> Ok (PLUS region) + | "-" -> Ok (MINUS region) + | "*" -> Ok (TIMES region) + | "/" -> Ok (SLASH region) + | "<" -> Ok (LT region) + | "<=" -> Ok (LE region) + | ">" -> Ok (GT region) + | ">=" -> Ok (GE region) + + (* Lexemes specific to PascaLIGO *) + | "=/=" -> Ok (NE region) + | "#" -> Ok (CONS region) + | ":=" -> Ok (ASS region) + + (* Invalid lexemes *) + | _ -> Error Invalid_symbol (* Identifiers *) @@ -632,13 +639,13 @@ let is_sym = function | VBAR _ | ARROW _ | ASS _ -| EQUAL _ +| EQ _ | COLON _ | LT _ -| LEQ _ +| LE _ | GT _ -| GEQ _ -| NEQ _ +| GE _ +| NE _ | PLUS _ | MINUS _ | SLASH _ diff --git a/src/passes/1-parser/pascaligo/ParToken.mly b/src/passes/1-parser/pascaligo/ParToken.mly index 49f77b8d3..9d3d14e10 100644 --- a/src/passes/1-parser/pascaligo/ParToken.mly +++ b/src/passes/1-parser/pascaligo/ParToken.mly @@ -9,7 +9,7 @@ %token <(LexToken.lexeme * Hex.t) Region.reg> Bytes %token <(LexToken.lexeme * Z.t) Region.reg> Int %token <(LexToken.lexeme * Z.t) Region.reg> Nat -%token <(LexToken.lexeme * Z.t) Region.reg> Mtz +%token <(LexToken.lexeme * Z.t) Region.reg> Mutez %token Ident %token Constr @@ -27,13 +27,13 @@ %token VBAR (* "|" *) %token ARROW (* "->" *) %token ASS (* ":=" *) -%token EQUAL (* "=" *) +%token EQ (* "=" *) %token COLON (* ":" *) %token LT (* "<" *) -%token LEQ (* "<=" *) +%token LE (* "<=" *) %token GT (* ">" *) -%token GEQ (* ">=" *) -%token NEQ (* "=/=" *) +%token GE (* ">=" *) +%token NE (* "=/=" *) %token PLUS (* "+" *) %token MINUS (* "-" *) %token SLASH (* "/" *) @@ -51,7 +51,6 @@ %token Case (* "case" *) %token Const (* "const" *) %token Contains (* "contains" *) -%token Down (* "down" *) %token Else (* "else" *) %token End (* "end" *) %token For (* "for" *) @@ -68,12 +67,10 @@ %token Of (* "of" *) %token Or (* "or" *) %token Patch (* "patch" *) -%token Procedure (* "procedure" *) %token Record (* "record" *) %token Remove (* "remove" *) %token Set (* "set" *) %token Skip (* "skip" *) -%token Step (* "step" *) %token Then (* "then" *) %token To (* "to" *) %token Type (* "type" *) diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly index 55729ed77..a23fb5e9a 100644 --- a/src/passes/1-parser/pascaligo/Parser.mly +++ b/src/passes/1-parser/pascaligo/Parser.mly @@ -114,9 +114,9 @@ contract: } declaration: - type_decl { TypeDecl $1 } -| const_decl { ConstDecl $1 } -| lambda_decl { LambdaDecl $1 } + type_decl { TypeDecl $1 } +| const_decl { ConstDecl $1 } +| fun_decl { FunDecl $1 } (* Type declarations *) @@ -137,23 +137,27 @@ type_decl: } type_expr: - cartesian { TProd $1 } -| sum_type { TSum $1 } + sum_type { TSum $1 } | record_type { TRecord $1 } +| cartesian { $1 } cartesian: - nsepseq(function_type,TIMES) { - let region = nsepseq_to_region type_expr_to_region $1 - in {region; value=$1}} + function_type TIMES nsepseq(function_type,TIMES) { + let value = Utils.nsepseq_cons $1 $2 $3 in + let region = nsepseq_to_region type_expr_to_region value + in TProd {region; value} + } +| function_type { ($1 : type_expr) } function_type: core_type { $1 } | core_type ARROW function_type { - let region = cover (type_expr_to_region $1) - (type_expr_to_region $3) - in TFun {region; value = ($1, $2, $3)} } + let start = type_expr_to_region $1 + and stop = type_expr_to_region $3 in + let region = cover start stop in + TFun {region; value = $1,$2,$3} } core_type: type_name { @@ -200,7 +204,7 @@ sum_type: variant: Constr Of cartesian { - let region = cover $1.region $3.region + let region = cover $1.region (type_expr_to_region $3) and value = {constr = $1; args = Some ($2, $3)} in {region; value} } @@ -209,21 +213,21 @@ variant: record_type: Record sep_or_term_list(field_decl,SEMI) End { - let elements, terminator = $2 in + let ne_elements, terminator = $2 in let region = cover $1 $3 - and value = { + and value = { opening = Kwd $1; - elements = Some elements; + ne_elements; terminator; closing = End $3} in {region; value} } | Record LBRACKET sep_or_term_list(field_decl,SEMI) RBRACKET { - let elements, terminator = $3 in + let ne_elements, terminator = $3 in let region = cover $1 $4 - and value = { + and value = { opening = KwdBracket ($1,$2); - elements = Some elements; + ne_elements; terminator; closing = RBracket $4} in {region; value} } @@ -235,11 +239,7 @@ field_decl: and value = {field_name = $1; colon = $2; field_type = $3} in {region; value} } -(* Function and procedure declarations *) - -lambda_decl: - fun_decl { FunDecl $1 } -| proc_decl { ProcDecl $1 } +(* Function declarations *) fun_decl: Function fun_name parameters COLON type_expr Is @@ -259,31 +259,32 @@ fun_decl: ret_type = $5; kwd_is = $6; local_decls = $7; - block = $8; - kwd_with = $9; + block = Some $8; + kwd_with = Some $9; return = $10; terminator = $11} - in {region; value}} - -proc_decl: - Procedure fun_name parameters Is - seq(local_decl) - block option(SEMI) - { - let stop = - match $7 with - Some region -> region - | None -> $6.region in - let region = cover $1 stop - and value = { - kwd_procedure = $1; - name = $2; - param = $3; - kwd_is = $4; - local_decls = $5; - block = $6; - terminator = $7} - in {region; value}} + in {region;value}} + | Function fun_name parameters COLON type_expr Is + expr option(SEMI) { + let stop = + match $8 with + Some region -> region + | None -> expr_to_region $7 in + let region = cover $1 stop + and value = { + kwd_function = $1; + name = $2; + param = $3; + colon = $4; + ret_type = $5; + kwd_is = $6; + local_decls = []; + block = None; + kwd_with = None; + return = $7; + terminator = $8; + } + in {region;value}} parameters: par(nsepseq(param_decl,SEMI)) { $1 } @@ -310,7 +311,7 @@ param_decl: in ParamConst {region; value}} param_type: - cartesian { TProd $1 } + cartesian { $1 } block: Begin sep_or_term_list(statement,SEMI) End { @@ -342,7 +343,7 @@ open_data_decl: | open_var_decl { LocalVar $1 } open_const_decl: - Const unqualified_decl(EQUAL) { + Const unqualified_decl(EQ) { let name, colon, const_type, equal, init, stop = $2 in let region = cover $1 stop and value = { @@ -371,7 +372,6 @@ open_var_decl: local_decl: fun_decl { LocalFun $1 } -| proc_decl { LocalProc $1 } | data_decl { LocalData $1 } data_decl: @@ -398,10 +398,6 @@ var_decl: | open_var_decl { $1 } instruction: - single_instr { Single $1 } -| block { Block $1 } - -single_instr: conditional { Cond $1 } | case_instr { CaseInstr $1 } | assignment { Assign $1 } @@ -437,7 +433,7 @@ map_remove: in {region; value}} set_patch: - Patch path With injection(Set,expr) { + Patch path With ne_injection(Set,expr) { let region = cover $1 $4.region in let value = { kwd_patch = $1; @@ -447,7 +443,7 @@ set_patch: in {region; value}} map_patch: - Patch path With injection(Map,binding) { + Patch path With ne_injection(Map,binding) { let region = cover $1 $4.region in let value = { kwd_patch = $1; @@ -495,6 +491,28 @@ injection(Kind,element): closing = RBracket $3} in {region; value}} +ne_injection(Kind,element): + Kind sep_or_term_list(element,SEMI) End { + let ne_elements, terminator = $2 in + let region = cover $1 $3 + and value = { + opening = Kwd $1; + ne_elements; + terminator; + closing = End $3} + in {region; value} + } +| Kind LBRACKET sep_or_term_list(element,SEMI) RBRACKET { + let ne_elements, terminator = $3 in + let region = cover $1 $4 + and value = { + opening = KwdBracket ($1,$2); + ne_elements; + terminator; + closing = RBracket $4} + in {region; value} + } + binding: expr ARROW expr { let start = expr_to_region $1 @@ -507,7 +525,7 @@ binding: in {region; value}} record_patch: - Patch path With record_expr { + Patch path With ne_injection(Record,field_assignment) { let region = cover $1 $4.region in let value = { kwd_patch = $1; @@ -522,7 +540,7 @@ proc_call: conditional: If expr Then if_clause option(SEMI) Else if_clause { let region = cover $1 (if_clause_to_region $7) in - let value = { + let value : conditional = { kwd_if = $1; test = $2; kwd_then = $3; @@ -533,19 +551,22 @@ conditional: in {region; value} } if_clause: - instruction { - ClauseInstr $1 - } + instruction { ClauseInstr $1 } +| clause_block { ClauseBlock $1 } + +clause_block: + block { + LongBlock $1 } | LBRACE sep_or_term_list(statement,SEMI) RBRACE { - let region = cover $1 $3 in - let value = { - lbrace = $1; - inside = $2; - rbrace = $3} in - ClauseBlock {value; region} } + let region = cover $1 $3 in + let value = { + lbrace = $1; + inside = $2; + rbrace = $3} in + ShortBlock {value; region} } case_instr: - case(instruction) { $1 instr_to_region } + case(if_clause) { $1 if_clause_to_region } case(rhs): Case expr Of option(VBAR) cases(rhs) End { @@ -616,38 +637,42 @@ while_loop: in While {region; value}} for_loop: - For var_assign Down? To expr option(step_clause) block { - let region = cover $1 $7.region in + For var_assign To expr block { + let region = cover $1 $5.region in let value = { kwd_for = $1; assign = $2; - down = $3; - kwd_to = $4; - bound = $5; - step = $6; - block = $7} + kwd_to = $3; + bound = $4; + block = $5} in For (ForInt {region; value}) } -| For var option(arrow_clause) In expr block { - let region = cover $1 $6.region in +| For var option(arrow_clause) COLON type_expr + In collection expr block { + let region = cover $1 $9.region in let value = { - kwd_for = $1; - var = $2; - bind_to = $3; - kwd_in = $4; - expr = $5; - block = $6} + kwd_for = $1; + var = $2; + bind_to = $3; + colon = $4; + elt_type = $5; + kwd_in = $6; + collection = $7; + expr = $8; + block = $9} in For (ForCollect {region; value})} +collection: + Map { Map $1 } +| Set { Set $1 } +| List { List $1 } + var_assign: var ASS expr { let region = cover $1.region (expr_to_region $3) and value = {name = $1; assign = $2; expr = $3} in {region; value}} -step_clause: - Step expr { $1,$2 } - arrow_clause: ARROW var { $1,$2 } @@ -658,14 +683,28 @@ interactive_expr: expr: case(expr) { ECase ($1 expr_to_region) } +| cond_expr { $1 } | disj_expr { $1 } +cond_expr: + If expr Then expr option(SEMI) Else expr { + let region = cover $1 (expr_to_region $7) in + let value : cond_expr = { + kwd_if = $1; + test = $2; + kwd_then = $3; + ifso = $4; + terminator = $5; + kwd_else = $6; + ifnot = $7} + in ECond {region; value} } + disj_expr: disj_expr Or conj_expr { let start = expr_to_region $1 and stop = expr_to_region $3 in let region = cover start stop - and value = {arg1 = $1; op = $2; arg2 = $3} in + and value = {arg1=$1; op=$2; arg2=$3} in ELogic (BoolExpr (Or {region; value})) } | conj_expr { $1 } @@ -675,7 +714,7 @@ conj_expr: let start = expr_to_region $1 and stop = expr_to_region $3 in let region = cover start stop - and value = {arg1 = $1; op = $2; arg2 = $3} + and value = {arg1=$1; op=$2; arg2=$3} in ELogic (BoolExpr (And {region; value})) } | set_membership { $1 } @@ -701,7 +740,7 @@ comp_expr: and value = {arg1 = $1; op = $2; arg2 = $3} in ELogic (CompExpr (Lt {region; value})) } -| comp_expr LEQ cat_expr { +| comp_expr LE cat_expr { let start = expr_to_region $1 and stop = expr_to_region $3 in let region = cover start stop @@ -715,21 +754,21 @@ comp_expr: and value = {arg1 = $1; op = $2; arg2 = $3} in ELogic (CompExpr (Gt {region; value})) } -| comp_expr GEQ cat_expr { +| comp_expr GE cat_expr { let start = expr_to_region $1 and stop = expr_to_region $3 in let region = cover start stop and value = {arg1 = $1; op = $2; arg2 = $3} in ELogic (CompExpr (Geq {region; value})) } -| comp_expr EQUAL cat_expr { +| comp_expr EQ cat_expr { let start = expr_to_region $1 and stop = expr_to_region $3 in let region = cover start stop and value = {arg1 = $1; op = $2; arg2 = $3} in ELogic (CompExpr (Equal {region; value})) } -| comp_expr NEQ cat_expr { +| comp_expr NE cat_expr { let start = expr_to_region $1 and stop = expr_to_region $3 in let region = cover start stop @@ -817,7 +856,7 @@ unary_expr: core_expr: Int { EArith (Int $1) } | Nat { EArith (Nat $1) } -| Mtz { EArith (Mtz $1) } +| Mutez { EArith (Mutez $1) } | var { EVar $1 } | String { EString (String $1) } | Bytes { EBytes $1 } @@ -826,6 +865,7 @@ core_expr: | C_Unit { EUnit $1 } | annot_expr { EAnnot $1 } | tuple_expr { ETuple $1 } +| par(expr) { EPar $1 } | list_expr { EList $1 } | C_None { EConstr (NoneExpr $1) } | fun_call { ECall $1 } @@ -859,6 +899,7 @@ set_expr: map_expr: map_lookup { MapLookUp $1 } | injection(Map,binding) { MapInj $1 } +| injection(BigMap,binding) { BigMapInj $1 } map_lookup: path brackets(expr) { @@ -888,7 +929,7 @@ record_expr: Record sep_or_term_list(field_assignment,SEMI) End { let elements, terminator = $2 in let region = cover $1 $3 - and value = { + and value : field_assign AST.reg injection = { opening = Kwd $1; elements = Some elements; terminator; @@ -898,7 +939,7 @@ record_expr: | Record LBRACKET sep_or_term_list(field_assignment,SEMI) RBRACKET { let elements, terminator = $3 in let region = cover $1 $4 - and value = { + and value : field_assign AST.reg injection = { opening = KwdBracket ($1,$2); elements = Some elements; terminator; @@ -906,7 +947,7 @@ record_expr: in {region; value} } field_assignment: - field_name EQUAL expr { + field_name EQ expr { let region = cover $1.region (expr_to_region $3) and value = { field_name = $1; @@ -920,13 +961,14 @@ fun_call: in {region; value = $1,$2}} tuple_expr: - tuple_inj { TupleInj $1 } + par(tuple_comp) { $1 } -tuple_inj: - par(nsepseq(expr,COMMA)) { $1 } +tuple_comp: + expr COMMA nsepseq(expr,COMMA) { + Utils.nsepseq_cons $1 $2 $3} arguments: - tuple_inj { $1 } + par(nsepseq(expr,COMMA)) { $1 } list_expr: injection(List,expr) { List $1 } @@ -935,14 +977,18 @@ list_expr: (* Patterns *) pattern: - nsepseq(core_pattern,CONS) { - let region = nsepseq_to_region pattern_to_region $1 - in PCons {region; value=$1}} + core_pattern CONS nsepseq(core_pattern,CONS) { + let value = Utils.nsepseq_cons $1 $2 $3 in + let region = nsepseq_to_region pattern_to_region value + in PCons {region; value}} +| core_pattern { $1 } core_pattern: var { PVar $1 } | WILD { PWild $1 } | Int { PInt $1 } +| Nat { PNat $1 } +| Bytes { PBytes $1 } | String { PString $1 } | C_Unit { PUnit $1 } | C_False { PFalse $1 } diff --git a/src/passes/1-parser/pascaligo/ParserLog.ml b/src/passes/1-parser/pascaligo/ParserLog.ml index 6cf9ccc3e..c6940bdee 100644 --- a/src/passes/1-parser/pascaligo/ParserLog.ml +++ b/src/passes/1-parser/pascaligo/ParserLog.ml @@ -62,6 +62,11 @@ let print_int buffer {region; value = lexeme, abstract} = (Z.to_string abstract) in Buffer.add_string buffer line +let print_nat buffer {region; value = lexeme, abstract} = + let line = sprintf "%s: Nat (\"%s\", %s)\n" + (compact region) lexeme + (Z.to_string abstract) + in Buffer.add_string buffer line (* Main printing function *) @@ -71,9 +76,9 @@ let rec print_tokens buffer ast = print_token buffer eof "EOF" and print_decl buffer = function - TypeDecl decl -> print_type_decl buffer decl -| ConstDecl decl -> print_const_decl buffer decl -| LambdaDecl decl -> print_lambda_decl buffer decl + TypeDecl decl -> print_type_decl buffer decl +| ConstDecl decl -> print_const_decl buffer decl +| FunDecl decl -> print_fun_decl buffer decl and print_const_decl buffer {value; _} = let {kwd_const; name; colon; const_type; @@ -107,20 +112,20 @@ and print_type_expr buffer = function and print_cartesian buffer {value; _} = print_nsepseq buffer "*" print_type_expr value -and print_variant buffer {value; _} = +and print_variant buffer ({value; _}: variant reg) = let {constr; args} = value in print_constr buffer constr; match args with None -> () - | Some (kwd_of, product) -> + | Some (kwd_of, t_expr) -> print_token buffer kwd_of "of"; - print_cartesian buffer product + print_type_expr buffer t_expr and print_sum_type buffer {value; _} = print_nsepseq buffer "|" print_variant value and print_record_type buffer record_type = - print_injection buffer "record" print_field_decl record_type + print_ne_injection buffer "record" print_field_decl record_type and print_type_app buffer {value; _} = let type_name, type_tuple = value in @@ -151,10 +156,6 @@ and print_type_tuple buffer {value; _} = print_nsepseq buffer "," print_type_expr inside; print_token buffer rpar ")" -and print_lambda_decl buffer = function - FunDecl fun_decl -> print_fun_decl buffer fun_decl -| ProcDecl proc_decl -> print_proc_decl buffer proc_decl - and print_fun_decl buffer {value; _} = let {kwd_function; name; param; colon; ret_type; kwd_is; local_decls; @@ -167,21 +168,13 @@ and print_fun_decl buffer {value; _} = print_token buffer kwd_is "is"; print_local_decls buffer local_decls; print_block buffer block; - print_token buffer kwd_with "with"; + match kwd_with with + | Some kwd_with -> + print_token buffer kwd_with "with"; + | None -> (); print_expr buffer return; print_terminator buffer terminator -and print_proc_decl buffer {value; _} = - let {kwd_procedure; name; param; kwd_is; - local_decls; block; terminator} = value in - print_token buffer kwd_procedure "procedure"; - print_var buffer name; - print_parameters buffer param; - print_token buffer kwd_is "is"; - print_local_decls buffer local_decls; - print_block buffer block; - print_terminator buffer terminator - and print_parameters buffer {value; _} = let {lpar; inside; rpar} = value in print_token buffer lpar "("; @@ -206,12 +199,16 @@ and print_param_var buffer {value; _} = print_token buffer colon ":"; print_type_expr buffer param_type -and print_block buffer {value; _} = - let {opening; statements; terminator; closing} = value in - print_block_opening buffer opening; - print_statements buffer statements; - print_terminator buffer terminator; - print_block_closing buffer closing +and print_block buffer reg = + match reg with + | Some reg -> + let value = reg.value in + let {opening; statements; terminator; closing} = value in + print_block_opening buffer opening; + print_statements buffer statements; + print_terminator buffer terminator; + print_block_closing buffer closing + | None -> () and print_block_opening buffer = function Block (kwd_block, lbrace) -> @@ -229,7 +226,6 @@ and print_local_decls buffer sequence = and print_local_decl buffer = function LocalFun decl -> print_fun_decl buffer decl -| LocalProc decl -> print_proc_decl buffer decl | LocalData decl -> print_data_decl buffer decl and print_data_decl buffer = function @@ -255,10 +251,6 @@ and print_statement buffer = function | Data data -> print_data_decl buffer data and print_instruction buffer = function - Single instr -> print_single_instr buffer instr -| Block block -> print_block buffer block - -and print_single_instr buffer = function Cond {value; _} -> print_conditional buffer value | CaseInstr {value; _} -> print_case_instr buffer value | Assign assign -> print_assignment buffer assign @@ -271,20 +263,31 @@ and print_single_instr buffer = function | MapRemove {value; _} -> print_map_remove buffer value | SetRemove {value; _} -> print_set_remove buffer value -and print_conditional buffer node = - let {kwd_if; test; kwd_then; ifso; terminator; - kwd_else; ifnot} = node in - print_token buffer kwd_if "if"; - print_expr buffer test; - print_token buffer kwd_then "then"; - print_if_clause buffer ifso; - print_terminator buffer terminator; - print_token buffer kwd_else "else"; - print_if_clause buffer ifnot +and print_cond_expr buffer (node: cond_expr) = + print_token buffer node.kwd_if "if"; + print_expr buffer node.test; + print_token buffer node.kwd_then "then"; + print_expr buffer node.ifso; + print_terminator buffer node.terminator; + print_token buffer node.kwd_else "else"; + print_expr buffer node.ifnot + +and print_conditional buffer (node: conditional) = + print_token buffer node.kwd_if "if"; + print_expr buffer node.test; + print_token buffer node.kwd_then "then"; + print_if_clause buffer node.ifso; + print_terminator buffer node.terminator; + print_token buffer node.kwd_else "else"; + print_if_clause buffer node.ifnot and print_if_clause buffer = function ClauseInstr instr -> print_instruction buffer instr -| ClauseBlock {value; _} -> +| ClauseBlock block -> print_clause_block buffer block + +and print_clause_block buffer = function + LongBlock block -> print_block buffer (Some block) + | ShortBlock {value; _} -> let {lbrace; inside; rbrace} = value in let statements, terminator = inside in print_token buffer lbrace "{"; @@ -292,7 +295,7 @@ and print_if_clause buffer = function print_terminator buffer terminator; print_token buffer rbrace "}" -and print_case_instr buffer (node : instruction case) = +and print_case_instr buffer (node : if_clause case) = let {kwd_case; expr; opening; lead_vbar; cases; closing} = node in print_token buffer kwd_case "case"; @@ -311,9 +314,9 @@ and print_cases_instr buffer {value; _} = and print_case_clause_instr buffer {value; _} = let {pattern; arrow; rhs} = value in - print_pattern buffer pattern; - print_token buffer arrow "->"; - print_instruction buffer rhs + print_pattern buffer pattern; + print_token buffer arrow "->"; + print_if_clause buffer rhs and print_assignment buffer {value; _} = let {lhs; assign; rhs} = value in @@ -335,22 +338,19 @@ and print_while_loop buffer value = let {kwd_while; cond; block} = value in print_token buffer kwd_while "while"; print_expr buffer cond; - print_block buffer block + print_block buffer (Some block) and print_for_loop buffer = function ForInt for_int -> print_for_int buffer for_int | ForCollect for_collect -> print_for_collect buffer for_collect and print_for_int buffer ({value; _} : for_int reg) = - let {kwd_for; assign; down; kwd_to; - bound; step; block} = value in + let {kwd_for; assign; kwd_to; bound; block} = value in print_token buffer kwd_for "for"; print_var_assign buffer assign; - print_down buffer down; print_token buffer kwd_to "to"; print_expr buffer bound; - print_step buffer step; - print_block buffer block + print_block buffer (Some block) and print_var_assign buffer {value; _} = let {name; assign; expr} = value in @@ -358,24 +358,26 @@ and print_var_assign buffer {value; _} = print_token buffer assign ":="; print_expr buffer expr -and print_down buffer = function - Some kwd_down -> print_token buffer kwd_down "down" -| None -> () - -and print_step buffer = function - Some (kwd_step, expr) -> - print_token buffer kwd_step "step"; - print_expr buffer expr -| None -> () - and print_for_collect buffer ({value; _} : for_collect reg) = - let {kwd_for; var; bind_to; kwd_in; expr; block} = value in - print_token buffer kwd_for "for"; - print_var buffer var; - print_bind_to buffer bind_to; - print_token buffer kwd_in "in"; - print_expr buffer expr; - print_block buffer block + let {kwd_for; var; bind_to; colon; elt_type; + kwd_in; collection; expr; block} = value in + print_token buffer kwd_for "for"; + print_var buffer var; + print_bind_to buffer bind_to; + print_token buffer colon ":"; + print_type_expr buffer elt_type; + print_token buffer kwd_in "in"; + print_collection buffer collection; + print_expr buffer expr; + print_block buffer (Some block) + +and print_collection buffer = function + Map kwd_map -> + print_token buffer kwd_map "map" +| Set kwd_set -> + print_token buffer kwd_set "set" +| List kwd_list -> + print_token buffer kwd_list "list" and print_bind_to buffer = function Some (arrow, variable) -> @@ -385,6 +387,7 @@ and print_bind_to buffer = function and print_expr buffer = function ECase {value;_} -> print_case_expr buffer value +| ECond {value;_} -> print_cond_expr buffer value | EAnnot {value;_} -> print_annot_expr buffer value | ELogic e -> print_logic_expr buffer e | EArith e -> print_arith_expr buffer e @@ -428,6 +431,7 @@ and print_case_clause_expr buffer {value; _} = and print_map_expr buffer = function MapLookUp {value; _} -> print_map_lookup buffer value | MapInj inj -> print_injection buffer "map" print_binding inj +| BigMapInj inj -> print_injection buffer "big_map" print_binding inj and print_set_expr buffer = function SetInj inj -> print_injection buffer "set" print_expr inj @@ -523,7 +527,7 @@ and print_arith_expr buffer = function print_expr buffer arg | Int i | Nat i -| Mtz i -> print_int buffer i +| Mutez i -> print_int buffer i and print_string_expr buffer = function Cat {value = {arg1; op; arg2}; _} -> @@ -570,24 +574,24 @@ and print_selection buffer = function and print_record_patch buffer node = let {kwd_patch; path; kwd_with; record_inj} = node in - print_token buffer kwd_patch "patch"; - print_path buffer path; - print_token buffer kwd_with "with"; - print_record_expr buffer record_inj + print_token buffer kwd_patch "patch"; + print_path buffer path; + print_token buffer kwd_with "with"; + print_ne_injection buffer "record" print_field_assign record_inj and print_set_patch buffer node = let {kwd_patch; path; kwd_with; set_inj} = node in - print_token buffer kwd_patch "patch"; - print_path buffer path; - print_token buffer kwd_with "with"; - print_injection buffer "set" print_expr set_inj + print_token buffer kwd_patch "patch"; + print_path buffer path; + print_token buffer kwd_with "with"; + print_ne_injection buffer "set" print_expr set_inj and print_map_patch buffer node = let {kwd_patch; path; kwd_with; map_inj} = node in - print_token buffer kwd_patch "patch"; - print_path buffer path; - print_token buffer kwd_with "with"; - print_injection buffer "map" print_binding map_inj + print_token buffer kwd_patch "patch"; + print_path buffer path; + print_token buffer kwd_with "with"; + print_ne_injection buffer "map" print_binding map_inj and print_map_remove buffer node = let {kwd_remove; key; kwd_from; kwd_map; map} = node in @@ -615,6 +619,16 @@ and print_injection : print_terminator buffer terminator; print_closing buffer closing +and print_ne_injection : + 'a.Buffer.t -> string -> (Buffer.t -> 'a -> unit) -> + 'a ne_injection reg -> unit = + fun buffer kwd print {value; _} -> + let {opening; ne_elements; terminator; closing} = value in + print_opening buffer kwd opening; + print_nsepseq buffer ";" print ne_elements; + print_terminator buffer terminator; + print_closing buffer closing + and print_opening buffer lexeme = function Kwd kwd -> print_token buffer kwd lexeme @@ -632,10 +646,7 @@ and print_binding buffer {value; _} = print_token buffer arrow "->"; print_expr buffer image -and print_tuple_expr buffer = function - TupleInj inj -> print_tuple_inj buffer inj - -and print_tuple_inj buffer {value; _} = +and print_tuple_expr buffer {value; _} = let {lpar; inside; rpar} = value in print_token buffer lpar "("; print_nsepseq buffer "," print_expr inside; @@ -647,20 +658,20 @@ and print_none_expr buffer value = print_token buffer value "None" and print_fun_call buffer {value; _} = let fun_name, arguments = value in - print_var buffer fun_name; - print_tuple_inj buffer arguments + print_var buffer fun_name; + print_tuple_expr buffer arguments and print_constr_app buffer {value; _} = let constr, arguments = value in print_constr buffer constr; match arguments with None -> () - | Some args -> print_tuple_inj buffer args + | Some args -> print_tuple_expr buffer args and print_some_app buffer {value; _} = let c_Some, arguments = value in - print_token buffer c_Some "Some"; - print_tuple_inj buffer arguments + print_token buffer c_Some "Some"; + print_tuple_expr buffer arguments and print_par_expr buffer {value; _} = let {lpar; inside; rpar} = value in @@ -673,6 +684,7 @@ and print_pattern buffer = function | PVar var -> print_var buffer var | PWild wild -> print_token buffer wild "_" | PInt i -> print_int buffer i +| PNat n -> print_nat buffer n | PBytes b -> print_bytes buffer b | PString s -> print_string buffer s | PUnit region -> print_token buffer region "Unit" @@ -740,3 +752,743 @@ let tokens_to_string = to_string print_tokens let path_to_string = to_string print_path let pattern_to_string = to_string print_pattern let instruction_to_string = to_string print_instruction + +(* Pretty-printing the AST *) + +let mk_pad len rank pc = + pc ^ (if rank = len-1 then "`-- " else "|-- "), + pc ^ (if rank = len-1 then " " else "| ") + +let pp_ident buffer ~pad:(pd,_) name = + let node = sprintf "%s%s\n" pd name + in Buffer.add_string buffer node + +let pp_string buffer = pp_ident buffer + +let pp_node buffer = pp_ident buffer + +let rec pp_ast buffer ~pad:(_,pc as pad) {decl; _} = + let apply len rank = + let pad = mk_pad len rank pc in + pp_declaration buffer ~pad in + let decls = Utils.nseq_to_list decl in + pp_node buffer ~pad ""; + List.iteri (List.length decls |> apply) decls + +and pp_declaration buffer ~pad:(_,pc as pad) = function + TypeDecl {value; _} -> + pp_node buffer ~pad "TypeDecl"; + pp_ident buffer ~pad:(mk_pad 2 0 pc) value.name.value; + pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.type_expr +| ConstDecl {value; _} -> + pp_node buffer ~pad "ConstDecl"; + pp_const_decl buffer ~pad value +| FunDecl {value; _} -> + pp_node buffer ~pad "FunDecl"; + pp_fun_decl buffer ~pad value + +and pp_const_decl buffer ~pad:(_,pc) decl = + pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name.value; + pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.const_type; + pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init + +and pp_type_expr buffer ~pad:(_,pc as pad) = function + TProd cartesian -> + pp_node buffer ~pad "TProd"; + pp_cartesian buffer ~pad cartesian +| TAlias {value; _} -> + pp_node buffer ~pad "TAlias"; + pp_ident buffer ~pad:(mk_pad 1 0 pc) value +| TPar {value; _} -> + pp_node buffer ~pad "TPar"; + pp_type_expr buffer ~pad:(mk_pad 1 0 pc) value.inside +| TApp {value=name,tuple; _} -> + pp_node buffer ~pad "TApp"; + pp_ident buffer ~pad:(mk_pad 1 0 pc) name.value; + pp_type_tuple buffer ~pad:(mk_pad 2 1 pc) tuple +| TFun {value; _} -> + pp_node buffer ~pad "TFun"; + let apply len rank = + let pad = mk_pad len rank pc in + pp_type_expr buffer ~pad in + let domain, _, range = value in + List.iteri (apply 2) [domain; range] +| TSum {value; _} -> + pp_node buffer ~pad "TSum"; + let apply len rank variant = + let pad = mk_pad len rank pc in + pp_variant buffer ~pad variant.value in + let variants = Utils.nsepseq_to_list value in + List.iteri (List.length variants |> apply) variants +| TRecord {value; _} -> + pp_node buffer ~pad "TRecord"; + let apply len rank field_decl = + pp_field_decl buffer ~pad:(mk_pad len rank pc) + field_decl.value in + let fields = Utils.nsepseq_to_list value.ne_elements in + List.iteri (List.length fields |> apply) fields + +and pp_cartesian buffer ~pad:(_,pc) {value; _} = + let apply len rank = + pp_type_expr buffer ~pad:(mk_pad len rank pc) in + let components = Utils.nsepseq_to_list value + in List.iteri (List.length components |> apply) components + +and pp_variant buffer ~pad:(_,pc as pad) {constr; args} = + pp_node buffer ~pad constr.value; + match args with + None -> () + | Some (_,c) -> + pp_type_expr buffer ~pad:(mk_pad 1 0 pc) c + +and pp_field_decl buffer ~pad:(_,pc as pad) decl = + pp_node buffer ~pad decl.field_name.value; + pp_type_expr buffer ~pad:(mk_pad 1 0 pc) decl.field_type + +and pp_type_tuple buffer ~pad:(_,pc) {value; _} = + let components = Utils.nsepseq_to_list value.inside in + let apply len rank = + pp_type_expr buffer ~pad:(mk_pad len rank pc) + in List.iteri (List.length components |> apply) components + +and pp_fun_decl buffer ~pad:(_,pc) decl = + let fields = + if decl.local_decls = [] then 5 else 6 in + let () = + let pad = mk_pad fields 0 pc in + pp_ident buffer ~pad decl.name.value in + let () = + let pad = mk_pad fields 1 pc in + pp_node buffer ~pad ""; + pp_parameters buffer ~pad decl.param in + let () = + let _, pc as pad = mk_pad fields 2 pc in + pp_node buffer ~pad ""; + pp_type_expr buffer ~pad:(mk_pad 1 0 pc) decl.ret_type in + let () = + if fields = 6 then + let pad = mk_pad fields 3 pc in + pp_node buffer ~pad ""; + pp_local_decls buffer ~pad decl.local_decls in + let () = + let pad = mk_pad fields (fields - 2) pc in + pp_node buffer ~pad ""; + let statements = + match decl.block with + | Some block -> block.value.statements + | None -> Instr (Skip Region.ghost), [] in + pp_statements buffer ~pad statements in + let () = + let _, pc as pad = mk_pad fields (fields - 1) pc in + pp_node buffer ~pad ""; + pp_expr buffer ~pad:(mk_pad 1 0 pc) decl.return + in () + +and pp_parameters buffer ~pad:(_,pc) {value; _} = + let params = Utils.nsepseq_to_list value.inside in + let arity = List.length params in + let apply len rank = + pp_param_decl buffer ~pad:(mk_pad len rank pc) + in List.iteri (apply arity) params + +and pp_param_decl buffer ~pad:(_,pc as pad) = function + ParamConst {value; _} -> + pp_node buffer ~pad "ParamConst"; + pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var.value; + pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type +| ParamVar {value; _} -> + pp_node buffer ~pad "ParamVar"; + pp_ident buffer ~pad:(mk_pad 2 0 pc) value.var.value; + pp_type_expr buffer ~pad:(mk_pad 2 1 pc) value.param_type + +and pp_statements buffer ~pad:(_,pc) statements = + let statements = Utils.nsepseq_to_list statements in + let length = List.length statements in + let apply len rank = + pp_statement buffer ~pad:(mk_pad len rank pc) + in List.iteri (apply length) statements + +and pp_statement buffer ~pad:(_,pc as pad) = function + Instr instr -> + pp_node buffer ~pad "Instr"; + pp_instruction buffer ~pad:(mk_pad 1 0 pc) instr +| Data data_decl -> + pp_node buffer ~pad "Data"; + pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data_decl + +and pp_instruction buffer ~pad:(_,pc as pad) = function + Cond {value; _} -> + pp_node buffer ~pad "Cond"; + pp_conditional buffer ~pad value +| CaseInstr {value; _} -> + pp_node buffer ~pad "CaseInstr"; + pp_case pp_if_clause buffer ~pad value +| Assign {value; _} -> + pp_node buffer ~pad "Assign"; + pp_assignment buffer ~pad value +| Loop loop -> + pp_node buffer ~pad "Loop"; + pp_loop buffer ~pad:(mk_pad 1 0 pc) loop +| ProcCall {value; _} -> + pp_node buffer ~pad "ProcCall"; + pp_fun_call buffer ~pad value +| Skip _ -> + pp_node buffer ~pad "Skip" +| RecordPatch {value; _} -> + pp_node buffer ~pad "RecordPatch"; + pp_record_patch buffer ~pad value +| MapPatch {value; _} -> + pp_node buffer ~pad "MapPatch"; + pp_map_patch buffer ~pad value +| SetPatch {value; _} -> + pp_node buffer ~pad "SetPatch"; + pp_set_patch buffer ~pad value +| MapRemove {value; _} -> + pp_node buffer ~pad "MapRemove"; + pp_map_remove buffer ~pad value +| SetRemove {value; _} -> + pp_node buffer ~pad "SetRemove"; + pp_set_remove buffer ~pad value + +and pp_cond_expr buffer ~pad:(_,pc) (cond: cond_expr) = + let () = + let _, pc as pad = mk_pad 3 0 pc in + pp_node buffer ~pad ""; + pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.test in + let () = + let _, pc as pad = mk_pad 3 1 pc in + pp_node buffer ~pad ""; + pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.ifso in + let () = + let _, pc as pad = mk_pad 3 2 pc in + pp_node buffer ~pad ""; + pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.ifnot + in () + +and pp_conditional buffer ~pad:(_,pc) (cond: conditional) = + let () = + let _, pc as pad = mk_pad 3 0 pc in + pp_node buffer ~pad ""; + pp_expr buffer ~pad:(mk_pad 1 0 pc) cond.test in + let () = + let _, pc as pad = mk_pad 3 1 pc in + pp_node buffer ~pad ""; + pp_if_clause buffer ~pad:(mk_pad 1 0 pc) cond.ifso in + let () = + let _, pc as pad = mk_pad 3 2 pc in + pp_node buffer ~pad ""; + pp_if_clause buffer ~pad:(mk_pad 1 0 pc) cond.ifnot + in () + +and pp_if_clause buffer ~pad:(_,pc as pad) = function + ClauseInstr instr -> + pp_node buffer ~pad "ClauseInstr"; + pp_instruction buffer ~pad:(mk_pad 1 0 pc) instr +| ClauseBlock block -> + pp_node buffer ~pad "ClauseBlock"; + pp_clause_block buffer ~pad:(mk_pad 1 0 pc) block + +and pp_clause_block buffer ~pad = function + LongBlock {value; _} -> + pp_node buffer ~pad "LongBlock"; + pp_statements buffer ~pad value.statements +| ShortBlock {value; _} -> + pp_node buffer ~pad "ShortBlock"; + let statements = fst value.inside in + pp_statements buffer ~pad statements + +and pp_case : + 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) + -> Buffer.t -> pad:(string*string) -> 'a case -> unit = + fun printer buffer ~pad:(_,pc) case -> + let clauses = Utils.nsepseq_to_list case.cases.value in + let clauses = List.map (fun {value; _} -> value) clauses in + let length = List.length clauses + 1 in + let apply len rank = + pp_case_clause printer buffer ~pad:(mk_pad len (rank+1) pc) + in pp_expr buffer ~pad:(mk_pad length 0 pc) case.expr; + List.iteri (apply length) clauses + +and pp_case_clause : + 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) + -> Buffer.t -> pad:(string*string) -> 'a case_clause -> unit = + fun printer buffer ~pad:(_,pc as pad) clause -> + pp_node buffer ~pad ""; + pp_pattern buffer ~pad:(mk_pad 2 0 pc) clause.pattern; + printer buffer ~pad:(mk_pad 2 1 pc) clause.rhs + +and pp_pattern buffer ~pad:(_,pc as pad) = function + PNone _ -> + pp_node buffer ~pad "PNone" +| PSome {value=_,{value=par; _}; _} -> + pp_node buffer ~pad "PSome"; + pp_pattern buffer ~pad:(mk_pad 1 0 pc) par.inside +| PWild _ -> + pp_node buffer ~pad "PWild" +| PConstr {value; _} -> + pp_node buffer ~pad "PConstr"; + pp_constr_pattern buffer ~pad:(mk_pad 1 0 pc) value +| PCons {value; _} -> + let patterns = Utils.nsepseq_to_list value in + let length = List.length patterns in + let apply len rank = + pp_pattern buffer ~pad:(mk_pad len rank pc) in + pp_node buffer ~pad "PCons"; + List.iteri (apply length) patterns +| PVar {value; _} -> + pp_node buffer ~pad "PVar"; + pp_ident buffer ~pad:(mk_pad 1 0 pc) value +| PInt {value; _} -> + pp_node buffer ~pad "PInt"; + pp_int buffer ~pad value +| PNat {value; _} -> + pp_node buffer ~pad "PNat"; + pp_int buffer ~pad value +| PBytes {value; _} -> + pp_node buffer ~pad "PBytes"; + pp_bytes buffer ~pad value +| PString {value; _} -> + pp_node buffer ~pad "PString"; + pp_ident buffer ~pad:(mk_pad 1 0 pc) value +| PUnit _ -> + pp_node buffer ~pad "PUnit" +| PFalse _ -> + pp_node buffer ~pad "PFalse" +| PTrue _ -> + pp_node buffer ~pad "PTrue" +| PList plist -> + pp_node buffer ~pad "PList"; + pp_plist buffer ~pad:(mk_pad 1 0 pc) plist +| PTuple {value; _} -> + pp_node buffer ~pad "PTuple"; + pp_tuple_pattern buffer ~pad:(mk_pad 1 0 pc) value + +and pp_bytes buffer ~pad:(_,pc) (lexeme, hex) = + pp_string buffer ~pad:(mk_pad 2 0 pc) lexeme; + pp_string buffer ~pad:(mk_pad 2 1 pc) (Hex.to_string hex) + +and pp_int buffer ~pad:(_,pc) (lexeme, z) = + pp_string buffer ~pad:(mk_pad 2 0 pc) lexeme; + pp_string buffer ~pad:(mk_pad 2 1 pc) (Z.to_string z) + +and pp_constr_pattern buffer ~pad = function + {value; _}, None -> + pp_ident buffer ~pad value +| {value=id; _}, Some {value=ptuple; _} -> + pp_ident buffer ~pad id; + pp_tuple_pattern buffer ~pad ptuple + +and pp_plist buffer ~pad:(_,pc as pad) = function + Sugar {value; _} -> + pp_node buffer ~pad "Sugar"; + pp_injection pp_pattern buffer ~pad:(mk_pad 1 0 pc) value +| PNil _ -> + pp_node buffer ~pad "PNil" +| Raw {value; _} -> + pp_node buffer ~pad "Raw"; + pp_raw buffer ~pad:(mk_pad 1 0 pc) value.inside + +and pp_raw buffer ~pad:(_,pc) (head, _, tail) = + pp_pattern buffer ~pad:(mk_pad 2 0 pc) head; + pp_pattern buffer ~pad:(mk_pad 2 1 pc) tail + +and pp_injection : + 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) + -> Buffer.t -> pad:(string*string) -> 'a injection -> unit = + fun printer buffer ~pad:(_,pc) inj -> + let elements = Utils.sepseq_to_list inj.elements in + let length = List.length elements in + let apply len rank = printer buffer ~pad:(mk_pad len rank pc) + in List.iteri (apply length) elements + +and pp_ne_injection : + 'a.(Buffer.t -> pad:(string*string) -> 'a -> unit) + -> Buffer.t -> pad:(string*string) -> 'a ne_injection -> unit = + fun printer buffer ~pad:(_,pc) inj -> + let ne_elements = Utils.nsepseq_to_list inj.ne_elements in + let length = List.length ne_elements in + let apply len rank = printer buffer ~pad:(mk_pad len rank pc) + in List.iteri (apply length) ne_elements + +and pp_tuple_pattern buffer ~pad:(_,pc) tuple = + let patterns = Utils.nsepseq_to_list tuple.inside in + let length = List.length patterns in + let apply len rank = + pp_pattern buffer ~pad:(mk_pad len rank pc) + in List.iteri (apply length) patterns + +and pp_assignment buffer ~pad:(_,pc) asgn = + pp_lhs buffer ~pad:(mk_pad 2 0 pc) asgn.lhs; + pp_expr buffer ~pad:(mk_pad 2 1 pc) asgn.rhs + +and pp_lhs buffer ~pad:(_,pc as pad) = function + Path path -> + pp_node buffer ~pad "Path"; + pp_path buffer ~pad:(mk_pad 1 0 pc) path +| MapPath {value; _} -> + pp_node buffer ~pad "MapPath"; + pp_map_lookup buffer ~pad value + +and pp_path buffer ~pad:(_,pc as pad) = function + Name {value; _} -> + pp_node buffer ~pad "Name"; + pp_ident buffer ~pad:(mk_pad 1 0 pc) value +| Path {value; _} -> + pp_node buffer ~pad "Path"; + pp_projection buffer ~pad value + +and pp_projection buffer ~pad:(_,pc) proj = + let selections = Utils.nsepseq_to_list proj.field_path in + let len = List.length selections in + let apply len rank = + pp_selection buffer ~pad:(mk_pad len rank pc) in + pp_ident buffer ~pad:(mk_pad (1+len) 0 pc) proj.struct_name.value; + List.iteri (apply len) selections + +and pp_selection buffer ~pad:(_,pc as pad) = function + FieldName {value; _} -> + pp_node buffer ~pad "FieldName"; + pp_ident buffer ~pad:(mk_pad 1 0 pc) value +| Component {value; _} -> + pp_node buffer ~pad "Component"; + pp_int buffer ~pad value + +and pp_map_lookup buffer ~pad:(_,pc) lookup = + pp_path buffer ~pad:(mk_pad 2 0 pc) lookup.path; + pp_expr buffer ~pad:(mk_pad 2 1 pc) lookup.index.value.inside + +and pp_loop buffer ~pad:(_,pc as pad) = function + While {value; _} -> + pp_node buffer ~pad ""; + let () = + let _, pc as pad = mk_pad 2 0 pc in + pp_node buffer ~pad ""; + pp_expr buffer ~pad:(mk_pad 1 0 pc) value.cond in + let () = + let pad = mk_pad 2 1 pc in + let statements = value.block.value.statements in + pp_node buffer ~pad ""; + pp_statements buffer ~pad statements + in () +| For for_loop -> + pp_node buffer ~pad ""; + pp_for_loop buffer ~pad:(mk_pad 1 0 pc) for_loop + +and pp_for_loop buffer ~pad = function + ForInt {value; _} -> + pp_node buffer ~pad "ForInt"; + pp_for_int buffer ~pad value +| ForCollect {value; _} -> + pp_node buffer ~pad "ForCollect"; + pp_for_collect buffer ~pad value + +and pp_for_int buffer ~pad:(_,pc) for_int = + let () = + let pad = mk_pad 3 0 pc in + pp_node buffer ~pad ""; + pp_var_assign buffer ~pad for_int.assign.value in + let () = + let _, pc as pad = mk_pad 3 1 pc in + pp_node buffer ~pad ""; + pp_expr buffer ~pad:(mk_pad 1 0 pc) for_int.bound in + let () = + let pad = mk_pad 3 2 pc in + let statements = for_int.block.value.statements in + pp_node buffer ~pad ""; + pp_statements buffer ~pad statements + in () + +and pp_var_assign buffer ~pad:(_,pc) asgn = + let pad = mk_pad 2 0 pc in + pp_ident buffer ~pad asgn.name.value; + let pad = mk_pad 2 1 pc in + pp_expr buffer ~pad asgn.expr + +and pp_for_collect buffer ~pad:(_,pc) collect = + let () = + let pad = mk_pad 4 0 pc in + match collect.bind_to with + None -> + pp_ident buffer ~pad collect.var.value + | Some (_, var) -> + pp_var_binding buffer ~pad (collect.var, var) in + let () = + let _, pc as pad = mk_pad 4 1 pc in + pp_node buffer ~pad ""; + pp_type_expr buffer ~pad:(mk_pad 1 0 pc) collect.elt_type in + let () = + let _, pc as pad = mk_pad 4 2 pc in + pp_node buffer ~pad ""; + pp_collection buffer ~pad:(mk_pad 2 0 pc) collect.collection; + pp_expr buffer ~pad:(mk_pad 1 0 pc) collect.expr in + let () = + let pad = mk_pad 4 3 pc in + let statements = collect.block.value.statements in + pp_node buffer ~pad ""; + pp_statements buffer ~pad statements + in () + +and pp_collection buffer ~pad = function + Map _ -> pp_string buffer ~pad "map" +| Set _ -> pp_string buffer ~pad "set" +| List _ -> pp_string buffer ~pad "list" + +and pp_var_binding buffer ~pad:(_,pc as pad) (source, image) = + pp_node buffer ~pad ""; + pp_ident buffer ~pad:(mk_pad 2 0 pc) source.value; + pp_ident buffer ~pad:(mk_pad 2 1 pc) image.value + +and pp_fun_call buffer ~pad:(_,pc) (name, args) = + let args = Utils.nsepseq_to_list args.value.inside in + let arity = List.length args in + let apply len rank = + pp_expr buffer ~pad:(mk_pad len rank pc) + in pp_ident buffer ~pad:(mk_pad (1+arity) 0 pc) name.value; + List.iteri (apply arity) args + +and pp_record_patch buffer ~pad:(_,pc as pad) patch = + pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path; + pp_ne_injection pp_field_assign buffer + ~pad patch.record_inj.value + +and pp_field_assign buffer ~pad:(_,pc as pad) {value; _} = + pp_node buffer ~pad ""; + pp_ident buffer ~pad:(mk_pad 2 0 pc) value.field_name.value; + pp_expr buffer ~pad:(mk_pad 2 1 pc) value.field_expr + +and pp_map_patch buffer ~pad:(_,pc as pad) patch = + pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path; + pp_ne_injection pp_binding buffer + ~pad patch.map_inj.value + +and pp_binding buffer ~pad:(_,pc as pad) {value; _} = + let source, image = value.source, value.image in + pp_node buffer ~pad ""; + pp_expr buffer ~pad:(mk_pad 2 0 pc) source; + pp_expr buffer ~pad:(mk_pad 2 1 pc) image + +and pp_set_patch buffer ~pad:(_,pc as pad) patch = + pp_path buffer ~pad:(mk_pad 2 0 pc) patch.path; + pp_ne_injection pp_expr buffer ~pad patch.set_inj.value + +and pp_map_remove buffer ~pad:(_,pc) rem = + pp_expr buffer ~pad:(mk_pad 2 0 pc) rem.key; + pp_path buffer ~pad:(mk_pad 2 1 pc) rem.map + +and pp_set_remove buffer ~pad:(_,pc) rem = + pp_expr buffer ~pad:(mk_pad 2 0 pc) rem.element; + pp_path buffer ~pad:(mk_pad 2 1 pc) rem.set + +and pp_local_decls buffer ~pad:(_,pc) decls = + let apply len rank = + pp_local_decl buffer ~pad:(mk_pad len rank pc) + in List.iteri (List.length decls |> apply) decls + +and pp_local_decl buffer ~pad:(_,pc as pad) = function + LocalFun {value; _} -> + pp_node buffer ~pad "LocalFun"; + pp_fun_decl buffer ~pad value +| LocalData data -> + pp_node buffer ~pad "LocalData"; + pp_data_decl buffer ~pad:(mk_pad 1 0 pc) data + +and pp_data_decl buffer ~pad = function + LocalConst {value; _} -> + pp_node buffer ~pad "LocalConst"; + pp_const_decl buffer ~pad value +| LocalVar {value; _} -> + pp_node buffer ~pad "LocalVar"; + pp_var_decl buffer ~pad value + +and pp_var_decl buffer ~pad:(_,pc) decl = + pp_ident buffer ~pad:(mk_pad 3 0 pc) decl.name.value; + pp_type_expr buffer ~pad:(mk_pad 3 1 pc) decl.var_type; + pp_expr buffer ~pad:(mk_pad 3 2 pc) decl.init + +and pp_expr buffer ~pad:(_,pc as pad) = function + ECase {value; _} -> + pp_node buffer ~pad "ECase"; + pp_case pp_expr buffer ~pad value +| ECond {value; _} -> + pp_node buffer ~pad "ECond"; + pp_cond_expr buffer ~pad value +| EAnnot {value; _} -> + pp_node buffer ~pad "EAnnot"; + pp_annotated buffer ~pad value +| ELogic e_logic -> + pp_node buffer ~pad "ELogic"; + pp_e_logic buffer ~pad:(mk_pad 1 0 pc) e_logic +| EArith e_arith -> + pp_node buffer ~pad "EArith"; + pp_arith_expr buffer ~pad:(mk_pad 1 0 pc) e_arith +| EString e_string -> + pp_node buffer ~pad "EString"; + pp_string_expr buffer ~pad:(mk_pad 1 0 pc) e_string +| EList e_list -> + pp_node buffer ~pad "EList"; + pp_list_expr buffer ~pad:(mk_pad 1 0 pc) e_list +| ESet e_set -> + pp_node buffer ~pad "ESet"; + pp_set_expr buffer ~pad:(mk_pad 1 0 pc) e_set +| EConstr e_constr -> + pp_node buffer ~pad "EConstr"; + pp_constr_expr buffer ~pad:(mk_pad 1 0 pc) e_constr +| ERecord {value; _} -> + pp_node buffer ~pad "ERecord"; + pp_injection pp_field_assign buffer ~pad value +| EProj {value; _} -> + pp_node buffer ~pad "EProj"; + pp_projection buffer ~pad value +| EMap e_map -> + pp_node buffer ~pad "EMap"; + pp_map_expr buffer ~pad:(mk_pad 1 0 pc) e_map +| EVar {value; _} -> + pp_node buffer ~pad "EVar"; + pp_ident buffer ~pad:(mk_pad 1 0 pc) value +| ECall {value; _} -> + pp_node buffer ~pad "ECall"; + pp_fun_call buffer ~pad value +| EBytes {value; _} -> + pp_node buffer ~pad "EBytes"; + pp_bytes buffer ~pad value +| EUnit _ -> + pp_node buffer ~pad "EUnit" +| ETuple e_tuple -> + pp_node buffer ~pad "ETuple"; + pp_tuple_expr buffer ~pad e_tuple +| EPar {value; _} -> + pp_node buffer ~pad "EPar"; + pp_expr buffer ~pad:(mk_pad 1 0 pc) value.inside + +and pp_list_expr buffer ~pad:(_,pc as pad) = function + Cons {value; _} -> + pp_node buffer ~pad "Cons"; + pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1; + pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2 +| List {value; _} -> + pp_node buffer ~pad "List"; + pp_injection pp_expr buffer ~pad value +| Nil _ -> + pp_node buffer ~pad "Nil" + +and pp_arith_expr buffer ~pad:(_,pc as pad) = function + Add {value; _} -> + pp_bin_op "Add" buffer ~pad value +| Sub {value; _} -> + pp_bin_op "Sub" buffer ~pad value +| Mult {value; _} -> + pp_bin_op "Mult" buffer ~pad value +| Div {value; _} -> + pp_bin_op "Div" buffer ~pad value +| Mod {value; _} -> + pp_bin_op "Mod" buffer ~pad value +| Neg {value; _} -> + pp_node buffer ~pad "Neg"; + pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg; +| Int {value; _} -> + pp_node buffer ~pad "Int"; + pp_int buffer ~pad value +| Nat {value; _} -> + pp_node buffer ~pad "Nat"; + pp_int buffer ~pad value +| Mutez {value; _} -> + pp_node buffer ~pad "Mutez"; + pp_int buffer ~pad value + +and pp_set_expr buffer ~pad:(_,pc as pad) = function + SetInj {value; _} -> + pp_node buffer ~pad "SetInj"; + pp_injection pp_expr buffer ~pad value +| SetMem {value; _} -> + pp_node buffer ~pad "SetMem"; + pp_expr buffer ~pad:(mk_pad 2 0 pc) value.set; + pp_expr buffer ~pad:(mk_pad 2 1 pc) value.element + +and pp_e_logic buffer ~pad = function + BoolExpr e -> + pp_node buffer ~pad "BoolExpr"; + pp_bool_expr buffer ~pad e +| CompExpr e -> + pp_node buffer ~pad "CompExpr"; + pp_comp_expr buffer ~pad e + +and pp_bool_expr buffer ~pad:(_,pc as pad) = function + Or {value; _} -> + pp_bin_op "Or" buffer ~pad value +| And {value; _} -> + pp_bin_op "And" buffer ~pad value +| Not {value; _} -> + let _, pc as pad = mk_pad 1 0 pc in + pp_node buffer ~pad "Not"; + pp_expr buffer ~pad:(mk_pad 1 0 pc) value.arg +| False _ -> + pp_node buffer ~pad:(mk_pad 1 0 pc) "False" +| True _ -> + pp_node buffer ~pad:(mk_pad 1 0 pc) "True" + +and pp_comp_expr buffer ~pad = function + Lt {value; _} -> + pp_bin_op "Lt" buffer ~pad value +| Leq {value; _} -> + pp_bin_op "Leq" buffer ~pad value +| Gt {value; _} -> + pp_bin_op "Gt" buffer ~pad value +| Geq {value; _} -> + pp_bin_op "Geq" buffer ~pad value +| Equal {value; _} -> + pp_bin_op "Equal" buffer ~pad value +| Neq {value; _} -> + pp_bin_op "Neq" buffer ~pad value + +and pp_constr_expr buffer ~pad:(_, pc as pad) = function + SomeApp {value=some_region,args; _} -> + let constr = {value="Some"; region=some_region} in + let app = constr, Some args in + pp_node buffer ~pad "SomeApp"; + pp_constr_app buffer ~pad app +| NoneExpr _ -> + pp_node buffer ~pad "NoneExpr" +| ConstrApp {value; _} -> + pp_node buffer ~pad "ConstrApp"; + pp_constr_app buffer ~pad:(mk_pad 1 0 pc) value + +and pp_constr_app buffer ~pad (constr, args_opt) = + pp_ident buffer ~pad constr.value; + match args_opt with + None -> () + | Some args -> pp_tuple_expr buffer ~pad args + +and pp_map_expr buffer ~pad = function + MapLookUp {value; _} -> + pp_node buffer ~pad "MapLookUp"; + pp_map_lookup buffer ~pad value +| MapInj {value; _} | BigMapInj {value; _} -> + pp_node buffer ~pad "MapInj"; + pp_injection pp_binding buffer ~pad value + +and pp_tuple_expr buffer ~pad:(_,pc) {value; _} = + let exprs = Utils.nsepseq_to_list value.inside in + let length = List.length exprs in + let apply len rank = + pp_expr buffer ~pad:(mk_pad len rank pc) + in List.iteri (apply length) exprs + +and pp_string_expr buffer ~pad:(_,pc as pad) = function + Cat {value; _} -> + pp_node buffer ~pad "Cat"; + pp_expr buffer ~pad:(mk_pad 2 0 pc) value.arg1; + pp_expr buffer ~pad:(mk_pad 2 1 pc) value.arg2; +| String {value; _} -> + pp_node buffer ~pad "String"; + pp_string buffer ~pad:(mk_pad 1 0 pc) value + +and pp_annotated buffer ~pad:(_,pc) (expr, t_expr) = + pp_expr buffer ~pad:(mk_pad 2 0 pc) expr; + pp_type_expr buffer ~pad:(mk_pad 2 1 pc) t_expr + +and pp_bin_op node buffer ~pad:(_,pc as pad) op = + pp_node buffer ~pad node; + pp_expr buffer ~pad:(mk_pad 2 0 pc) op.arg1; + pp_expr buffer ~pad:(mk_pad 2 1 pc) op.arg2 + +let pp_ast buffer = pp_ast buffer ~pad:("","") diff --git a/src/passes/1-parser/pascaligo/ParserLog.mli b/src/passes/1-parser/pascaligo/ParserLog.mli index ad0c3f4f3..bf53dc3e2 100644 --- a/src/passes/1-parser/pascaligo/ParserLog.mli +++ b/src/passes/1-parser/pascaligo/ParserLog.mli @@ -12,3 +12,5 @@ val tokens_to_string : AST.t -> string val path_to_string : AST.path -> string val pattern_to_string : AST.pattern -> string val instruction_to_string : AST.instruction -> string + +val pp_ast : Buffer.t -> AST.t -> unit diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml index 70d8a8542..5fa99ab76 100644 --- a/src/passes/1-parser/pascaligo/ParserMain.ml +++ b/src/passes/1-parser/pascaligo/ParserMain.ml @@ -103,6 +103,14 @@ let () = try let ast = Parser.contract tokeniser buffer in if Utils.String.Set.mem "ast" options.verbose + then let buffer = Buffer.create 131 in + begin + ParserLog.offsets := options.offsets; + ParserLog.mode := options.mode; + ParserLog.pp_ast buffer ast; + Buffer.output_buffer stdout buffer + end + else if Utils.String.Set.mem "ast-tokens" options.verbose then let buffer = Buffer.create 131 in begin ParserLog.offsets := options.offsets; diff --git a/src/passes/1-parser/pascaligo/SParser.ml b/src/passes/1-parser/pascaligo/SParser.ml index faa9780ed..70dc5166b 100644 --- a/src/passes/1-parser/pascaligo/SParser.ml +++ b/src/passes/1-parser/pascaligo/SParser.ml @@ -312,7 +312,7 @@ and unary_expr = parser and core_expr = parser [< 'Int _ >] -> () | [< 'Nat _ >] -> () -| [< 'Mtz _ >] -> () +| [< 'Mutez _ >] -> () | [< 'Ident _; _ = opt core_suffix >] -> () | [< 'String _ >] -> () | [< 'Bytes _ >] -> () diff --git a/src/passes/1-parser/shared/EvalOpt.ml b/src/passes/1-parser/shared/EvalOpt.ml index 44bb9adc8..a4508ab30 100644 --- a/src/passes/1-parser/shared/EvalOpt.ml +++ b/src/passes/1-parser/shared/EvalOpt.ml @@ -39,7 +39,7 @@ let help language extension () = print " -q, --quiet No output, except errors (default)"; print " --columns Columns for source locations"; print " --bytes Bytes for source locations"; - print " --verbose= cmdline, cpp, ast (colon-separated)"; + print " --verbose= cmdline, cpp, ast-tokens, ast (colon-separated)"; print " --version Commit hash on stdout"; print " -h, --help This help"; exit 0 diff --git a/src/passes/1-parser/shared/Lexer.mli b/src/passes/1-parser/shared/Lexer.mli index 7d4cbb810..cc0359998 100644 --- a/src/passes/1-parser/shared/Lexer.mli +++ b/src/passes/1-parser/shared/Lexer.mli @@ -60,22 +60,22 @@ module type TOKEN = (* Errors *) - type int_err = Non_canonical_zero - type ident_err = Reserved_name - type invalid_natural = - | Invalid_natural - | Non_canonical_zero_nat + type int_err = Non_canonical_zero + type ident_err = Reserved_name + type nat_err = Invalid_natural + | Non_canonical_zero_nat + type sym_err = Invalid_symbol (* Injections *) + val mk_int : lexeme -> Region.t -> (token, int_err) result + val mk_nat : lexeme -> Region.t -> (token, nat_err) result + val mk_mutez : lexeme -> Region.t -> (token, int_err) result + val mk_ident : lexeme -> Region.t -> (token, ident_err) result + val mk_sym : lexeme -> Region.t -> (token, sym_err) result val mk_string : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token - val mk_int : lexeme -> Region.t -> (token, int_err) result - val mk_nat : lexeme -> Region.t -> (token, invalid_natural) result - val mk_mtz : lexeme -> Region.t -> (token, int_err) result - val mk_ident : lexeme -> Region.t -> (token, ident_err) result val mk_constr : lexeme -> Region.t -> token - val mk_sym : lexeme -> Region.t -> token val eof : Region.t -> token (* Predicates *) diff --git a/src/passes/1-parser/shared/Lexer.mll b/src/passes/1-parser/shared/Lexer.mll index f2172595f..3f2ac2020 100644 --- a/src/passes/1-parser/shared/Lexer.mll +++ b/src/passes/1-parser/shared/Lexer.mll @@ -101,22 +101,22 @@ module type TOKEN = (* Errors *) - type int_err = Non_canonical_zero - type ident_err = Reserved_name - type invalid_natural = - | Invalid_natural - | Non_canonical_zero_nat + type int_err = Non_canonical_zero + type ident_err = Reserved_name + type nat_err = Invalid_natural + | Non_canonical_zero_nat + type sym_err = Invalid_symbol (* Injections *) + val mk_int : lexeme -> Region.t -> (token, int_err) result + val mk_nat : lexeme -> Region.t -> (token, nat_err) result + val mk_mutez : lexeme -> Region.t -> (token, int_err) result + val mk_ident : lexeme -> Region.t -> (token, ident_err) result + val mk_sym : lexeme -> Region.t -> (token, sym_err) result val mk_string : lexeme -> Region.t -> token val mk_bytes : lexeme -> Region.t -> token - val mk_int : lexeme -> Region.t -> (token, int_err) result - val mk_nat : lexeme -> Region.t -> (token, invalid_natural) result - val mk_mtz : lexeme -> Region.t -> (token, int_err) result - val mk_ident : lexeme -> Region.t -> (token, ident_err) result val mk_constr : lexeme -> Region.t -> token - val mk_sym : lexeme -> Region.t -> token val eof : Region.t -> token (* Predicates *) @@ -343,6 +343,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) = type Error.t += Broken_string type Error.t += Invalid_character_in_string type Error.t += Reserved_name + type Error.t += Invalid_symbol type Error.t += Invalid_natural let error_to_string = function @@ -386,6 +387,9 @@ module Make (Token: TOKEN) : (S with module Token = Token) = | Reserved_name -> "Reserved named.\n\ Hint: Change the name.\n" + | Invalid_symbol -> + "Invalid symbol.\n\ + Hint: Check the LIGO syntax you use.\n" | Invalid_natural -> "Invalid natural." | _ -> assert false @@ -432,9 +436,9 @@ module Make (Token: TOKEN) : (S with module Token = Token) = | Error Token.Invalid_natural -> fail region Invalid_natural - let mk_mtz state buffer = + let mk_mutez state buffer = let region, lexeme, state = sync state buffer in - match Token.mk_mtz lexeme region with + match Token.mk_mutez lexeme region with Ok token -> token, state | Error Token.Non_canonical_zero -> fail region Non_canonical_zero @@ -443,7 +447,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) = let region, lexeme, state = sync state buffer in let lexeme = Str.string_before lexeme (String.index lexeme 't') in let lexeme = Z.mul (Z.of_int 1_000_000) (Z.of_string lexeme) in - match Token.mk_mtz (Z.to_string lexeme ^ "mtz") region with + match Token.mk_mutez (Z.to_string lexeme ^ "mutez") region with Ok token -> token, state | Error Token.Non_canonical_zero -> fail region Non_canonical_zero @@ -457,9 +461,9 @@ module Make (Token: TOKEN) : (S with module Token = Token) = let num = Z.of_string (integral ^ fractional) and den = Z.of_string ("1" ^ String.make (len-index-1) '0') and million = Q.of_string "1000000" in - let mtz = Q.make num den |> Q.mul million in - let should_be_1 = Q.den mtz in - if Z.equal Z.one should_be_1 then Some (Q.num mtz) else None + let mutez = Q.make num den |> Q.mul million in + let should_be_1 = Q.den mutez in + if Z.equal Z.one should_be_1 then Some (Q.num mutez) else None | exception Not_found -> assert false let mk_tz_decimal state buffer = @@ -467,7 +471,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) = let lexeme = Str.string_before lexeme (String.index lexeme 't') in match format_tz lexeme with | Some tz -> ( - match Token.mk_mtz (Z.to_string tz ^ "mtz") region with + match Token.mk_mutez (Z.to_string tz ^ "mutez") region with Ok token -> token, state | Error Token.Non_canonical_zero -> @@ -487,8 +491,10 @@ module Make (Token: TOKEN) : (S with module Token = Token) = in Token.mk_constr lexeme region, state let mk_sym state buffer = - let region, lexeme, state = sync state buffer - in Token.mk_sym lexeme region, state + let region, lexeme, state = sync state buffer in + match Token.mk_sym lexeme region with + Ok token -> token, state + | Error Token.Invalid_symbol -> fail region Invalid_symbol let mk_eof state buffer = let region, _, state = sync state buffer @@ -518,12 +524,17 @@ let byte_seq = byte | byte (byte | '_')* byte let bytes = "0x" (byte_seq? as seq) let esc = "\\n" | "\\\"" | "\\\\" | "\\b" | "\\r" | "\\t" | "\\x" byte -let symbol = ';' | ',' | '(' | ')'| '[' | ']' | '{' | '}' - | '#' | '|' | "->" | ":=" | '=' | ':' - | '<' | "<=" | '>' | ">=" | "=/=" | "<>" - | '+' | '-' | '*' | '/' | '.' | '_' | '^' - | "::" | "||" | "&&" -let string = [^'"' '\\' '\n']* (* For strings of #include *) +let pascaligo_sym = "=/=" | '#' | ":=" +let cameligo_sym = "<>" | "::" | "||" | "&&" + +let symbol = + ';' | ',' | '(' | ')'| '[' | ']' | '{' | '}' +| '=' | ':' | '|' | "->" | '.' | '_' | '^' +| '+' | '-' | '*' | '/' +| '<' | "<=" | '>' | ">=" +| pascaligo_sym | cameligo_sym + +let string = [^'"' '\\' '\n']* (* For strings of #include *) (* RULES *) @@ -548,7 +559,7 @@ and scan state = parse | bytes { (mk_bytes seq) state lexbuf |> enqueue } | natural 'n' { mk_nat state lexbuf |> enqueue } | natural 'p' { mk_nat state lexbuf |> enqueue } -| natural "mtz" { mk_mtz state lexbuf |> enqueue } +| natural "mutez" { mk_mutez state lexbuf |> enqueue } | natural "tz" { mk_tz state lexbuf |> enqueue } | decimal "tz" { mk_tz_decimal state lexbuf |> enqueue } | natural { mk_int state lexbuf |> enqueue } diff --git a/src/passes/1-parser/shared/Markup.mli b/src/passes/1-parser/shared/Markup.mli index 2522b52a9..6b31c0647 100644 --- a/src/passes/1-parser/shared/Markup.mli +++ b/src/passes/1-parser/shared/Markup.mli @@ -1,12 +1,11 @@ -(* This module defines the sorts of markup recognised by the LIGO +(** This module defines the sorts of markup recognised by the LIGO lexer *) module Region = Simple_utils.Region -(* A lexeme is piece of concrete syntax belonging to a token. In +(** A lexeme is piece of concrete syntax belonging to a token. In algebraic terms, a token is also a piece of abstract lexical syntax. Lexical units emcompass both markup and lexemes. *) - type lexeme = string type t = @@ -19,7 +18,7 @@ type t = type markup = t -(* Pretty-printing of markup +(** Pretty-printing of markup The difference between [to_lexeme] and [to_string] is that the former builds the corresponding concrete syntax (the lexeme), diff --git a/src/passes/2-simplify/dune b/src/passes/2-simplify/dune index 9649d13dc..e27b5139d 100644 --- a/src/passes/2-simplify/dune +++ b/src/passes/2-simplify/dune @@ -6,6 +6,7 @@ tezos-utils parser ast_simplified + self_ast_simplified operators) (modules ligodity pascaligo simplify) (preprocess diff --git a/src/passes/2-simplify/ligodity.ml b/src/passes/2-simplify/ligodity.ml index 92877e722..68e5b136f 100644 --- a/src/passes/2-simplify/ligodity.ml +++ b/src/passes/2-simplify/ligodity.ml @@ -49,28 +49,6 @@ module Errors = struct ] in error ~data title message - let unsupported_arith_op expr = - let title () = "arithmetic expressions" in - let message () = - Format.asprintf "this arithmetic operator is not supported yet" in - let expr_loc = Raw.expr_to_region expr in - let data = [ - ("expr_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc) - ] in - error ~data title message - - let unsupported_string_catenation expr = - let title () = "string expressions" in - let message () = - Format.asprintf "string concatenation is not supported yet" in - let expr_loc = Raw.expr_to_region expr in - let data = [ - ("expr_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ expr_loc) - ] in - error ~data title message - let untyped_fun_param var = let title () = "function parameter" in let message () = @@ -431,13 +409,12 @@ let rec simpl_expression : let n = Z.to_int @@ snd @@ n in return @@ e_literal ~loc (Literal_nat n) ) - | EArith (Mtz n) -> ( + | EArith (Mutez n) -> ( let (n , loc) = r_split n in let n = Z.to_int @@ snd @@ n in return @@ e_literal ~loc (Literal_mutez n) ) - | EArith _ as e -> - fail @@ unsupported_arith_op e + | EArith (Neg e) -> simpl_unop "NEG" e | EString (String s) -> ( let (s , loc) = r_split s in let s' = @@ -446,8 +423,11 @@ let rec simpl_expression : in return @@ e_literal ~loc (Literal_string s') ) - | EString (Cat _) as e -> - fail @@ unsupported_string_catenation e + | EString (Cat c) -> + let (c, loc) = r_split c in + let%bind string_left = simpl_expression c.arg1 in + let%bind string_right = simpl_expression c.arg2 in + return @@ e_string_cat ~loc string_left string_right | ELogic l -> simpl_logic_expression l | EList l -> simpl_list_expression l | ECase c -> ( diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 095ab6ac5..4dee47dec 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -8,7 +8,6 @@ open Combinators let nseq_to_list (hd, tl) = hd :: tl let npseq_to_list (hd, tl) = hd :: (List.map snd tl) -let npseq_to_nelist (hd, tl) = hd, (List.map snd tl) let pseq_to_list = function | None -> [] | Some lst -> npseq_to_list lst @@ -36,26 +35,6 @@ module Errors = struct ] in error ~data title message - let unsupported_proc_decl decl = - let title () = "procedure declarations" in - let message () = - Format.asprintf "procedures are not supported yet" in - let data = [ - ("declaration", - fun () -> Format.asprintf "%a" Location.pp_lift @@ decl.Region.region) - ] in - error ~data title message - - let unsupported_local_proc region = - let title () = "local procedure declarations" in - let message () = - Format.asprintf "local procedures are not supported yet" in - let data = [ - ("declaration", - fun () -> Format.asprintf "%a" Location.pp_lift @@ region) - ] in - error ~data title message - let corner_case ~loc message = let title () = "corner case" in let content () = "We don't have a good error message for this case. \ @@ -89,79 +68,6 @@ module Errors = struct ] in error ~data title message - let unsupported_proc_calls call = - let title () = "procedure calls" in - let message () = - Format.asprintf "procedure calls are not supported yet" in - let data = [ - ("call_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ call.Region.region) - ] in - error ~data title message - - let unsupported_for_loops region = - let title () = "bounded iterators" in - let message () = - Format.asprintf "only simple for loops are supported for now" in - let data = [ - ("loop_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ region) - ] in - error ~data title message - - let unsupported_empty_record_patch record_expr = - let title () = "empty record patch" in - let message () = - Format.asprintf "empty record patches are not supported yet" in - let data = [ - ("record_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ record_expr.Region.region) - ] in - error ~data title message - - let unsupported_map_patches patch = - let title () = "map patches" in - let message () = - Format.asprintf "map patches (a.k.a. functional updates) are \ - not supported yet" in - let data = [ - ("patch_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ patch.Region.region) - ] in - error ~data title message - - let unsupported_set_patches patch = - let title () = "set patches" in - let message () = - Format.asprintf "set patches (a.k.a. functional updates) are \ - not supported yet" in - let data = [ - ("patch_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ patch.Region.region) - ] in - error ~data title message - - (* let unsupported_set_removal remove = - let title () = "set removals" in - let message () = - Format.asprintf "removal of elements in a set is not \ - supported yet" in - let data = [ - ("removal_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ remove.Region.region) - ] in - error ~data title message *) - - let unsupported_deep_set_rm path = - let title () = "set removals" in - let message () = - Format.asprintf "removal of members from embedded sets is not supported yet" in - let data = [ - ("path_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ path.Region.region) - ] in - error ~data title message - let unsupported_non_var_pattern p = let title () = "pattern is not a variable" in let message () = @@ -221,13 +127,14 @@ module Errors = struct ] in error ~data title message - let unsupported_sub_blocks b = - let title () = "block instructions" in + let unsupported_deep_access_for_collection for_col = + let title () = "deep access in loop over collection" in let message () = - Format.asprintf "Sub-blocks are not supported yet" in + Format.asprintf "currently, we do not support deep \ + accesses in loops over collection" in let data = [ - ("block_loc", - fun () -> Format.asprintf "%a" Location.pp_lift @@ b.Region.region) + ("pattern_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ for_col.Region.region) ] in error ~data title message @@ -309,7 +216,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = let%bind lst = bind_list @@ List.map aux @@ List.map apply - @@ pseq_to_list r.value.elements in + @@ npseq_to_list r.value.ne_elements in let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in ok @@ T_record m | TSum s -> @@ -317,10 +224,11 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = let args = match v.value.args with None -> [] - | Some (_, product) -> - npseq_to_list product.value in - let%bind te = simpl_list_type_expression - @@ args in + | Some (_, t_expr) -> + match t_expr with + TProd product -> npseq_to_list product.value + | _ -> [t_expr] in + let%bind te = simpl_list_type_expression @@ args in ok (v.value.constr.value, te) in let%bind lst = bind_list @@ -389,8 +297,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = let (x' , loc) = r_split x in return @@ e_literal ~loc (Literal_bytes (Bytes.of_string @@ fst x')) | ETuple tpl -> - let (Raw.TupleInj tpl') = tpl in - let (tpl' , loc) = r_split tpl' in + let (tpl' , loc) = r_split tpl in simpl_tuple_expression ~loc @@ npseq_to_list tpl'.inside | ERecord r -> let%bind fields = bind_list @@ -442,7 +349,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = let n = Z.to_int @@ snd @@ n in return @@ e_literal ~loc (Literal_nat n) ) - | EArith (Mtz n) -> ( + | EArith (Mutez n) -> ( let (n , loc) = r_split n in let n = Z.to_int @@ snd @@ n in return @@ e_literal ~loc (Literal_mutez n) @@ -463,6 +370,12 @@ let rec simpl_expression (t:Raw.expr) : expr result = | ELogic l -> simpl_logic_expression l | EList l -> simpl_list_expression l | ESet s -> simpl_set_expression s + | ECond c -> + let (c , loc) = r_split c in + let%bind expr = simpl_expression c.test in + let%bind match_true = simpl_expression c.ifso in + let%bind match_false = simpl_expression c.ifnot in + return @@ e_matching expr ~loc (Match_bool {match_true; match_false}) | ECase c -> ( let (c , loc) = r_split c in let%bind e = simpl_expression c.expr in @@ -477,7 +390,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = let%bind cases = simpl_cases lst in return @@ e_matching ~loc e cases ) - | EMap (MapInj mi) -> ( + | EMap (MapInj mi) -> ( let (mi , loc) = r_split mi in let%bind lst = let lst = List.map get_value @@ pseq_to_list mi.elements in @@ -489,6 +402,18 @@ let rec simpl_expression (t:Raw.expr) : expr result = bind_map_list aux lst in return @@ e_map ~loc lst ) + | EMap (BigMapInj mi) -> ( + let (mi , loc) = r_split mi in + let%bind lst = + let lst = List.map get_value @@ pseq_to_list mi.elements in + let aux : Raw.binding -> (expression * expression) result = + fun b -> + let%bind src = simpl_expression b.source in + let%bind dst = simpl_expression b.image in + ok (src, dst) in + bind_map_list aux lst in + return @@ e_big_map ~loc lst + ) | EMap (MapLookUp lu) -> ( let (lu , loc) = r_split lu in let%bind path = match lu.path with @@ -594,8 +519,7 @@ and simpl_local_declaration : Raw.local_decl -> _ result = fun t -> let (f , loc) = r_split f in let%bind (name , e) = simpl_fun_declaration ~loc f in return_let_in ~loc name e - | LocalProc d -> - fail @@ unsupported_local_proc d.Region.region + and simpl_data_declaration : Raw.data_decl -> _ result = fun t -> match t with | LocalVar x -> @@ -630,11 +554,13 @@ and simpl_fun_declaration : fun ~loc x -> let open! Raw in let {name;param;ret_type;local_decls;block;return} : fun_decl = x in - (match npseq_to_list param.value.inside with - | [] -> - fail @@ - corner_case ~loc:__LOC__ "parameter-less function should not exist" - | [a] -> ( + let statements = + match block with + | Some block -> npseq_to_list block.value.statements + | None -> [] + in + (match param.value.inside with + a, [] -> ( let%bind input = simpl_param a in let name = name.value in let (binder , input_type) = input in @@ -642,7 +568,7 @@ and simpl_fun_declaration : bind_map_list simpl_local_declaration local_decls in let%bind instructions = bind_list @@ List.map simpl_statement - @@ npseq_to_list block.value.statements in + @@ statements in let%bind result = simpl_expression return in let%bind output_type = simpl_type_expression ret_type in let body = local_declarations @ instructions in @@ -655,6 +581,7 @@ and simpl_fun_declaration : ok ((name , type_annotation) , expression) ) | lst -> ( + let lst = npseq_to_list lst in let arguments_name = "arguments" in let%bind params = bind_map_list simpl_param lst in let (binder , input_type) = @@ -672,7 +599,7 @@ and simpl_fun_declaration : bind_map_list simpl_local_declaration local_decls in let%bind instructions = bind_list @@ List.map simpl_statement - @@ npseq_to_list block.value.statements in + @@ statements in let%bind result = simpl_expression return in let%bind output_type = simpl_type_expression ret_type in let body = tpl_declarations @ local_declarations @ instructions in @@ -703,13 +630,11 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = ok @@ Declaration_constant (name.value , type_annotation , expression) in bind_map_location simpl_const_decl (Location.lift_region x) - | LambdaDecl (FunDecl x) -> ( + | FunDecl x -> ( let (x , loc) = r_split x in let%bind ((name , ty_opt) , expr) = simpl_fun_declaration ~loc x in ok @@ Location.wrap ~loc (Declaration_constant (name , ty_opt , expr)) ) - | LambdaDecl (ProcDecl decl) -> - fail @@ unsupported_proc_decl decl and simpl_statement : Raw.statement -> (_ -> expression result) result = fun s -> @@ -717,7 +642,7 @@ and simpl_statement : Raw.statement -> (_ -> expression result) result = | Instr i -> simpl_instruction i | Data d -> simpl_data_declaration d -and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) result = +and simpl_single_instruction : Raw.instruction -> (_ -> expression result) result = fun t -> match t with | ProcCall x -> ( @@ -743,17 +668,35 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu let%bind body = simpl_block l.block.value in let%bind body = body None in return_statement @@ e_loop cond body - | Loop (For (ForInt {region; _} | ForCollect {region ; _})) -> - fail @@ unsupported_for_loops region + | Loop (For (ForInt fi)) -> + let%bind loop = simpl_for_int fi.value in + let%bind loop = loop None in + return_statement @@ loop + | Loop (For (ForCollect fc)) -> + let%bind loop = simpl_for_collect fc.value in + let%bind loop = loop None in + return_statement @@ loop | Cond c -> ( let (c , loc) = r_split c in let%bind expr = simpl_expression c.test in let%bind match_true = match c.ifso with - | ClauseInstr i -> simpl_instruction_block i - | ClauseBlock b -> simpl_statements @@ fst b.value.inside in + ClauseInstr i -> + simpl_single_instruction i + | ClauseBlock b -> + match b with + LongBlock {value; _} -> + simpl_block value + | ShortBlock {value; _} -> + simpl_statements @@ fst value.inside in let%bind match_false = match c.ifnot with - | ClauseInstr i -> simpl_instruction_block i - | ClauseBlock b -> simpl_statements @@ fst b.value.inside in + ClauseInstr i -> + simpl_single_instruction i + | ClauseBlock b -> + match b with + LongBlock {value; _} -> + simpl_block value + | ShortBlock {value; _} -> + simpl_statements @@ fst value.inside in let%bind match_true = match_true None in let%bind match_false = match_false None in return_statement @@ e_matching expr ~loc (Match_bool {match_true; match_false}) @@ -772,7 +715,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu | Name name -> ok (name.value , e_variable name.value, []) | Path p -> let (name,p') = simpl_path v'.path in - let%bind accessor = simpl_projection p in + let%bind accessor = simpl_projection p in ok @@ (name , accessor , p') in let%bind key_expr = simpl_expression v'.index.value.inside in @@ -784,10 +727,19 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu let (c , loc) = r_split c in let%bind expr = simpl_expression c.expr in let%bind cases = - let aux (x : Raw.instruction Raw.case_clause Raw.reg) = - let%bind i = simpl_instruction_block x.value.rhs in - let%bind i = i None in - ok (x.value.pattern, i) in + let aux (x : Raw.if_clause Raw.case_clause Raw.reg) = + let%bind case_clause = + match x.value.rhs with + ClauseInstr i -> + simpl_single_instruction i + | ClauseBlock b -> + match b with + LongBlock {value; _} -> + simpl_block value + | ShortBlock {value; _} -> + simpl_statements @@ fst value.inside in + let%bind case_clause = case_clause None in + ok (x.value.pattern, case_clause) in bind_list @@ List.map aux @@ npseq_to_list c.cases.value in @@ -797,30 +749,72 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu | RecordPatch r -> ( let r = r.value in let (name , access_path) = simpl_path r.path in - let%bind inj = bind_list - @@ List.map (fun (x:Raw.field_assign Region.reg) -> + + let head, tail = r.record_inj.value.ne_elements in + + let%bind tail' = bind_list + @@ List.map (fun (x: Raw.field_assign Region.reg) -> let (x , loc) = r_split x in let%bind e = simpl_expression x.field_expr in ok (x.field_name.value, e , loc) ) - @@ pseq_to_list r.record_inj.value.elements in + @@ List.map snd tail in + + let%bind head' = + let (x , loc) = r_split head in + let%bind e = simpl_expression x.field_expr + in ok (x.field_name.value, e , loc) in + let%bind expr = let aux = fun (access , v , loc) -> - e_assign ~loc name (access_path @ [ Access_record access ]) v in - let assigns = List.map aux inj in - match assigns with - | [] -> fail @@ unsupported_empty_record_patch r.record_inj - | hd :: tl -> ( - let aux acc cur = e_sequence acc cur in - ok @@ List.fold_left aux hd tl - ) + e_assign ~loc name (access_path @ [Access_record access]) v in + + let hd, tl = aux head', List.map aux tail' in + let aux acc cur = e_sequence acc cur in + ok @@ List.fold_left aux hd tl in return_statement @@ expr + ) + | MapPatch patch -> ( + let (map_p, loc) = r_split patch in + let (name, access_path) = simpl_path map_p.path in + let%bind inj = bind_list + @@ List.map (fun (x:Raw.binding Region.reg) -> + let x = x.value in + let (key, value) = x.source, x.image in + let%bind key' = simpl_expression key in + let%bind value' = simpl_expression value + in ok @@ (key', value') + ) + @@ npseq_to_list map_p.map_inj.value.ne_elements in + let expr = + match inj with + | [] -> e_skip ~loc () + | _ :: _ -> + let assigns = List.fold_right + (fun (key, value) map -> (e_map_add key value map)) + inj + (e_accessor ~loc (e_variable name) access_path) + in e_assign ~loc name access_path assigns + in return_statement @@ expr + ) + | SetPatch patch -> ( + let (setp, loc) = r_split patch in + let (name , access_path) = simpl_path setp.path in + let%bind inj = + bind_list @@ + List.map simpl_expression @@ + npseq_to_list setp.set_inj.value.ne_elements in + let expr = + match inj with + | [] -> e_skip ~loc () + | _ :: _ -> + let assigns = List.fold_right + (fun hd s -> e_constant "SET_ADD" [hd ; s]) + inj (e_accessor ~loc (e_variable name) access_path) in + e_assign ~loc name access_path assigns in + return_statement @@ expr ) - | MapPatch patch -> - fail @@ unsupported_map_patches patch - | SetPatch patch -> - fail @@ unsupported_set_patches patch | MapRemove r -> ( let (v , loc) = r_split r in let key = v.key in @@ -828,7 +822,7 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu | Name v -> ok (v.value , e_variable v.value , []) | Path p -> let (name,p') = simpl_path v.map in - let%bind accessor = simpl_projection p in + let%bind accessor = simpl_projection p in ok @@ (name , accessor , p') in let%bind key' = simpl_expression key in @@ -837,12 +831,16 @@ and simpl_single_instruction : Raw.single_instr -> (_ -> expression result) resu ) | SetRemove r -> ( let (set_rm, loc) = r_split r in - let%bind set = match set_rm.set with - | Name v -> ok v.value - | Path path -> fail @@ unsupported_deep_set_rm path in + let%bind (varname, set, path) = match set_rm.set with + | Name v -> ok (v.value, e_variable v.value, []) + | Path path -> + let(name, p') = simpl_path set_rm.set in + let%bind accessor = simpl_projection path in + ok @@ (name, accessor, p') + in let%bind removed' = simpl_expression set_rm.element in - let expr = e_constant ~loc "SET_REMOVE" [removed' ; e_variable set] in - return_statement @@ e_assign ~loc set [] expr + let expr = e_constant ~loc "SET_REMOVE" [removed' ; set] in + return_statement @@ e_assign ~loc varname path expr ) and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p -> @@ -886,7 +884,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - | [] -> ok x' | _ -> ok t ) - | _ -> fail @@ corner_case ~loc:__LOC__ "unexpected pattern" in + | pattern -> ok pattern in let get_constr (t: Raw.pattern) = match t with | PConstr v -> ( @@ -951,18 +949,9 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - bind_map_list aux lst in ok @@ Match_variant constrs -and simpl_instruction_block : Raw.instruction -> (_ -> expression result) result = - fun t -> - match t with - | Single s -> simpl_single_instruction s - | Block b -> simpl_block b.value - and simpl_instruction : Raw.instruction -> (_ -> expression result) result = fun t -> - trace (simplifying_instruction t) @@ - match t with - | Single s -> simpl_single_instruction s - | Block b -> fail @@ unsupported_sub_blocks b + trace (simplifying_instruction t) @@ simpl_single_instruction t and simpl_statements : Raw.statements -> (_ -> expression result) result = fun ss -> @@ -979,5 +968,206 @@ and simpl_statements : Raw.statements -> (_ -> expression result) result = and simpl_block : Raw.block -> (_ -> expression result) result = fun t -> simpl_statements t.statements +and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> + (* cond part *) + let var = e_variable fi.assign.value.name.value in + let%bind value = simpl_expression fi.assign.value.expr in + let%bind bound = simpl_expression fi.bound in + let comp = e_annotation (e_constant "LE" [var ; bound]) t_bool + in + (* body part *) + let%bind body = simpl_block fi.block.value in + let%bind body = body None in + let step = e_int 1 in + let ctrl = e_assign + fi.assign.value.name.value [] (e_constant "ADD" [ var ; step ]) in + let rec add_to_seq expr = match expr.expression with + | E_sequence (_,a) -> add_to_seq a + | _ -> e_sequence body ctrl in + let body' = add_to_seq body in + let loop = e_loop comp body' in + return_statement @@ e_let_in (fi.assign.value.name.value, Some t_int) value loop + +(** simpl_for_collect + For loops over collections, like + + ``` concrete syntax : + for x : int in set myset + begin + myint := myint + x ; + myst := myst ^ "to" ; + end + ``` + + are implemented using a MAP_FOLD, LIST_FOLD or SET_FOLD: + + ``` pseudo Ast_simplified + let #COMPILER#folded_record = list_fold( mylist , + record st = st; acc = acc; end; + lamby = fun arguments -> ( + let #COMPILER#acc = arguments.0 in + let #COMPILER#elt = arguments.1 in + #COMPILER#acc.myint := #COMPILER#acc.myint + #COMPILER#elt ; + #COMPILER#acc.myst := #COMPILER#acc.myst ^ "to" ; + #COMPILER#acc + ) + ) in + { + myst := #COMPILER#folded_record.myst ; + myint := #COMPILER#folded_record.myint ; + } + ``` + + We are performing the following steps: + 1) Simplifying the for body using ̀simpl_block` + + 2) Detect the free variables and build a list of their names + (myint and myst in the previous example) + + 3) Build the initial record (later passed as 2nd argument of + `MAP/SET/LIST_FOLD`) capturing the environment using the + free variables list of (2) + + 4) In the filtered body of (1), replace occurences: + - free variable of name X as rhs ==> accessor `#COMPILER#acc.X` + - free variable of name X as lhs ==> accessor `#COMPILER#acc.X` + And, in the case of a map: + - references to the iterated key ==> variable `#COMPILER#elt_key` + - references to the iterated value ==> variable `#COMPILER#elt_value` + in the case of a set/list: + - references to the iterated value ==> variable `#COMPILER#elt` + + 5) Append the return value to the body + + 6) Prepend the declaration of the lambda arguments to the body which + is a serie of `let .. in`'s + Note that the parameter of the lambda ̀arguments` is a tree of + tuple holding: + * In the case of `list` or ̀set`: + ( folding record , current list/set element ) as + ( #COMPILER#acc , #COMPILER#elt ) + * In the case of `map`: + ( folding record , current map key , current map value ) as + ( #COMPILER#acc , #COMPILER#elt_key , #COMPILER#elt_value ) + + 7) Build the lambda using the final body of (6) + + 8) Build a sequence of assignments for all the captured variables + to their new value, namely an access to the folded record + (#COMPILER#folded_record) + + 9) Attach the sequence of 8 to the ̀let .. in` declaration + of #COMPILER#folded_record + +**) +and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc -> + (* STEP 1 *) + let%bind for_body = simpl_block fc.block.value in + let%bind for_body = for_body None in + (* STEP 2 *) + let%bind captured_name_list = Self_ast_simplified.fold_expression + (fun (prev : type_name list) (ass_exp : expression) -> + match ass_exp.expression with + | E_assign ( name , _ , _ ) -> + if (String.contains name '#') then + ok prev + else + ok (name::prev) + | _ -> ok prev ) + [] + for_body in + (* STEP 3 *) + let add_to_record (prev: expression type_name_map) (captured_name: string) = + SMap.add captured_name (e_variable captured_name) prev in + let init_record = e_record (List.fold_left add_to_record SMap.empty captured_name_list) in + (* STEP 4 *) + let replace exp = + match exp.expression with + (* replace references to fold accumulator as rhs *) + | E_assign ( name , path , expr ) -> ( + match path with + | [] -> ok @@ e_assign "#COMPILER#acc" [Access_record name] expr + (* This fails for deep accesses, see LIGO-131 LIGO-134 *) + | _ -> + (* ok @@ e_assign "#COMPILER#acc" ((Access_record name)::path) expr) *) + fail @@ unsupported_deep_access_for_collection fc.block ) + | E_variable name -> ( + if (List.mem name captured_name_list) then + (* replace references to fold accumulator as lhs *) + ok @@ e_accessor (e_variable "#COMPILER#acc") [Access_record name] + else match fc.collection with + (* loop on map *) + | Map _ -> + let k' = e_variable "#COMPILER#collec_elt_k" in + if ( name = fc.var.value ) then + ok @@ k' (* replace references to the the key *) + else ( + match fc.bind_to with + | Some (_,v) -> + let v' = e_variable "#COMPILER#collec_elt_v" in + if ( name = v.value ) then + ok @@ v' (* replace references to the the value *) + else ok @@ exp + | None -> ok @@ exp + ) + (* loop on set or list *) + | (Set _ | List _) -> + if (name = fc.var.value ) then + (* replace references to the collection element *) + ok @@ (e_variable "#COMPILER#collec_elt") + else ok @@ exp + ) + | _ -> ok @@ exp in + let%bind for_body = Self_ast_simplified.map_expression replace for_body in + (* STEP 5 *) + let rec add_return (expr : expression) = match expr.expression with + | E_sequence (a,b) -> e_sequence a (add_return b) + | _ -> e_sequence expr (e_variable "#COMPILER#acc") in + let for_body = add_return for_body in + (* STEP 6 *) + let for_body = + let ( arg_access: Types.access_path -> expression ) = e_accessor (e_variable "arguments") in + ( match fc.collection with + | Map _ -> + (* let acc = arg_access [Access_tuple 0 ; Access_tuple 0] in + let collec_elt_v = arg_access [Access_tuple 1 ; Access_tuple 0] in + let collec_elt_k = arg_access [Access_tuple 1 ; Access_tuple 1] in *) + (* The above should work, but not yet (see LIGO-131) *) + let temp_kv = arg_access [Access_tuple 1] in + let acc = arg_access [Access_tuple 0] in + let collec_elt_v = e_accessor (e_variable "#COMPILER#temp_kv") [Access_tuple 0] in + let collec_elt_k = e_accessor (e_variable "#COMPILER#temp_kv") [Access_tuple 1] in + e_let_in ("#COMPILER#acc", None) acc @@ + e_let_in ("#COMPILER#temp_kv", None) temp_kv @@ + e_let_in ("#COMPILER#collec_elt_k", None) collec_elt_v @@ + e_let_in ("#COMPILER#collec_elt_v", None) collec_elt_k (for_body) + | _ -> + let acc = arg_access [Access_tuple 0] in + let collec_elt = arg_access [Access_tuple 1] in + e_let_in ("#COMPILER#acc", None) acc @@ + e_let_in ("#COMPILER#collec_elt", None) collec_elt (for_body) + ) in + (* STEP 7 *) + let%bind collect = simpl_expression fc.expr in + let lambda = e_lambda "arguments" None None for_body in + let op_name = match fc.collection with + | Map _ -> "MAP_FOLD" | Set _ -> "SET_FOLD" | List _ -> "LIST_FOLD" in + let fold = e_constant op_name [collect ; init_record ; lambda] in + (* STEP 8 *) + let assign_back (prev : expression option) (captured_varname : string) : expression option = + let access = e_accessor (e_variable "#COMPILER#folded_record") + [Access_record captured_varname] in + let assign = e_assign captured_varname [] access in + match prev with + | None -> Some assign + | Some p -> Some (e_sequence p assign) in + let reassign_sequence = List.fold_left assign_back None captured_name_list in + (* STEP 9 *) + let final_sequence = match reassign_sequence with + (* None case means that no variables were captured *) + | None -> e_skip () + | Some seq -> e_let_in ("#COMPILER#folded_record", None) fold seq in + return_statement @@ final_sequence + let simpl_program : Raw.ast -> program result = fun t -> - bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl + bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl \ No newline at end of file diff --git a/src/passes/2-simplify/pascaligo.mli b/src/passes/2-simplify/pascaligo.mli index ccc42e5e1..f0e63026a 100644 --- a/src/passes/2-simplify/pascaligo.mli +++ b/src/passes/2-simplify/pascaligo.mli @@ -1,81 +1,22 @@ +(** Converts PascaLIGO programs to the Simplified Abstract Syntax Tree. *) + open Trace open Ast_simplified module Raw = Parser.Pascaligo.AST module SMap = Map.String -(* -val nseq_to_list : 'a * 'a list -> 'a list -val npseq_to_list : 'a * ( 'b * 'a ) list -> 'a list -*) -val npseq_to_nelist : 'a * ( 'b * 'c ) list -> 'a * 'c list -(* -val pseq_to_list : ('a * ('b * 'a) list) option -> 'a list -val get_value : 'a Raw.reg -> 'a -*) +module Errors : + sig + val bad_bytes : Location.t -> string -> unit -> error + val unsupported_arith_op : Raw.expr -> unit -> error + end -module Errors : sig - (* - val unsupported_cst_constr : Raw.pattern -> unit -> error - val unsupported_ass_None : Raw.wild -> unit -> error - val unsupported_entry_decl : 'a Raw.reg -> unit -> error - val unsupported_proc_decl : 'a Raw.reg -> unit -> error - *) - val bad_bytes : Location.t -> string -> unit -> error - (* - val unsupported_local_proc : Raw.wild -> unit -> error - val corner_case : loc:string -> string -> unit -> error - val unknown_predefined_type : string Raw.reg -> unit -> error - *) - val unsupported_arith_op : Raw.expr -> unit -> error - (* - val unsupported_set_expr : Raw.expr -> unit -> error - *) - val unsupported_proc_calls : 'a Raw.reg -> unit -> error - (* - val unsupported_for_loops : Raw.wild -> unit -> error - val unsupported_deep_map_assign : 'a Raw.reg -> unit -> error - val unsupported_empty_record_patch : 'a Raw.reg -> unit -> error - val unsupported_map_patches : 'a Raw.reg -> unit -> error - val unsupported_set_patches : 'a Raw.reg -> unit -> error - val unsupported_deep_map_rm : 'a Raw.reg -> unit -> error - val unsupported_set_removal : 'a Raw.reg -> unit -> error - val unsupported_non_var_pattern : Raw.pattern -> unit -> error - val only_constructors : Raw.pattern -> unit -> error - val unsupported_tuple_pattern : Raw.pattern -> unit -> error - val unsupported_deep_Some_patterns : Raw.pattern -> unit -> error - val unsupported_deep_list_patterns : 'a Raw.reg -> unit -> error - val unsupported_sub_blocks : 'a Raw.reg -> unit -> error - val simplifying_instruction : Raw.instruction -> unit -> error - *) -end -(* -val r_split : 'a Raw.reg -> 'a * Location.t -val return : expr -> ( expr option -> expr result ) result -val return_let_in : ?loc:Location.t -> string * type_expression option -> expr -> ( expr option -> expr result ) result -val simpl_type_expression : Raw.type_expr -> type_expression result -val simpl_list_type_expression : Raw.type_expr list -> type_expression result -*) +(** Convert a concrete PascaLIGO expression AST to the simplified expression AST + used by the compiler. *) val simpl_expression : Raw.expr -> expr result -(* -val simpl_logic_expression : Raw.logic_expr -> expression result -val simpl_list_expression : Raw.list_expr -> expression result -val simpl_set_expression : Raw.set_expr -> expression result -val simpl_binop : string -> Raw.wild Raw.bin_op Region.reg -> expression result -val simpl_unop : string -> Raw.wild Raw.un_op Region.reg -> expression result -val simpl_tuple_expression : ?loc:Location.t -> Raw.expr list -> expression result -val simpl_local_declaration : Raw.local_decl -> ( expr option -> expr result) result -val simpl_data_declaration : Raw.data_decl -> ( expr option -> expr result ) result -val simpl_param : Raw.param_decl -> (type_name * type_expression) result -val simpl_fun_declaration : loc:Location.t -> Raw.fun_decl -> ((name * type_expression option) * expression) result -val simpl_declaration : Raw.declaration -> declaration Location.wrap result -val simpl_single_instruction : Raw.single_instr -> (expression option -> expression result) result -val simpl_path : Raw.path -> string * Ast_simplified.access_path -val simpl_cases : (Raw.pattern * 'a) list -> 'a matching result -val simpl_instruction_block : Raw.instruction -> (expression option -> expression result) result -val simpl_instruction : Raw.instruction -> (expression option -> expression result) result -val simpl_statements : Raw.statements -> (expression option -> expression result) result -val simpl_block : Raw.block -> (expression option -> expression result) result -*) + +(** Convert a concrete PascaLIGO program AST to the simplified program AST used + by the compiler. *) val simpl_program : Raw.ast -> program result diff --git a/src/passes/3-self_ast_simplified/helpers.ml b/src/passes/3-self_ast_simplified/helpers.ml index 0793e8420..04b641f87 100644 --- a/src/passes/3-self_ast_simplified/helpers.ml +++ b/src/passes/3-self_ast_simplified/helpers.ml @@ -1,8 +1,93 @@ open Ast_simplified open Trace -type mapper = expression -> expression result +type 'a folder = 'a -> expression -> 'a result +let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e -> + let self = fold_expression f in + let%bind init' = f init e in + match e.expression with + | E_literal _ | E_variable _ | E_skip -> ok init' + | E_list lst | E_set lst | E_tuple lst | E_constant (_ , lst) -> ( + let%bind res' = bind_fold_list self init' lst in + ok res' + ) + | E_map lst | E_big_map lst -> ( + let%bind res' = bind_fold_list (bind_fold_pair self) init' lst in + ok res' + ) + | E_look_up ab | E_sequence ab | E_loop ab | E_application ab -> ( + let%bind res' = bind_fold_pair self init' ab in + ok res' + ) + | E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e } + | E_annotation (e , _) | E_constructor (_ , e) -> ( + let%bind res' = self init' e in + ok res' + ) + | E_assign (_ , path , e) | E_accessor (e , path) -> ( + let%bind res' = fold_path f init' path in + let%bind res' = self res' e in + ok res' + ) + | E_matching (e , cases) -> ( + let%bind res = self init' e in + let%bind res = fold_cases f res cases in + ok res + ) + | E_record m -> ( + let aux init'' _ expr = + let%bind res' = fold_expression self init'' expr in + ok res' + in + let%bind res = bind_fold_smap aux (ok init') m in + ok res + ) + | E_let_in { binder = _ ; rhs ; result } -> ( + let%bind res = self init' rhs in + let%bind res = self res result in + ok res + ) +and fold_path : 'a folder -> 'a -> access_path -> 'a result = fun f init p -> bind_fold_list (fold_access f) init p + +and fold_access : 'a folder -> 'a -> access -> 'a result = fun f init a -> + match a with + | Access_map e -> ( + let%bind e' = fold_expression f init e in + ok e' + ) + | _ -> ok init + +and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind res = fold_expression f init match_true in + let%bind res = fold_expression f res match_false in + ok res + ) + | Match_list { match_nil ; match_cons = (_ , _ , cons) } -> ( + let%bind res = fold_expression f init match_nil in + let%bind res = fold_expression f res cons in + ok res + ) + | Match_option { match_none ; match_some = (_ , some) } -> ( + let%bind res = fold_expression f init match_none in + let%bind res = fold_expression f res some in + ok res + ) + | Match_tuple (_ , e) -> ( + let%bind res = fold_expression f init e in + ok res + ) + | Match_variant lst -> ( + let aux init' ((_ , _) , e) = + let%bind res' = fold_expression f init' e in + ok res' in + let%bind res = bind_fold_list aux init lst in + ok res + ) + +type mapper = expression -> expression result let rec map_expression : mapper -> expression -> expression result = fun f e -> let self = map_expression f in let%bind e' = f e in diff --git a/src/passes/3-self_ast_simplified/literals.ml b/src/passes/3-self_ast_simplified/literals.ml index 5d7be25b6..154851601 100644 --- a/src/passes/3-self_ast_simplified/literals.ml +++ b/src/passes/3-self_ast_simplified/literals.ml @@ -4,6 +4,27 @@ open Trace let peephole_expression : expression -> expression result = fun e -> let return expression = ok { e with expression } in match e.expression with + | E_constant ("BIG_MAP_LITERAL" , lst) -> ( + let%bind elt = + trace_option (simple_error "big_map literal expects a single parameter") @@ + List.to_singleton lst + in + let%bind lst = + trace (simple_error "big_map literal expects a list as parameter") @@ + get_e_list elt.expression + in + let aux = fun (e : expression) -> + trace (simple_error "big_map literal expects a list of pairs as parameter") @@ + let%bind tpl = get_e_tuple e.expression in + let%bind (a , b) = + trace_option (simple_error "of pairs") @@ + List.to_pair tpl + in + ok (a , b) + in + let%bind pairs = bind_map_list aux lst in + return @@ E_big_map pairs + ) | E_constant ("MAP_LITERAL" , lst) -> ( let%bind elt = trace_option (simple_error "map literal expects a single parameter") @@ @@ -25,6 +46,13 @@ let peephole_expression : expression -> expression result = fun e -> let%bind pairs = bind_map_list aux lst in return @@ E_map pairs ) + | E_constant ("BIG_MAP_EMPTY" , lst) -> ( + let%bind () = + trace_strong (simple_error "BIG_MAP_EMPTY expects no parameter") @@ + Assert.assert_list_empty lst + in + return @@ E_big_map [] + ) | E_constant ("MAP_EMPTY" , lst) -> ( let%bind () = trace_strong (simple_error "MAP_EMPTY expects no parameter") @@ diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_simplified/self_ast_simplified.ml index aa18b4a8c..a1ce4b580 100644 --- a/src/passes/3-self_ast_simplified/self_ast_simplified.ml +++ b/src/passes/3-self_ast_simplified/self_ast_simplified.ml @@ -21,3 +21,7 @@ let all_program = let all_expression = let all_p = List.map Helpers.map_expression all in bind_chain all_p + +let map_expression = Helpers.map_expression + +let fold_expression = Helpers.fold_expression diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 6a82ba9a6..ab2ecd61d 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -707,6 +707,42 @@ and type_expression : environment -> Solver.state -> I.expression -> (O.annotate * let%bind (name', tv) = * type_constant name tv_lst tv_opt ae.location in * return (E_constant (name' , lst')) tv *) + | E_constant ( ("LIST_FOLD"|"MAP_FOLD"|"SET_FOLD") as opname , + [ collect ; + init_record ; + ( { expression = (I.E_lambda { binder = (lname, None) ; + input_type = None ; + output_type = None ; + result }) ; + location = _ }) as _lambda + ] ) -> +let _TODO = (opname, collect, init_record, lname, result) in +failwith "TODO: E_constant merge" +(* ******************************************************************************************************************************************************** *) +(* + (* this special case is here force annotation of the untyped lambda + generated by pascaligo's for_collect loop *) + let%bind (v_col , v_initr ) = bind_map_pair (type_expression e) (collect , init_record ) in + let tv_col = get_type_annotation v_col in (* this is the type of the collection *) + let tv_out = get_type_annotation v_initr in (* this is the output type of the lambda*) + let%bind input_type = match tv_col.type_value' with + | O.T_constant ( ("list"|"set") , t) -> ok @@ t_tuple (tv_out::t) () + | O.T_constant ( "map" , t) -> ok @@ t_tuple (tv_out::[(t_tuple t ())]) () + | _ -> + let wtype = Format.asprintf + "Loops over collections expect lists, sets or maps, got type %a" O.PP.type_value tv_col in + fail @@ simple_error wtype in + let e' = Environment.add_ez_binder lname input_type e in + let%bind body = type_expression ?tv_opt:(Some tv_out) e' result in + let output_type = body.type_annotation in + let lambda' = make_a_e (E_lambda {binder = lname ; body}) (t_function input_type output_type ()) e in + let lst' = [v_col; v_initr ; lambda'] in + let tv_lst = List.map get_type_annotation lst' in + let%bind (opname', tv) = + type_constant opname tv_lst tv_opt ae.location in + return (E_constant (opname' , lst')) tv +*) +(* ******************************************************************************************************************************************************** *) | E_application (f, arg) -> let%bind (f' , state') = type_expression e state f in let%bind (arg , state'') = type_expression e state' arg in diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 7c7cd3e1c..42ec5c380 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -1,3 +1,7 @@ +(* The Transpiler is a function that takes as input the Typed AST, and outputs expressions in a language that is basically a Michelson with named variables and first-class-environments. + +For more info, see back-end.md: https://gitlab.com/ligolang/ligo/blob/dev/gitlab-pages/docs/contributors/big-picture/back-end.md *) + open! Trace open Helpers @@ -125,6 +129,7 @@ let rec transpile_type (t:AST.type_value) : type_value result = | T_constant (Type_name "timestamp", []) -> ok (T_base Base_timestamp) | T_constant (Type_name "unit", []) -> ok (T_base Base_unit) | T_constant (Type_name "operation", []) -> ok (T_base Base_operation) + | T_constant (Type_name "signature", []) -> ok (T_base Base_signature) | T_constant (Type_name "contract", [x]) -> let%bind x' = transpile_type x in ok (T_contract x') @@ -296,21 +301,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re | E_application (a, b) -> let%bind a = transpile_annotated_expression a in let%bind b = transpile_annotated_expression b in - let%bind contains_closure = - Self_mini_c.Helpers.fold_type_value - (fun contains_closure exp -> - ok (contains_closure - || match exp with - | T_deep_closure _ -> true - | _ -> false)) - false - b.type_value in - if contains_closure - then - let errmsg = Format.asprintf "Cannot apply closure in function arguments: %a\n" - Mini_c.PP.expression_with_type b in - fail @@ simple_error errmsg - else return @@ E_application (a, b) + return @@ E_application (a, b) | E_constructor (m, param) -> ( let%bind param' = transpile_annotated_expression param in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in diff --git a/src/passes/8-compiler/compiler_environment.ml b/src/passes/8-compiler/compiler_environment.ml index a196d9c49..d205c421b 100644 --- a/src/passes/8-compiler/compiler_environment.ml +++ b/src/passes/8-compiler/compiler_environment.ml @@ -14,31 +14,46 @@ let get : environment -> string -> michelson result = fun e s -> error title content in generic_try error @@ (fun () -> Environment.get_i s e) in - let rec aux = fun n -> + let rec aux_bubble = fun n -> match n with | 0 -> i_dup | n -> seq [ - dip @@ aux (n - 1) ; + dip @@ aux_bubble (n - 1) ; i_swap ; ] in - let code = aux position in + let aux_dig = fun n -> seq [ + dipn n i_dup ; + i_dig n ; + ] + in + let code = + if position < 2 + then aux_bubble position + else aux_dig position in ok code let set : environment -> string -> michelson result = fun e s -> let%bind (_ , position) = - generic_try (simple_error "Environment.get") @@ + generic_try (simple_error "Environment.set") @@ (fun () -> Environment.get_i s e) in - let rec aux = fun n -> + let rec aux_bubble = fun n -> match n with | 0 -> dip i_drop | n -> seq [ i_swap ; - dip (aux (n - 1)) ; + dip (aux_bubble (n - 1)) ; ] in - let code = aux position in + let aux_dug = fun n -> seq [ + dipn (n + 1) i_drop ; + i_dug n ; + ] in + let code = + if position < 2 + then aux_bubble position + else aux_dug position in ok code @@ -73,5 +88,12 @@ let pack_closure : environment -> selector -> michelson result = fun e lst -> ok code let unpack_closure : environment -> michelson result = fun e -> - let aux = fun code _ -> seq [ i_unpair ; dip code ] in - ok (List.fold_right' aux (seq []) e) + match e with + | [] -> ok @@ seq [] + | _ :: tl -> ( + let aux = fun code _ -> seq [ i_unpair ; dip code ] in + let unpairs = (List.fold_right' aux (seq []) tl) in + ok @@ seq [ i_unpiar ; dip unpairs ] + ) + (* let aux = fun code _ -> seq [ i_unpair ; dip code ] in + * ok (List.fold_right' aux (seq []) e) *) diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index ef3d19395..5ec9d7a7c 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -151,33 +151,21 @@ and translate_expression (expr:expression) (env:environment) : michelson result return @@ seq [ closure_pack_code ; i_push lambda_ty lambda_body_code ; - i_pair ; + i_swap ; + i_apply ; ] ) | _ -> simple_fail "expected closure type" ) | E_application (f , arg) -> ( - match Combinators.Expression.get_type f with - | T_function _ -> ( - trace (simple_error "Compiling quote application") @@ - let%bind f = translate_expression f env in - let%bind arg = translate_expression arg env in - return @@ seq [ - arg ; - dip f ; - prim I_EXEC ; - ] - ) - | T_deep_closure (_ , _ , _) -> ( - let%bind f_code = translate_expression f env in - let%bind arg_code = translate_expression arg env in - return @@ seq [ - arg_code ; - dip (seq [ f_code ; i_unpair ; i_swap ]) ; i_pair ; - prim I_EXEC ; - ] - ) - | _ -> simple_fail "E_applicationing something not appliable" + trace (simple_error "Compiling quote application") @@ + let%bind f = translate_expression f env in + let%bind arg = translate_expression arg env in + return @@ seq [ + arg ; + dip f ; + prim I_EXEC ; + ] ) | E_variable x -> let%bind code = Compiler_environment.get env x in diff --git a/src/passes/8-compiler/compiler_type.ml b/src/passes/8-compiler/compiler_type.ml index 4521339bd..df0ff7bc6 100644 --- a/src/passes/8-compiler/compiler_type.ml +++ b/src/passes/8-compiler/compiler_type.ml @@ -32,24 +32,24 @@ module Ty = struct let mutez = Mutez_t None let string = String_t None let key = Key_t None - let list a = List_t (a, None) + let list a = List_t (a, None , has_big_map a) let set a = Set_t (a, None) let address = Address_t None - let option a = Option_t ((a, None), None, None) + let option a = Option_t (a, None , has_big_map a) let contract a = Contract_t (a, None) let lambda a b = Lambda_t (a, b, None) let timestamp = Timestamp_t None - let map a b = Map_t (a, b, None) - let pair a b = Pair_t ((a, None, None), (b, None, None), None) - let union a b = Union_t ((a, None), (b, None), None) + let map a b = Map_t (a, b, None , has_big_map b) + let pair a b = Pair_t ((a, None, None), (b, None, None), None , has_big_map a || has_big_map b) + let union a b = Union_t ((a, None), (b, None), None , has_big_map a || has_big_map b) let field_annot = Option.map (fun ann -> `Field_annot ann) let union_ann (anna, a) (annb, b) = - Union_t ((a, field_annot anna), (b, field_annot annb), None) + Union_t ((a, field_annot anna), (b, field_annot annb), None , has_big_map a || has_big_map b) let pair_ann (anna, a) (annb, b) = - Pair_t ((a, field_annot anna, None), (b, field_annot annb, None), None) + Pair_t ((a, field_annot anna, None), (b, field_annot annb, None), None , has_big_map a || has_big_map b) let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) () let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) () @@ -68,6 +68,7 @@ module Ty = struct | Base_timestamp -> return timestamp_k | Base_bytes -> return bytes_k | Base_operation -> fail (not_comparable "operation") + | Base_signature -> fail (not_comparable "signature") let comparable_type : type_value -> ex_comparable_ty result = fun tv -> match tv with @@ -97,6 +98,7 @@ module Ty = struct | Base_timestamp -> return timestamp | Base_bytes -> return bytes | Base_operation -> return operation + | Base_signature -> return signature let rec type_ : type_value -> ex_ty result = function @@ -115,11 +117,10 @@ module Ty = struct let%bind (Ex_ty arg) = type_ arg in let%bind (Ex_ty ret) = type_ ret in ok @@ Ex_ty (lambda arg ret) - | T_deep_closure (c, arg, ret) -> - let%bind (Ex_ty capture) = environment_representation c in + | T_deep_closure (_, arg, ret) -> let%bind (Ex_ty arg) = type_ arg in let%bind (Ex_ty ret) = type_ ret in - ok @@ Ex_ty (pair (lambda (pair arg capture) ret) capture) + ok @@ Ex_ty (lambda arg ret) | T_map (k, v) -> let%bind (Ex_comparable_ty k') = comparable_type k in let%bind (Ex_ty v') = type_ v in @@ -183,6 +184,7 @@ let base_type : type_base -> O.michelson result = | Base_timestamp -> ok @@ O.prim T_timestamp | Base_bytes -> ok @@ O.prim T_bytes | Base_operation -> ok @@ O.prim T_operation + | Base_signature -> ok @@ O.prim T_signature let rec type_ : type_value -> O.michelson result = function @@ -219,10 +221,10 @@ let rec type_ : type_value -> O.michelson result = let%bind arg = type_ arg in let%bind ret = type_ ret in ok @@ O.prim ~children:[arg;ret] T_lambda - | T_deep_closure (c , arg , ret) -> - let%bind capture = environment_closure c in - let%bind lambda = lambda_closure (c , arg , ret) in - ok @@ O.t_pair lambda capture + | T_deep_closure (_ , arg , ret) -> + let%bind arg = type_ arg in + let%bind ret = type_ ret in + ok @@ O.prim ~children:[arg;ret] T_lambda and annotated : type_value annotated -> O.michelson result = function @@ -243,7 +245,7 @@ and lambda_closure = fun (c , arg , ret) -> let%bind capture = environment_closure c in let%bind arg = type_ arg in let%bind ret = type_ ret in - ok @@ O.t_lambda (O.t_pair arg capture) ret + ok @@ O.t_lambda (O.t_pair capture arg) ret and environment_closure = function diff --git a/src/passes/8-compiler/uncompiler.ml b/src/passes/8-compiler/uncompiler.ml index 310d3a72f..3e28f4db8 100644 --- a/src/passes/8-compiler/uncompiler.ml +++ b/src/passes/8-compiler/uncompiler.ml @@ -8,16 +8,16 @@ open Script_ir_translator let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = match (ty, value) with - | Pair_t ((a_ty, _, _), (b_ty, _, _), _), (a, b) -> ( + | Pair_t ((a_ty, _, _), (b_ty, _, _), _ , _), (a, b) -> ( let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in ok @@ D_pair(a, b) ) - | Union_t ((a_ty, _), _, _), L a -> ( + | Union_t ((a_ty, _), _, _ , _), L a -> ( let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in ok @@ D_left a ) - | Union_t (_, (b_ty, _), _), R b -> ( + | Union_t (_, (b_ty, _), _ , _), R b -> ( let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in ok @@ D_right b ) @@ -47,16 +47,16 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = ok @@ D_string s | (Bytes_t _), b -> ok @@ D_bytes (Tezos_stdlib.MBytes.to_bytes b) - | (Address_t _), s -> + | (Address_t _), (s , _) -> ok @@ D_string (Alpha_context.Contract.to_b58check s) | (Unit_t _), () -> ok @@ D_unit | (Option_t _), None -> ok @@ D_none - | (Option_t ((o_ty, _), _, _)), Some s -> + | (Option_t (o_ty, _, _)), Some s -> let%bind s' = translate_value @@ Ex_typed_value (o_ty, s) in ok @@ D_some s' - | (Map_t (k_cty, v_ty, _)), m -> + | (Map_t (k_cty, v_ty, _ , _)), m -> let k_ty = Script_ir_translator.ty_of_comparable_ty k_cty in let lst = let aux k v acc = (k, v) :: acc in @@ -95,7 +95,7 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = | None -> ok orig_rem in bind_fold_list aux original_big_map lst in ok @@ D_big_map lst' - | (List_t (ty, _)), lst -> + | (List_t (ty, _ , _)), lst -> let%bind lst' = let aux = fun t -> translate_value (Ex_typed_value (ty, t)) in bind_map_list aux lst @@ -113,7 +113,7 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = in ok @@ D_set lst'' ) - | (Operation_t _) , op -> + | (Operation_t _) , (op , _) -> ok @@ D_operation op | ty, v -> let%bind error = diff --git a/src/passes/9-self_michelson/self_michelson.ml b/src/passes/9-self_michelson/self_michelson.ml index 3085376e3..711bf64f2 100644 --- a/src/passes/9-self_michelson/self_michelson.ml +++ b/src/passes/9-self_michelson/self_michelson.ml @@ -14,13 +14,44 @@ open Tezos_utils.Michelson without effects other than gas consumption. It must never fail. *) let arity : prim -> int option = function + (* stack things *) + | I_DIP -> None + | I_DROP -> None + | I_DUP -> None + | I_SWAP -> None + | I_DIG -> None + | I_DUG -> None + (* control *) + | I_FAILWITH -> None + | I_EXEC -> None + | I_IF -> None + | I_IF_CONS -> None + | I_IF_LEFT -> None + | I_IF_NONE -> None + | I_LOOP -> None + | I_MAP -> None + | I_ITER -> None + | I_LOOP_LEFT -> None + (* internal ops *) + | I_CREATE_ACCOUNT -> None + | I_CREATE_CONTRACT -> None + | I_TRANSFER_TOKENS -> None + | I_SET_DELEGATE -> None + (* tez arithmetic (can fail) *) + | I_ADD -> None + | I_MUL -> None + | I_SUB -> None (* can fail for tez *) + (* etc *) + | I_CONCAT -> None (* sometimes 1, sometimes 2 :( *) + | I_CAST -> None + | I_RENAME -> None + (* stuff *) | I_PACK -> Some 1 | I_UNPACK -> Some 1 | I_BLAKE2B -> Some 1 | I_SHA256 -> Some 1 | I_SHA512 -> Some 1 | I_ABS -> Some 1 - | I_ADD -> None (* can fail for tez *) | I_AMOUNT -> Some 0 | I_AND -> Some 2 | I_BALANCE -> Some 0 @@ -28,39 +59,24 @@ let arity : prim -> int option = function | I_CDR -> Some 1 | I_CHECK_SIGNATURE -> Some 3 | I_COMPARE -> Some 2 - | I_CONCAT -> None (* sometimes 1, sometimes 2 :( *) | I_CONS -> Some 2 - | I_CREATE_ACCOUNT -> None (* effects, kind of *) - | I_CREATE_CONTRACT -> None (* effects, kind of *) | I_IMPLICIT_ACCOUNT -> Some 1 - | I_DIP -> None - | I_DROP -> None - | I_DUP -> None | I_EDIV -> Some 2 | I_EMPTY_MAP -> Some 0 | I_EMPTY_SET -> Some 0 | I_EQ -> Some 1 - | I_EXEC -> None (* effects *) - | I_FAILWITH -> None | I_GE -> Some 1 | I_GET -> Some 2 | I_GT -> Some 1 | I_HASH_KEY -> Some 1 - | I_IF -> None - | I_IF_CONS -> None - | I_IF_LEFT -> None - | I_IF_NONE -> None | I_INT -> Some 1 | I_LAMBDA -> Some 0 | I_LE -> Some 1 | I_LEFT -> Some 1 - | I_LOOP -> None | I_LSL -> Some 1 | I_LSR -> Some 1 | I_LT -> Some 1 - | I_MAP -> None | I_MEM -> Some 2 - | I_MUL -> None (* can fail for tez *) | I_NEG -> Some 1 | I_NEQ -> Some 1 | I_NIL -> Some 0 @@ -78,21 +94,17 @@ let arity : prim -> int option = function | I_SELF -> Some 0 | I_SLICE -> Some 3 | I_STEPS_TO_QUOTA -> Some 0 - | I_SUB -> None (* can fail for tez *) - | I_SWAP -> None - | I_TRANSFER_TOKENS -> None (* effects, kind of *) - | I_SET_DELEGATE -> None (* effects, kind of *) | I_UNIT -> Some 0 | I_UPDATE -> Some 3 | I_XOR -> Some 2 - | I_ITER -> None - | I_LOOP_LEFT -> None | I_ADDRESS -> Some 1 | I_CONTRACT -> Some 1 | I_ISNAT -> Some 1 - | I_CAST -> None - | I_RENAME -> None + | I_CHAIN_ID -> Some 0 + | I_EMPTY_BIG_MAP -> Some 0 + | I_APPLY -> Some 2 + (* not instructions *) | K_parameter | K_storage | K_code @@ -126,7 +138,9 @@ let arity : prim -> int option = function | T_timestamp | T_unit | T_operation - | T_address -> None + | T_address + | T_chain_id + -> None let is_nullary_op (p : prim) : bool = match arity p with @@ -264,15 +278,15 @@ let rec iterate_optimizer (f : michelson -> bool * michelson) : michelson -> mic let opt_drop2 : peep2 = function (* nullary_op ; DROP ↦ *) - | Prim (_, p, _, _), Prim (_, I_DROP, _, _) when is_nullary_op p -> Some [] + | Prim (_, p, _, _), Prim (_, I_DROP, [], _) when is_nullary_op p -> Some [] (* DUP ; DROP ↦ *) - | Prim (_, I_DUP, _, _), Prim (_, I_DROP, _, _) -> Some [] + | Prim (_, I_DUP, _, _), Prim (_, I_DROP, [], _) -> Some [] (* unary_op ; DROP ↦ DROP *) - | Prim (_, p, _, _), Prim (_, I_DROP, _, _) when is_unary_op p -> Some [i_drop] + | Prim (_, p, _, _), Prim (_, I_DROP, [], _) when is_unary_op p -> Some [i_drop] (* binary_op ; DROP ↦ DROP ; DROP *) - | Prim (_, p, _, _), Prim (_, I_DROP, _, _) when is_binary_op p -> Some [i_drop; i_drop] + | Prim (_, p, _, _), Prim (_, I_DROP, [], _) when is_binary_op p -> Some [i_drop; i_drop] (* ternary_op ; DROP ↦ DROP ; DROP ; DROP *) - | Prim (_, p, _, _), Prim (_, I_DROP, _, _) when is_ternary_op p -> Some [i_drop; i_drop; i_drop] + | Prim (_, p, _, _), Prim (_, I_DROP, [], _) when is_ternary_op p -> Some [i_drop; i_drop; i_drop] | _ -> None let opt_drop4 : peep4 = function @@ -280,7 +294,7 @@ let opt_drop4 : peep4 = function | Prim (_, I_DUP, _, _), (Prim (_, p, _, _) as unary_op), Prim (_, I_SWAP, _, _), - Prim (_, I_DROP, _, _) + Prim (_, I_DROP, [], _) when is_unary_op p -> Some [unary_op] | _ -> None @@ -294,19 +308,6 @@ let opt_dip1 : peep1 = function (* DIP { unary_op } ↦ SWAP ; unary_op ; SWAP *) | Prim (_, I_DIP, [Seq (_, [(Prim (_, p, _, _) as unary_op)])], _) when is_unary_op p -> Some [i_swap ; unary_op ; i_swap] - (* saves 5 bytes *) - (* DIP { DROP } ↦ SWAP ; DROP *) - | Prim (_, I_DIP, [Seq (_, [Prim (_, I_DROP, _, _)])], _) -> - Some [i_swap; i_drop] - (* saves 3 bytes *) - (* DIP { DROP ; DROP } ↦ SWAP ; DROP ; SWAP ; DROP *) - | Prim (_, I_DIP, [Seq (_, [Prim (_, I_DROP, _, _) ; Prim (_, I_DROP, _, _)])], _) -> - Some [i_swap; i_drop; i_swap; i_drop] - (* still saves 1 byte *) - (* DIP { DROP ; DROP ; DROP } ↦ SWAP ; DROP ; SWAP ; DROP ; SWAP ; DROP *) - | Prim (_, I_DIP, [Seq (_, [Prim (_, I_DROP, _, _) ; Prim (_, I_DROP, _, _) ; Prim (_, I_DROP, _, _)])], _) -> - Some [i_swap; i_drop; i_swap; i_drop; i_swap; i_drop] - (* after this, DIP { DROP ; ... } is smaller *) | _ -> None let opt_dip2 : peep2 = function @@ -316,16 +317,16 @@ let opt_dip2 : peep2 = function | Prim (_, I_DIP, [Seq (_, code1)], _), Prim (_, I_DIP, [Seq (_, code2)], _) -> Some [Prim (0, I_DIP, [Seq (0, code1 @ code2)], [])] (* DIP { code } ; DROP ↦ DROP ; code *) - | Prim (_, I_DIP, code, _), (Prim (_, I_DROP, _, _) as drop) -> + | Prim (_, I_DIP, [Seq (_, code)], _), (Prim (_, I_DROP, [], _) as drop) -> Some (drop :: code) (* nullary_op ; DIP { code } ↦ code ; nullary_op *) | (Prim (_, p, _, _) as nullary_op), Prim (_, I_DIP, [Seq (_, code)], _) when is_nullary_op p -> Some (code @ [nullary_op]) (* DIP { code } ; unary_op ↦ unary_op ; DIP { code } *) - | (Prim (_, I_DIP, _, _) as dip), (Prim (_, p, _, _) as unary_op) when is_unary_op p -> + | (Prim (_, I_DIP, [Seq _], _) as dip), (Prim (_, p, _, _) as unary_op) when is_unary_op p -> Some [unary_op; dip] (* unary_op ; DIP { code } ↦ DIP { code } ; unary_op *) - (* | (Prim (_, p, _, _) as unary_op), (Prim (_, I_DIP, _, _) as dip) when is_unary_op p -> + (* | (Prim (_, p, _, _) as unary_op), (Prim (_, I_DIP, [Seq _], _) as dip) when is_unary_op p -> * Some [dip; unary_op] *) | _ -> None @@ -371,6 +372,24 @@ let rec opt_tail_fail : michelson -> michelson = Prim (l, p, List.map opt_tail_fail args, annot) | x -> x +let rec opt_combine_drops (x : michelson) : michelson = + let rec combine : michelson list -> michelson list = function + | [] -> [] + | Prim (_, I_DROP, [], []) :: xs -> + let xs' = combine xs in + begin match xs' with + | [] -> [Prim (-1, I_DROP, [], [])] + | Prim (_, I_DROP, [], []) :: xs' -> Prim (-1, I_DROP, [Int (-1, Z.of_int 2)], []) :: xs' + | Prim (_, I_DROP, [Int (_, n)], []) :: xs' -> Prim (-1, I_DROP, [Int (-1, Z.of_int (1 + Z.to_int n))], []) :: xs' + | x' :: xs' -> Prim (-1, I_DROP, [], []) :: x' :: xs' + end + | x :: xs -> x :: combine xs in + match x with + | Seq (l, args) -> Seq (l, combine (List.map opt_combine_drops args)) + | Prim (l, p, args, annot) -> + Prim (l, p, List.map opt_combine_drops args, annot) + | x -> x + let optimize : michelson -> michelson = fun x -> let x = use_lambda_instr x in @@ -384,4 +403,5 @@ let optimize : michelson -> michelson = peephole @@ peep2 opt_swap2 ; ] in let x = iterate_optimizer (sequence_optimizers optimizers) x in + let x = opt_combine_drops x in x diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 1a8a84e35..4d21583c5 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -85,6 +85,7 @@ module Simplify = struct ("list_iter" , "LIST_ITER") ; ("list_fold" , "LIST_FOLD") ; ("list_map" , "LIST_MAP") ; + (*ici*) ("map_iter" , "MAP_ITER") ; ("map_map" , "MAP_MAP") ; ("map_fold" , "MAP_FOLD") ; @@ -154,6 +155,7 @@ module Simplify = struct ("Set.add" , "SET_ADD") ; ("Set.remove" , "SET_REMOVE") ; ("Set.fold" , "SET_FOLD") ; + ("Set.size", "SIZE") ; ("Map.find_opt" , "MAP_FIND_OPT") ; ("Map.find" , "MAP_FIND") ; @@ -167,6 +169,18 @@ module Simplify = struct ("Map.literal" , "MAP_LITERAL" ) ; ("Map.size" , "SIZE" ) ; + ("Big_map.find_opt" , "MAP_FIND_OPT") ; + ("Big_map.find" , "MAP_FIND") ; + ("Big_map.update" , "MAP_UPDATE") ; + ("Big_map.add" , "MAP_ADD") ; + ("Big_map.remove" , "MAP_REMOVE") ; + ("Big_map.literal" , "BIG_MAP_LITERAL" ) ; + ("Big_map.empty" , "BIG_MAP_EMPTY" ) ; + + ("Bitwise.lor" , "OR") ; + ("Bitwise.land" , "AND") ; + ("Bitwise.lxor" , "XOR") ; + ("String.length", "SIZE") ; ("String.size", "SIZE") ; ("String.slice", "SLICE") ; @@ -456,7 +470,10 @@ module Typer = struct let%bind () = assert_eq_1 op_lst (t_list (t_operation ()) ()) in ok @@ (t_pair (t_operation ()) (t_address ()) ()) - let get_contract = typer_1_opt "CONTRACT" @@ fun _ tv_opt -> + let get_contract = typer_1_opt "CONTRACT" @@ fun addr_tv tv_opt -> + if not (type_value_eq (addr_tv, t_address ())) + then fail @@ simple_error (Format.asprintf "get_contract expects an address, got %a" PP.type_value addr_tv) + else let%bind tv = trace_option (simple_error "get_contract needs a type annotation") tv_opt in let%bind tv' = @@ -497,11 +514,15 @@ module Typer = struct then ok @@ t_int () else if eq_1 a (t_mutez ()) && eq_1 b (t_nat ()) then ok @@ t_mutez () else + if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ()) + then ok @@ t_nat () else simple_fail "Dividing with wrong types" let mod_ = typer_2 "MOD" @@ fun a b -> if (eq_1 a (t_nat ()) || eq_1 a (t_int ())) && (eq_1 b (t_nat ()) || eq_1 b (t_int ())) then ok @@ t_nat () else + if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ()) + then ok @@ t_mutez () else simple_fail "Computing modulo with wrong types" let add = typer_2 "ADD" @@ fun a b -> diff --git a/src/stages/ast_simplified/PP.ml b/src/stages/ast_simplified/PP.ml index 19a802419..b99e7e62e 100644 --- a/src/stages/ast_simplified/PP.ml +++ b/src/stages/ast_simplified/PP.ml @@ -25,7 +25,7 @@ let literal ppf (l:literal) = match l with | Literal_int n -> fprintf ppf "%d" n | Literal_nat n -> fprintf ppf "+%d" n | Literal_timestamp n -> fprintf ppf "+%d" n - | Literal_mutez n -> fprintf ppf "%dmtz" n + | Literal_mutez n -> fprintf ppf "%dmutez" n | Literal_string s -> fprintf ppf "%S" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_address s -> fprintf ppf "@%S" s diff --git a/src/stages/ast_simplified/PP.mli b/src/stages/ast_simplified/PP.mli index 4a08aaf28..aa7c9470c 100644 --- a/src/stages/ast_simplified/PP.mli +++ b/src/stages/ast_simplified/PP.mli @@ -1,3 +1,5 @@ +(** Pretty printer for the Simplified Abstract Syntax Tree *) + open Types open Format @@ -32,7 +34,7 @@ val matching_variant_case : (formatter -> 'a -> unit) -> formatter -> (construct val matching : (formatter -> 'a -> unit) -> formatter -> 'a matching -> unit *) -(* Shows the type expected for the matched value *) +(** Shows the type expected for the matched value *) val matching_type : formatter -> 'a matching -> unit (* @@ -41,4 +43,5 @@ val matching_variant_case_type : formatter -> ( ( constructor_name * name) * 'a) val declaration : formatter -> declaration -> unit *) +(** Pretty print a full program AST *) val program : formatter -> program -> unit diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index b8533fc5b..c60eec0dd 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -70,7 +70,7 @@ and literal ppf (l:literal) : unit = | Literal_int n -> fprintf ppf "%d" n | Literal_nat n -> fprintf ppf "+%d" n | Literal_timestamp n -> fprintf ppf "+%d" n - | Literal_mutez n -> fprintf ppf "%dmtz" n + | Literal_mutez n -> fprintf ppf "%dmutez" n | Literal_string s -> fprintf ppf "%s" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_address s -> fprintf ppf "@%s" s diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index 951aa2ae6..e904ad01f 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -20,6 +20,7 @@ let type_base ppf : type_base -> _ = function | Base_timestamp -> fprintf ppf "timestamp" | Base_bytes -> fprintf ppf "bytes" | Base_operation -> fprintf ppf "operation" + | Base_signature -> fprintf ppf "signature" let rec type_ ppf : type_value -> _ = function | T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b @@ -53,7 +54,7 @@ let rec value ppf : value -> unit = function | D_int n -> fprintf ppf "%d" n | D_nat n -> fprintf ppf "+%d" n | D_timestamp n -> fprintf ppf "+%d" n - | D_mutez n -> fprintf ppf "%dmtz" n + | D_mutez n -> fprintf ppf "%dmutez" n | D_unit -> fprintf ppf "unit" | D_string s -> fprintf ppf "\"%s\"" s | D_bytes x -> diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index 5901b7dc6..2646d3dc9 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -6,7 +6,7 @@ type type_base = | Base_int | Base_nat | Base_tez | Base_timestamp | Base_string | Base_bytes | Base_address - | Base_operation + | Base_operation | Base_signature type 'a annotated = string option * 'a diff --git a/src/test/contracts/annotation.ligo b/src/test/contracts/annotation.ligo index 1eaef7b0c..7f5e969f4 100644 --- a/src/test/contracts/annotation.ligo +++ b/src/test/contracts/annotation.ligo @@ -1,3 +1,5 @@ +(* Test that a string is cast to an address given a type annotation *) + const lst : list(int) = list [] ; const address : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ; diff --git a/src/test/contracts/arithmetic.mligo b/src/test/contracts/arithmetic.mligo new file mode 100644 index 000000000..e3bb8ba07 --- /dev/null +++ b/src/test/contracts/arithmetic.mligo @@ -0,0 +1,30 @@ +// Test CameLIGO arithmetic operators + +let mod_op (n : int) : nat = + n mod 42 + +let plus_op (n : int) : int = + n + 42 + +let minus_op (n : int) : int = + n - 42 + +let times_op (n : int) : int = + n * 42 + +let div_op (n : int) : int = + n / 2 + +(* TODO (?): Support conversion from nat to int and back + +let int_op (n : nat) : int = + Int n + +*) + +let neg_op (n : int) : int = + -n + +let foo (n : int) : int = n + 10 + +let neg_op_2 (b: int) : int = -(foo b) diff --git a/src/test/contracts/big_map.ligo b/src/test/contracts/big_map.ligo index 8fb705ab5..3d504aa75 100644 --- a/src/test/contracts/big_map.ligo +++ b/src/test/contracts/big_map.ligo @@ -1,30 +1,36 @@ type storage_ is big_map(int, int) * unit +type foo is big_map(int, int) function main(const p : unit; const s : storage_) : list(operation) * storage_ is - var r : big_map(int, int) := s.0 ; var toto : option (int) := Some(0); block { - toto := r[23]; - r[2] := 444; - s.0 := r; + toto := s.0[23]; + s.0[2] := 444; } with ((nil: list(operation)), s) -function set_ (var n : int ; var m : storage_) : storage_ is block { - var tmp : big_map(int,int) := m.0 ; - tmp[23] := n ; - m.0 := tmp ; +function set_ (var n : int ; var m : foo) : foo is block { + m[23] := n ; } with m -function rm (var m : storage_) : storage_ is block { - var tmp : big_map(int,int) := m.0 ; - remove 42 from map tmp; - m.0 := tmp; +function rm (var m : foo) : foo is block { + remove 42 from map m; } with m -function gf (const m : storage_) : int is begin skip end with get_force(23, m.0) +function gf (const m : foo) : int is begin skip end with get_force(23, m) -function get (const m : storage_) : option(int) is - begin - skip - end with m.0[42] \ No newline at end of file +function get (const m : foo) : option(int) is begin skip end with m[42] + +const empty_big_map : big_map(int,int) = big_map end + +const big_map1 : big_map(int,int) = big_map + 23 -> 0 ; + 42 -> 0 ; +end + +function mutimaps (const m : foo ; const n : foo) : foo is block +{ + var bar : foo := m ; + bar[42] := 0 ; + n[42] := get_force(42, bar) ; +} with n \ No newline at end of file diff --git a/src/test/contracts/big_map.mligo b/src/test/contracts/big_map.mligo index d032fad8c..52a366fe6 100644 --- a/src/test/contracts/big_map.mligo +++ b/src/test/contracts/big_map.mligo @@ -1,12 +1,21 @@ -type storage_ = ((int, int) big_map * unit) +type foo = (int, int) big_map -let set_ (n : int) (m : storage_) : storage_ = - (Map.update 23 (Some(n)) m.(0), ()) +let set_ (n : int) (m : foo) : foo = Big_map.update 23 (Some(n)) m -let rm (m : storage_) : storage_ = - (Map.remove 42 m.(0), ()) +let rm (m : foo) : foo = Big_map.remove 42 m -let gf (m : storage_) : int = Map.find 23 m.(0) +let gf (m : foo) : int = Big_map.find 23 m -let get (m: storage_): int option = - Map.find_opt 42 m.(0) \ No newline at end of file +let get (m: foo): int option = Big_map.find_opt 42 m + +let empty_map : foo = Big_map.empty + +let map1 : foo = Big_map.literal + [ (23 , 0) ; (42, 0) ] + +let map1 : foo = Big_map.literal + [ (23 , 0) ; (42, 0) ] + +let mutimaps (m : foo) (n : foo) : foo = + let bar : foo = Big_map.update 42 (Some(0)) m in + Big_map.update 42 (get(bar)) n \ No newline at end of file diff --git a/src/test/contracts/bitwise_arithmetic.mligo b/src/test/contracts/bitwise_arithmetic.mligo new file mode 100644 index 000000000..831592c70 --- /dev/null +++ b/src/test/contracts/bitwise_arithmetic.mligo @@ -0,0 +1,10 @@ +(* Test CameLIGO bitwise operators *) + +let or_op (n : nat) : nat = + Bitwise.lor n 4p + +let and_op (n : nat) : nat = + Bitwise.land n 7p + +let xor_op (n : nat) : nat = + Bitwise.lxor n 7p diff --git a/src/test/contracts/blockless.ligo b/src/test/contracts/blockless.ligo new file mode 100644 index 000000000..103b926f0 --- /dev/null +++ b/src/test/contracts/blockless.ligo @@ -0,0 +1,2 @@ +function blockless (const n: int) : int is + n + 10; diff --git a/src/test/contracts/boolean_operators.mligo b/src/test/contracts/boolean_operators.mligo new file mode 100644 index 000000000..7eb3cfd69 --- /dev/null +++ b/src/test/contracts/boolean_operators.mligo @@ -0,0 +1,16 @@ +// Test CameLIGO boolean operators + +let or_true (b : bool) : bool = + b || true + +let or_false (b : bool) : bool = + b || false + +let and_true (b : bool) : bool = + b && true + +let and_false (b : bool) : bool = + b && false + +let not_bool (b: bool) : bool = + not b diff --git a/src/test/contracts/condition-annot.mligo b/src/test/contracts/condition-annot.mligo new file mode 100644 index 000000000..b5b87ef68 --- /dev/null +++ b/src/test/contracts/condition-annot.mligo @@ -0,0 +1,5 @@ +let%entry main (i : int) = + if (i = 2 : bool) then + (42 : int) + else + (0 : int) diff --git a/src/test/contracts/condition-shadowing.mligo b/src/test/contracts/condition-shadowing.mligo new file mode 100644 index 000000000..099b9fd7c --- /dev/null +++ b/src/test/contracts/condition-shadowing.mligo @@ -0,0 +1,9 @@ +(* TODO : make a test using mutation, not shadowing *) +let%entry main (i : int) = + let result = 0 in + if i = 2 then + let result = 42 in + result + else + let result = 0 in + result diff --git a/src/test/contracts/condition.ligo b/src/test/contracts/condition.ligo index 98672b1c9..53a75ed07 100644 --- a/src/test/contracts/condition.ligo +++ b/src/test/contracts/condition.ligo @@ -8,3 +8,9 @@ function main (const i : int) : int is else result := 0 end with result + +function foo (const b : bool) : int is + var x : int := 41 ; + begin + x := 1 + (if b then x else main(x)) ; + end with x \ No newline at end of file diff --git a/src/test/contracts/condition.mligo b/src/test/contracts/condition.mligo new file mode 100644 index 000000000..3d9fdd0c6 --- /dev/null +++ b/src/test/contracts/condition.mligo @@ -0,0 +1,7 @@ +// Test if conditional in CameLIGO + +let%entry main (i : int) = + if i = 2 then + 42 + else + 0 diff --git a/src/test/contracts/fibo.mligo b/src/test/contracts/fibo.mligo new file mode 100644 index 000000000..efc437c30 --- /dev/null +++ b/src/test/contracts/fibo.mligo @@ -0,0 +1,8 @@ +type storage = unit + + +let%entry main (p:unit) storage = + (fun (f : (int * int) -> int) (x : int) (y : int) -> f (y, x)) + (fun (x : int) (y : int) -> x + y) + 0 + 1 diff --git a/src/test/contracts/fibo2.mligo b/src/test/contracts/fibo2.mligo new file mode 100644 index 000000000..1daa72adb --- /dev/null +++ b/src/test/contracts/fibo2.mligo @@ -0,0 +1,7 @@ +type storage = unit + +let%entry main (p:unit) storage = + (fun (f : int -> int) (x : int) (y : int) -> (f y)) + (fun (x : int) -> x) + 0 + 1 diff --git a/src/test/contracts/fibo3.mligo b/src/test/contracts/fibo3.mligo new file mode 100644 index 000000000..ebce6b862 --- /dev/null +++ b/src/test/contracts/fibo3.mligo @@ -0,0 +1,7 @@ +type storage = unit + +let%entry main (p:unit) storage = + (fun (f : int -> int -> int) (x : int) (y : int) -> (f y) (x + y)) + (fun (x : int) (y : int) -> x + y) + 0 + 1 diff --git a/src/test/contracts/fibo4.mligo b/src/test/contracts/fibo4.mligo new file mode 100644 index 000000000..207d0c96c --- /dev/null +++ b/src/test/contracts/fibo4.mligo @@ -0,0 +1,6 @@ +type storage = unit + +let%entry main (p:unit) storage = + (fun (f : int -> int) (x : int) -> (f x)) + (fun (x : int) -> x) + 1 diff --git a/src/contracts/for_fail.ligo b/src/test/contracts/for_fail.ligo similarity index 100% rename from src/contracts/for_fail.ligo rename to src/test/contracts/for_fail.ligo diff --git a/src/test/contracts/function-shared.mligo b/src/test/contracts/function-shared.mligo new file mode 100644 index 000000000..5fc3e0b29 --- /dev/null +++ b/src/test/contracts/function-shared.mligo @@ -0,0 +1,7 @@ +(* Test use of multiple subroutines in a CameLIGO function *) + +let foo (i: int) : int = i + 20 + +let bar (i: int) : int = i + 50 + +let foobar (i: int) : int = (foo i) + (bar i) diff --git a/src/test/contracts/high-order.ligo b/src/test/contracts/high-order.ligo index d3c83170a..44822f088 100644 --- a/src/test/contracts/high-order.ligo +++ b/src/test/contracts/high-order.ligo @@ -8,21 +8,20 @@ function foobar (const i : int) : int is // higher order function with more than one argument function higher2(const i: int; const f: int -> int): int is - block { - const ii: int = f(i) - } with ii + block { + const ii: int = f(i) + } with ii function foobar2 (const i : int) : int is function foo2 (const i : int) : int is block { skip } with i; block { skip } with higher2(i,foo2) -// This is not supported yet: -// const a : int = 123; -// function foobar3 (const i : int) : int is -// function foo2 (const i : int) : int is -// block { skip } with (a+i); -// block { skip } with higher2(i,foo2) +const a : int = 0; +function foobar3 (const i : int) : int is + function foo2 (const i : int) : int is + block { skip } with (a+i); + block { skip } with higher2(i,foo2) function f (const i : int) : int is block { skip } @@ -35,3 +34,16 @@ function g (const i : int) : int is function foobar4 (const i : int) : int is block { skip } with g(g(i)) + +function higher3(const i: int; const f: int -> int; const g: int -> int): int is + block { + const ii: int = f(g(i)); + } with ii + +function foobar5 (const i : int) : int is + const a : int = 0; + function foo (const i : int) : int is + block { skip } with (a+i); + function goo (const i : int) : int is + block { skip } with foo(i); + block { skip } with higher3(i,foo,goo) diff --git a/src/contracts/incr_decr.mligo b/src/test/contracts/incr_decr.mligo similarity index 100% rename from src/contracts/incr_decr.mligo rename to src/test/contracts/incr_decr.mligo diff --git a/src/test/contracts/loop.ligo b/src/test/contracts/loop.ligo index 03cc751a7..2f250cf18 100644 --- a/src/test/contracts/loop.ligo +++ b/src/test/contracts/loop.ligo @@ -16,12 +16,140 @@ function while_sum (var n : nat) : nat is block { } } with r -(* function for_sum (var n : nat) : nat is block { - for i := 1 to 100 +function for_sum (var n : nat) : int is block { + var acc : int := 0 ; + for i := 1 to int(n) begin - n := n + 1; - end } - with n *) + acc := acc + i ; + end +} with acc + +function for_collection_list (var nee : unit) : (int * string) is block { + var acc : int := 0 ; + var st : string := "to" ; + var mylist : list(int) := list 1 ; 1 ; 1 end ; + for x : int in list mylist + begin + acc := acc + x ; + st := st^"to" ; + end +} with (acc, st) + +function for_collection_set (var nee : unit) : (int * string) is block { + var acc : int := 0 ; + var st : string := "to" ; + var myset : set(int) := set 1 ; 2 ; 3 end ; + for x : int in set myset + begin + acc := acc + x ; + st := st^"to" ; + end +} with (acc, st) + +function for_collection_if_and_local_var (var nee : unit) : int is block { + var acc : int := 0 ; + const theone : int = 1 ; + var myset : set(int) := set 1 ; 2 ; 3 end ; + for x : int in set myset + begin + const thetwo : int = 2 ; + if (x=theone) then + acc := acc + x ; + else if (x=thetwo) then + acc := acc + thetwo ; + else + acc := acc + 10 ; + end +} with acc + +function for_collection_rhs_capture (var nee : unit) : int is block { + var acc : int := 0 ; + const mybigint : int = 1000 ; + var myset : set(int) := set 1 ; 2 ; 3 end ; + for x : int in set myset + begin + if (x=1) then + acc := acc + mybigint ; + else + acc := acc + 10 ; + end +} with acc + +function for_collection_proc_call (var nee : unit) : int is block { + var acc : int := 0 ; + var myset : set(int) := set 1 ; 2 ; 3 end ; + for x : int in set myset + begin + if (x=1) then + acc := acc + for_collection_rhs_capture(unit) ; + else + acc := acc + 10 ; + end +} with acc + +function for_collection_comp_with_acc (var nee : unit) : int is block { + var myint : int := 0 ; + var mylist : list(int) := list 1 ; 10 ; 15 end; + for x : int in list mylist + begin + if (x < myint) then skip ; + else myint := myint + 10 ; + end +} with myint + +function for_collection_with_patches (var nee : unit) : map(string,int) is block { + var myint : int := 12 ; + var mylist : list(string) := list "I" ; "am" ; "foo" end; + var mymap : map(string,int) := map end; + for x : string in list mylist + begin + patch mymap with map [ x -> myint ]; + end +} with mymap + +function for_collection_empty (var nee : unit) : int is block { + var acc : int := 0 ; + var myset : set(int) := set 1 ; 2 ; 3 end ; + for x : int in set myset + begin + skip ; + end +} with acc + +function for_collection_map_kv (var nee : unit) : (int * string) is block { + var acc : int := 0 ; + var st : string := "" ; + var mymap : map(string,int) := map "1" -> 1 ; "2" -> 2 ; "3" -> 3 end ; + for k -> v : (string * int) in map mymap + begin + acc := acc + v ; + st := st^k ; + end +} with (acc, st) + +function for_collection_map_k (var nee : unit) : string is block { + var st : string := "" ; + var mymap : map(string,int) := map "1" -> 1 ; "2" -> 2 ; "3" -> 3 end ; + for k : string in map mymap + begin + st := st^k ; + end +} with st + +// function nested_for_collection (var nee : unit) : (int*string) is block { +// var myint : int := 0; +// var myst : string := ""; +// var mylist : list(int) := list 1 ; 2 ; 3 end ; +// for i : int in list mylist +// begin +// myint := myint + i ; +// var myset : set(string) := set "1" ; "2" ; "3" end ; +// for st : string in set myset +// begin +// myst := myst ^ st ; +// end +// end +// } with (myint,myst) function dummy (const n : nat) : nat is block { while (False) block { skip } diff --git a/src/test/contracts/map.ligo b/src/test/contracts/map.ligo index 7437cfb26..5c169fe25 100644 --- a/src/test/contracts/map.ligo +++ b/src/test/contracts/map.ligo @@ -25,6 +25,13 @@ function rm (var m : foobar) : foobar is block { remove 42 from map m } with m +function patch_ (var m: foobar) : foobar is block { + patch m with map [0 -> 5; 1 -> 6; 2 -> 7] +} with m + +function patch_deep (var m: foobar * nat) : foobar * nat is + begin patch m.0 with map [1 -> 9]; end with m + function size_ (const m : foobar) : nat is block {skip} with (size(m)) @@ -60,4 +67,4 @@ var coco : (int*foobar) := (0, m); block { remove 42 from map coco.1 ; coco.1[32] := 16 ; -} with coco.1 \ No newline at end of file +} with coco.1 diff --git a/src/test/contracts/map.mligo b/src/test/contracts/map.mligo index 094252c0e..829201b23 100644 --- a/src/test/contracts/map.mligo +++ b/src/test/contracts/map.mligo @@ -11,6 +11,15 @@ let set_ (n : int) (m : foobar) : foobar = let rm (m : foobar) : foobar = Map.remove 42 m +(* Dummy test so that we can add the same test for PascaLIGO *) +let patch_ (m : foobar) : foobar = Map.literal [ (0, 5) ; (1, 6) ; (2, 7) ] + +(* Second dummy test, see above *) +let patch_empty (m : foobar) : foobar = Map.literal [ (0, 0) ; (1, 1) ; (2, 2) ] + +(* Third dummy test, see above *) +let patch_deep (m: foobar * nat) : foobar * nat = (Map.literal [ (0, 0) ; (1, 9) ; (2, 2) ], 10p) + let size_ (m : foobar) : nat = Map.size m let gf (m : foobar) : int = Map.find 23 m @@ -34,4 +43,4 @@ let deep_op (m : foobar) : foobar = let coco = (0,m) in let coco = (0 , Map.remove 42 coco.(1)) in let coco = (0 , Map.update 32 (Some 16) coco.(1)) in - coco.(1) \ No newline at end of file + coco.(1) diff --git a/src/test/contracts/match.mligo b/src/test/contracts/match.mligo index 1665e9f27..394925538 100644 --- a/src/test/contracts/match.mligo +++ b/src/test/contracts/match.mligo @@ -11,3 +11,18 @@ let%entry main (p : param) storage = Add n -> n | Sub n -> 0-n) in (([] : operation list), storage) + +let match_bool (b: bool) : int = + match b with + true -> 10 + | false -> 0 + +let match_list (l: int list) : int = + match l with + hd :: tl -> hd + | [] -> 10 + +let match_option (i : int option) : int = + match i with + Some n -> n + | None -> 0 diff --git a/src/test/contracts/multiple-parameters.mligo b/src/test/contracts/multiple-parameters.mligo new file mode 100644 index 000000000..5a6e51297 --- /dev/null +++ b/src/test/contracts/multiple-parameters.mligo @@ -0,0 +1,4 @@ +(* Test function with several parameters *) + +let abcde (a : int) (b : int) (c : int) (d : int) (e : int) : int = + (c + e + 3) diff --git a/src/contracts/procedure.ligo b/src/test/contracts/procedure.ligo similarity index 100% rename from src/contracts/procedure.ligo rename to src/test/contracts/procedure.ligo diff --git a/src/test/contracts/set_arithmetic-1.mligo b/src/test/contracts/set_arithmetic-1.mligo new file mode 100644 index 000000000..811b5b7af --- /dev/null +++ b/src/test/contracts/set_arithmetic-1.mligo @@ -0,0 +1,6 @@ +// Test set iteration + +let aggregate (i : int) (j : int) : int = i + j + +let fold_op (s : int set) : int = + Set.fold s 15 aggregate diff --git a/src/test/contracts/set_arithmetic.ligo b/src/test/contracts/set_arithmetic.ligo index 81f9b0d6c..eb0f8cf9e 100644 --- a/src/test/contracts/set_arithmetic.ligo +++ b/src/test/contracts/set_arithmetic.ligo @@ -17,6 +17,14 @@ function remove_op (const s : set(string)) : set(string) is function remove_syntax (var s : set(string)) : set(string) is begin remove "foobar" from set s; end with s +function remove_deep (var s : set(string) * nat) : set(string) * nat is + begin remove "foobar" from set s.0; end with s + +function patch_op (var s: set(string)) : set(string) is + begin patch s with set ["foobar"]; end with s + +function patch_op_deep (var s: set(string)*nat) : set(string)*nat is + begin patch s.0 with set ["foobar"]; end with s + function mem_op (const s : set(string)) : bool is begin skip end with set_mem("foobar" , s) - diff --git a/src/test/contracts/set_arithmetic.mligo b/src/test/contracts/set_arithmetic.mligo new file mode 100644 index 000000000..86d81fe67 --- /dev/null +++ b/src/test/contracts/set_arithmetic.mligo @@ -0,0 +1,24 @@ +(* Test set operations in CameLIGO *) + +let add_op (s : string set) : string set = + Set.add "foobar" s + +let remove_op (s : string set) : string set = + Set.remove "foobar" s + +let remove_deep (s : string set * nat) : string set * nat = + Set.remove "foobar" s.(0) + +(* +let patch_op (s: string set) : string set = + begin patch s with set ["foobar"]; end with s + +let patch_op_deep (s: string set * nat) : string set * nat = + begin patch s.0 with set ["foobar"]; end with s +*) + +let mem_op (s : string set) : bool = + Set.mem "foobar" s + +let size_op (s: string set) : nat = + Set.size s diff --git a/src/test/contracts/string_arithmetic.mligo b/src/test/contracts/string_arithmetic.mligo new file mode 100644 index 000000000..1e1db9750 --- /dev/null +++ b/src/test/contracts/string_arithmetic.mligo @@ -0,0 +1,10 @@ +(* Test that the string concatenation syntax in CameLIGO works *) + +let size_op (s : string) : nat = + String.size s + +let slice_op (s : string) : string = + String.slice 1p 2p s + +let concat_syntax (s: string) = + s ^ "test_literal" diff --git a/src/test/contracts/tez.ligo b/src/test/contracts/tez.ligo index cf487808d..31d5915cf 100644 --- a/src/test/contracts/tez.ligo +++ b/src/test/contracts/tez.ligo @@ -1,4 +1,16 @@ -const add_tez : tez = 21mtz + 0.000021tz; -const sub_tez : tez = 21mtz - 20mtz; -(* is this enough? *) -const not_enough_tez : tez = 4611686018427387903mtz; +const add_tez : tez = 21mutez + 0.000021tz; +const sub_tez : tez = 21mutez - 20mutez; +(* This is not enough. *) +const not_enough_tez : tez = 4611686018427387903mutez; + + +const nat_mul_tez : tez = 1n * 100mutez; +const tez_mul_nat : tez = 100mutez * 10n; + +const tez_div_tez1 : nat = 100mutez / 1mutez; +const tez_div_tez2 : nat = 100mutez / 90mutez; +const tez_div_tez3 : nat = 100mutez / 110mutez; + +const tez_mod_tez1 : tez = 100mutez mod 1mutez; +const tez_mod_tez2 : tez = 100mutez mod 90mutez; +const tez_mod_tez3 : tez = 100mutez mod 110mutez; diff --git a/src/test/contracts/tez.mligo b/src/test/contracts/tez.mligo index 3f82198c5..557de9e2d 100644 --- a/src/test/contracts/tez.mligo +++ b/src/test/contracts/tez.mligo @@ -1,4 +1,4 @@ -let add_tez : tez = 21mtz + 0.000021tz +let add_tez : tez = 21mutez + 0.000021tz let sub_tez : tez = 0.000021tz - 0.000020tz let not_enough_tez : tez = 4611686018427.387903tz diff --git a/src/test/contracts/tuple.mligo b/src/test/contracts/tuple.mligo new file mode 100644 index 000000000..178ecfe7b --- /dev/null +++ b/src/test/contracts/tuple.mligo @@ -0,0 +1,15 @@ +type abc = int * int * int + +let projection_abc (tpl : abc) : int = + tpl.(1) + +type foobar = int * int + +let fb : foobar = (0, 0) + +let projection (tpl : foobar) : int = + tpl.(0) + tpl.(1) + +type big_tuple = int * int * int * int * int + +let br : big_tuple = (23, 23, 23, 23, 23) diff --git a/src/test/contracts/website2.mligo b/src/test/contracts/website2.mligo new file mode 100644 index 000000000..f972e9b47 --- /dev/null +++ b/src/test/contracts/website2.mligo @@ -0,0 +1,20 @@ +type storage = int + +(* variant defining pseudo multi-entrypoint actions *) + +type action = +| Increment of int +| Decrement of int + +let add (a: int) (b: int) : int = a + b + +let subtract (a: int) (b: int) : int = a - b + +(* real entrypoint that re-routes the flow based on the action provided *) + +let%entry main (p : action) storage = + let storage = + match p with + | Increment n -> add storage n + | Decrement n -> subtract storage n + in (([] : operation list), storage) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index a0d93c782..e2dbe5d4a 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -21,7 +21,12 @@ let function_ () : unit result = let make_expect = fun n -> n in expect_eq_n_int program "main" make_expect -(* Procedures are not supported yet +let blockless () : unit result = + let%bind program = type_file "./contracts/blockless.ligo" in + let make_expect = fun n-> n + 10 in + expect_eq_n_int program "blockless" make_expect + +(* Procedures are not supported yet let procedure () : unit result = let%bind program = type_file "./contracts/procedure.ligo" in let make_expect = fun n -> n + 1 in @@ -119,10 +124,10 @@ let higher_order () : unit result = let make_expect = fun n -> n in let%bind _ = expect_eq_n_int program "foobar" make_expect in let%bind _ = expect_eq_n_int program "foobar2" make_expect in - (* not supported yet: - let%bind _ = expect_eq_n_int program "foobar3" make_expect in *) + let%bind _ = expect_eq_n_int program "foobar3" make_expect in let%bind _ = expect_eq_n_int program "foobar4" make_expect in - ok () + let%bind _ = expect_eq_n_int program "foobar5" make_expect in + ok () let shared_function () : unit result = let%bind program = type_file "./contracts/function-shared.ligo" in @@ -151,6 +156,14 @@ let shared_function () : unit result = in ok () +let shared_function_mligo () : unit result = + let%bind program = mtype_file "./contracts/function-shared.mligo" in + let%bind () = + let make_expect = fun n -> (2 * n + 70) in + expect_eq_n_int program "foobar" make_expect + in + ok () + let bool_expression () : unit result = let%bind program = type_file "./contracts/boolean_operators.ligo" in let%bind _ = @@ -164,6 +177,19 @@ let bool_expression () : unit result = ] in ok () +let bool_expression_mligo () : unit result = + let%bind program = mtype_file "./contracts/boolean_operators.mligo" in + let%bind _ = + let aux (name, f) = expect_eq_b_bool program name f in + bind_map_list aux [ + ("or_true", fun b -> b || true) ; + ("or_false", fun b -> b || false) ; + ("and_true", fun b -> b && true) ; + ("and_false", fun b -> b && false) ; + ("not_bool", fun b -> not b) ; + ] in + ok () + let arithmetic () : unit result = let%bind program = type_file "./contracts/arithmetic.ligo" in let%bind _ = @@ -179,6 +205,21 @@ let arithmetic () : unit result = let%bind () = expect_eq_n_pos program "div_op" e_int (fun n -> e_int (n / 2)) in ok () +let arithmetic_mligo () : unit result = + let%bind program = mtype_file "./contracts/arithmetic.mligo" in + let%bind _ = + let aux (name, f) = expect_eq_n_int program name f in + bind_map_list aux [ + ("plus_op", fun n -> (n + 42)) ; + ("minus_op", fun n -> (n - 42)) ; + ("times_op", fun n -> (n * 42)) ; + ("neg_op", fun n -> (-n)) ; + ("neg_op_2", fun n -> -(n + 10)) ; + ] in + let%bind () = expect_eq_n_pos program "mod_op" e_int (fun n -> e_nat (n mod 42)) in + let%bind () = expect_eq_n_pos program "div_op" e_int (fun n -> e_int (n / 2)) in + ok () + let bitwise_arithmetic () : unit result = let%bind program = type_file "./contracts/bitwise_arithmetic.ligo" in let%bind () = expect_eq program "or_op" (e_nat 7) (e_nat 7) in @@ -195,6 +236,22 @@ let bitwise_arithmetic () : unit result = let%bind () = expect_eq program "xor_op" (e_nat 7) (e_nat 0) in ok () +let bitwise_arithmetic_mligo () : unit result = + let%bind program = mtype_file "./contracts/bitwise_arithmetic.mligo" in + let%bind () = expect_eq program "or_op" (e_nat 7) (e_nat 7) in + let%bind () = expect_eq program "or_op" (e_nat 3) (e_nat 7) in + let%bind () = expect_eq program "or_op" (e_nat 2) (e_nat 6) in + let%bind () = expect_eq program "or_op" (e_nat 14) (e_nat 14) in + let%bind () = expect_eq program "or_op" (e_nat 10) (e_nat 14) in + let%bind () = expect_eq program "and_op" (e_nat 7) (e_nat 7) in + let%bind () = expect_eq program "and_op" (e_nat 3) (e_nat 3) in + let%bind () = expect_eq program "and_op" (e_nat 2) (e_nat 2) in + let%bind () = expect_eq program "and_op" (e_nat 14) (e_nat 6) in + let%bind () = expect_eq program "and_op" (e_nat 10) (e_nat 2) in + let%bind () = expect_eq program "xor_op" (e_nat 0) (e_nat 7) in + let%bind () = expect_eq program "xor_op" (e_nat 7) (e_nat 0) in + ok () + let string_arithmetic () : unit result = let%bind program = type_file "./contracts/string_arithmetic.ligo" in let%bind () = expect_eq program "concat_op" (e_string "foo") (e_string "foototo") in @@ -204,6 +261,14 @@ let string_arithmetic () : unit result = let%bind () = expect_fail program "slice_op" (e_string "ba") in ok () +let string_arithmetic_mligo () : unit result = + let%bind program = mtype_file "./contracts/string_arithmetic.mligo" in + let%bind () = expect_eq program "size_op" (e_string "tata") (e_nat 4) in + let%bind () = expect_eq program "slice_op" (e_string "tata") (e_string "at") in + let%bind () = expect_eq program "slice_op" (e_string "foo") (e_string "oo") in + let%bind () = expect_eq program "concat_syntax" (e_string "string_") (e_string "string_test_literal") + in ok () + let bytes_arithmetic () : unit result = let%bind program = type_file "./contracts/bytes_arithmetic.ligo" in let%bind foo = e_bytes "0f00" in @@ -251,6 +316,27 @@ let set_arithmetic () : unit result = expect_eq program "remove_syntax" (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) (e_set [e_string "foo" ; e_string "bar"]) in + let%bind () = + expect_eq program "remove_deep" + (e_pair + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_nat 42)) + (e_pair + (e_set [e_string "foo" ; e_string "bar"]) + (e_nat 42)) + in + let%bind () = + expect_eq program "patch_op" + (e_set [e_string "foo" ; e_string "bar"]) + (e_set [e_string "foo" ; e_string "bar"; e_string "foobar"]) in + let%bind () = + expect_eq program "patch_op_deep" + (e_pair + (e_set [e_string "foo" ; e_string "bar"]) + (e_nat 42)) + (e_pair + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_nat 42)) in let%bind () = expect_eq program "mem_op" (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) @@ -266,6 +352,36 @@ let set_arithmetic () : unit result = in ok () +let set_arithmetic_mligo () : unit result = + let%bind program = mtype_file "./contracts/set_arithmetic.mligo" in + let%bind program_1 = type_file "./contracts/set_arithmetic-1.ligo" in + let%bind () = + expect_eq program "size_op" + (e_set [e_string "foo"; e_string "bar"; e_string "foobar"]) + (e_nat 3) in + let%bind () = + expect_eq program "add_op" + (e_set [e_string "foo" ; e_string "bar"]) + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) in + let%bind () = + expect_eq program "add_op" + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) in + let%bind () = + expect_eq program "remove_op" + (e_set [e_string "foo" ; e_string "bar"]) + (e_set [e_string "foo" ; e_string "bar"]) in + let%bind () = + expect_eq program "remove_op" + (e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) + (e_set [e_string "foo" ; e_string "bar"]) in + let%bind () = + expect_eq program_1 "fold_op" + (e_set [ e_int 4 ; e_int 10 ]) + (e_int 29) + in + ok () + let unit_expression () : unit result = let%bind program = type_file "./contracts/unit.ligo" in expect_eq_evaluate program "u" (e_unit ()) @@ -298,6 +414,18 @@ let multiple_parameters () : unit result = ] in ok () +let multiple_parameters_mligo () : unit result = + let%bind program = mtype_file "./contracts/multiple-parameters.mligo" in + let aux ((name : string) , make_input , make_output) = + let make_output' = fun n -> e_int @@ make_output n in + expect_eq_n program name make_input make_output' + in + let%bind _ = bind_list @@ List.map aux [ + (* Didn't include the other tests because they're probably not necessary *) + ("abcde", tuple_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ; + ] in + ok () + let record () : unit result = let%bind program = type_file "./contracts/record.ligo" in let%bind () = @@ -369,6 +497,30 @@ let tuple () : unit result = in ok () +let tuple_mligo () : unit result = + let%bind program = mtype_file "./contracts/tuple.mligo" in + let ez n = + e_tuple (List.map e_int n) in + let%bind () = + let expected = ez [0 ; 0] in + expect_eq_evaluate program "fb" expected + in + let%bind () = + let make_input = fun n -> ez [n ; n] in + let make_expected = fun n -> e_int (2 * n) in + expect_eq_n program "projection" make_input make_expected + in + let%bind () = + let make_input = fun n -> ez [n ; 2 * n ; n] in + let make_expected = fun n -> e_int (2 * n) in + expect_eq_n program "projection_abc" make_input make_expected + in + let%bind () = + let expected = ez [23 ; 23 ; 23 ; 23 ; 23] in + expect_eq_evaluate program "br" expected + in + ok () + let option () : unit result = let%bind program = type_file "./contracts/option.ligo" in let%bind () = @@ -417,6 +569,20 @@ let map_ type_f path : unit result = let expected = ez [23, 23] in expect_eq program "rm" input expected in + let%bind () = + let input = ez [(0,0) ; (1,1) ; (2,2)] in + let expected = ez [(0, 5) ; (1, 6) ; (2, 7)] in + expect_eq program "patch_" input expected + in + let%bind () = + let input = (e_pair + (ez [(0,0) ; (1,1) ; (2,2)]) + (e_nat 10)) in + let expected = (e_pair + (ez [(0,0) ; (1,9) ; (2,2)]) + (e_nat 10)) in + expect_eq program "patch_deep" input expected + in let%bind () = let make_input = fun n -> ez List.(map (fun x -> (x, x)) @@ range n) in let make_expected = e_nat in @@ -474,7 +640,7 @@ let big_map_ type_f path : unit result = let ez lst = let open Ast_simplified.Combinators in let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in - e_pair (e_typed_big_map lst' t_int t_int) (e_unit ()) + (e_typed_big_map lst' t_int t_int) in let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in @@ -549,9 +715,30 @@ let list () : unit result = let condition () : unit result = let%bind program = type_file "./contracts/condition.ligo" in - let make_input = e_int in - let make_expected = fun n -> e_int (if n = 2 then 42 else 0) in - expect_eq_n program "main" make_input make_expected + let%bind _ = + let make_input = e_int in + let make_expected = fun n -> e_int (if n = 2 then 42 else 0) in + expect_eq_n program "main" make_input make_expected + in + let%bind _ = + let make_expected = fun b -> e_int (if b then 42 else 1) in + expect_eq_b program "foo" make_expected + in + ok () + +let condition_mligo () : unit result = + let%bind _ = + let aux file = + let%bind program = mtype_file file in + let make_input = e_int in + let make_expected = fun n -> e_int (if n = 2 then 42 else 0) in + expect_eq_n program "main" make_input make_expected in + bind_map_list aux [ + "./contracts/condition.mligo"; + "./contracts/condition-shadowing.mligo"; + "./contracts/condition-annot.mligo"; + ] in + ok () let condition_simple () : unit result = let%bind program = type_file "./contracts/condition-simple.ligo" in @@ -564,24 +751,58 @@ let loop () : unit result = let%bind () = let make_input = e_nat in let make_expected = e_nat in - expect_eq_n_pos program "dummy" make_input make_expected - in + expect_eq_n_pos program "dummy" make_input make_expected in let%bind () = let make_input = e_nat in let make_expected = e_nat in - expect_eq_n_pos_mid program "counter" make_input make_expected - in + expect_eq_n_pos_mid program "counter" make_input make_expected in let%bind () = let make_input = e_nat in let make_expected = fun n -> e_nat (n * (n + 1) / 2) in - expect_eq_n_pos_mid program "while_sum" make_input make_expected - in(* For loop is currently unsupported - + expect_eq_n_pos_mid program "while_sum" make_input make_expected in let%bind () = let make_input = e_nat in - let make_expected = fun n -> e_nat (n * (n + 1) / 2) in - expect_eq_n_pos_mid program "for_sum" make_input make_expected - in *) + let make_expected = fun n -> e_int (n * (n + 1) / 2) in + expect_eq_n_pos_mid program "for_sum" make_input make_expected in + let input = e_unit () in + let%bind () = + let expected = e_pair (e_int 3) (e_string "totototo") in + expect_eq program "for_collection_list" input expected in + let%bind () = + let expected = e_pair (e_int 6) (e_string "totototo") in + expect_eq program "for_collection_set" input expected in + let%bind () = + let expected = e_pair (e_int 6) (e_string "123") in + expect_eq program "for_collection_map_kv" input expected in + let%bind () = + let expected = (e_string "123") in + expect_eq program "for_collection_map_k" input expected in + let%bind () = + let expected = (e_int 0) in + expect_eq program "for_collection_empty" input expected in + let%bind () = + let expected = (e_int 13) in + expect_eq program "for_collection_if_and_local_var" input expected in + let%bind () = + let expected = (e_int 1020) in + expect_eq program "for_collection_rhs_capture" input expected in + let%bind () = + let expected = (e_int 1040) in + expect_eq program "for_collection_proc_call" input expected in + let%bind () = + let expected = (e_int 20) in + expect_eq program "for_collection_comp_with_acc" input expected in + (* let%bind () = + let expected = e_pair (e_int 6) (e_string "123123123") in + expect_eq program "nested_for_collection" input expected in *) + let%bind () = + let ez lst = + let open Ast_simplified.Combinators in + let lst' = List.map (fun (x, y) -> e_string x, e_int y) lst in + e_typed_map lst' t_string t_int + in + let expected = ez [ ("I" , 12) ; ("am" , 12) ; ("foo" , 12) ] in + expect_eq program "for_collection_with_patches" input expected in ok () (* Don't know how to assert parse error happens in this test framework @@ -761,11 +982,33 @@ let let_in_mligo () : unit result = let match_variant () : unit result = let%bind program = mtype_file "./contracts/match.mligo" in - let make_input n = - e_pair (e_constructor "Sub" (e_int n)) (e_int 3) in - let make_expected n = - e_pair (e_typed_list [] t_operation) (e_int (3-n)) - in expect_eq_n program "main" make_input make_expected + let%bind () = + let make_input n = + e_pair (e_constructor "Sub" (e_int n)) (e_int 3) in + let make_expected n = + e_pair (e_typed_list [] t_operation) (e_int (3-n)) + in expect_eq_n program "main" make_input make_expected in + let%bind () = + let input = e_bool true in + let expected = e_int 10 in + expect_eq program "match_bool" input expected in + let%bind () = + let input = e_bool false in + let expected = e_int 0 in + expect_eq program "match_bool" input expected in + let%bind () = + let input = e_list [e_int 3] in + let expected = e_int 3 in + expect_eq program "match_list" input expected in + let%bind () = + let input = e_typed_list [] t_int in + let expected = e_int 10 in + expect_eq program "match_list" input expected in + let%bind () = + let make_input n = e_some (e_int n) in + let make_expected n = e_int n in + expect_eq_n program "match_option" make_input make_expected in + ok () let match_matej () : unit result = let%bind program = mtype_file "./contracts/match_bis.mligo" in @@ -814,6 +1057,12 @@ let lambda2_mligo () : unit result = let make_expected = (e_unit ()) in expect_eq program "main" make_input make_expected +let fibo_mligo () : unit result = + let%bind program = mtype_file "./contracts/fibo.mligo" in + let make_input = e_pair (e_unit ()) (e_unit ()) in + let make_expected = (e_int 42) in + expect_eq program "main" make_input make_expected + let website1_ligo () : unit result = let%bind program = type_file "./contracts/website1.ligo" in let make_input = fun n-> e_pair (e_int n) (e_int 42) in @@ -835,6 +1084,14 @@ let tez_ligo () : unit result = let%bind _ = expect_eq_evaluate program "add_tez" (e_mutez 42) in let%bind _ = expect_eq_evaluate program "sub_tez" (e_mutez 1) in let%bind _ = expect_eq_evaluate program "not_enough_tez" (e_mutez 4611686018427387903) in + let%bind _ = expect_eq_evaluate program "nat_mul_tez" (e_mutez 100) in + let%bind _ = expect_eq_evaluate program "tez_mul_nat" (e_mutez 1000) in + let%bind _ = expect_eq_evaluate program "tez_div_tez1" (e_nat 100) in + let%bind _ = expect_eq_evaluate program "tez_div_tez2" (e_nat 1) in + let%bind _ = expect_eq_evaluate program "tez_div_tez3" (e_nat 0) in + let%bind _ = expect_eq_evaluate program "tez_mod_tez1" (e_mutez 0) in + let%bind _ = expect_eq_evaluate program "tez_mod_tez2" (e_mutez 10) in + let%bind _ = expect_eq_evaluate program "tez_mod_tez3" (e_mutez 100) in ok () let tez_mligo () : unit result = @@ -845,32 +1102,52 @@ let tez_mligo () : unit result = let%bind _ = expect_eq_evaluate program "add_more_tez" (e_mutez 111111000) in ok () +let website2_mligo () : unit result = + let%bind program = mtype_file "./contracts/website2.mligo" in + let make_input = fun n -> + let action = if n mod 2 = 0 then "Increment" else "Decrement" in + e_pair (e_constructor action (e_int n)) (e_int 42) in + let make_expected = fun n -> + let op = if n mod 2 = 0 then (+) else (-) in + e_pair (e_typed_list [] t_operation) (e_int (op 42 n)) in + expect_eq_n program "main" make_input make_expected + let main = test_suite "Integration (End to End)" [ test "type alias" type_alias ; test "function" function_ ; + test "blockless function" blockless; (* test "procedure" procedure ; *) test "assign" assign ; test "declaration local" declaration_local ; test "complex function" complex_function ; test "closure" closure ; test "shared function" shared_function ; + test "shared function (mligo)" shared_function_mligo ; test "higher order" higher_order ; test "variant" variant ; test "variant (mligo)" variant_mligo ; test "variant matching" variant_matching ; test "tuple" tuple ; + test "tuple (mligo)" tuple_mligo ; test "record" record ; test "condition simple" condition_simple ; - test "condition" condition ; + test "condition (ligo)" condition ; + test "condition (mligo)" condition_mligo ; test "shadow" shadow ; test "annotation" annotation ; test "multiple parameters" multiple_parameters ; + test "multiple parameters (mligo)" multiple_parameters_mligo ; test "bool" bool_expression ; + test "bool (mligo)" bool_expression_mligo ; test "arithmetic" arithmetic ; - test "bitiwse_arithmetic" bitwise_arithmetic ; + test "arithmetic (mligo)" arithmetic_mligo ; + test "bitwise_arithmetic" bitwise_arithmetic ; + test "bitwise_arithmetic (mligo)" bitwise_arithmetic_mligo; test "string_arithmetic" string_arithmetic ; + test "string_arithmetic (mligo)" string_arithmetic_mligo ; test "bytes_arithmetic" bytes_arithmetic ; test "set_arithmetic" set_arithmetic ; + test "set_arithmetic (mligo)" set_arithmetic_mligo ; test "unit" unit_expression ; test "string" string_expression ; test "option" option ; @@ -903,9 +1180,14 @@ let main = test_suite "Integration (End to End)" [ (* test "guess string mligo" guess_string_mligo ; WIP? *) test "lambda mligo" lambda_mligo ; test "lambda ligo" lambda_ligo ; - (* test "lambda2 mligo" lambda2_mligo ; *) test "tez (ligo)" tez_ligo ; test "tez (mligo)" tez_mligo ; + test "lambda2 mligo" lambda2_mligo ; + (* test "fibo (mligo)" fibo_mligo ; *) + (* test "fibo2 (mligo)" fibo2_mligo ; *) + (* test "fibo3 (mligo)" fibo3_mligo ; *) + (* test "fibo4 (mligo)" fibo4_mligo ; *) test "website1 ligo" website1_ligo ; test "website2 ligo" website2_ligo ; + test "website2 (mligo)" website2_mligo ; ] diff --git a/vendors/ligo-utils/memory-proto-alpha/dune b/vendors/ligo-utils/memory-proto-alpha/dune index 0197e50c3..0df6b91ad 100644 --- a/vendors/ligo-utils/memory-proto-alpha/dune +++ b/vendors/ligo-utils/memory-proto-alpha/dune @@ -3,6 +3,6 @@ (public_name tezos-memory-proto-alpha) (libraries tezos-protocol-environment - tezos-protocol-alpha + tezos-protocol-005-PsBabyM1 ) ) diff --git a/vendors/ligo-utils/memory-proto-alpha/memory_proto_alpha.ml b/vendors/ligo-utils/memory-proto-alpha/memory_proto_alpha.ml index f55378cd9..2e07e7109 100644 --- a/vendors/ligo-utils/memory-proto-alpha/memory_proto_alpha.ml +++ b/vendors/ligo-utils/memory-proto-alpha/memory_proto_alpha.ml @@ -1,9 +1,9 @@ module Name = struct let name = "alpha" end -module Alpha_environment = Tezos_protocol_alpha.Protocol.Environment +module Alpha_environment = Tezos_protocol_005_PsBabyM1.Protocol.Environment type alpha_error = Alpha_environment.Error_monad.error type 'a alpha_tzresult = 'a Alpha_environment.Error_monad.tzresult module Alpha_error_monad = Alpha_environment.Error_monad -module Proto = Tezos_protocol_alpha +module Proto = Tezos_protocol_005_PsBabyM1 include Proto diff --git a/vendors/ligo-utils/memory-proto-alpha/tezos-memory-proto-alpha.opam b/vendors/ligo-utils/memory-proto-alpha/tezos-memory-proto-alpha.opam index 08031e2ec..1ec466604 100644 --- a/vendors/ligo-utils/memory-proto-alpha/tezos-memory-proto-alpha.opam +++ b/vendors/ligo-utils/memory-proto-alpha/tezos-memory-proto-alpha.opam @@ -10,7 +10,7 @@ bug-reports: "https://gitlab.com/ligolang/tezos/issues" depends: [ "dune" "tezos-protocol-environment" - "tezos-protocol-alpha" + "tezos-protocol-005-PsBabyM1" ] build: [ ["dune" "build" "-p" name] diff --git a/vendors/ligo-utils/proto-alpha-utils/cast.ml b/vendors/ligo-utils/proto-alpha-utils/cast.ml index cbf70180f..db677876c 100644 --- a/vendors/ligo-utils/proto-alpha-utils/cast.ml +++ b/vendors/ligo-utils/proto-alpha-utils/cast.ml @@ -56,183 +56,222 @@ include struct open Michelson_v1_primitives open Protocol.Environment + + let rec unparse_data_generic - : type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) -> - unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t + : type a. context -> ?mapper:_ -> unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t = fun ctxt ?(mapper = fun _ -> return None) mode ty a -> - Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> - mapper (Ex_typed_value (ty, a)) >>=? function - | Some x -> return (x, ctxt) - | None -> ( - match ty, a with - | Unit_t _, () -> - Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> - return (Prim (-1, D_Unit, [], []), ctxt) - | Int_t _, v -> - Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> - return (Int (-1, Script_int.to_zint v), ctxt) - | Nat_t _, v -> - Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> - return (Int (-1, Script_int.to_zint v), ctxt) - | String_t _, s -> - Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> - return (String (-1, s), ctxt) - | Bytes_t _, s -> - Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> - return (Bytes (-1, s), ctxt) - | Bool_t _, true -> - Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_True, [], []), ctxt) - | Bool_t _, false -> - Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_False, [], []), ctxt) - | Timestamp_t _, t -> - Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> - begin - match mode with - | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) - | Readable -> - match Script_timestamp.to_notation t with - | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) - | Some s -> return (String (-1, s), ctxt) - end - | Address_t _, c -> - Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in - return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) - end - | Contract_t _, (_, c) -> - Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in - return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) - end - | Signature_t _, s -> - Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.to_b58check s), ctxt) - end - | Mutez_t _, v -> - Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> - return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) - | Key_t _, k -> - Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.Public_key.to_b58check k), ctxt) - end - | Key_hash_t _, k -> - Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) - end - | Operation_t _, op -> - let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in - Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> - return (Bytes (-1, bytes), ctxt) - | Pair_t ((tl, _, _), (tr, _, _), _), (l, r) -> - Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) -> - unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Pair, [ l; r ], []), ctxt) - | Union_t ((tl, _), _, _), L l -> - Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) -> - return (Prim (-1, D_Left, [ l ], []), ctxt) - | Union_t (_, (tr, _), _), R r -> - Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Right, [ r ], []), ctxt) - | Option_t ((t, _), _, _), Some v -> - Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode t v >>=? fun (v, ctxt) -> - return (Prim (-1, D_Some, [ v ], []), ctxt) - | Option_t _, None -> - Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> - return (Prim (-1, D_None, [], []), ctxt) - | List_t (t, _), items -> - fold_left_s - (fun (l, ctxt) element -> - Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode t element >>=? fun (unparsed, ctxt) -> - return (unparsed :: l, ctxt)) - ([], ctxt) - items >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, List.rev items), ctxt) - | Set_t (t, _), set -> - let t = ty_of_comparable_ty t in - fold_left_s - (fun (l, ctxt) item -> - Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode t item >>=? fun (item, ctxt) -> - return (item :: l, ctxt)) - ([], ctxt) - (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items), ctxt) - | Map_t (kt, vt, _), map -> - let kt = ty_of_comparable_ty kt in - fold_left_s - (fun (l, ctxt) (k, v) -> - Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data_generic ~mapper ctxt mode vt v >>=? fun (value, ctxt) -> - return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) - ([], ctxt) - (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items), ctxt) - | Big_map_t (_kt, _kv, _), _map -> - return (Micheline.Seq (-1, []), ctxt) - | Lambda_t _, Lam (_, original_code) -> - unparse_code_generic ~mapper ctxt mode (root original_code) - ) + Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> + mapper (Ex_typed_value (ty, a)) >>=? function + | Some x -> return (x , ctxt) + | None -> ( + match ty, a with + | Unit_t _, () -> + Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> + return (Prim (-1, D_Unit, [], []), ctxt) + | Int_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | Nat_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | String_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> + return (String (-1, s), ctxt) + | Bytes_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> + return (Bytes (-1, s), ctxt) + | Bool_t _, true -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_True, [], []), ctxt) + | Bool_t _, false -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_False, [], []), ctxt) + | Timestamp_t _, t -> + Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> + begin + match mode with + | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Readable -> + match Script_timestamp.to_notation t with + | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Some s -> return (String (-1, s), ctxt) + end + | Address_t _, (c, entrypoint) -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let entrypoint = match entrypoint with "default" -> "" | name -> name in + let bytes = Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) in + return (Bytes (-1, bytes), ctxt) + | Readable -> + let notation = match entrypoint with + | "default" -> Contract.to_b58check c + | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in + return (String (-1, notation), ctxt) + end + | Contract_t _, (_, (c, entrypoint)) -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let entrypoint = match entrypoint with "default" -> "" | name -> name in + let bytes = Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) in + return (Bytes (-1, bytes), ctxt) + | Readable -> + let notation = match entrypoint with + | "default" -> Contract.to_b58check c + | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in + return (String (-1, notation), ctxt) + end + | Signature_t _, s -> + Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.to_b58check s), ctxt) + end + | Mutez_t _, v -> + Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> + return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) + | Key_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key.to_b58check k), ctxt) + end + | Key_hash_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) + end + | Operation_t _, (op, _big_map_diff) -> + let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in + Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Chain_id_t _, chain_id -> + let bytes = Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id in + Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r) -> + Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> + unparse_data_generic ctxt mode tl l >>=? fun (l, ctxt) -> + unparse_data_generic ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Pair, [ l; r ], []), ctxt) + | Union_t ((tl, _), _, _, _), L l -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data_generic ctxt mode tl l >>=? fun (l, ctxt) -> + return (Prim (-1, D_Left, [ l ], []), ctxt) + | Union_t (_, (tr, _), _, _), R r -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data_generic ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Right, [ r ], []), ctxt) + | Option_t (t, _, _), Some v -> + Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> + unparse_data_generic ctxt mode t v >>=? fun (v, ctxt) -> + return (Prim (-1, D_Some, [ v ], []), ctxt) + | Option_t _, None -> + Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> + return (Prim (-1, D_None, [], []), ctxt) + | List_t (t, _, _), items -> + fold_left_s + (fun (l, ctxt) element -> + Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> + unparse_data_generic ctxt mode t element >>=? fun (unparsed, ctxt) -> + return (unparsed :: l, ctxt)) + ([], ctxt) + items >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, List.rev items), ctxt) + | Set_t (t, _), set -> + let t = ty_of_comparable_ty t in + fold_left_s + (fun (l, ctxt) item -> + Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> + unparse_data_generic ctxt mode t item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) + (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Map_t (kt, vt, _, _), map -> + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_data_generic ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data_generic ctxt mode vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (kt, vt, _), { id = None ; diff = (module Diff) ; _ } -> + (* this branch is to allow roundtrip of big map literals *) + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_data_generic ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data_generic ctxt mode vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (Diff.OPS.fold + (fun k v acc -> match v with | None -> acc | Some v -> (k, v) :: acc) + (fst Diff.boxed) []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (_kt, _kv, _), { id = Some id ; diff = (module Diff) ; _ } -> + if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then + return (Micheline.Int (-1, id), ctxt) + else + (* this can only be the result of an execution and the map + must have been flushed at this point *) + assert false + | Lambda_t _, Lam (_, original_code) -> + unparse_code_generic ctxt ~mapper mode original_code + ) - and unparse_code_generic ctxt ?mapper mode = function + and unparse_code_generic ctxt ?mapper mode = + let legacy = true in + function | Prim (loc, I_PUSH, [ ty ; data ], annot) -> - Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) -> - parse_data ctxt t data >>=? fun (data, ctxt) -> - unparse_data_generic ?mapper ctxt mode t data >>=? fun (data, ctxt) -> - Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> - return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) + Lwt.return (parse_packable_ty ctxt ~legacy ty) >>=? fun (Ex_ty t, ctxt) -> + parse_data ctxt ~legacy t data >>=? fun (data, ctxt) -> + unparse_data_generic ctxt ?mapper mode t data >>=? fun (data, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> + return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) | Seq (loc, items) -> - fold_left_s - (fun (l, ctxt) item -> - unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code_generic ctxt ?mapper mode item >>=? fun (item, ctxt) -> return (item :: l, ctxt)) - ([], ctxt) items >>=? fun (items, ctxt) -> - Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt -> - return (Micheline.Seq (loc, List.rev items), ctxt) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt -> + return (Micheline.Seq (loc, List.rev items), ctxt) | Prim (loc, prim, items, annot) -> - fold_left_s - (fun (l, ctxt) item -> - unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code_generic ctxt ?mapper mode item >>=? fun (item, ctxt) -> return (item :: l, ctxt)) - ([], ctxt) items >>=? fun (items, ctxt) -> - Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt -> - return (Prim (loc, prim, List.rev items, annot), ctxt) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt -> + return (Prim (loc, prim, List.rev items, annot), ctxt) | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt) - end let rec mapper (Ex_typed_value (ty, a)) = diff --git a/vendors/ligo-utils/proto-alpha-utils/dune b/vendors/ligo-utils/proto-alpha-utils/dune index 2b43cce9e..3f8f6b3a1 100644 --- a/vendors/ligo-utils/proto-alpha-utils/dune +++ b/vendors/ligo-utils/proto-alpha-utils/dune @@ -4,7 +4,7 @@ (libraries tezos-error-monad tezos-stdlib-unix - tezos-protocol-alpha-parameters + tezos-protocol-005-PsBabyM1-parameters tezos-memory-proto-alpha simple-utils tezos-utils diff --git a/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml index 812d18b24..8239c6c21 100644 --- a/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml +++ b/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml @@ -96,26 +96,6 @@ module Context_init = struct return context let genesis - ?(preserved_cycles = Constants_repr.default.preserved_cycles) - ?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle) - ?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment) - ?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot) - ?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period) - ?(time_between_blocks = Constants_repr.default.time_between_blocks) - ?(endorsers_per_block = Constants_repr.default.endorsers_per_block) - ?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation) - ?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block) - ?(proof_of_work_threshold = Int64.(neg one)) - ?(tokens_per_roll = Constants_repr.default.tokens_per_roll) - ?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size) - ?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip) - ?(origination_size = Constants_repr.default.origination_size) - ?(block_security_deposit = Constants_repr.default.block_security_deposit) - ?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit) - ?(block_reward = Constants_repr.default.block_reward) - ?(endorsement_reward = Constants_repr.default.endorsement_reward) - ?(cost_per_byte = Constants_repr.default.cost_per_byte) - ?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation) ?(commitments = []) ?(security_deposit_ramp_up_cycles = None) ?(no_reward_cycles = None) @@ -125,45 +105,7 @@ module Context_init = struct Pervasives.failwith "Must have one account with a roll to bake"; (* Check there is at least one roll *) - let open Tezos_base.TzPervasives.Error_monad in - begin try - let (>>?=) x y = match x with - | Ok(a) -> y a - | Error(b) -> fail @@ List.hd b in - fold_left_s (fun acc (_, amount) -> - Alpha_environment.wrap_error @@ - Tez_repr.(+?) acc amount >>?= fun acc -> - if acc >= tokens_per_roll then - raise Exit - else return acc - ) Tez_repr.zero initial_accounts >>=? fun _ -> - failwith "Insufficient tokens in initial accounts to create one roll" - with Exit -> return () - end >>=? fun () -> - - let constants : Constants_repr.parametric = Tezos_protocol_alpha_parameters.Default_parameters.({ - preserved_cycles ; - blocks_per_cycle ; - blocks_per_commitment ; - blocks_per_roll_snapshot ; - blocks_per_voting_period ; - time_between_blocks ; - endorsers_per_block ; - hard_gas_limit_per_operation ; - hard_gas_limit_per_block ; - proof_of_work_threshold ; - tokens_per_roll ; - michelson_maximum_type_size ; - seed_nonce_revelation_tip ; - origination_size ; - block_security_deposit ; - endorsement_security_deposit ; - block_reward ; - endorsement_reward ; - cost_per_byte ; - hard_storage_limit_per_operation ; - test_chain_duration = constants_mainnet.test_chain_duration ; - }) in + let constants : Constants_repr.parametric = Tezos_protocol_005_PsBabyM1_parameters.Default_parameters.constants_test in check_constants_consistency constants >>=? fun () -> let hash = @@ -187,8 +129,6 @@ module Context_init = struct let init ?(slow=false) - ?preserved_cycles - ?endorsers_per_block ?commitments n = let open Error_monad in @@ -198,18 +138,10 @@ module Context_init = struct begin if slow then genesis - ?preserved_cycles - ?endorsers_per_block ?commitments accounts else genesis - ?preserved_cycles - ~blocks_per_cycle:32l - ~blocks_per_commitment:4l - ~blocks_per_roll_snapshot:8l - ~blocks_per_voting_period:(Int32.mul 32l 8l) - ?endorsers_per_block ?commitments accounts end >>=? fun ctxt -> diff --git a/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam b/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam index af3f7d9fe..6c16581a6 100644 --- a/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam +++ b/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam @@ -42,7 +42,7 @@ depends: [ "tezos-data-encoding" "tezos-protocol-environment" "tezos-protocol-alpha" - "tezos-protocol-alpha-parameters" + "tezos-protocol-005-PsBabyM1-parameters" "michelson-parser" "simple-utils" "tezos-utils" diff --git a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml index 21dead97a..581ccbde4 100644 --- a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml +++ b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml @@ -14,18 +14,21 @@ module X = struct open Alpha_context open Script_tc_errors open Alpha_environment.Error_monad -let rec stack_ty_eq - : type ta tb. context -> int -> ta stack_ty -> tb stack_ty -> - ((ta stack_ty, tb stack_ty) eq * context) tzresult - = fun ctxt lvl ta tb -> - match ta, tb with - | Item_t (tva, ra, _), Item_t (tvb, rb, _) -> + + let rec stack_ty_eq + : type ta tb. context -> int -> ta stack_ty -> tb stack_ty -> + ((ta stack_ty, tb stack_ty) eq * context) tzresult + = fun ctxt lvl ta tb -> + match ta, tb with + | Item_t (tva, ra, _), Item_t (tvb, rb, _) -> ty_eq ctxt tva tvb |> record_trace (Bad_stack_item lvl) >>? fun (Eq, ctxt) -> stack_ty_eq ctxt (lvl + 1) ra rb >>? fun (Eq, ctxt) -> (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult) - | Empty_t, Empty_t -> Ok (Eq, ctxt) - | _, _ -> error Bad_stack_length + | Empty_t, Empty_t -> Ok (Eq, ctxt) + | _, _ -> error Bad_stack_length + + open Script_typed_ir open Protocol.Environment.Error_monad @@ -37,183 +40,221 @@ let rec stack_ty_eq type ex_typed_value = Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value - let rec unparse_data_generic - : type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) -> - unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t + : type a. context -> ?mapper:_ -> unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t = fun ctxt ?(mapper = fun _ -> return None) mode ty a -> - Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> - mapper (Ex_typed_value (ty, a)) >>=? function - | Some x -> return (x, ctxt) - | None -> ( - match ty, a with - | Unit_t _, () -> - Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> - return (Prim (-1, D_Unit, [], []), ctxt) - | Int_t _, v -> - Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> - return (Int (-1, Script_int.to_zint v), ctxt) - | Nat_t _, v -> - Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> - return (Int (-1, Script_int.to_zint v), ctxt) - | String_t _, s -> - Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> - return (String (-1, s), ctxt) - | Bytes_t _, s -> - Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> - return (Bytes (-1, s), ctxt) - | Bool_t _, true -> - Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_True, [], []), ctxt) - | Bool_t _, false -> - Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_False, [], []), ctxt) - | Timestamp_t _, t -> - Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> - begin - match mode with - | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) - | Readable -> - match Script_timestamp.to_notation t with - | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) - | Some s -> return (String (-1, s), ctxt) - end - | Address_t _, c -> - Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in - return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) - end - | Contract_t _, (_, c) -> - Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in - return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) - end - | Signature_t _, s -> - Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.to_b58check s), ctxt) - end - | Mutez_t _, v -> - Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> - return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) - | Key_t _, k -> - Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.Public_key.to_b58check k), ctxt) - end - | Key_hash_t _, k -> - Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) - end - | Operation_t _, op -> - let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in - Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> - return (Bytes (-1, bytes), ctxt) - | Pair_t ((tl, _, _), (tr, _, _), _), (l, r) -> - Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) -> - unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Pair, [ l; r ], []), ctxt) - | Union_t ((tl, _), _, _), L l -> - Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) -> - return (Prim (-1, D_Left, [ l ], []), ctxt) - | Union_t (_, (tr, _), _), R r -> - Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Right, [ r ], []), ctxt) - | Option_t ((t, _), _, _), Some v -> - Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode t v >>=? fun (v, ctxt) -> - return (Prim (-1, D_Some, [ v ], []), ctxt) - | Option_t _, None -> - Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> - return (Prim (-1, D_None, [], []), ctxt) - | List_t (t, _), items -> - fold_left_s - (fun (l, ctxt) element -> - Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode t element >>=? fun (unparsed, ctxt) -> - return (unparsed :: l, ctxt)) - ([], ctxt) - items >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, List.rev items), ctxt) - | Set_t (t, _), set -> - let t = ty_of_comparable_ty t in - fold_left_s - (fun (l, ctxt) item -> - Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode t item >>=? fun (item, ctxt) -> - return (item :: l, ctxt)) - ([], ctxt) - (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items), ctxt) - | Map_t (kt, vt, _), map -> - let kt = ty_of_comparable_ty kt in - fold_left_s - (fun (l, ctxt) (k, v) -> - Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> - unparse_data_generic ~mapper ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data_generic ~mapper ctxt mode vt v >>=? fun (value, ctxt) -> - return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) - ([], ctxt) - (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items), ctxt) - | Big_map_t (_kt, _kv, _), _map -> - return (Micheline.Seq (-1, []), ctxt) - | Lambda_t _, Lam (_, original_code) -> - unparse_code_generic ~mapper ctxt mode (root original_code) - ) + Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> + mapper (Ex_typed_value (ty, a)) >>=? function + | Some x -> return (x , ctxt) + | None -> ( + match ty, a with + | Unit_t _, () -> + Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> + return (Prim (-1, D_Unit, [], []), ctxt) + | Int_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | Nat_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | String_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> + return (String (-1, s), ctxt) + | Bytes_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> + return (Bytes (-1, s), ctxt) + | Bool_t _, true -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_True, [], []), ctxt) + | Bool_t _, false -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_False, [], []), ctxt) + | Timestamp_t _, t -> + Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> + begin + match mode with + | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Readable -> + match Script_timestamp.to_notation t with + | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Some s -> return (String (-1, s), ctxt) + end + | Address_t _, (c, entrypoint) -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let entrypoint = match entrypoint with "default" -> "" | name -> name in + let bytes = Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) in + return (Bytes (-1, bytes), ctxt) + | Readable -> + let notation = match entrypoint with + | "default" -> Contract.to_b58check c + | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in + return (String (-1, notation), ctxt) + end + | Contract_t _, (_, (c, entrypoint)) -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let entrypoint = match entrypoint with "default" -> "" | name -> name in + let bytes = Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) in + return (Bytes (-1, bytes), ctxt) + | Readable -> + let notation = match entrypoint with + | "default" -> Contract.to_b58check c + | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in + return (String (-1, notation), ctxt) + end + | Signature_t _, s -> + Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.to_b58check s), ctxt) + end + | Mutez_t _, v -> + Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> + return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) + | Key_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key.to_b58check k), ctxt) + end + | Key_hash_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) + end + | Operation_t _, (op, _big_map_diff) -> + let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in + Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Chain_id_t _, chain_id -> + let bytes = Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id in + Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r) -> + Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> + unparse_data_generic ctxt mode tl l >>=? fun (l, ctxt) -> + unparse_data_generic ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Pair, [ l; r ], []), ctxt) + | Union_t ((tl, _), _, _, _), L l -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data_generic ctxt mode tl l >>=? fun (l, ctxt) -> + return (Prim (-1, D_Left, [ l ], []), ctxt) + | Union_t (_, (tr, _), _, _), R r -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_data_generic ctxt mode tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Right, [ r ], []), ctxt) + | Option_t (t, _, _), Some v -> + Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> + unparse_data_generic ctxt mode t v >>=? fun (v, ctxt) -> + return (Prim (-1, D_Some, [ v ], []), ctxt) + | Option_t _, None -> + Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> + return (Prim (-1, D_None, [], []), ctxt) + | List_t (t, _, _), items -> + fold_left_s + (fun (l, ctxt) element -> + Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> + unparse_data_generic ctxt mode t element >>=? fun (unparsed, ctxt) -> + return (unparsed :: l, ctxt)) + ([], ctxt) + items >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, List.rev items), ctxt) + | Set_t (t, _), set -> + let t = ty_of_comparable_ty t in + fold_left_s + (fun (l, ctxt) item -> + Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> + unparse_data_generic ctxt mode t item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) + (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Map_t (kt, vt, _, _), map -> + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_data_generic ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data_generic ctxt mode vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (kt, vt, _), { id = None ; diff = (module Diff) ; _ } -> + (* this branch is to allow roundtrip of big map literals *) + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_data_generic ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data_generic ctxt mode vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (Diff.OPS.fold + (fun k v acc -> match v with | None -> acc | Some v -> (k, v) :: acc) + (fst Diff.boxed) []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (_kt, _kv, _), { id = Some id ; diff = (module Diff) ; _ } -> + if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then + return (Micheline.Int (-1, id), ctxt) + else + (* this can only be the result of an execution and the map + must have been flushed at this point *) + assert false + | Lambda_t _, Lam (_, original_code) -> + unparse_code_generic ctxt ~mapper mode original_code + ) - and unparse_code_generic ctxt ?mapper mode = function + and unparse_code_generic ctxt ?mapper mode = + let legacy = true in + function | Prim (loc, I_PUSH, [ ty ; data ], annot) -> - Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) -> - parse_data ctxt t data >>=? fun (data, ctxt) -> - unparse_data_generic ?mapper ctxt mode t data >>=? fun (data, ctxt) -> - Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> - return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) + Lwt.return (parse_packable_ty ctxt ~legacy ty) >>=? fun (Ex_ty t, ctxt) -> + parse_data ctxt ~legacy t data >>=? fun (data, ctxt) -> + unparse_data_generic ctxt ?mapper mode t data >>=? fun (data, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> + return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) | Seq (loc, items) -> - fold_left_s - (fun (l, ctxt) item -> - unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code_generic ctxt ?mapper mode item >>=? fun (item, ctxt) -> return (item :: l, ctxt)) - ([], ctxt) items >>=? fun (items, ctxt) -> - Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt -> - return (Micheline.Seq (loc, List.rev items), ctxt) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt -> + return (Micheline.Seq (loc, List.rev items), ctxt) | Prim (loc, prim, items, annot) -> - fold_left_s - (fun (l, ctxt) item -> - unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) -> + fold_left_s + (fun (l, ctxt) item -> + unparse_code_generic ctxt ?mapper mode item >>=? fun (item, ctxt) -> return (item :: l, ctxt)) - ([], ctxt) items >>=? fun (items, ctxt) -> - Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt -> - return (Prim (loc, prim, List.rev items, annot), ctxt) + ([], ctxt) items >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt -> + return (Prim (loc, prim, List.rev items, annot), ctxt) | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt) + module Interp_costs = Michelson_v1_gas.Cost_of type ex_descr_stack = Ex_descr_stack : (('a, 'b) descr * 'a stack) -> ex_descr_stack @@ -235,698 +276,698 @@ let unparse_stack ctxt (stack, stack_ty) = return ((data, annot) :: rest) in unparse_stack (stack, stack_ty) -let rec step - : type b a. - (?log: execution_trace ref -> - context -> - source: Contract.t -> - self: Contract.t -> - payer: Contract.t -> - ?visitor: (ex_descr_stack -> unit) -> - Tez.t -> - (b, a) descr -> b stack -> - (a stack * context) tzresult Lwt.t) = - fun ?log ctxt ~source ~self ~payer ?visitor amount ({ instr ; loc ; _ } as descr) stack -> - Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> - (match visitor with - | Some visitor -> visitor @@ Ex_descr_stack(descr, stack) - | None -> ()) ; - let step_same ctxt = step ?log ctxt ~source ~self ~payer ?visitor amount in - let logged_return : type a b. - (b, a) descr -> - a stack * context -> - (a stack * context) tzresult Lwt.t = - fun descr (ret, ctxt) -> - match log with - | None -> return (ret, ctxt) - | Some log -> - trace - Cannot_serialize_log - (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> - log := (descr.loc, Gas.level ctxt, stack) :: !log ; - return (ret, ctxt) in - let get_log (log : execution_trace ref option) = - Option.map ~f:(fun l -> List.rev !l) log in - let consume_gas_terop : type ret arg1 arg2 arg3 rest. - (_ * (_ * (_ * rest)), ret * rest) descr -> - ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> - (arg1 -> arg2 -> arg3 -> Gas.cost) -> - rest stack -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2, x3) cost_func rest -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2 x3, rest), ctxt) in - let consume_gas_binop : type ret arg1 arg2 rest. - (_ * (_ * rest), ret * rest) descr -> - ((arg1 -> arg2 -> ret) * arg1 * arg2) -> - (arg1 -> arg2 -> Gas.cost) -> - rest stack -> - context -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2, rest), ctxt) in - let consume_gas_unop : type ret arg rest. - (_ * rest, ret * rest) descr -> - ((arg -> ret) * arg) -> - (arg -> Gas.cost) -> - rest stack -> - context -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, arg) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> - logged_return descr (Item (op arg, rest), ctxt) in - let consume_gaz_comparison : - type t rest. - (t * (t * rest), Script_int.z Script_int.num * rest) descr -> - (t -> t -> int) -> - (t -> t -> Gas.cost) -> - t -> t -> - rest stack -> - ((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t = - fun descr op cost x1 x2 rest -> - Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt -> - logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in - let logged_return : - a stack * context -> - (a stack * context) tzresult Lwt.t = - logged_return descr in - match instr, stack with - (* stack ops *) - | Drop, Item (_, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (rest, ctxt) - | Dup, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (v, Item (v, rest)), ctxt) - | Swap, Item (vi, Item (vo, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (vo, Item (vi, rest)), ctxt) - | Const v, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - (* options *) - | Cons_some, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (Some v, rest), ctxt) - | Cons_none _, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | If_none (bt, _), Item (None, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step_same ctxt bt rest - | If_none (_, bf), Item (Some v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step_same ctxt bf (Item (v, rest)) - (* pairs *) - | Cons_pair, Item (a, Item (b, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> - logged_return (Item ((a, b), rest), ctxt) - | Car, Item ((a, _), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (a, rest), ctxt) - | Cdr, Item ((_, b), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (b, rest), ctxt) - (* unions *) - | Left, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (L v, rest), ctxt) - | Right, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (R v, rest), ctxt) - | If_left (bt, _), Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step_same ctxt bt (Item (v, rest)) - | If_left (_, bf), Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step_same ctxt bf (Item (v, rest)) - (* lists *) - | Cons_list, Item (hd, Item (tl, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> - logged_return (Item (hd :: tl, rest), ctxt) - | Nil, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item ([], rest), ctxt) - | If_cons (_, bf), Item ([], rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step_same ctxt bf rest - | If_cons (bt, _), Item (hd :: tl, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step_same ctxt bt (Item (hd, Item (tl, rest))) - | List_map body, Item (l, rest) -> - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (Item (List.rev acc, rest), ctxt) - | hd :: tl -> - step_same ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (hd :: acc) - in loop rest ctxt l [] >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | List_size, Item (list, rest) -> - Lwt.return - (List.fold_left - (fun acc _ -> - acc >>? fun (size, ctxt) -> - Gas.consume ctxt Interp_costs.list_size >>? fun ctxt -> - ok (size + 1 (* FIXME: overflow *), ctxt)) - (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> - logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) - | List_iter body, Item (l, init) -> - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step_same ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - (* sets *) - | Empty_set t, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> - logged_return (Item (empty_set t, rest), ctxt) - | Set_iter body, Item (set, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> - let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step_same ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Set_mem, Item (v, Item (set, rest)) -> - consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt - | Set_update, Item (v, Item (presence, Item (set, rest))) -> - consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest - | Set_size, Item (set, rest) -> - consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt - (* maps *) - | Empty_map (t, _), rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> - logged_return (Item (empty_map t, rest), ctxt) - | Map_map body, Item (map, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (acc, ctxt) - | (k, _) as hd :: tl -> - step_same ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (map_update k (Some hd) acc) - in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Map_iter body, Item (map, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step_same ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Map_mem, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt - | Map_get, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt - | Map_update, Item (k, Item (v, Item (map, rest))) -> - consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest - | Map_size, Item (map, rest) -> - consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt - (* Big map operations *) - | Big_map_mem, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_get, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> - consume_gas_terop descr - (Script_ir_translator.big_map_update, key, maybe_value, map) - Interp_costs.big_map_update rest - (* timestamp operations *) - | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> - consume_gas_binop descr - (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> - consume_gas_binop descr (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> - consume_gas_binop descr (Script_timestamp.sub_delta, t, s) - Interp_costs.sub_timestamp rest ctxt - | Diff_timestamps, Item (t1, Item (t2, rest)) -> - consume_gas_binop descr (Script_timestamp.diff, t1, t2) - Interp_costs.diff_timestamps rest ctxt - (* string operations *) - | Concat_string_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> - let s = String.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_string, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> - let s = String.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_string, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (String.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | String_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) - (* bytes operations *) - | Concat_bytes_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> - let s = MBytes.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_bytes, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> - let s = MBytes.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (MBytes.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | Bytes_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) - (* currency operations *) - | Add_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x +? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Sub_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x -? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Mul_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - | Mul_nattez, Item (y, Item (x, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - (* boolean operations *) - | Or, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt - | And, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt - | Xor, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt - | Not, Item (x, rest) -> - consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt - (* integer operations *) - | Is_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt - | Abs_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt - | Int_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt - | Neg_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Neg_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Add_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt - | Sub_int, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt - | Mul_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt - | Ediv_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - let x = Script_int.of_int64 (Tez.to_mutez x) in - consume_gas_binop descr - ((fun x y -> - 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 -> - begin - match Tez.of_mutez q, Tez.of_mutez r with - | Some q, Some r -> Some (q,r) - (* Cannot overflow *) - | _ -> assert false - end - (* Cannot overflow *) - | _ -> assert false), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - 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 - consume_gas_binop descr - ((fun x y -> match Script_int.ediv_n x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 r with - | None -> assert false (* Cannot overflow *) - | Some r -> - match Tez.of_mutez r with - | None -> assert false (* Cannot overflow *) - | Some r -> Some (q, r)), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt - | Lsl_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> - begin - match Script_int.shift_left_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some x -> logged_return (Item (x, rest), ctxt) - end - | Lsr_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> - begin - match Script_int.shift_right_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some r -> logged_return (Item (r, rest), ctxt) - end - | Or_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt - | And_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | And_int_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | Xor_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt - | Not_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - | Not_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - (* control *) - | Seq (hd, tl), stack -> - step_same ctxt hd stack >>=? fun (trans, ctxt) -> - step_same ctxt tl trans - | If (bt, _), Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step_same ctxt bt rest - | If (_, bf), Item (false, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step_same ctxt bf rest - | Loop body, Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step_same ctxt body rest >>=? fun (trans, ctxt) -> - step_same ctxt descr trans - | Loop _, Item (false, rest) -> - logged_return (rest, ctxt) - | Loop_left body, Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step_same ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) -> - step_same ctxt descr trans - | Loop_left _, Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - | Dip b, Item (ign, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - step_same ctxt b rest >>=? fun (res, ctxt) -> - logged_return (Item (ign, res), ctxt) - | Exec, Item (arg, Item (lam, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> - interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Lambda lam, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (lam, rest), ctxt) - | Failwith tv, Item (v, _) -> - trace Cannot_serialize_failure - (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - fail (Reject (loc, v, get_log log)) - | Nop, stack -> - logged_return (stack, ctxt) - (* comparison *) - | Compare (Bool_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest - | Compare (String_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest - | Compare (Bytes_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest - | Compare (Mutez_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest - | Compare (Int_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest - | Compare (Nat_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest - | Compare (Key_hash_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Signature.Public_key_hash.compare - Interp_costs.compare_key_hash a b rest - | Compare (Timestamp_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest - | Compare (Address_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest - (* comparators *) - | Eq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres = 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Neq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <> 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Lt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres < 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Le, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Gt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres > 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Ge, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres >= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - (* packing *) - | Pack t, Item (value, rest) -> - Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> - logged_return (Item (bytes, rest), ctxt) - | Unpack t, Item (bytes, rest) -> - Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> - if Compare.Int.(MBytes.length bytes >= 1) && - Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then - let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in - match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with - | None -> - Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | Some expr -> - Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> - parse_data ctxt t (Micheline.root expr) >>= function - | Ok (value, ctxt) -> - logged_return (Item (Some value, rest), ctxt) - | Error _ignored -> - Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - else - logged_return (Item (None, rest), ctxt) - (* protocol *) - | Address, Item ((_, contract), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> - logged_return (Item (contract, rest), ctxt) - | Contract t, Item (contract, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> - Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) -> - logged_return (Item (maybe_contract, rest), ctxt) - | Transfer_tokens, - Item (p, Item (amount, Item ((tp, destination), rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> - unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> - let operation = - Transaction - { amount ; destination ; - parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) - | Create_account, - Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; manager ; delegate ; preorigination = Some contract ; - delegatable ; script = None ; spendable = true } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, - Item (contract, rest)), ctxt) - | Implicit_account, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> - let contract = Contract.implicit_contract key in - logged_return (Item ((Unit_t None, contract), rest), ctxt) - | Create_contract (storage_type, param_type, Lam (_, code)), - Item (manager, Item - (delegate, Item - (spendable, Item - (delegatable, Item - (credit, Item - (init, rest)))))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> - unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> - unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> - let code = - Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; - Prim (0, K_storage, [ unparsed_storage_type ], []) ; - Prim (0, K_code, [ Micheline.root code ], []) ])) in - unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> - let storage = Micheline.strip_locations storage in - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; manager ; delegate ; preorigination = Some contract ; - delegatable ; spendable ; - script = Some { code = Script.lazy_expr code ; - storage = Script.lazy_expr storage } } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return - (Item (Internal_operation { source = self ; operation ; nonce }, - Item (contract, rest)), ctxt) - | Set_delegate, - Item (delegate, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - let operation = Delegation delegate in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) - | Balance, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> - Contract.get_balance ctxt self >>=? fun balance -> - logged_return (Item (balance, rest), ctxt) - | Now, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> - let now = Script_timestamp.now ctxt in - logged_return (Item (now, rest), ctxt) - | Check_signature, Item (key, Item (signature, Item (message, rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt -> - let res = Signature.check key signature message in - logged_return (Item (res, rest), ctxt) - | Hash_key, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> - logged_return (Item (Signature.Public_key.hash key, rest), ctxt) - | Blake2b, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> - let hash = Raw_hashes.blake2b bytes in - logged_return (Item (hash, rest), ctxt) - | Sha256, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> - let hash = Raw_hashes.sha256 bytes in - logged_return (Item (hash, rest), ctxt) - | Sha512, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt -> - let hash = Raw_hashes.sha512 bytes in - logged_return (Item (hash, rest), ctxt) - | Steps_to_quota, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> - let steps = match Gas.level ctxt with - | Limited { remaining } -> remaining - | Unaccounted -> Z.of_string "99999999" in - logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) - | Source, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item (payer, rest), ctxt) - | Sender, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item (source, rest), ctxt) - | Self t, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> - logged_return (Item ((t,self), rest), ctxt) - | Amount, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> - logged_return (Item (amount, rest), ctxt) +(* let rec step + * : type b a. + * (?log: execution_trace ref -> + * context -> + * source: Contract.t -> + * self: Contract.t -> + * payer: Contract.t -> + * ?visitor: (ex_descr_stack -> unit) -> + * Tez.t -> + * (b, a) descr -> b stack -> + * (a stack * context) tzresult Lwt.t) = + * fun ?log ctxt ~source ~self ~payer ?visitor amount ({ instr ; loc ; _ } as descr) stack -> + * Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> + * (match visitor with + * | Some visitor -> visitor @@ Ex_descr_stack(descr, stack) + * | None -> ()) ; + * let step_same ctxt = step ?log ctxt ~source ~self ~payer ?visitor amount in + * let logged_return : type a b. + * (b, a) descr -> + * a stack * context -> + * (a stack * context) tzresult Lwt.t = + * fun descr (ret, ctxt) -> + * match log with + * | None -> return (ret, ctxt) + * | Some log -> + * trace + * Cannot_serialize_log + * (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> + * log := (descr.loc, Gas.level ctxt, stack) :: !log ; + * return (ret, ctxt) in + * let get_log (log : execution_trace ref option) = + * Option.map ~f:(fun l -> List.rev !l) log in + * let consume_gas_terop : type ret arg1 arg2 arg3 rest. + * (_ * (_ * (_ * rest)), ret * rest) descr -> + * ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> + * (arg1 -> arg2 -> arg3 -> Gas.cost) -> + * rest stack -> + * ((ret * rest) stack * context) tzresult Lwt.t = + * fun descr (op, x1, x2, x3) cost_func rest -> + * Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> + * logged_return descr (Item (op x1 x2 x3, rest), ctxt) in + * let consume_gas_binop : type ret arg1 arg2 rest. + * (_ * (_ * rest), ret * rest) descr -> + * ((arg1 -> arg2 -> ret) * arg1 * arg2) -> + * (arg1 -> arg2 -> Gas.cost) -> + * rest stack -> + * context -> + * ((ret * rest) stack * context) tzresult Lwt.t = + * fun descr (op, x1, x2) cost_func rest ctxt -> + * Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> + * logged_return descr (Item (op x1 x2, rest), ctxt) in + * let consume_gas_unop : type ret arg rest. + * (_ * rest, ret * rest) descr -> + * ((arg -> ret) * arg) -> + * (arg -> Gas.cost) -> + * rest stack -> + * context -> + * ((ret * rest) stack * context) tzresult Lwt.t = + * fun descr (op, arg) cost_func rest ctxt -> + * Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> + * logged_return descr (Item (op arg, rest), ctxt) in + * let consume_gaz_comparison : + * type t rest. + * (t * (t * rest), Script_int.z Script_int.num * rest) descr -> + * (t -> t -> int) -> + * (t -> t -> Gas.cost) -> + * t -> t -> + * rest stack -> + * ((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t = + * fun descr op cost x1 x2 rest -> + * Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt -> + * logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in + * let logged_return : + * a stack * context -> + * (a stack * context) tzresult Lwt.t = + * logged_return descr in + * match instr, stack with + * (\* stack ops *\) + * | Drop, Item (_, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + * logged_return (rest, ctxt) + * | Dup, Item (v, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + * logged_return (Item (v, Item (v, rest)), ctxt) + * | Swap, Item (vi, Item (vo, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + * logged_return (Item (vo, Item (vi, rest)), ctxt) + * | Const v, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + * logged_return (Item (v, rest), ctxt) + * (\* options *\) + * | Cons_some, Item (v, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + * logged_return (Item (Some v, rest), ctxt) + * | Cons_none _, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + * logged_return (Item (None, rest), ctxt) + * | If_none (bt, _), Item (None, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + * step_same ctxt bt rest + * | If_none (_, bf), Item (Some v, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + * step_same ctxt bf (Item (v, rest)) + * (\* pairs *\) + * | Cons_pair, Item (a, Item (b, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> + * logged_return (Item ((a, b), rest), ctxt) + * | Car, Item ((a, _), rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + * logged_return (Item (a, rest), ctxt) + * | Cdr, Item ((_, b), rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + * logged_return (Item (b, rest), ctxt) + * (\* unions *\) + * | Left, Item (v, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + * logged_return (Item (L v, rest), ctxt) + * | Right, Item (v, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + * logged_return (Item (R v, rest), ctxt) + * | If_left (bt, _), Item (L v, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + * step_same ctxt bt (Item (v, rest)) + * | If_left (_, bf), Item (R v, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + * step_same ctxt bf (Item (v, rest)) + * (\* lists *\) + * | Cons_list, Item (hd, Item (tl, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> + * logged_return (Item (hd :: tl, rest), ctxt) + * | Nil, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + * logged_return (Item ([], rest), ctxt) + * | If_cons (_, bf), Item ([], rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + * step_same ctxt bf rest + * | If_cons (bt, _), Item (hd :: tl, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + * step_same ctxt bt (Item (hd, Item (tl, rest))) + * | List_map body, Item (l, rest) -> + * let rec loop rest ctxt l acc = + * Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + * match l with + * | [] -> return (Item (List.rev acc, rest), ctxt) + * | hd :: tl -> + * step_same ctxt body (Item (hd, rest)) + * >>=? fun (Item (hd, rest), ctxt) -> + * loop rest ctxt tl (hd :: acc) + * in loop rest ctxt l [] >>=? fun (res, ctxt) -> + * logged_return (res, ctxt) + * | List_size, Item (list, rest) -> + * Lwt.return + * (List.fold_left + * (fun acc _ -> + * acc >>? fun (size, ctxt) -> + * Gas.consume ctxt Interp_costs.list_size >>? fun ctxt -> + * ok (size + 1 (\* FIXME: overflow *\), ctxt)) + * (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> + * logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) + * | List_iter body, Item (l, init) -> + * let rec loop ctxt l stack = + * Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + * match l with + * | [] -> return (stack, ctxt) + * | hd :: tl -> + * step_same ctxt body (Item (hd, stack)) + * >>=? fun (stack, ctxt) -> + * loop ctxt tl stack + * in loop ctxt l init >>=? fun (res, ctxt) -> + * logged_return (res, ctxt) + * (\* sets *\) + * | Empty_set t, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> + * logged_return (Item (empty_set t, rest), ctxt) + * | Set_iter body, Item (set, init) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> + * let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + * let rec loop ctxt l stack = + * Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + * match l with + * | [] -> return (stack, ctxt) + * | hd :: tl -> + * step_same ctxt body (Item (hd, stack)) + * >>=? fun (stack, ctxt) -> + * loop ctxt tl stack + * in loop ctxt l init >>=? fun (res, ctxt) -> + * logged_return (res, ctxt) + * | Set_mem, Item (v, Item (set, rest)) -> + * consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt + * | Set_update, Item (v, Item (presence, Item (set, rest))) -> + * consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest + * | Set_size, Item (set, rest) -> + * consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt + * (\* maps *\) + * | Empty_map (t, _), rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> + * logged_return (Item (empty_map t, rest), ctxt) + * | Map_map body, Item (map, rest) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + * let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + * let rec loop rest ctxt l acc = + * Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + * match l with + * | [] -> return (acc, ctxt) + * | (k, _) as hd :: tl -> + * step_same ctxt body (Item (hd, rest)) + * >>=? fun (Item (hd, rest), ctxt) -> + * loop rest ctxt tl (map_update k (Some hd) acc) + * in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> + * logged_return (Item (res, rest), ctxt) + * | Map_iter body, Item (map, init) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + * let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + * let rec loop ctxt l stack = + * Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + * match l with + * | [] -> return (stack, ctxt) + * | hd :: tl -> + * step_same ctxt body (Item (hd, stack)) + * >>=? fun (stack, ctxt) -> + * loop ctxt tl stack + * in loop ctxt l init >>=? fun (res, ctxt) -> + * logged_return (res, ctxt) + * | Map_mem, Item (v, Item (map, rest)) -> + * consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt + * | Map_get, Item (v, Item (map, rest)) -> + * consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt + * | Map_update, Item (k, Item (v, Item (map, rest))) -> + * consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest + * | Map_size, Item (map, rest) -> + * consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt + * (\* Big map operations *\) + * | Big_map_mem, Item (key, Item (map, rest)) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> + * Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) -> + * logged_return (Item (res, rest), ctxt) + * | Big_map_get, Item (key, Item (map, rest)) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> + * Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) -> + * logged_return (Item (res, rest), ctxt) + * | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> + * consume_gas_terop descr + * (Script_ir_translator.big_map_update, key, maybe_value, map) + * Interp_costs.big_map_update rest + * (\* timestamp operations *\) + * | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> + * consume_gas_binop descr + * (Script_timestamp.add_delta, t, n) + * Interp_costs.add_timestamp rest ctxt + * | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> + * consume_gas_binop descr (Script_timestamp.add_delta, t, n) + * Interp_costs.add_timestamp rest ctxt + * | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> + * consume_gas_binop descr (Script_timestamp.sub_delta, t, s) + * Interp_costs.sub_timestamp rest ctxt + * | Diff_timestamps, Item (t1, Item (t2, rest)) -> + * consume_gas_binop descr (Script_timestamp.diff, t1, t2) + * Interp_costs.diff_timestamps rest ctxt + * (\* string operations *\) + * | Concat_string_pair, Item (x, Item (y, rest)) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> + * let s = String.concat "" [x; y] in + * logged_return (Item (s, rest), ctxt) + * | Concat_string, Item (ss, rest) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> + * let s = String.concat "" ss in + * logged_return (Item (s, rest), ctxt) + * | Slice_string, Item (offset, Item (length, Item (s, rest))) -> + * let s_length = Z.of_int (String.length s) in + * let offset = Script_int.to_zint offset in + * let length = Script_int.to_zint length in + * if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + * Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + * logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + * else + * Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + * logged_return (Item (None, rest), ctxt) + * | String_size, Item (s, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + * logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) + * (\* bytes operations *\) + * | Concat_bytes_pair, Item (x, Item (y, rest)) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> + * let s = MBytes.concat "" [x; y] in + * logged_return (Item (s, rest), ctxt) + * | Concat_bytes, Item (ss, rest) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> + * let s = MBytes.concat "" ss in + * logged_return (Item (s, rest), ctxt) + * | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> + * let s_length = Z.of_int (MBytes.length s) in + * let offset = Script_int.to_zint offset in + * let length = Script_int.to_zint length in + * if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + * Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + * logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + * else + * Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + * logged_return (Item (None, rest), ctxt) + * | Bytes_size, Item (s, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + * logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) + * (\* currency operations *\) + * | Add_tez, Item (x, Item (y, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + * Lwt.return Tez.(x +? y) >>=? fun res -> + * logged_return (Item (res, rest), ctxt) + * | Sub_tez, Item (x, Item (y, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + * Lwt.return Tez.(x -? y) >>=? fun res -> + * logged_return (Item (res, rest), ctxt) + * | Mul_teznat, Item (x, Item (y, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + * Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + * begin + * match Script_int.to_int64 y with + * | None -> fail (Overflow (loc, get_log log)) + * | Some y -> + * Lwt.return Tez.(x *? y) >>=? fun res -> + * logged_return (Item (res, rest), ctxt) + * end + * | Mul_nattez, Item (y, Item (x, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + * Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + * begin + * match Script_int.to_int64 y with + * | None -> fail (Overflow (loc, get_log log)) + * | Some y -> + * Lwt.return Tez.(x *? y) >>=? fun res -> + * logged_return (Item (res, rest), ctxt) + * end + * (\* boolean operations *\) + * | Or, Item (x, Item (y, rest)) -> + * consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt + * | And, Item (x, Item (y, rest)) -> + * consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt + * | Xor, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt + * | Not, Item (x, rest) -> + * consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt + * (\* integer operations *\) + * | Is_nat, Item (x, rest) -> + * consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt + * | Abs_int, Item (x, rest) -> + * consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt + * | Int_nat, Item (x, rest) -> + * consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt + * | Neg_int, Item (x, rest) -> + * consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + * | Neg_nat, Item (x, rest) -> + * consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + * | Add_intint, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + * | Add_intnat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + * | Add_natint, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + * | Add_natnat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt + * | Sub_int, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt + * | Mul_intint, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + * | Mul_intnat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + * | Mul_natint, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + * | Mul_natnat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt + * | Ediv_teznat, Item (x, Item (y, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + * let x = Script_int.of_int64 (Tez.to_mutez x) in + * consume_gas_binop descr + * ((fun x y -> + * 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 -> + * begin + * match Tez.of_mutez q, Tez.of_mutez r with + * | Some q, Some r -> Some (q,r) + * (\* Cannot overflow *\) + * | _ -> assert false + * end + * (\* Cannot overflow *\) + * | _ -> assert false), + * x, y) + * Interp_costs.div + * rest + * ctxt + * | Ediv_tez, Item (x, Item (y, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + * Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + * 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 + * consume_gas_binop descr + * ((fun x y -> match Script_int.ediv_n x y with + * | None -> None + * | Some (q, r) -> + * match Script_int.to_int64 r with + * | None -> assert false (\* Cannot overflow *\) + * | Some r -> + * match Tez.of_mutez r with + * | None -> assert false (\* Cannot overflow *\) + * | Some r -> Some (q, r)), + * x, y) + * Interp_costs.div + * rest + * ctxt + * | Ediv_intint, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + * | Ediv_intnat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + * | Ediv_natint, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + * | Ediv_natnat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt + * | Lsl_nat, Item (x, Item (y, rest)) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> + * begin + * match Script_int.shift_left_n x y with + * | None -> fail (Overflow (loc, get_log log)) + * | Some x -> logged_return (Item (x, rest), ctxt) + * end + * | Lsr_nat, Item (x, Item (y, rest)) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> + * begin + * match Script_int.shift_right_n x y with + * | None -> fail (Overflow (loc, get_log log)) + * | Some r -> logged_return (Item (r, rest), ctxt) + * end + * | Or_nat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt + * | And_nat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + * | And_int_nat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + * | Xor_nat, Item (x, Item (y, rest)) -> + * consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt + * | Not_int, Item (x, rest) -> + * consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + * | Not_nat, Item (x, rest) -> + * consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + * (\* control *\) + * | Seq (hd, tl), stack -> + * step_same ctxt hd stack >>=? fun (trans, ctxt) -> + * step_same ctxt tl trans + * | If (bt, _), Item (true, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + * step_same ctxt bt rest + * | If (_, bf), Item (false, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + * step_same ctxt bf rest + * | Loop body, Item (true, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + * step_same ctxt body rest >>=? fun (trans, ctxt) -> + * step_same ctxt descr trans + * | Loop _, Item (false, rest) -> + * logged_return (rest, ctxt) + * | Loop_left body, Item (L v, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + * step_same ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) -> + * step_same ctxt descr trans + * | Loop_left _, Item (R v, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + * logged_return (Item (v, rest), ctxt) + * | Dip b, Item (ign, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + * step_same ctxt b rest >>=? fun (res, ctxt) -> + * logged_return (Item (ign, res), ctxt) + * | Exec, Item (arg, Item (lam, rest)) -> + * Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> + * interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) -> + * logged_return (Item (res, rest), ctxt) + * | Lambda lam, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + * logged_return (Item (lam, rest), ctxt) + * | Failwith tv, Item (v, _) -> + * trace Cannot_serialize_failure + * (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> + * let v = Micheline.strip_locations v in + * fail (Reject (loc, v, get_log log)) + * | Nop, stack -> + * logged_return (stack, ctxt) + * (\* comparison *\) + * | Compare (Bool_key _), Item (a, Item (b, rest)) -> + * consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest + * | Compare (String_key _), Item (a, Item (b, rest)) -> + * consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest + * | Compare (Bytes_key _), Item (a, Item (b, rest)) -> + * consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest + * | Compare (Mutez_key _), Item (a, Item (b, rest)) -> + * consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest + * | Compare (Int_key _), Item (a, Item (b, rest)) -> + * consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest + * | Compare (Nat_key _), Item (a, Item (b, rest)) -> + * consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest + * | Compare (Key_hash_key _), Item (a, Item (b, rest)) -> + * consume_gaz_comparison descr Signature.Public_key_hash.compare + * Interp_costs.compare_key_hash a b rest + * | Compare (Timestamp_key _), Item (a, Item (b, rest)) -> + * consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest + * | Compare (Address_key _), Item (a, Item (b, rest)) -> + * consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest + * (\* comparators *\) + * | Eq, Item (cmpres, rest) -> + * let cmpres = Script_int.compare cmpres Script_int.zero in + * let cmpres = Compare.Int.(cmpres = 0) in + * Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + * logged_return (Item (cmpres, rest), ctxt) + * | Neq, Item (cmpres, rest) -> + * let cmpres = Script_int.compare cmpres Script_int.zero in + * let cmpres = Compare.Int.(cmpres <> 0) in + * Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + * logged_return (Item (cmpres, rest), ctxt) + * | Lt, Item (cmpres, rest) -> + * let cmpres = Script_int.compare cmpres Script_int.zero in + * let cmpres = Compare.Int.(cmpres < 0) in + * Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + * logged_return (Item (cmpres, rest), ctxt) + * | Le, Item (cmpres, rest) -> + * let cmpres = Script_int.compare cmpres Script_int.zero in + * let cmpres = Compare.Int.(cmpres <= 0) in + * Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + * logged_return (Item (cmpres, rest), ctxt) + * | Gt, Item (cmpres, rest) -> + * let cmpres = Script_int.compare cmpres Script_int.zero in + * let cmpres = Compare.Int.(cmpres > 0) in + * Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + * logged_return (Item (cmpres, rest), ctxt) + * | Ge, Item (cmpres, rest) -> + * let cmpres = Script_int.compare cmpres Script_int.zero in + * let cmpres = Compare.Int.(cmpres >= 0) in + * Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + * logged_return (Item (cmpres, rest), ctxt) + * (\* packing *\) + * | Pack t, Item (value, rest) -> + * Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> + * logged_return (Item (bytes, rest), ctxt) + * | Unpack t, Item (bytes, rest) -> + * Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> + * if Compare.Int.(MBytes.length bytes >= 1) && + * Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then + * let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in + * match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + * | None -> + * Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + * logged_return (Item (None, rest), ctxt) + * | Some expr -> + * Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> + * parse_data ctxt t (Micheline.root expr) >>= function + * | Ok (value, ctxt) -> + * logged_return (Item (Some value, rest), ctxt) + * | Error _ignored -> + * Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + * logged_return (Item (None, rest), ctxt) + * else + * logged_return (Item (None, rest), ctxt) + * (\* protocol *\) + * | Address, Item ((_, contract), rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> + * logged_return (Item (contract, rest), ctxt) + * | Contract t, Item (contract, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> + * Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) -> + * logged_return (Item (maybe_contract, rest), ctxt) + * | Transfer_tokens, + * Item (p, Item (amount, Item ((tp, destination), rest))) -> + * Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> + * unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> + * let operation = + * Transaction + * { amount ; destination ; + * parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in + * Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + * logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) + * | Create_account, + * Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> + * Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + * Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + * let operation = + * Origination + * { credit ; manager ; delegate ; preorigination = Some contract ; + * delegatable ; script = None ; spendable = true } in + * Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + * logged_return (Item (Internal_operation { source = self ; operation ; nonce }, + * Item (contract, rest)), ctxt) + * | Implicit_account, Item (key, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> + * let contract = Contract.implicit_contract key in + * logged_return (Item ((Unit_t None, contract), rest), ctxt) + * | Create_contract (storage_type, param_type, Lam (_, code)), + * Item (manager, Item + * (delegate, Item + * (spendable, Item + * (delegatable, Item + * (credit, Item + * (init, rest)))))) -> + * Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> + * unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> + * unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> + * let code = + * Micheline.strip_locations + * (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; + * Prim (0, K_storage, [ unparsed_storage_type ], []) ; + * Prim (0, K_code, [ Micheline.root code ], []) ])) in + * unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> + * let storage = Micheline.strip_locations storage in + * Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + * let operation = + * Origination + * { credit ; manager ; delegate ; preorigination = Some contract ; + * delegatable ; spendable ; + * script = Some { code = Script.lazy_expr code ; + * storage = Script.lazy_expr storage } } in + * Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + * logged_return + * (Item (Internal_operation { source = self ; operation ; nonce }, + * Item (contract, rest)), ctxt) + * | Set_delegate, + * Item (delegate, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + * let operation = Delegation delegate in + * Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + * logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) + * | Balance, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> + * Contract.get_balance ctxt self >>=? fun balance -> + * logged_return (Item (balance, rest), ctxt) + * | Now, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> + * let now = Script_timestamp.now ctxt in + * logged_return (Item (now, rest), ctxt) + * | Check_signature, Item (key, Item (signature, Item (message, rest))) -> + * Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt -> + * let res = Signature.check key signature message in + * logged_return (Item (res, rest), ctxt) + * | Hash_key, Item (key, rest) -> + * Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> + * logged_return (Item (Signature.Public_key.hash key, rest), ctxt) + * | Blake2b, Item (bytes, rest) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> + * let hash = Raw_hashes.blake2b bytes in + * logged_return (Item (hash, rest), ctxt) + * | Sha256, Item (bytes, rest) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> + * let hash = Raw_hashes.sha256 bytes in + * logged_return (Item (hash, rest), ctxt) + * | Sha512, Item (bytes, rest) -> + * Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt -> + * let hash = Raw_hashes.sha512 bytes in + * logged_return (Item (hash, rest), ctxt) + * | Steps_to_quota, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> + * let steps = match Gas.level ctxt with + * | Limited { remaining } -> remaining + * | Unaccounted -> Z.of_string "99999999" in + * logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) + * | Source, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + * logged_return (Item (payer, rest), ctxt) + * | Sender, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + * logged_return (Item (source, rest), ctxt) + * | Self t, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> + * logged_return (Item ((t,self), rest), ctxt) + * | Amount, rest -> + * Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> + * logged_return (Item (amount, rest), ctxt) *) -and interp - : type p r. - (?log: execution_trace ref -> - context -> - source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t -> - (p, r) lambda -> p -> - (r * context) tzresult Lwt.t) - = fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg -> - let stack = (Item (arg, Empty)) in - begin match log with - | None -> return_unit - | Some log -> - trace Cannot_serialize_log - (unparse_stack ctxt (stack, code.bef)) >>=? fun stack -> - log := (code.loc, Gas.level ctxt, stack) :: !log ; - return_unit - end >>=? fun () -> - step ctxt ~source ~payer ~self amount code stack >>=? fun (Item (ret, Empty), ctxt) -> - return (ret, ctxt) +(* and interp + * : type p r. + * (?log: execution_trace ref -> + * context -> + * source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t -> + * (p, r) lambda -> p -> + * (r * context) tzresult Lwt.t) + * = fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg -> + * let stack = (Item (arg, Empty)) in + * begin match log with + * | None -> return_unit + * | Some log -> + * trace Cannot_serialize_log + * (unparse_stack ctxt (stack, code.bef)) >>=? fun stack -> + * log := (code.loc, Gas.level ctxt, stack) :: !log ; + * return_unit + * end >>=? fun () -> + * step ctxt ~source ~payer ~self amount code stack >>=? fun (Item (ret, Empty), ctxt) -> + * return (ret, ctxt) *) @@ -956,7 +997,7 @@ let parse_michelson (type aft) parse_instr ?type_logger top_level tezos_context - michelson bef >>=?? fun (j, _) -> + michelson bef ~legacy:false >>=?? fun (j, _) -> match j with | Typed descr -> ( Lwt.return ( @@ -976,7 +1017,7 @@ let parse_michelson_fail (type aft) parse_instr ?type_logger top_level tezos_context - michelson bef >>=?? fun (j, _) -> + michelson bef ~legacy:false >>=?? fun (j, _) -> match j with | Typed descr -> ( Lwt.return ( @@ -991,14 +1032,14 @@ let parse_michelson_fail (type aft) let parse_michelson_data ?(tezos_context = dummy_environment.tezos_context) michelson ty = - parse_data tezos_context ty michelson >>=?? fun (data, _) -> + parse_data tezos_context ty michelson ~legacy:false >>=?? fun (data, _) -> return data let parse_michelson_ty ?(tezos_context = dummy_environment.tezos_context) - ?(allow_big_map = true) ?(allow_operation = true) + ?(allow_big_map = true) ?(allow_operation = true) ?(allow_contract = true) michelson = - Lwt.return @@ parse_ty tezos_context ~allow_big_map ~allow_operation michelson >>=?? fun (ty, _) -> + Lwt.return @@ parse_ty tezos_context ~allow_big_map ~allow_operation michelson ~legacy:false ~allow_contract >>=?? fun (ty, _) -> return ty let unparse_michelson_data @@ -1020,6 +1061,7 @@ type options = { payer: Alpha_context.Contract.t ; self: Alpha_context.Contract.t ; amount: Alpha_context.Tez.t ; + chain_id: Environment.Chain_id.t ; } let make_options @@ -1027,24 +1069,29 @@ let make_options ?(source = (List.nth dummy_environment.identities 0).implicit_contract) ?(self = (List.nth dummy_environment.identities 0).implicit_contract) ?(payer = (List.nth dummy_environment.identities 1).implicit_contract) - ?(amount = Alpha_context.Tez.one) () + ?(amount = Alpha_context.Tez.one) + ?(chain_id = Environment.Chain_id.zero) + () = { tezos_context ; source ; self ; payer ; amount ; + chain_id ; } let default_options = make_options () -let interpret ?(options = default_options) ?visitor (instr:('a, 'b) descr) (bef:'a stack) : 'b stack tzresult Lwt.t = +let interpret ?(options = default_options) (instr:('a, 'b) descr) (bef:'a stack) : 'b stack tzresult Lwt.t = let { tezos_context ; source ; self ; payer ; amount ; + chain_id ; } = options in - X.step tezos_context ~source ~self ~payer ?visitor amount instr bef >>=?? + let step_constants = { source ; self ; payer ; amount ; chain_id } in + Script_interpreter.step tezos_context step_constants instr bef >>=?? fun (stack, _) -> return stack diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml index b9dcfcf39..920de32c7 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml @@ -25,86 +25,90 @@ open Protocol -let constants_mainnet = - Constants_repr. - { - preserved_cycles = 5; - blocks_per_cycle = 4096l; - blocks_per_commitment = 32l; - blocks_per_roll_snapshot = 256l; - blocks_per_voting_period = 32768l; - time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 75L]; - endorsers_per_block = 32; - hard_gas_limit_per_operation = Z.of_int 800_000; - hard_gas_limit_per_block = Z.of_int 8_000_000; - proof_of_work_threshold = Int64.(sub (shift_left 1L 46) 1L); - tokens_per_roll = Tez_repr.(mul_exn one 8_000); - michelson_maximum_type_size = 1000; - seed_nonce_revelation_tip = - (match Tez_repr.(one /? 8L) with Ok c -> c | Error _ -> assert false); - origination_size = 257; - block_security_deposit = Tez_repr.(mul_exn one 512); - endorsement_security_deposit = Tez_repr.(mul_exn one 64); - block_reward = Tez_repr.(mul_exn one 16); - endorsement_reward = Tez_repr.(mul_exn one 2); - hard_storage_limit_per_operation = Z.of_int 60_000; - cost_per_byte = Tez_repr.of_mutez_exn 1_000L; - test_chain_duration = Int64.mul 32768L 60L; - } +let constants_mainnet = Constants_repr.{ + preserved_cycles = 5 ; + blocks_per_cycle = 4096l ; + blocks_per_commitment = 32l ; + blocks_per_roll_snapshot = 256l ; + blocks_per_voting_period = 32768l ; + time_between_blocks = + List.map Period_repr.of_seconds_exn [ 60L ; 40L ] ; + endorsers_per_block = 32 ; + hard_gas_limit_per_operation = Z.of_int 800_000 ; + hard_gas_limit_per_block = Z.of_int 8_000_000 ; + proof_of_work_threshold = + Int64.(sub (shift_left 1L 46) 1L) ; + tokens_per_roll = Tez_repr.(mul_exn one 8_000) ; + michelson_maximum_type_size = 1000 ; + seed_nonce_revelation_tip = begin + match Tez_repr.(one /? 8L) with + | Ok c -> c + | Error _ -> assert false + end ; + origination_size = 257 ; + block_security_deposit = Tez_repr.(mul_exn one 512) ; + endorsement_security_deposit = Tez_repr.(mul_exn one 64) ; + block_reward = Tez_repr.(mul_exn one 16) ; + endorsement_reward = Tez_repr.(mul_exn one 2) ; + hard_storage_limit_per_operation = Z.of_int 60_000 ; + cost_per_byte = Tez_repr.of_mutez_exn 1_000L ; + test_chain_duration = Int64.mul 32768L 60L ; + quorum_min = 20_00l ; (* quorum is in centile of a percentage *) + quorum_max = 70_00l ; + min_proposal_quorum = 5_00l ; + initial_endorsers = 24 ; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L ; + } -let constants_sandbox = - Constants_repr. - { - constants_mainnet with - preserved_cycles = 2; - blocks_per_cycle = 8l; - blocks_per_commitment = 4l; - blocks_per_roll_snapshot = 4l; - blocks_per_voting_period = 64l; - time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L]; - proof_of_work_threshold = Int64.of_int (-1); - } +let constants_sandbox = Constants_repr.{ + constants_mainnet with + preserved_cycles = 2 ; + blocks_per_cycle = 8l ; + blocks_per_commitment = 4l ; + blocks_per_roll_snapshot = 4l ; + blocks_per_voting_period = 64l ; + time_between_blocks = + List.map Period_repr.of_seconds_exn [ 1L ; 0L ] ; + proof_of_work_threshold = Int64.of_int (-1) ; + initial_endorsers = 1 ; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L ; + } -let constants_test = - Constants_repr. - { - constants_mainnet with - blocks_per_cycle = 128l; - blocks_per_commitment = 4l; - blocks_per_roll_snapshot = 32l; - blocks_per_voting_period = 256l; - time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L]; - proof_of_work_threshold = Int64.of_int (-1); - } - -let bootstrap_accounts_strings = - [ "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"; - "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9"; - "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV"; - "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU"; - "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ] +let constants_test = Constants_repr.{ + constants_mainnet with + blocks_per_cycle = 128l ; + blocks_per_commitment = 4l ; + blocks_per_roll_snapshot = 32l ; + blocks_per_voting_period = 256l ; + time_between_blocks = + List.map Period_repr.of_seconds_exn [ 1L ; 0L ] ; + proof_of_work_threshold = Int64.of_int (-1) ; + initial_endorsers = 1 ; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L ; + } +let bootstrap_accounts_strings = [ + "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" ; + "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9" ; + "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV" ; + "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU" ; + "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ; +] let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L - -let bootstrap_accounts = - List.map - (fun s -> - let public_key = Signature.Public_key.of_b58check_exn s in - let public_key_hash = Signature.Public_key.hash public_key in - Parameters_repr. - { - public_key_hash; - public_key = Some public_key; - amount = boostrap_balance; - }) +let bootstrap_accounts = List.map (fun s -> + let public_key = Signature.Public_key.of_b58check_exn s in + let public_key_hash = Signature.Public_key.hash public_key in + Parameters_repr.{ + public_key_hash ; + public_key = Some public_key ; + amount = boostrap_balance ; + }) bootstrap_accounts_strings (* TODO this could be generated from OCaml together with the faucet for now these are harcoded values in the tests *) let commitments = - let json_result = - Data_encoding.Json.from_string - {json| + let json_result = Data_encoding.Json.from_string {json| [ [ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ], [ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ], @@ -119,28 +123,27 @@ let commitments = ]|json} in match json_result with - | Error err -> - raise (Failure err) - | Ok json -> - Data_encoding.Json.destruct - (Data_encoding.list Commitment_repr.encoding) - json + | Error err -> raise (Failure err) + | Ok json -> Data_encoding.Json.destruct + (Data_encoding.list Commitment_repr.encoding) json let make_bootstrap_account (pkh, pk, amount) = - Parameters_repr.{public_key_hash = pkh; public_key = Some pk; amount} + Parameters_repr.{ public_key_hash = pkh ; public_key = Some pk ; amount } -let parameters_of_constants ?(bootstrap_accounts = bootstrap_accounts) - ?(bootstrap_contracts = []) ?(with_commitments = false) constants = +let parameters_of_constants + ?(bootstrap_accounts = bootstrap_accounts) + ?(bootstrap_contracts = []) + ?(with_commitments = false) + constants = let commitments = if with_commitments then commitments else [] in - Parameters_repr. - { - bootstrap_accounts; - bootstrap_contracts; - commitments; - constants; - security_deposit_ramp_up_cycles = None; - no_reward_cycles = None; - } + Parameters_repr.{ + bootstrap_accounts ; + bootstrap_contracts ; + commitments ; + constants ; + security_deposit_ramp_up_cycles = None ; + no_reward_cycles = None ; + } let json_of_parameters parameters = Data_encoding.Json.construct Parameters_repr.encoding parameters diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli index 598574c8f..2ba8f6b08 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli @@ -25,21 +25,18 @@ open Protocol -val constants_mainnet : Constants_repr.parametric +val constants_mainnet: Constants_repr.parametric +val constants_sandbox: Constants_repr.parametric +val constants_test: Constants_repr.parametric -val constants_sandbox : Constants_repr.parametric - -val constants_test : Constants_repr.parametric - -val make_bootstrap_account : +val make_bootstrap_account: Signature.public_key_hash * Signature.public_key * Tez_repr.t -> Parameters_repr.bootstrap_account -val parameters_of_constants : +val parameters_of_constants: ?bootstrap_accounts:Parameters_repr.bootstrap_account list -> ?bootstrap_contracts:Parameters_repr.bootstrap_contract list -> ?with_commitments:bool -> - Constants_repr.parametric -> - Parameters_repr.t + Constants_repr.parametric -> Parameters_repr.t -val json_of_parameters : Parameters_repr.t -> Data_encoding.json +val json_of_parameters: Parameters_repr.t -> Data_encoding.json diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune index b2c277a02..efccb5e51 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune @@ -1,22 +1,22 @@ (library - (name tezos_protocol_alpha_parameters) - (public_name tezos-protocol-alpha-parameters) + (name tezos_protocol_005_PsBabyM1_parameters) + (public_name tezos-protocol-005-PsBabyM1-parameters) (modules :standard \ gen) (libraries tezos-base tezos-protocol-environment - tezos-protocol-alpha) + tezos-protocol-005-PsBabyM1) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_alpha + -open Tezos_protocol_005_PsBabyM1 -linkall)) ) (executable (name gen) (libraries tezos-base - tezos-protocol-alpha-parameters) + tezos-protocol-005-PsBabyM1-parameters) (modules gen) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_alpha_parameters + -open Tezos_protocol_005_PsBabyM1_parameters -linkall))) (rule diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml b/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml index 93a0a459d..2b6e75dac 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml @@ -29,19 +29,18 @@ let () = let print_usage_and_fail s = - Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" Sys.argv.(0) ; + Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" + Sys.argv.(0) ; raise (Invalid_argument s) in let dump parameters file = - let str = - Data_encoding.Json.to_string - (Default_parameters.json_of_parameters parameters) - in + let str = Data_encoding.Json.to_string + (Default_parameters.json_of_parameters parameters) in let fd = open_out file in - output_string fd str ; close_out fd + output_string fd str ; + close_out fd in - if Array.length Sys.argv < 2 then print_usage_and_fail "" - else + if Array.length Sys.argv < 2 then print_usage_and_fail "" else match Sys.argv.(1) with | "--sandbox" -> dump @@ -49,13 +48,10 @@ let () = "sandbox-parameters.json" | "--test" -> dump - Default_parameters.( - parameters_of_constants ~with_commitments:true constants_sandbox) + Default_parameters.(parameters_of_constants ~with_commitments:true constants_sandbox) "test-parameters.json" | "--mainnet" -> dump - Default_parameters.( - parameters_of_constants ~with_commitments:true constants_mainnet) + Default_parameters.(parameters_of_constants ~with_commitments:true constants_mainnet) "mainnet-parameters.json" - | s -> - print_usage_and_fail s + | s -> print_usage_and_fail s diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-alpha-parameters.opam b/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-005-PsBabyM1-parameters.opam similarity index 76% rename from vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-alpha-parameters.opam rename to vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-005-PsBabyM1-parameters.opam index 481bde015..839f7ca54 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-alpha-parameters.opam +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-005-PsBabyM1-parameters.opam @@ -1,5 +1,4 @@ opam-version: "2.0" -version: "dev" maintainer: "contact@tezos.com" authors: [ "Tezos devteam" ] homepage: "https://www.tezos.com/" @@ -12,10 +11,9 @@ depends: [ "dune" { build & >= "1.7" } "tezos-base" "tezos-protocol-environment" - "tezos-protocol-alpha" + "tezos-protocol-005-PsBabyM1" ] build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} + [ "dune" "build" "-p" name "-j" jobs ] ] synopsis: "Tezos/Protocol: parameters" diff --git a/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL b/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL index 227ece362..92c00fb26 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL +++ b/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL @@ -1,5 +1,5 @@ { - "hash": "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK", + "hash": "PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS", "modules": [ "Misc", "Storage_description", @@ -25,6 +25,7 @@ "Script_timestamp_repr", "Michelson_v1_primitives", "Script_repr", + "Legacy_script_support_repr", "Contract_repr", "Roll_repr", "Vote_repr", diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml index 435d9920e..c5fd259f1 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml @@ -62,9 +62,16 @@ module Script_int = Script_int_repr module Script_timestamp = struct include Script_timestamp_repr let now ctxt = - Raw_context.current_timestamp ctxt - |> Timestamp.to_seconds - |> of_int64 + let { Constants_repr.time_between_blocks ; _ } = + Raw_context.constants ctxt in + match time_between_blocks with + | [] -> failwith "Internal error: 'time_between_block' constants \ + is an empty list." + | first_delay :: _ -> + let current_timestamp = Raw_context.predecessor_timestamp ctxt in + Time.add current_timestamp (Period_repr.to_seconds first_delay) + |> Timestamp.to_seconds + |> of_int64 end module Script = struct include Michelson_v1_primitives @@ -79,6 +86,7 @@ module Script = struct (Script_repr.force_bytes lexpr >>? fun (b, cost) -> Raw_context.consume_gas ctxt cost >|? fun ctxt -> (b, ctxt)) + module Legacy_support = Legacy_script_support_repr end module Fees = Fees_storage @@ -113,13 +121,30 @@ module Contract = struct include Contract_repr include Contract_storage - let originate c contract ~balance ~manager ?script ~delegate - ~spendable ~delegatable = - originate c contract ~balance ~manager ?script ~delegate - ~spendable ~delegatable + let originate c contract ~balance ~script ~delegate = + originate c contract ~balance ~script ~delegate let init_origination_nonce = Raw_context.init_origination_nonce let unset_origination_nonce = Raw_context.unset_origination_nonce end +module Big_map = struct + type id = Z.t + let fresh = Storage.Big_map.Next.incr + let fresh_temporary = Raw_context.fresh_temporary_big_map + let mem c m k = Storage.Big_map.Contents.mem (c, m) k + let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k + let rpc_arg = Storage.Big_map.rpc_arg + let cleanup_temporary c = + Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c >>= fun c -> + Lwt.return (Raw_context.reset_temporary_big_map c) + let exists c id = + Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) >>=? fun c -> + Storage.Big_map.Key_type.get_option c id >>=? fun kt -> + match kt with + | None -> return (c, None) + | Some kt -> + Storage.Big_map.Value_type.get c id >>=? fun kv -> + return (c, Some (kt, kv)) +end module Delegate = Delegate_storage module Roll = struct include Roll_repr @@ -148,8 +173,8 @@ module Commitment = struct end module Global = struct - let get_last_block_priority = Storage.Last_block_priority.get - let set_last_block_priority = Storage.Last_block_priority.set + let get_block_priority = Storage.Block_priority.get + let set_block_priority = Storage.Block_priority.set end let prepare_first_block = Init_storage.prepare_first_block @@ -169,6 +194,7 @@ let fork_test_chain = Raw_context.fork_test_chain let record_endorsement = Raw_context.record_endorsement let allowed_endorsements = Raw_context.allowed_endorsements let init_endorsements = Raw_context.init_endorsements +let included_endorsements = Raw_context.included_endorsements let reset_internal_nonce = Raw_context.reset_internal_nonce let fresh_internal_nonce = Raw_context.fresh_internal_nonce diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli index 62d317621..b970ad110 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli @@ -65,11 +65,13 @@ module Period : sig include BASIC_DATA type period = t + val rpc_arg: period RPC_arg.arg val of_seconds: int64 -> period tzresult val to_seconds: period -> int64 val mult: int32 -> period -> period tzresult + val zero: period val one_second: period val one_minute: period val one_hour: period @@ -81,6 +83,7 @@ module Timestamp : sig include BASIC_DATA with type t = Time.t type time = t val (+?) : time -> Period.t -> time tzresult + val (-?) : time -> time -> Period.t tzresult val of_notation: string -> time option val to_notation: time -> string @@ -143,6 +146,7 @@ module Gas : sig type error += Gas_limit_too_high (* `Permanent *) val free : cost + val atomic_step_cost : int -> cost val step_cost : int -> cost val alloc_cost : int -> cost val alloc_bytes_cost : int -> cost @@ -209,6 +213,7 @@ module Script : sig | I_BALANCE | I_CAR | I_CDR + | I_CHAIN_ID | I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT @@ -220,10 +225,12 @@ module Script : sig | I_DROP | I_DUP | I_EDIV + | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC + | I_APPLY | I_FAILWITH | I_GE | I_GET @@ -275,6 +282,8 @@ module Script : sig | I_ISNAT | I_CAST | I_RENAME + | I_DIG + | I_DUG | T_bool | T_contract | T_int @@ -297,6 +306,8 @@ module Script : sig | T_unit | T_operation | T_address + | T_chain_id + type location = Micheline.canonical_location @@ -336,6 +347,27 @@ module Script : sig val minimal_deserialize_cost : lazy_expr -> Gas.cost val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t + + val unit_parameter : lazy_expr + + module Legacy_support : sig + val manager_script_code: lazy_expr + val add_do: + manager_pkh: Signature.Public_key_hash.t -> + script_code: lazy_expr -> + script_storage: lazy_expr -> + (lazy_expr * lazy_expr) tzresult Lwt.t + val add_set_delegate: + manager_pkh: Signature.Public_key_hash.t -> + script_code: lazy_expr -> + script_storage: lazy_expr -> + (lazy_expr * lazy_expr) tzresult Lwt.t + val has_default_entrypoint: lazy_expr -> bool + val add_root_entrypoint: + script_code: lazy_expr -> + lazy_expr tzresult Lwt.t + end + end module Constants : sig @@ -380,6 +412,11 @@ module Constants : sig cost_per_byte: Tez.t ; hard_storage_limit_per_operation: Z.t ; test_chain_duration: int64; + quorum_min: int32 ; + quorum_max: int32 ; + min_proposal_quorum : int32 ; + initial_endorsers: int ; + delay_per_missing_endorsement : Period.t ; } val parametric_encoding: parametric Data_encoding.t val parametric: context -> parametric @@ -390,6 +427,8 @@ module Constants : sig val blocks_per_voting_period: context -> int32 val time_between_blocks: context -> Period.t list val endorsers_per_block: context -> int + val initial_endorsers: context -> int + val delay_per_missing_endorsement: context -> Period.t val hard_gas_limit_per_operation: context -> Z.t val hard_gas_limit_per_block: context -> Z.t val cost_per_byte: context -> Tez.t @@ -404,6 +443,9 @@ module Constants : sig val block_security_deposit: context -> Tez.t val endorsement_security_deposit: context -> Tez.t val test_chain_duration: context -> int64 + val quorum_min: context -> int32 + val quorum_max: context -> int32 + val min_proposal_quorum: context -> int32 (** All constants: fixed and parametric *) type t = { @@ -531,6 +573,17 @@ module Seed : sig end +module Big_map: sig + type id = Z.t + val fresh : context -> (context * id) tzresult Lwt.t + val fresh_temporary : context -> context * id + val mem : context -> id -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t + val get_opt : context -> id -> Script_expr_hash.t -> (context * Script.expr option) tzresult Lwt.t + val rpc_arg : id RPC_arg.t + val cleanup_temporary : context -> context Lwt.t + val exists : context -> id -> (context * (Script.expr * Script.expr) option) tzresult Lwt.t +end + module Contract : sig include BASIC_DATA @@ -551,27 +604,22 @@ module Contract : sig val list: context -> contract list Lwt.t - val get_manager: - context -> contract -> public_key_hash tzresult Lwt.t - val get_manager_key: - context -> contract -> public_key tzresult Lwt.t + context -> public_key_hash -> public_key tzresult Lwt.t val is_manager_key_revealed: - context -> contract -> bool tzresult Lwt.t + context -> public_key_hash -> bool tzresult Lwt.t val reveal_manager_key: - context -> contract -> public_key -> context tzresult Lwt.t + context -> public_key_hash -> public_key -> context tzresult Lwt.t - val is_delegatable: - context -> contract -> bool tzresult Lwt.t - val is_spendable: - context -> contract -> bool tzresult Lwt.t + val get_script_code: + context -> contract -> (context * Script.lazy_expr option) tzresult Lwt.t val get_script: context -> contract -> (context * Script.t option) tzresult Lwt.t val get_storage: context -> contract -> (context * Script.expr option) tzresult Lwt.t - val get_counter: context -> contract -> Z.t tzresult Lwt.t + val get_counter: context -> public_key_hash -> Z.t tzresult Lwt.t val get_balance: context -> contract -> Tez.t tzresult Lwt.t @@ -580,29 +628,34 @@ module Contract : sig val fresh_contract_from_current_nonce : context -> (context * t) tzresult Lwt.t val originated_from_current_nonce: since: context -> until:context -> contract list tzresult Lwt.t - type big_map_diff_item = { - diff_key : Script_repr.expr; - diff_key_hash : Script_expr_hash.t; - diff_value : Script_repr.expr option; - } + type big_map_diff_item = + | Update of { + big_map : Big_map.id ; + diff_key : Script.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script.expr option; + } + | Clear of Big_map.id + | Copy of Big_map.id * Big_map.id + | Alloc of { + big_map : Big_map.id; + key_type : Script.expr; + value_type : Script.expr; + } type big_map_diff = big_map_diff_item list val big_map_diff_encoding : big_map_diff Data_encoding.t val originate: context -> contract -> balance: Tez.t -> - manager: public_key_hash -> - ?script: (Script.t * big_map_diff option) -> + script: (Script.t * big_map_diff option) -> delegate: public_key_hash option -> - spendable: bool -> - delegatable: bool -> context tzresult Lwt.t + context tzresult Lwt.t type error += Balance_too_low of contract * Tez.t * Tez.t val spend: context -> contract -> Tez.t -> context tzresult Lwt.t - val spend_from_script: - context -> contract -> Tez.t -> context tzresult Lwt.t val credit: context -> contract -> Tez.t -> context tzresult Lwt.t @@ -615,17 +668,10 @@ module Contract : sig val used_storage_space: context -> t -> Z.t tzresult Lwt.t val increment_counter: - context -> contract -> context tzresult Lwt.t + context -> public_key_hash -> context tzresult Lwt.t val check_counter_increment: - context -> contract -> Z.t -> unit tzresult Lwt.t - - module Big_map : sig - val mem: - context -> contract -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t - val get_opt: - context -> contract -> Script_expr_hash.t -> (context * Script_repr.expr option) tzresult Lwt.t - end + context -> public_key_hash -> Z.t -> unit tzresult Lwt.t (**/**) (* Only for testing *) @@ -658,9 +704,6 @@ module Delegate : sig val set: context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t - val set_from_script: - context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t - val fold: context -> init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t @@ -713,7 +756,7 @@ module Delegate : sig val delegated_contracts: context -> Signature.Public_key_hash.t -> - Contract_hash.t list Lwt.t + Contract_repr.t list Lwt.t val delegated_balance: context -> Signature.Public_key_hash.t -> @@ -775,7 +818,9 @@ module Vote : sig context -> Voting_period.kind -> context tzresult Lwt.t val get_current_quorum: context -> int32 tzresult Lwt.t - val set_current_quorum: context -> int32 -> context tzresult Lwt.t + + val get_participation_ema: context -> int32 tzresult Lwt.t + val set_participation_ema: context -> int32 -> context tzresult Lwt.t val get_current_proposal: context -> proposal tzresult Lwt.t @@ -892,7 +937,7 @@ and _ contents = ballot: Vote.ballot ; } -> Kind.ballot contents | Manager_operation : { - source: Contract.contract ; + source: Signature.Public_key_hash.t ; fee: Tez.tez ; counter: counter ; operation: 'kind manager_operation ; @@ -904,15 +949,13 @@ and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : { amount: Tez.tez ; - parameters: Script.lazy_expr option ; + parameters: Script.lazy_expr ; + entrypoint: string ; destination: Contract.contract ; } -> Kind.transaction manager_operation | Origination : { - manager: Signature.Public_key_hash.t ; delegate: Signature.Public_key_hash.t option ; - script: Script.t option ; - spendable: bool ; - delegatable: bool ; + script: Script.t ; credit: Tez.tez ; preorigination: Contract.t option ; } -> Kind.origination manager_operation @@ -1111,8 +1154,8 @@ end module Global : sig - val get_last_block_priority: context -> int tzresult Lwt.t - val set_last_block_priority: context -> int -> context tzresult Lwt.t + val get_block_priority: context -> int tzresult Lwt.t + val set_block_priority: context -> int -> context tzresult Lwt.t end @@ -1128,6 +1171,7 @@ val prepare_first_block: val prepare: Context.t -> level:Int32.t -> + predecessor_timestamp:Time.t -> timestamp:Time.t -> fitness:Fitness.t -> context tzresult Lwt.t @@ -1146,6 +1190,8 @@ val init_endorsements: context -> (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t -> context +val included_endorsements: + context -> int val reset_internal_nonce: context -> context val fresh_internal_nonce: context -> (context * int) tzresult diff --git a/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml b/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml index ec30af110..ba6d9ba64 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml @@ -26,34 +26,46 @@ open Alpha_context (** Returns the proposal submitted by the most delegates. - Returns None in case of a tie or if there are no proposals. *) -let select_winning_proposal proposals = + Returns None in case of a tie, if proposal quorum is below required + minimum or if there are no proposals. *) +let select_winning_proposal ctxt = + Vote.get_proposals ctxt >>=? fun proposals -> let merge proposal vote winners = match winners with | None -> Some ([proposal], vote) | Some (winners, winners_vote) as previous -> if Compare.Int32.(vote = winners_vote) then Some (proposal :: winners, winners_vote) - else if Compare.Int32.(vote >= winners_vote) then + else if Compare.Int32.(vote > winners_vote) then Some ([proposal], vote) else previous in match Protocol_hash.Map.fold merge proposals None with - | None -> None - | Some ([proposal], _) -> Some proposal - | Some _ -> None (* in case of a tie, lets do nothing. *) + | Some ([proposal], vote) -> + Vote.listing_size ctxt >>=? fun max_vote -> + let min_proposal_quorum = Constants.min_proposal_quorum ctxt in + let min_vote_to_pass = + Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l in + if Compare.Int32.(vote >= min_vote_to_pass) then + return_some proposal + else + return_none + | _ -> + return_none (* in case of a tie, let's do nothing. *) (** A proposal is approved if it has supermajority and the participation reaches the current quorum. Supermajority means the yays are more 8/10 of casted votes. The participation is the ratio of all received votes, including passes, with - respect to the number of possible votes. The quorum starts at 80% and at - each vote is updated using the last expected quorum and the current - participation with the following weights: - newQ = oldQ * 8/10 + participation * 2/10 *) -let check_approval_and_update_quorum ctxt = + respect to the number of possible votes. + The participation EMA (exponential moving average) uses the last + participation EMA and the current participation./ + The expected quorum is calculated using the last participation EMA, capped + by the min/max quorum protocol constants. *) +let check_approval_and_update_participation_ema ctxt = Vote.get_ballots ctxt >>=? fun ballots -> Vote.listing_size ctxt >>=? fun maximum_vote -> + Vote.get_participation_ema ctxt >>=? fun participation_ema -> Vote.get_current_quorum ctxt >>=? fun expected_quorum -> (* Note overflows: considering a maximum of 8e8 tokens, with roll size as small as 1e3, there is a maximum of 8e5 rolls and thus votes. @@ -64,15 +76,18 @@ let check_approval_and_update_quorum ctxt = let all_votes = Int32.add casted_votes ballots.pass in let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in let participation = (* in centile of percentage *) - Int64.to_int32 - (Int64.div - (Int64.mul (Int64.of_int32 all_votes) 100_00L) - (Int64.of_int32 maximum_vote)) in + Int64.(to_int32 + (div + (mul (of_int32 all_votes) 100_00L) + (of_int32 maximum_vote))) in let outcome = Compare.Int32.(participation >= expected_quorum && ballots.yay >= supermajority) in - let updated_quorum = - Int32.div (Int32.add (Int32.mul 8l expected_quorum) (Int32.mul 2l participation)) 10l in - Vote.set_current_quorum ctxt updated_quorum >>=? fun ctxt -> + let new_participation_ema = + Int32.(div (add + (mul 8l participation_ema) + (mul 2l participation)) + 10l) in + Vote.set_participation_ema ctxt new_participation_ema >>=? fun ctxt -> return (ctxt, outcome) (** Implements the state machine of the amendment procedure. @@ -82,10 +97,10 @@ let check_approval_and_update_quorum ctxt = let start_new_voting_period ctxt = Vote.get_current_period_kind ctxt >>=? function | Proposal -> begin - Vote.get_proposals ctxt >>=? fun proposals -> + select_winning_proposal ctxt >>=? fun proposal -> Vote.clear_proposals ctxt >>= fun ctxt -> Vote.clear_listings ctxt >>=? fun ctxt -> - match select_winning_proposal proposals with + match proposal with | None -> Vote.freeze_listings ctxt >>=? fun ctxt -> return ctxt @@ -96,7 +111,7 @@ let start_new_voting_period ctxt = return ctxt end | Testing_vote -> - check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) -> + check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) -> Vote.clear_ballots ctxt >>= fun ctxt -> Vote.clear_listings ctxt >>=? fun ctxt -> if approved then @@ -116,7 +131,7 @@ let start_new_voting_period ctxt = Vote.set_current_period_kind ctxt Promotion_vote >>=? fun ctxt -> return ctxt | Promotion_vote -> - check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) -> + check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) -> begin if approved then Vote.get_current_proposal ctxt >>=? fun proposal -> diff --git a/vendors/ligo-utils/tezos-protocol-alpha/apply.ml b/vendors/ligo-utils/tezos-protocol-alpha/apply.ml index 984d1fee6..df4ba5b85 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/apply.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/apply.ml @@ -33,8 +33,6 @@ type error += Duplicate_endorsement of Signature.Public_key_hash.t (* `Branch *) type error += Invalid_endorsement_level type error += Invalid_commitment of { expected: bool } type error += Internal_operation_replay of packed_internal_operation -type error += Cannot_originate_spendable_smart_contract (* `Permanent *) -type error += Cannot_originate_non_spendable_account (* `Permanent *) type error += Invalid_double_endorsement_evidence (* `Permanent *) type error += Inconsistent_double_endorsement_evidence @@ -60,6 +58,12 @@ type error += Outdated_double_baking_evidence type error += Invalid_activation of { pkh : Ed25519.Public_key_hash.t } type error += Multiple_revelation type error += Gas_quota_exceeded_init_deserialize (* Permanent *) +type error += + Not_enough_endorsements_for_priority of + { required : int ; + priority : int ; + endorsements : int ; + timestamp: Time.t } let () = register_error_kind @@ -135,30 +139,6 @@ let () = Operation.internal_operation_encoding (function Internal_operation_replay op -> Some op | _ -> None) (fun op -> Internal_operation_replay op) ; - register_error_kind - `Permanent - ~id:"cannot_originate_non_spendable_account" - ~title:"Cannot originate non spendable account" - ~description:"An origination was attempted \ - that would create a non spendable, non scripted contract" - ~pp:(fun ppf () -> - Format.fprintf ppf "It is not possible anymore to originate \ - a non scripted contract that is not spendable.") - Data_encoding.empty - (function Cannot_originate_non_spendable_account -> Some () | _ -> None) - (fun () -> Cannot_originate_non_spendable_account) ; - register_error_kind - `Permanent - ~id:"cannot_originate_spendable_smart_contract" - ~title:"Cannot originate spendable smart contract" - ~description:"An origination was attempted \ - that would create a spendable scripted contract" - ~pp:(fun ppf () -> - Format.fprintf ppf "It is not possible anymore to originate \ - a scripted contract that is spendable.") - Data_encoding.empty - (function Cannot_originate_spendable_smart_contract -> Some () | _ -> None) - (fun () -> Cannot_originate_spendable_smart_contract) ; register_error_kind `Permanent ~id:"block.invalid_double_endorsement_evidence" @@ -372,34 +352,49 @@ let () = parse within the provided gas bounds." Data_encoding.empty (function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None) - (fun () -> Gas_quota_exceeded_init_deserialize) + (fun () -> Gas_quota_exceeded_init_deserialize) ; + register_error_kind + `Permanent + ~id:"operation.not_enought_endorsements_for_priority" + ~title:"Not enough endorsements for priority" + ~description:"The block being validated does not include the \ + required minimum number of endorsements for this priority." + ~pp:(fun ppf (required, endorsements, priority, timestamp) -> + Format.fprintf ppf "Wrong number of endorsements (%i) for \ + priority (%i), %i are expected at %a" + endorsements priority required Time.pp_hum timestamp) + Data_encoding.(obj4 + (req "required" int31) + (req "endorsements" int31) + (req "priority" int31) + (req "timestamp" Time.encoding)) + (function Not_enough_endorsements_for_priority + { required ; endorsements ; priority ; timestamp } -> + Some (required, endorsements, priority, timestamp) | _ -> None) + (fun (required, endorsements, priority, timestamp) -> + Not_enough_endorsements_for_priority + { required ; endorsements ; priority ; timestamp }) open Apply_results let apply_manager_operation_content : type kind. ( Alpha_context.t -> Script_ir_translator.unparsing_mode -> payer:Contract.t -> source:Contract.t -> - internal:bool -> kind manager_operation -> + chain_id:Chain_id.t -> internal:bool -> kind manager_operation -> (context * kind successful_manager_operation_result * packed_internal_operation list) tzresult Lwt.t ) = - fun ctxt mode ~payer ~source ~internal operation -> + fun ctxt mode ~payer ~source ~chain_id ~internal operation -> let before_operation = (* This context is not used for backtracking. Only to compute gas consumption and originations for the operation result. *) ctxt in Contract.must_exist ctxt source >>=? fun () -> - let spend = - (* Ignore the spendable flag for smart contracts. *) - if internal then Contract.spend_from_script else Contract.spend in - let set_delegate = - (* Ignore the delegatable flag for smart contracts. *) - if internal then Delegate.set_from_script else Delegate.set in Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation) >>=? fun ctxt -> match operation with | Reveal _ -> return (* No-op: action already performed by `precheck_manager_contents`. *) (ctxt, (Reveal_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt } : kind successful_manager_operation_result), []) - | Transaction { amount ; parameters ; destination } -> begin - spend ctxt source amount >>=? fun ctxt -> + | Transaction { amount ; parameters ; destination ; entrypoint } -> begin + Contract.spend ctxt source amount >>=? fun ctxt -> begin match Contract.is_implicit destination with | None -> return (ctxt, [], false) | Some _ -> @@ -413,20 +408,21 @@ let apply_manager_operation_content : Contract.get_script ctxt destination >>=? fun (ctxt, script) -> match script with | None -> begin - match parameters with - | None -> return ctxt - | Some arg -> - Script.force_decode ctxt arg >>=? fun (arg, ctxt) -> (* see [note] *) - (* [note]: for toplevel ops, cost is nil since the - lazy value has already been forced at precheck, so - we compute and consume the full cost again *) - let cost_arg = Script.deserialized_cost arg in - Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> - match Micheline.root arg with - | Prim (_, D_Unit, [], _) -> - (* Allow [Unit] parameter to non-scripted contracts. *) - return ctxt - | _ -> fail (Script_interpreter.Bad_contract_parameter destination) + begin match entrypoint with + | "default" -> return () + | entrypoint -> fail (Script_tc_errors.No_such_entrypoint entrypoint) + end >>=? fun () -> + Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *) + (* [note]: for toplevel ops, cost is nil since the + lazy value has already been forced at precheck, so + we compute and consume the full cost again *) + let cost_arg = Script.deserialized_cost arg in + Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> + match Micheline.root arg with + | Prim (_, D_Unit, [], _) -> + (* Allow [Unit] parameter to non-scripted contracts. *) + return ctxt + | _ -> fail (Script_interpreter.Bad_contract_parameter destination) end >>=? fun ctxt -> let result = Transaction_result @@ -445,20 +441,18 @@ let apply_manager_operation_content : } in return (ctxt, result, []) | Some script -> - begin match parameters with - | None -> - (* Forge a [Unit] parameter that will be checked by [execute]. *) - let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], [])) in - return (ctxt, unit) - | Some parameters -> - Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *) - let cost_arg = Script.deserialized_cost arg in - Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> - return (ctxt, arg) - end >>=? fun (ctxt, parameter) -> + Script.force_decode ctxt parameters >>=? fun (parameter, ctxt) -> (* see [note] *) + let cost_parameter = Script.deserialized_cost parameter in + Lwt.return (Gas.consume ctxt cost_parameter) >>=? fun ctxt -> + let step_constants = + let open Script_interpreter in + { source ; + payer ; + self = destination ; + amount ; + chain_id } in Script_interpreter.execute - ctxt mode - ~source ~payer ~self:(destination, script) ~amount ~parameter + ctxt mode step_constants ~script ~parameter ~entrypoint >>=? fun { ctxt ; storage ; big_map_diff ; operations } -> Contract.update_script_storage ctxt destination storage big_map_diff >>=? fun ctxt -> @@ -483,27 +477,20 @@ let apply_manager_operation_content : allocated_destination_contract } in return (ctxt, result, operations) end - | Origination { manager ; delegate ; script ; preorigination ; - spendable ; delegatable ; credit } -> - begin match script with - | None -> - if spendable then - return (None, ctxt) - else - fail Cannot_originate_non_spendable_account - | Some script -> - if spendable then - fail Cannot_originate_spendable_smart_contract - else - Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *) - Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt -> - Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *) - Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt -> - Script_ir_translator.parse_script ctxt script >>=? fun (ex_script, ctxt) -> - Script_ir_translator.big_map_initialization ctxt Optimized ex_script >>=? fun (big_map_diff, ctxt) -> - return (Some (script, big_map_diff), ctxt) - end >>=? fun (script, ctxt) -> - spend ctxt source credit >>=? fun ctxt -> + | Origination { delegate ; script ; preorigination ; credit } -> + Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt -> + Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt -> + Script_ir_translator.parse_script ctxt ~legacy:false script >>=? fun (Ex_script parsed_script, ctxt) -> + Script_ir_translator.collect_big_maps ctxt parsed_script.storage_type parsed_script.storage >>=? fun (to_duplicate, ctxt) -> + let to_update = Script_ir_translator.no_big_map_id in + Script_ir_translator.extract_big_map_diff ctxt Optimized parsed_script.storage_type parsed_script.storage + ~to_duplicate ~to_update ~temporary:false >>=? fun (storage, big_map_diff, ctxt) -> + Script_ir_translator.unparse_data ctxt Optimized parsed_script.storage_type storage >>=? fun (storage, ctxt) -> + let storage = Script.lazy_expr (Micheline.strip_locations storage) in + let script = { script with storage } in + Contract.spend ctxt source credit >>=? fun ctxt -> begin match preorigination with | Some contract -> assert internal ; @@ -515,14 +502,14 @@ let apply_manager_operation_content : Contract.fresh_contract_from_current_nonce ctxt end >>=? fun (ctxt, contract) -> Contract.originate ctxt contract - ~manager ~delegate ~balance:credit - ?script - ~spendable ~delegatable >>=? fun ctxt -> + ~delegate ~balance:credit + ~script:(script, big_map_diff) >>=? fun ctxt -> Fees.origination_burn ctxt >>=? fun (ctxt, origination_burn) -> Fees.record_paid_storage_space ctxt contract >>=? fun (ctxt, size, paid_storage_size_diff, fees) -> let result = Origination_result - { balance_updates = + { big_map_diff ; + balance_updates = Delegate.cleanup_balance_updates [ Contract payer, Debited fees ; Contract payer, Debited origination_burn ; @@ -534,10 +521,10 @@ let apply_manager_operation_content : paid_storage_size_diff } in return (ctxt, result, []) | Delegation delegate -> - set_delegate ctxt source delegate >>=? fun ctxt -> + Delegate.set ctxt source delegate >>=? fun ctxt -> return (ctxt, Delegation_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt }, []) -let apply_internal_manager_operations ctxt mode ~payer ops = +let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = let rec apply ctxt applied worklist = match worklist with | [] -> Lwt.return (`Success ctxt, List.rev applied) @@ -549,7 +536,7 @@ let apply_internal_manager_operations ctxt mode ~payer ops = else let ctxt = record_internal_nonce ctxt nonce in apply_manager_operation_content - ctxt mode ~source ~payer ~internal:true operation + ctxt mode ~source ~payer ~chain_id ~internal:true operation end >>= function | Error errors -> let result = @@ -573,20 +560,20 @@ let precheck_manager_contents Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () -> let ctxt = Gas.set_limit ctxt gas_limit in Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () -> - Contract.must_be_allocated ctxt source >>=? fun () -> + Contract.must_be_allocated ctxt (Contract.implicit_contract source) >>=? fun () -> Contract.check_counter_increment ctxt source counter >>=? fun () -> begin match operation with | Reveal pk -> Contract.reveal_manager_key ctxt source pk - | Transaction { parameters = Some arg ; _ } -> + | Transaction { parameters ; _ } -> (* Fail quickly if not enough gas for minimal deserialization cost *) Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ - Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () -> + Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters) >>=? fun () -> (* Fail if not enough gas for complete deserialization cost *) trace Gas_quota_exceeded_init_deserialize @@ - Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt - | Origination { script = Some script ; _ } -> + Script.force_decode ctxt parameters >>|? fun (_arg, ctxt) -> ctxt + | Origination { script ; _ } -> (* Fail quickly if not enough gas for minimal deserialization cost *) Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ (Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt -> @@ -606,12 +593,12 @@ let precheck_manager_contents sequence of transactions. *) Operation.check_signature public_key chain_id raw_operation >>=? fun () -> Contract.increment_counter ctxt source >>=? fun ctxt -> - Contract.spend ctxt source fee >>=? fun ctxt -> + Contract.spend ctxt (Contract.implicit_contract source) fee >>=? fun ctxt -> add_fees ctxt fee >>=? fun ctxt -> return ctxt let apply_manager_contents - (type kind) ctxt mode (op : kind Kind.manager contents) + (type kind) ctxt mode chain_id (op : kind Kind.manager contents) : ([ `Success of context | `Failure ] * kind manager_operation_result * packed_internal_operation_result list) Lwt.t = @@ -619,11 +606,12 @@ let apply_manager_contents { source ; operation ; gas_limit ; storage_limit } = op in let ctxt = Gas.set_limit ctxt gas_limit in let ctxt = Fees.start_counting_storage_fees ctxt in + let source = Contract.implicit_contract source in apply_manager_operation_content ctxt mode - ~source ~payer:source ~internal:false operation >>= function + ~source ~payer:source ~internal:false ~chain_id operation >>= function | Ok (ctxt, operation_results, internal_operations) -> begin apply_internal_manager_operations - ctxt mode ~payer:source internal_operations >>= function + ctxt mode ~payer:source ~chain_id internal_operations >>= function | (`Success ctxt, internal_operations_results) -> begin Fees.burn_storage_fees ctxt ~storage_limit ~payer:source >>= function | Ok ctxt -> @@ -654,6 +642,7 @@ let rec mark_skipped baker : Signature.Public_key_hash.t -> Level.t -> kind Kind.manager contents_list -> kind Kind.manager contents_result_list = fun ~baker level -> function | Single (Manager_operation { source ; fee ; operation } ) -> + let source = Contract.implicit_contract source in Single_result (Manager_operation_result { balance_updates = @@ -663,6 +652,7 @@ let rec mark_skipped operation_result = skipped_operation_result operation ; internal_operation_results = [] }) | Cons (Manager_operation { source ; fee ; operation } , rest) -> + let source = Contract.implicit_contract source in Cons_result (Manager_operation_result { balance_updates = @@ -688,14 +678,15 @@ let rec precheck_manager_contents_list let rec apply_manager_contents_list_rec : type kind. Alpha_context.t -> Script_ir_translator.unparsing_mode -> - public_key_hash -> kind Kind.manager contents_list -> + public_key_hash -> Chain_id.t -> kind Kind.manager contents_list -> ([ `Success of context | `Failure ] * kind Kind.manager contents_result_list) Lwt.t = - fun ctxt mode baker contents_list -> + fun ctxt mode baker chain_id contents_list -> let level = Level.current ctxt in match contents_list with | Single (Manager_operation { source ; fee ; _ } as op) -> begin - apply_manager_contents ctxt mode op + let source = Contract.implicit_contract source in + apply_manager_contents ctxt mode chain_id op >>= fun (ctxt_result, operation_result, internal_operation_results) -> let result = Manager_operation_result { @@ -709,7 +700,8 @@ let rec apply_manager_contents_list_rec Lwt.return (ctxt_result, Single_result (result)) end | Cons (Manager_operation { source ; fee ; _ } as op, rest) -> - apply_manager_contents ctxt mode op >>= function + let source = Contract.implicit_contract source in + apply_manager_contents ctxt mode chain_id op >>= function | (`Failure, operation_result, internal_operation_results) -> let result = Manager_operation_result { @@ -731,7 +723,7 @@ let rec apply_manager_contents_list_rec operation_result ; internal_operation_results ; } in - apply_manager_contents_list_rec ctxt mode baker rest >>= fun (ctxt_result, results) -> + apply_manager_contents_list_rec ctxt mode baker chain_id rest >>= fun (ctxt_result, results) -> Lwt.return (ctxt_result, Cons_result (result, results)) let mark_backtracked results = @@ -765,14 +757,16 @@ let mark_backtracked results = | Applied result -> Backtracked (result, None) in mark_contents_list results -let apply_manager_contents_list ctxt mode baker contents_list = - apply_manager_contents_list_rec ctxt mode baker contents_list >>= fun (ctxt_result, results) -> +let apply_manager_contents_list ctxt mode baker chain_id contents_list = + apply_manager_contents_list_rec ctxt mode baker chain_id contents_list >>= fun (ctxt_result, results) -> match ctxt_result with | `Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results) - | `Success ctxt -> Lwt.return (ctxt, results) + | `Success ctxt -> + Big_map.cleanup_temporary ctxt >>= fun ctxt -> + Lwt.return (ctxt, results) let apply_contents_list - (type kind) ctxt ~partial chain_id mode pred_block baker + (type kind) ctxt chain_id mode pred_block baker (operation : kind operation) (contents_list : kind contents_list) : (context * kind contents_result_list) tzresult Lwt.t = @@ -791,18 +785,12 @@ let apply_contents_list else let ctxt = record_endorsement ctxt delegate in let gap = List.length slots in - let ctxt = Fitness.increase ~gap ctxt in Lwt.return Tez.(Constants.endorsement_security_deposit ctxt *? Int64.of_int gap) >>=? fun deposit -> - begin - if partial then - Delegate.freeze_deposit ctxt delegate deposit - else - add_deposit ctxt delegate deposit - end >>=? fun ctxt -> - Global.get_last_block_priority ctxt >>=? fun block_priority -> - Baking.endorsement_reward ctxt ~block_priority gap >>=? fun reward -> + Delegate.freeze_deposit ctxt delegate deposit >>=? fun ctxt -> + Global.get_block_priority ctxt >>=? fun block_priority -> + Baking.endorsing_reward ctxt ~block_priority gap >>=? fun reward -> Delegate.freeze_rewards ctxt delegate reward >>=? fun ctxt -> let level = Level.from_raw ctxt level in return (ctxt, Single_result @@ -944,17 +932,17 @@ let apply_contents_list return (ctxt, Single_result Ballot_result) | Single (Manager_operation _) as op -> precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt -> - apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) -> + apply_manager_contents_list ctxt mode baker chain_id op >>= fun (ctxt, result) -> return (ctxt, result) | Cons (Manager_operation _, _) as op -> precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt -> - apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) -> + apply_manager_contents_list ctxt mode baker chain_id op >>= fun (ctxt, result) -> return (ctxt, result) -let apply_operation ctxt ~partial chain_id mode pred_block baker hash operation = +let apply_operation ctxt chain_id mode pred_block baker hash operation = let ctxt = Contract.init_origination_nonce ctxt hash in apply_contents_list - ctxt ~partial chain_id mode pred_block baker operation + ctxt chain_id mode pred_block baker operation operation.protocol_data.contents >>=? fun (ctxt, result) -> let ctxt = Gas.set_unlimited ctxt in let ctxt = Contract.unset_origination_nonce ctxt in @@ -983,15 +971,17 @@ let may_start_new_cycle ctxt = return (ctxt, update_balances, deactivated) let begin_full_construction ctxt pred_timestamp protocol_data = + Alpha_context.Global.set_block_priority ctxt + protocol_data.Block_header.priority >>=? fun ctxt -> Baking.check_baking_rights - ctxt protocol_data pred_timestamp >>=? fun delegate_pk -> + ctxt protocol_data pred_timestamp >>=? fun (delegate_pk, block_delay) -> let ctxt = Fitness.increase ctxt in match Level.pred ctxt (Level.current ctxt) with | None -> assert false (* genesis *) | Some pred_level -> Baking.endorsement_rights ctxt pred_level >>=? fun rights -> let ctxt = init_endorsements ctxt rights in - return (ctxt, protocol_data, delegate_pk) + return (ctxt, protocol_data, delegate_pk, block_delay) let begin_partial_construction ctxt = let ctxt = Fitness.increase ctxt in @@ -1003,11 +993,14 @@ let begin_partial_construction ctxt = return ctxt let begin_application ctxt chain_id block_header pred_timestamp = + Alpha_context.Global.set_block_priority ctxt + block_header.Block_header.protocol_data.contents.priority >>=? fun ctxt -> let current_level = Alpha_context.Level.current ctxt in Baking.check_proof_of_work_stamp ctxt block_header >>=? fun () -> Baking.check_fitness_gap ctxt block_header >>=? fun () -> Baking.check_baking_rights - ctxt block_header.protocol_data.contents pred_timestamp >>=? fun delegate_pk -> + ctxt block_header.protocol_data.contents pred_timestamp + >>=? fun (delegate_pk, block_delay) -> Baking.check_signature block_header chain_id delegate_pk >>=? fun () -> let has_commitment = match block_header.protocol_data.contents.seed_nonce_hash with @@ -1023,12 +1016,27 @@ let begin_application ctxt chain_id block_header pred_timestamp = | Some pred_level -> Baking.endorsement_rights ctxt pred_level >>=? fun rights -> let ctxt = init_endorsements ctxt rights in - return (ctxt, delegate_pk) + return (ctxt, delegate_pk, block_delay) -let finalize_application ctxt protocol_data delegate = +let check_minimum_endorsements ctxt protocol_data block_delay included_endorsements = + let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in + let timestamp = Timestamp.current ctxt in + fail_unless Compare.Int.(included_endorsements >= minimum) + (Not_enough_endorsements_for_priority + { required = minimum ; + priority = protocol_data.Block_header.priority ; + endorsements = included_endorsements ; + timestamp }) + +let finalize_application ctxt protocol_data delegate ~block_delay = + let included_endorsements = included_endorsements ctxt in + check_minimum_endorsements ctxt + protocol_data block_delay included_endorsements >>=? fun () -> let deposit = Constants.block_security_deposit ctxt in add_deposit ctxt delegate deposit >>=? fun ctxt -> - let reward = (Constants.block_reward ctxt) in + + Baking.baking_reward ctxt + ~block_priority:protocol_data.priority ~included_endorsements >>=? fun reward -> add_rewards ctxt reward >>=? fun ctxt -> Signature.Public_key_hash.Map.fold (fun delegate deposit ctxt -> @@ -1048,8 +1056,6 @@ let finalize_application ctxt protocol_data delegate = Nonce.record_hash ctxt { nonce_hash ; delegate ; rewards ; fees } end >>=? fun ctxt -> - Alpha_context.Global.set_last_block_priority - ctxt protocol_data.priority >>=? fun ctxt -> (* end of cycle *) may_snapshot_roll ctxt >>=? fun ctxt -> may_start_new_cycle ctxt >>=? fun (ctxt, balance_updates, deactivated) -> diff --git a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml index 0ef56ef6e..d02de349a 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml @@ -56,7 +56,8 @@ type _ successful_manager_operation_result = allocated_destination_contract : bool ; } -> Kind.transaction successful_manager_operation_result | Origination_result : - { balance_updates : Delegate.balance_updates ; + { big_map_diff : Contract.big_map_diff option ; + balance_updates : Delegate.balance_updates ; originated_contracts : Contract.t list ; consumed_gas : Z.t ; storage_size : Z.t ; @@ -215,7 +216,8 @@ module Manager_result = struct make ~op_case: Operation.Encoding.Manager_operations.origination_case ~encoding: - (obj5 + (obj6 + (opt "big_map_diff" Contract.big_map_diff_encoding) (dft "balance_updates" Delegate.balance_updates_encoding []) (dft "originated_contracts" (list Contract.encoding) []) (dft "consumed_gas" z Z.zero) @@ -234,19 +236,19 @@ module Manager_result = struct ~proj: (function | Origination_result - { balance_updates ; + { big_map_diff ; balance_updates ; originated_contracts ; consumed_gas ; storage_size ; paid_storage_size_diff } -> - (balance_updates, + (big_map_diff, balance_updates, originated_contracts, consumed_gas, storage_size, paid_storage_size_diff)) ~kind: Kind.Origination_manager_kind ~inj: - (fun (balance_updates, + (fun (big_map_diff, balance_updates, originated_contracts, consumed_gas, storage_size, paid_storage_size_diff) -> Origination_result - { balance_updates ; + { big_map_diff ; balance_updates ; originated_contracts ; consumed_gas ; storage_size ; paid_storage_size_diff }) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli index b4505f502..a5f17d2ef 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli @@ -100,7 +100,8 @@ and _ successful_manager_operation_result = allocated_destination_contract : bool ; } -> Kind.transaction successful_manager_operation_result | Origination_result : - { balance_updates : Delegate.balance_updates ; + { big_map_diff : Contract.big_map_diff option ; + balance_updates : Delegate.balance_updates ; originated_contracts : Contract.t list ; consumed_gas : Z.t ; storage_size : Z.t ; diff --git a/vendors/ligo-utils/tezos-protocol-alpha/baking.ml b/vendors/ligo-utils/tezos-protocol-alpha/baking.ml index d8d222c20..168e70708 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/baking.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/baking.ml @@ -142,17 +142,19 @@ let earlier_predecessor_timestamp ctxt level = let check_timestamp c priority pred_timestamp = minimal_time c priority pred_timestamp >>=? fun minimal_time -> let timestamp = Alpha_context.Timestamp.current c in - fail_unless Timestamp.(minimal_time <= timestamp) - (Timestamp_too_early (minimal_time, timestamp)) + Lwt.return + (record_trace (Timestamp_too_early (minimal_time, timestamp)) + Timestamp.(timestamp -? minimal_time)) let check_baking_rights c { Block_header.priority ; _ } pred_timestamp = let level = Level.current c in Roll.baking_rights_owner c level ~priority >>=? fun delegate -> - check_timestamp c priority pred_timestamp >>=? fun () -> - return delegate + check_timestamp c priority pred_timestamp >>=? fun block_delay -> + return (delegate, block_delay) type error += Incorrect_priority (* `Permanent *) +type error += Incorrect_number_of_endorsements (* `Permanent *) let () = register_error_kind @@ -166,7 +168,34 @@ let () = (function Incorrect_priority -> Some () | _ -> None) (fun () -> Incorrect_priority) -let endorsement_reward ctxt ~block_priority:prio n = +let () = + let description = "The number of endorsements must be non-negative and \ + at most the endosers_per_block constant." in + register_error_kind + `Permanent + ~id:"incorrect_number_of_endorsements" + ~title:"Incorrect number of endorsements" + ~description + ~pp:(fun ppf () -> Format.fprintf ppf "%s" description) + Data_encoding.unit + (function Incorrect_number_of_endorsements -> Some () | _ -> None) + (fun () -> Incorrect_number_of_endorsements) + +let baking_reward ctxt ~block_priority:prio ~included_endorsements:num_endo = + fail_unless Compare.Int.(prio >= 0) Incorrect_priority >>=? fun () -> + let max_endorsements = Constants.endorsers_per_block ctxt in + fail_unless Compare.Int.(num_endo >= 0 && num_endo <= max_endorsements) + Incorrect_number_of_endorsements >>=? fun () -> + let prio_factor_denominator = Int64.(succ (of_int prio)) in + let endo_factor_numerator = Int64.of_int (8 + 2 * num_endo / max_endorsements) in + let endo_factor_denominator = 10L in + Lwt.return + Tez.( + Constants.block_reward ctxt *? endo_factor_numerator >>? fun val1 -> + val1 /? endo_factor_denominator >>? fun val2 -> + val2 /? prio_factor_denominator) + +let endorsing_reward ctxt ~block_priority:prio n = if Compare.Int.(prio >= 0) then Lwt.return @@ -271,9 +300,7 @@ let check_signature block chain_id key = fail (Invalid_block_signature (Block_header.hash block, Signature.Public_key.hash key)) -let max_fitness_gap ctxt = - let slots = Int64.of_int (Constants.endorsers_per_block ctxt + 1) in - Int64.add slots 1L +let max_fitness_gap _ctxt = 1L let check_fitness_gap ctxt (block : Block_header.t) = let current_fitness = Fitness.current ctxt in @@ -294,3 +321,36 @@ let dawn_of_a_new_cycle ctxt = return_some level.cycle else return_none + +let minimum_allowed_endorsements ctxt ~block_delay = + let minimum = Constants.initial_endorsers ctxt in + let delay_per_missing_endorsement = + Int64.to_int + (Period.to_seconds + (Constants.delay_per_missing_endorsement ctxt)) + in + let reduced_time_constraint = + let delay = Int64.to_int (Period.to_seconds block_delay) in + if Compare.Int.(delay_per_missing_endorsement = 0) then + delay + else + delay / delay_per_missing_endorsement + in + Compare.Int.max 0 (minimum - reduced_time_constraint) + +let minimal_valid_time ctxt ~priority ~endorsing_power = + let predecessor_timestamp = Timestamp.current ctxt in + minimal_time ctxt + priority predecessor_timestamp >>=? fun minimal_time -> + let minimal_required_endorsements = Constants.initial_endorsers ctxt in + let delay_per_missing_endorsement = + Constants.delay_per_missing_endorsement ctxt + in + let missing_endorsements = + Compare.Int.max 0 (minimal_required_endorsements - endorsing_power) in + match Period.mult + (Int32.of_int missing_endorsements) + delay_per_missing_endorsement with + | Ok delay -> + return (Time.add minimal_time (Period.to_seconds delay)) + | Error _ as err -> Lwt.return err diff --git a/vendors/ligo-utils/tezos-protocol-alpha/baking.mli b/vendors/ligo-utils/tezos-protocol-alpha/baking.mli index 52c78f74b..39cc2e8e2 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/baking.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/baking.mli @@ -47,7 +47,7 @@ val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t *) val check_baking_rights: context -> Block_header.contents -> Time.t -> - public_key tzresult Lwt.t + (public_key * Period.t) tzresult Lwt.t (** For a given level computes who has the right to include an endorsement in the next block. @@ -63,8 +63,15 @@ val check_endorsement_rights: context -> Chain_id.t -> Kind.endorsement Operation.t -> (public_key_hash * int list * bool) tzresult Lwt.t -(** Returns the endorsement reward calculated w.r.t a given priority. *) -val endorsement_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t +(** Returns the baking reward calculated w.r.t a given priority [p] and a + number [e] of included endorsements as follows: + (block_reward / (p+1)) * (0.8 + 0.2 * e / endorsers_per_block) +*) +val baking_reward: context -> + block_priority:int -> included_endorsements:int -> Tez.t tzresult Lwt.t + +(** Returns the endorsing reward calculated w.r.t a given priority. *) +val endorsing_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t (** [baking_priorities ctxt level] is the lazy list of contract's public key hashes that are allowed to bake for [level]. *) @@ -106,3 +113,39 @@ val check_fitness_gap: val dawn_of_a_new_cycle: context -> Cycle.t option tzresult Lwt.t val earlier_predecessor_timestamp: context -> Level.t -> Timestamp.t tzresult Lwt.t + +(** Since Emmy+ + + A block is valid only if its timestamp has a minimal delay with + respect to the previous block's timestamp, and this minimal delay + depends not only on the block's priority but also on the number of + endorsement operations included in the block. + + In Emmy+, blocks' fitness increases by one unit with each level. + + In this way, Emmy+ simplifies the optimal baking strategy: The + bakers used to have to choose whether to wait for more endorsements + to include in their block, or to publish the block immediately, + without waiting. The incentive for including more endorsements was + to increase the fitness and win against unknown blocks. However, + when a block was produced too late in the priority period, there + was the risk that the block did not reach endorsers before the + block of next priority. In Emmy+, the baker does not need to take + such a decision, because the baker cannot publish a block too + early. *) + +(** Given a delay of a block's timestamp with respect to the minimum + time to bake at the block's priority (as returned by + `minimum_time`), it returns the minimum number of endorsements that + the block has to contain *) +val minimum_allowed_endorsements: context -> block_delay:Period.t -> int + +(** This is the somehow the dual of the previous function. Given a + block priority and a number of endorsement slots (given by the + `endorsing_power` argument), it returns the minimum time at which + the next block can be baked. *) +val minimal_valid_time: + context -> + priority:int -> + endorsing_power: int -> + Time.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml index 50d17dfff..8e0b46abc 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml @@ -31,7 +31,7 @@ let init_account ctxt Contract_storage.credit ctxt contract amount >>=? fun ctxt -> match public_key with | Some public_key -> - Contract_storage.reveal_manager_key ctxt contract public_key >>=? fun ctxt -> + Contract_storage.reveal_manager_key ctxt public_key_hash public_key >>=? fun ctxt -> Delegate_storage.set ctxt contract (Some public_key_hash) >>=? fun ctxt -> return ctxt | None -> return ctxt @@ -43,11 +43,8 @@ let init_contract ~typecheck ctxt Contract_storage.originate ctxt contract ~balance:amount ~prepaid_bootstrap_storage:true - ~manager:Signature.Public_key_hash.zero ~script - ~delegate:(Some delegate) - ~spendable:false - ~delegatable:false >>=? fun ctxt -> + ~delegate:(Some delegate) >>=? fun ctxt -> return ctxt let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts = diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml index 7ab55b468..6ad7b1526 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml @@ -23,7 +23,8 @@ (* *) (*****************************************************************************) -let version_number = "\000" +let version_number_004 = "\000" +let version_number = "\001" let proof_of_work_nonce_size = 8 let nonce_length = 32 let max_revelations_per_block = 32 @@ -95,37 +96,11 @@ type parametric = { cost_per_byte: Tez_repr.t ; hard_storage_limit_per_operation: Z.t ; test_chain_duration: int64 ; (* in seconds *) -} - -let default = { - preserved_cycles = 5 ; - blocks_per_cycle = 4096l ; - blocks_per_commitment = 32l ; - blocks_per_roll_snapshot = 256l ; - blocks_per_voting_period = 32768l ; - time_between_blocks = - List.map Period_repr.of_seconds_exn [ 60L ; 75L ] ; - endorsers_per_block = 32 ; - hard_gas_limit_per_operation = Z.of_int 800_000 ; - hard_gas_limit_per_block = Z.of_int 8_000_000 ; - proof_of_work_threshold = - Int64.(sub (shift_left 1L 46) 1L) ; - tokens_per_roll = - Tez_repr.(mul_exn one 8_000) ; - michelson_maximum_type_size = 1000 ; - seed_nonce_revelation_tip = begin - match Tez_repr.(one /? 8L) with - | Ok c -> c - | Error _ -> assert false - end ; - origination_size = 257 ; - block_security_deposit = Tez_repr.(mul_exn one 512) ; - endorsement_security_deposit = Tez_repr.(mul_exn one 64) ; - block_reward = Tez_repr.(mul_exn one 16) ; - endorsement_reward = Tez_repr.(mul_exn one 2) ; - hard_storage_limit_per_operation = Z.of_int 60_000 ; - cost_per_byte = Tez_repr.of_mutez_exn 1_000L ; - test_chain_duration = Int64.mul 32768L 60L; + quorum_min: int32 ; + quorum_max: int32 ; + min_proposal_quorum: int32 ; + initial_endorsers: int ; + delay_per_missing_endorsement: Period_repr.t ; } let parametric_encoding = @@ -152,7 +127,13 @@ let parametric_encoding = (c.endorsement_reward, c.cost_per_byte, c.hard_storage_limit_per_operation, - c.test_chain_duration))) ) + c.test_chain_duration, + c.quorum_min, + c.quorum_max, + c.min_proposal_quorum, + c.initial_endorsers, + c.delay_per_missing_endorsement + ))) ) (fun (( preserved_cycles, blocks_per_cycle, blocks_per_commitment, @@ -173,7 +154,12 @@ let parametric_encoding = (endorsement_reward, cost_per_byte, hard_storage_limit_per_operation, - test_chain_duration))) -> + test_chain_duration, + quorum_min, + quorum_max, + min_proposal_quorum, + initial_endorsers, + delay_per_missing_endorsement))) -> { preserved_cycles ; blocks_per_cycle ; blocks_per_commitment ; @@ -195,6 +181,11 @@ let parametric_encoding = cost_per_byte ; hard_storage_limit_per_operation ; test_chain_duration ; + quorum_min ; + quorum_max ; + min_proposal_quorum ; + initial_endorsers ; + delay_per_missing_endorsement ; } ) (merge_objs (obj9 @@ -217,11 +208,17 @@ let parametric_encoding = (req "block_security_deposit" Tez_repr.encoding) (req "endorsement_security_deposit" Tez_repr.encoding) (req "block_reward" Tez_repr.encoding)) - (obj4 + (obj9 (req "endorsement_reward" Tez_repr.encoding) (req "cost_per_byte" Tez_repr.encoding) (req "hard_storage_limit_per_operation" z) - (req "test_chain_duration" int64)))) + (req "test_chain_duration" int64) + (req "quorum_min" int32) + (req "quorum_max" int32) + (req "min_proposal_quorum" int32) + (req "initial_endorsers" uint16) + (req "delay_per_missing_endorsement" Period_repr.encoding) + ))) type t = { fixed : fixed ; diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml index 3ede67cc2..c6b1dfd2a 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml @@ -44,6 +44,12 @@ let time_between_blocks c = let endorsers_per_block c = let constants = Raw_context.constants c in constants.endorsers_per_block +let initial_endorsers c = + let constants = Raw_context.constants c in + constants.initial_endorsers +let delay_per_missing_endorsement c = + let constants = Raw_context.constants c in + constants.delay_per_missing_endorsement let hard_gas_limit_per_operation c = let constants = Raw_context.constants c in constants.hard_gas_limit_per_operation @@ -86,5 +92,14 @@ let endorsement_reward c = let test_chain_duration c = let constants = Raw_context.constants c in constants.test_chain_duration +let quorum_min c = + let constants = Raw_context.constants c in + constants.quorum_min +let quorum_max c = + let constants = Raw_context.constants c in + constants.quorum_max +let min_proposal_quorum c = + let constants = Raw_context.constants c in + constants.min_proposal_quorum let parametric c = Raw_context.constants c diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml index 95e974ef4..89632c77a 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml @@ -109,6 +109,8 @@ let () = let implicit_contract id = Implicit id +let originated_contract_004 id = Originated id + let is_implicit = function | Implicit m -> Some m | Originated _ -> None diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli index 08ced771a..37f5503f6 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli @@ -30,13 +30,16 @@ type contract = t include Compare.S with type t := contract -(** {2 Implicit contracts} *****************************************************) +(** {2 Implicit contracts} *) val implicit_contract : Signature.Public_key_hash.t -> contract +(** Only for migration from proto_004 *) +val originated_contract_004 : Contract_hash.t -> contract + val is_implicit : contract -> Signature.Public_key_hash.t option -(** {2 Originated contracts} **************************************************) +(** {2 Originated contracts} *) (** Originated contracts handles are crafted from the hash of the operation that triggered their origination (and nothing else). @@ -56,7 +59,7 @@ val incr_origination_nonce : origination_nonce -> origination_nonce val is_originated : contract -> Contract_hash.t option -(** {2 Human readable notation} ***********************************************) +(** {2 Human readable notation} *) type error += Invalid_contract_notation of string (* `Permanent *) @@ -68,7 +71,7 @@ val pp: Format.formatter -> contract -> unit val pp_short: Format.formatter -> contract -> unit -(** {2 Serializers} ***********************************************************) +(** {2 Serializers} *) val encoding : contract Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml index 3951a34ae..5d57e0174 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml @@ -28,35 +28,28 @@ open Alpha_context let custom_root = (RPC_path.(open_root / "context" / "contracts") : RPC_context.t RPC_path.context) +let big_map_root = + (RPC_path.(open_root / "context" / "big_maps") : RPC_context.t RPC_path.context) + type info = { - manager: public_key_hash ; balance: Tez.t ; - spendable: bool ; - delegate: bool * public_key_hash option ; - counter: counter ; + delegate: public_key_hash option ; + counter: counter option ; script: Script.t option ; } let info_encoding = let open Data_encoding in conv - (fun {manager ; balance ; spendable ; delegate ; - script ; counter } -> - (manager, balance, spendable, delegate, - script, counter)) - (fun (manager, balance, spendable, delegate, - script, counter) -> - {manager ; balance ; spendable ; delegate ; - script ; counter}) @@ - obj6 - (req "manager" Signature.Public_key_hash.encoding) + (fun {balance ; delegate ; script ; counter } -> + (balance, delegate, script, counter)) + (fun (balance, delegate, script, counter) -> + {balance ; delegate ; script ; counter}) @@ + obj4 (req "balance" Tez.encoding) - (req "spendable" bool) - (req "delegate" @@ obj2 - (req "setable" bool) - (opt "value" Signature.Public_key_hash.encoding)) + (opt "delegate" Signature.Public_key_hash.encoding) (opt "script" Script.encoding) - (req "counter" n) + (opt "counter" n) module S = struct @@ -69,20 +62,11 @@ module S = struct ~output: Tez.encoding RPC_path.(custom_root /: Contract.rpc_arg / "balance") - let manager = - RPC_service.get_service - ~description: "Access the manager of a contract." - ~query: RPC_query.empty - ~output: Signature.Public_key_hash.encoding - RPC_path.(custom_root /: Contract.rpc_arg / "manager") - let manager_key = RPC_service.get_service ~description: "Access the manager of a contract." ~query: RPC_query.empty - ~output: (obj2 - (req "manager" Signature.Public_key_hash.encoding) - (opt "key" Signature.Public_key.encoding)) + ~output: (option Signature.Public_key.encoding) RPC_path.(custom_root /: Contract.rpc_arg / "manager_key") let delegate = @@ -99,20 +83,6 @@ module S = struct ~output: z RPC_path.(custom_root /: Contract.rpc_arg / "counter") - let spendable = - RPC_service.get_service - ~description: "Tells if the contract tokens can be spent by the manager." - ~query: RPC_query.empty - ~output: bool - RPC_path.(custom_root /: Contract.rpc_arg / "spendable") - - let delegatable = - RPC_service.get_service - ~description: "Tells if the contract delegate can be changed." - ~query: RPC_query.empty - ~output: bool - RPC_path.(custom_root /: Contract.rpc_arg / "delegatable") - let script = RPC_service.get_service ~description: "Access the code and data of the contract." @@ -127,15 +97,43 @@ module S = struct ~output: Script.expr_encoding RPC_path.(custom_root /: Contract.rpc_arg / "storage") - let big_map_get = - RPC_service.post_service - ~description: "Access the value associated with a key in the big map storage of the contract." + let entrypoint_type = + RPC_service.get_service + ~description: "Return the type of the given entrypoint of the contract" ~query: RPC_query.empty - ~input: (obj2 - (req "key" Script.expr_encoding) - (req "type" Script.expr_encoding)) - ~output: (option Script.expr_encoding) - RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get") + ~output: Script.expr_encoding + RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string) + + + let list_entrypoints = + RPC_service.get_service + ~description: "Return the list of entrypoints of the contract" + ~query: RPC_query.empty + ~output: (obj2 + (dft "unreachable" + (Data_encoding.list + (obj1 (req "path" (Data_encoding.list Michelson_v1_primitives.prim_encoding)))) + []) + (req "entrypoints" + (assoc Script.expr_encoding))) + RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints") + + let contract_big_map_get_opt = + RPC_service.post_service + ~description: "Access the value associated with a key in a big map of the contract (deprecated)." + ~query: RPC_query.empty + ~input: (obj2 + (req "key" Script.expr_encoding) + (req "type" Script.expr_encoding)) + ~output: (option Script.expr_encoding) + RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get") + + let big_map_get = + RPC_service.get_service + ~description: "Access the value associated with a key in a big map." + ~query: RPC_query.empty + ~output: Script.expr_encoding + RPC_path.(big_map_root /: Big_map.rpc_arg /: Script_expr_hash.rpc_arg) let info = RPC_service.get_service @@ -170,20 +168,39 @@ let register () = f ctxt a1 >>=? function | None -> raise Not_found | Some v -> return v) in + let do_big_map_get ctxt id key = + let open Script_ir_translator in + let ctxt = Gas.set_unlimited ctxt in + Big_map.exists ctxt id >>=? fun (ctxt, types) -> + match types with + | None -> raise Not_found + | Some (_, value_type) -> + Lwt.return (parse_ty ctxt + ~legacy:true ~allow_big_map:false ~allow_operation:false ~allow_contract:true + (Micheline.root value_type)) + >>=? fun (Ex_ty value_type, ctxt) -> + Big_map.get_opt ctxt id key >>=? fun (_ctxt, value) -> + match value with + | None -> raise Not_found + | Some value -> + parse_data ctxt ~legacy:true value_type (Micheline.root value) >>=? fun (value, ctxt) -> + unparse_data ctxt Readable value_type value >>=? fun (value, _ctxt) -> + return (Micheline.strip_locations value) in register_field S.balance Contract.get_balance ; - register_field S.manager Contract.get_manager ; - register_field S.manager_key - (fun ctxt c -> - Contract.get_manager ctxt c >>=? fun mgr -> - Contract.is_manager_key_revealed ctxt c >>=? fun revealed -> - if revealed then - Contract.get_manager_key ctxt c >>=? fun key -> - return (mgr, Some key) - else return (mgr, None)) ; + register1 S.manager_key + (fun ctxt contract () () -> + match Contract.is_implicit contract with + | None -> raise Not_found + | Some mgr -> + Contract.is_manager_key_revealed ctxt mgr >>=? function + | false -> return_none + | true -> Contract.get_manager_key ctxt mgr >>=? return_some) ; register_opt_field S.delegate Delegate.get ; - register_field S.counter Contract.get_counter ; - register_field S.spendable Contract.is_spendable ; - register_field S.delegatable Contract.is_delegatable ; + register1 S.counter + (fun ctxt contract () () -> + match Contract.is_implicit contract with + | None -> raise Not_found + | Some mgr -> Contract.get_counter ctxt mgr) ; register_opt_field S.script (fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ; register_opt_field S.storage (fun ctxt contract -> @@ -193,39 +210,95 @@ let register () = | Some script -> let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in - parse_script ctxt script >>=? fun (Ex_script script, ctxt) -> + parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) -> unparse_script ctxt Readable script >>=? fun (script, ctxt) -> Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) -> return_some storage) ; - register1 S.big_map_get (fun ctxt contract () (key, key_type) -> - let open Script_ir_translator in - let ctxt = Gas.set_unlimited ctxt in - Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root key_type)) - >>=? fun (Ex_ty key_type, ctxt) -> - parse_data ctxt key_type (Micheline.root key) >>=? fun (key, ctxt) -> - hash_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - Contract.Big_map.get_opt ctxt contract key_hash >>=? fun (_ctxt, value) -> - return value) ; + register2 S.entrypoint_type + (fun ctxt v entrypoint () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) -> + match expr with + | None -> raise Not_found + | Some expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = true in + let open Script_ir_translator in + Script.force_decode ctxt expr >>=? fun (expr, _) -> + Lwt.return + begin + parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> + parse_ty ctxt ~legacy + ~allow_big_map:true ~allow_operation:false + ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.find_entrypoint ~root_name arg_type + entrypoint + end >>= function + Ok (_f , Ex_ty ty)-> + unparse_ty ctxt ty >>=? fun (ty_node, _) -> + return (Micheline.strip_locations ty_node) + | Error _ -> raise Not_found) ; + register1 S.list_entrypoints + (fun ctxt v () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) -> + match expr with + | None -> raise Not_found + | Some expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = true in + let open Script_ir_translator in + Script.force_decode ctxt expr >>=? fun (expr, _) -> + Lwt.return + begin + parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> + parse_ty ctxt ~legacy + ~allow_big_map:true ~allow_operation:false + ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.list_entrypoints ~root_name arg_type ctxt + end >>=? fun (unreachable_entrypoint,map) -> + return + (unreachable_entrypoint, + Entrypoints_map.fold + begin fun entry (_,ty) acc -> + (entry , Micheline.strip_locations ty) ::acc end + map []) + ) ; + register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) -> + Contract.get_script ctxt contract >>=? fun (ctxt, script) -> + Lwt.return (Script_ir_translator.parse_packable_ty ctxt ~legacy:true (Micheline.root key_type)) >>=? fun (Ex_ty key_type, ctxt) -> + Script_ir_translator.parse_data ctxt ~legacy:true key_type (Micheline.root key) >>=? fun (key, ctxt) -> + Script_ir_translator.hash_data ctxt key_type key >>=? fun (key, ctxt) -> + match script with + | None -> raise Not_found + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) -> + Script_ir_translator.collect_big_maps ctxt script.storage_type script.storage >>=? fun (ids, _ctxt) -> + let ids = Script_ir_translator.list_of_big_map_ids ids in + let rec find = function + | [] -> return_none + | (id : Z.t) :: ids -> try do_big_map_get ctxt id key >>=? return_some with Not_found -> find ids in + find ids) ; + register2 S.big_map_get (fun ctxt id key () () -> + do_big_map_get ctxt id key) ; register_field S.info (fun ctxt contract -> Contract.get_balance ctxt contract >>=? fun balance -> - Contract.get_manager ctxt contract >>=? fun manager -> Delegate.get ctxt contract >>=? fun delegate -> - Contract.get_counter ctxt contract >>=? fun counter -> - Contract.is_delegatable ctxt contract >>=? fun delegatable -> - Contract.is_spendable ctxt contract >>=? fun spendable -> + begin match Contract.is_implicit contract with + | Some manager -> + Contract.get_counter ctxt manager >>=? fun counter -> + return_some counter + | None -> return None + end >>=? fun counter -> Contract.get_script ctxt contract >>=? fun (ctxt, script) -> begin match script with | None -> return (None, ctxt) | Some script -> let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in - parse_script ctxt script >>=? fun (Ex_script script, ctxt) -> + parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) -> unparse_script ctxt Readable script >>=? fun (script, ctxt) -> return (Some script, ctxt) end >>=? fun (script, _ctxt) -> - return { manager ; balance ; - spendable ; delegate = (delegatable, delegate) ; - script ; counter }) + return { balance ; delegate ; script ; counter }) let list ctxt block = RPC_context.make_call0 S.list ctxt block () () @@ -236,11 +309,8 @@ let info ctxt block contract = let balance ctxt block contract = RPC_context.make_call1 S.balance ctxt block contract () () -let manager ctxt block contract = - RPC_context.make_call1 S.manager ctxt block contract () () - -let manager_key ctxt block contract = - RPC_context.make_call1 S.manager_key ctxt block contract () () +let manager_key ctxt block mgr = + RPC_context.make_call1 S.manager_key ctxt block (Contract.implicit_contract mgr) () () let delegate ctxt block contract = RPC_context.make_call1 S.delegate ctxt block contract () () @@ -248,14 +318,8 @@ let delegate ctxt block contract = let delegate_opt ctxt block contract = RPC_context.make_opt_call1 S.delegate ctxt block contract () () -let counter ctxt block contract = - RPC_context.make_call1 S.counter ctxt block contract () () - -let is_delegatable ctxt block contract = - RPC_context.make_call1 S.delegatable ctxt block contract () () - -let is_spendable ctxt block contract = - RPC_context.make_call1 S.spendable ctxt block contract () () +let counter ctxt block mgr = + RPC_context.make_call1 S.counter ctxt block (Contract.implicit_contract mgr) () () let script ctxt block contract = RPC_context.make_call1 S.script ctxt block contract () () @@ -266,8 +330,17 @@ let script_opt ctxt block contract = let storage ctxt block contract = RPC_context.make_call1 S.storage ctxt block contract () () +let entrypoint_type ctxt block contract entrypoint = + RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint () () + +let list_entrypoints ctxt block contract = + RPC_context.make_call1 S.list_entrypoints ctxt block contract () () + let storage_opt ctxt block contract = RPC_context.make_opt_call1 S.storage ctxt block contract () () -let big_map_get_opt ctxt block contract key = - RPC_context.make_call1 S.big_map_get ctxt block contract () key +let big_map_get ctxt block id key = + RPC_context.make_call2 S.big_map_get ctxt block id key () () + +let contract_big_map_get_opt ctxt block contract key = + RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli index 0682c387b..7b638ebd7 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli @@ -29,11 +29,9 @@ val list: 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t type info = { - manager: public_key_hash ; balance: Tez.t ; - spendable: bool ; - delegate: bool * public_key_hash option ; - counter: counter ; + delegate: public_key_hash option ; + counter: counter option ; script: Script.t option ; } @@ -45,11 +43,8 @@ val info: val balance: 'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t -val manager: - 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t - val manager_key: - 'a #RPC_context.simple -> 'a -> Contract.t -> (public_key_hash * public_key option) shell_tzresult Lwt.t + 'a #RPC_context.simple -> 'a -> public_key_hash -> public_key option shell_tzresult Lwt.t val delegate: 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t @@ -57,14 +52,8 @@ val delegate: val delegate_opt: 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash option shell_tzresult Lwt.t -val is_delegatable: - 'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t - -val is_spendable: - 'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t - val counter: - 'a #RPC_context.simple -> 'a -> Contract.t -> counter shell_tzresult Lwt.t + 'a #RPC_context.simple -> 'a -> public_key_hash -> counter shell_tzresult Lwt.t val script: 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t @@ -75,12 +64,22 @@ val script_opt: val storage: 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t +val entrypoint_type: + 'a #RPC_context.simple -> 'a -> Contract.t -> string -> Script.expr shell_tzresult Lwt.t + +val list_entrypoints: + 'a #RPC_context.simple -> 'a -> Contract.t -> + (Michelson_v1_primitives.prim list list * + (string * Script.expr) list) shell_tzresult Lwt.t + val storage_opt: 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr option shell_tzresult Lwt.t -val big_map_get_opt: - 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr * Script.expr -> - Script.expr option shell_tzresult Lwt.t +val big_map_get: + 'a #RPC_context.simple -> 'a -> Z.t -> Script_expr_hash.t -> + Script.expr shell_tzresult Lwt.t +val contract_big_map_get_opt: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr * Script.expr -> Script.expr option shell_tzresult Lwt.t val register: unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml index cc75a1c0d..21a74782b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml @@ -202,96 +202,185 @@ let () = let failwith msg = fail (Failure msg) -type big_map_diff_item = { - diff_key : Script_repr.expr; - diff_key_hash : Script_expr_hash.t; - diff_value : Script_repr.expr option; -} +type big_map_diff_item = + | Update of { + big_map : Z.t; + diff_key : Script_repr.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script_repr.expr option; + } + | Clear of Z.t + | Copy of Z.t * Z.t + | Alloc of { + big_map : Z.t; + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } + type big_map_diff = big_map_diff_item list let big_map_diff_item_encoding = let open Data_encoding in - conv - (fun { diff_key_hash ; diff_key ; diff_value } -> (diff_key_hash, diff_key, diff_value)) - (fun (diff_key_hash, diff_key, diff_value) -> { diff_key_hash ; diff_key ; diff_value }) - (obj3 - (req "key_hash" Script_expr_hash.encoding) - (req "key" Script_repr.expr_encoding) - (opt "value" Script_repr.expr_encoding)) + union + [ case (Tag 0) ~title:"update" + (obj5 + (req "action" (constant "update")) + (req "big_map" z) + (req "key_hash" Script_expr_hash.encoding) + (req "key" Script_repr.expr_encoding) + (opt "value" Script_repr.expr_encoding)) + (function + | Update { big_map ; diff_key_hash ; diff_key ; diff_value } -> + Some ((), big_map, diff_key_hash, diff_key, diff_value) + | _ -> None ) + (fun ((), big_map, diff_key_hash, diff_key, diff_value) -> + Update { big_map ; diff_key_hash ; diff_key ; diff_value }) ; + case (Tag 1) ~title:"remove" + (obj2 + (req "action" (constant "remove")) + (req "big_map" z)) + (function + | Clear big_map -> + Some ((), big_map) + | _ -> None ) + (fun ((), big_map) -> + Clear big_map) ; + case (Tag 2) ~title:"copy" + (obj3 + (req "action" (constant "copy")) + (req "source_big_map" z) + (req "destination_big_map" z)) + (function + | Copy (src, dst) -> + Some ((), src, dst) + | _ -> None ) + (fun ((), src, dst) -> + Copy (src, dst)) ; + case (Tag 3) ~title:"alloc" + (obj4 + (req "action" (constant "alloc")) + (req "big_map" z) + (req "key_type" Script_repr.expr_encoding) + (req "value_type" Script_repr.expr_encoding)) + (function + | Alloc { big_map ; key_type ; value_type } -> + Some ((), big_map, key_type, value_type) + | _ -> None ) + (fun ((), big_map, key_type, value_type) -> + Alloc { big_map ; key_type ; value_type }) ] let big_map_diff_encoding = let open Data_encoding in def "contract.big_map_diff" @@ list big_map_diff_item_encoding -let update_script_big_map c contract = function +let big_map_key_cost = 65 +let big_map_cost = 33 + +let update_script_big_map c = function | None -> return (c, Z.zero) | Some diff -> - fold_left_s (fun (c, total) diff_item -> - match diff_item.diff_value with - | None -> - Storage.Contract.Big_map.remove (c, contract) diff_item.diff_key_hash - >>=? fun (c, freed) -> - return (c, Z.sub total (Z.of_int freed)) - | Some v -> - Storage.Contract.Big_map.init_set (c, contract) diff_item.diff_key_hash v - >>=? fun (c, size_diff) -> - return (c, Z.add total (Z.of_int size_diff))) + fold_left_s (fun (c, total) -> function + | Clear id -> + Storage.Big_map.Total_bytes.get c id >>=? fun size -> + Storage.Big_map.remove_rec c id >>= fun c -> + if Compare.Z.(id < Z.zero) then + return (c, total) + else + return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost)) + | Copy (from, to_) -> + Storage.Big_map.copy c ~from ~to_ >>=? fun c -> + if Compare.Z.(to_ < Z.zero) then + return (c, total) + else + Storage.Big_map.Total_bytes.get c from >>=? fun size -> + return (c, Z.add (Z.add total size) (Z.of_int big_map_cost)) + | Alloc { big_map ; key_type ; value_type } -> + Storage.Big_map.Total_bytes.init c big_map Z.zero >>=? fun c -> + (* Annotations are erased to allow sharing on + [Copy]. The types from the contract code are used, + these ones are only used to make sure they are + compatible during transmissions between contracts, + and only need to be compatible, annotations + nonwhistanding. *) + let key_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root key_type)) in + let value_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root value_type)) in + Storage.Big_map.Key_type.init c big_map key_type >>=? fun c -> + Storage.Big_map.Value_type.init c big_map value_type >>=? fun c -> + if Compare.Z.(big_map < Z.zero) then + return (c, total) + else + return (c, Z.add total (Z.of_int big_map_cost)) + | Update { big_map ; diff_key_hash ; diff_value = None } -> + Storage.Big_map.Contents.remove (c, big_map) diff_key_hash + >>=? fun (c, freed, existed) -> + let freed = if existed then freed + big_map_key_cost else freed in + Storage.Big_map.Total_bytes.get c big_map >>=? fun size -> + Storage.Big_map.Total_bytes.set c big_map (Z.sub size (Z.of_int freed)) >>=? fun c -> + if Compare.Z.(big_map < Z.zero) then + return (c, total) + else + return (c, Z.sub total (Z.of_int freed)) + | Update { big_map ; diff_key_hash ; diff_value = Some v } -> + Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v + >>=? fun (c, size_diff, existed) -> + let size_diff = if existed then size_diff else size_diff + big_map_key_cost in + Storage.Big_map.Total_bytes.get c big_map >>=? fun size -> + Storage.Big_map.Total_bytes.set c big_map (Z.add size (Z.of_int size_diff)) >>=? fun c -> + if Compare.Z.(big_map < Z.zero) then + return (c, total) + else + return (c, Z.add total (Z.of_int size_diff))) (c, Z.zero) diff let create_base c ?(prepaid_bootstrap_storage=false) (* Free space for bootstrap contracts *) contract - ~balance ~manager ~delegate ?script ~spendable ~delegatable = - (match Contract_repr.is_implicit contract with - | None -> return Z.zero - | Some _ -> Storage.Contract.Global_counter.get c) >>=? fun counter -> + ~balance ~manager ~delegate ?script () = + begin match Contract_repr.is_implicit contract with + | None -> return c + | Some _ -> + Storage.Contract.Global_counter.get c >>=? fun counter -> + Storage.Contract.Counter.init c contract counter + end >>=? fun c -> Storage.Contract.Balance.init c contract balance >>=? fun c -> - Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) >>=? fun c -> + begin match manager with + | Some manager -> + Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) + | None -> return c + end >>=? fun c -> begin match delegate with | None -> return c | Some delegate -> Delegate_storage.init c contract delegate end >>=? fun c -> - Storage.Contract.Spendable.set c contract spendable >>= fun c -> - Storage.Contract.Delegatable.set c contract delegatable >>= fun c -> - Storage.Contract.Counter.init c contract counter >>=? fun c -> - (match script with - | Some ({ Script_repr.code ; storage }, big_map_diff) -> - Storage.Contract.Code.init c contract code >>=? fun (c, code_size) -> - Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) -> - update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size) -> - let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in - assert Compare.Z.(total_size >= Z.zero) ; - let prepaid_bootstrap_storage = - if prepaid_bootstrap_storage then - total_size - else - Z.zero - in - Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c -> - Storage.Contract.Used_storage_space.init c contract total_size - | None -> begin - match Contract_repr.is_implicit contract with - | None -> - Storage.Contract.Paid_storage_space.init c contract Z.zero >>=? fun c -> - Storage.Contract.Used_storage_space.init c contract Z.zero - | Some _ -> - return c - end >>=? fun c -> - return c) >>=? fun c -> - return c + match script with + | Some ({ Script_repr.code ; storage }, big_map_diff) -> + Storage.Contract.Code.init c contract code >>=? fun (c, code_size) -> + Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) -> + update_script_big_map c big_map_diff >>=? fun (c, big_map_size) -> + let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in + assert Compare.Z.(total_size >= Z.zero) ; + let prepaid_bootstrap_storage = + if prepaid_bootstrap_storage then + total_size + else + Z.zero + in + Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c -> + Storage.Contract.Used_storage_space.init c contract total_size + | None -> + return c let originate c ?prepaid_bootstrap_storage contract - ~balance ~manager ?script ~delegate ~spendable ~delegatable = - create_base c ?prepaid_bootstrap_storage contract ~balance ~manager - ~delegate ?script ~spendable ~delegatable + ~balance ~script ~delegate = + create_base c ?prepaid_bootstrap_storage contract ~balance + ~manager:None ~delegate ~script () let create_implicit c manager ~balance = create_base c (Contract_repr.implicit_contract manager) - ~balance ~manager ?script:None ~delegate:None - ~spendable:true ~delegatable:false + ~balance ~manager:(Some manager) ?script:None ~delegate:None () let delete c contract = match Contract_repr.is_implicit contract with @@ -302,17 +391,15 @@ let delete c contract = Delegate_storage.remove c contract >>=? fun c -> Storage.Contract.Balance.delete c contract >>=? fun c -> Storage.Contract.Manager.delete c contract >>=? fun c -> - Storage.Contract.Spendable.del c contract >>= fun c -> - Storage.Contract.Delegatable.del c contract >>= fun c -> Storage.Contract.Counter.delete c contract >>=? fun c -> - Storage.Contract.Code.remove c contract >>=? fun (c, _) -> - Storage.Contract.Storage.remove c contract >>=? fun (c, _) -> + Storage.Contract.Code.remove c contract >>=? fun (c, _, _) -> + Storage.Contract.Storage.remove c contract >>=? fun (c, _, _) -> Storage.Contract.Paid_storage_space.remove c contract >>= fun c -> Storage.Contract.Used_storage_space.remove c contract >>= fun c -> return c let allocated c contract = - Storage.Contract.Counter.get_option c contract >>=? function + Storage.Contract.Balance.get_option c contract >>=? function | None -> return_false | Some _ -> return_true @@ -349,7 +436,8 @@ let originated_from_current_nonce ~since: ctxt_since ~until: ctxt_until = | false -> return_none) (Contract_repr.originated_contracts ~since ~until) -let check_counter_increment c contract counter = +let check_counter_increment c manager counter = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Counter.get c contract >>=? fun contract_counter -> let expected = Z.succ contract_counter in if Compare.Z.(expected = counter) @@ -359,12 +447,16 @@ let check_counter_increment c contract counter = else fail (Counter_in_the_future (contract, expected, counter)) -let increment_counter c contract = +let increment_counter c manager = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Global_counter.get c >>=? fun global_counter -> Storage.Contract.Global_counter.set c (Z.succ global_counter) >>=? fun c -> Storage.Contract.Counter.get c contract >>=? fun contract_counter -> Storage.Contract.Counter.set c contract (Z.succ contract_counter) +let get_script_code c contract = + Storage.Contract.Code.get_option c contract + let get_script c contract = Storage.Contract.Code.get_option c contract >>=? fun (c, code) -> Storage.Contract.Storage.get_option c contract >>=? fun (c, storage) -> @@ -381,7 +473,8 @@ let get_storage ctxt contract = Lwt.return (Raw_context.consume_gas ctxt cost) >>=? fun ctxt -> return (ctxt, Some storage) -let get_counter c contract = +let get_counter c manager = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Counter.get_option c contract >>=? function | None -> begin match Contract_repr.is_implicit contract with @@ -390,7 +483,7 @@ let get_counter c contract = end | Some v -> return v -let get_manager c contract = +let get_manager_004 c contract = Storage.Contract.Manager.get_option c contract >>=? function | None -> begin match Contract_repr.is_implicit contract with @@ -400,19 +493,22 @@ let get_manager c contract = | Some (Manager_repr.Hash v) -> return v | Some (Manager_repr.Public_key v) -> return (Signature.Public_key.hash v) -let get_manager_key c contract = +let get_manager_key c manager = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Manager.get_option c contract >>=? function | None -> failwith "get_manager_key" | Some (Manager_repr.Hash _) -> fail (Unrevealed_manager_key contract) | Some (Manager_repr.Public_key v) -> return v -let is_manager_key_revealed c contract = +let is_manager_key_revealed c manager = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Manager.get_option c contract >>=? function | None -> return_false | Some (Manager_repr.Hash _) -> return_false | Some (Manager_repr.Public_key _) -> return_true -let reveal_manager_key c contract public_key = +let reveal_manager_key c manager public_key = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Manager.get c contract >>=? function | Public_key _ -> fail (Previously_revealed_key contract) | Hash v -> @@ -432,22 +528,15 @@ let get_balance c contract = end | Some v -> return v -let is_delegatable = Delegate_storage.is_delegatable -let is_spendable c contract = - match Contract_repr.is_implicit contract with - | Some _ -> return_true - | None -> - Storage.Contract.Spendable.mem c contract >>= return - let update_script_storage c contract storage big_map_diff = let storage = Script_repr.lazy_expr storage in - update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size_diff) -> + update_script_big_map c big_map_diff >>=? fun (c, big_map_size_diff) -> Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) -> Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size -> let new_size = Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff)) in Storage.Contract.Used_storage_space.set c contract new_size -let spend_from_script c contract amount = +let spend c contract amount = Storage.Contract.Balance.get c contract >>=? fun balance -> match Tez_repr.(balance -? amount) with | Error _ -> @@ -490,12 +579,6 @@ let credit c contract amount = Storage.Contract.Balance.set c contract balance >>=? fun c -> Roll_storage.Contract.add_amount c contract amount -let spend c contract amount = - is_spendable c contract >>=? fun spendable -> - if not spendable - then fail (Unspendable_contract contract) - else spend_from_script c contract amount - let init c = Storage.Contract.Global_counter.init c Z.zero @@ -517,10 +600,3 @@ let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space = let to_pay = Z.sub new_storage_space already_paid_space in Storage.Contract.Paid_storage_space.set c contract new_storage_space >>=? fun c -> return (to_pay, c) - -module Big_map = struct - let mem ctxt contract key = - Storage.Contract.Big_map.mem (ctxt, contract) key - let get_opt ctxt contract key = - Storage.Contract.Big_map.get_option (ctxt, contract) key -end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli index 00ab16462..a8c1747e1 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli @@ -47,42 +47,49 @@ val must_be_allocated: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t val list: Raw_context.t -> Contract_repr.t list Lwt.t val check_counter_increment: - Raw_context.t -> Contract_repr.t -> Z.t -> unit tzresult Lwt.t + Raw_context.t -> Signature.Public_key_hash.t -> Z.t -> unit tzresult Lwt.t val increment_counter: - Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t + Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t -val is_delegatable: - Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t - -val is_spendable: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t - -val get_manager: +val get_manager_004: Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t tzresult Lwt.t val get_manager_key: - Raw_context.t -> Contract_repr.t -> Signature.Public_key.t tzresult Lwt.t + Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t tzresult Lwt.t val is_manager_key_revealed: - Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t + Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t val reveal_manager_key: - Raw_context.t -> Contract_repr.t -> Signature.Public_key.t -> + Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t -> Raw_context.t tzresult Lwt.t val get_balance: Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t -val get_counter: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t +val get_counter: Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t +val get_script_code: + Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t val get_script: Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.t option) tzresult Lwt.t val get_storage: Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t -type big_map_diff_item = { - diff_key : Script_repr.expr; - diff_key_hash : Script_expr_hash.t; - diff_value : Script_repr.expr option; -} +type big_map_diff_item = + | Update of { + big_map : Z.t ; + diff_key : Script_repr.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script_repr.expr option; + } + | Clear of Z.t + | Copy of Z.t * Z.t + | Alloc of { + big_map : Z.t; + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } + type big_map_diff = big_map_diff_item list val big_map_diff_encoding : big_map_diff Data_encoding.t @@ -96,26 +103,17 @@ val credit: Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t -(** checks that the contract is spendable and decrease_balance *) val spend: Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t -(** decrease_balance even if the contract is not spendable *) -val spend_from_script: - Raw_context.t -> Contract_repr.t -> Tez_repr.t -> - Raw_context.t tzresult Lwt.t - val originate: Raw_context.t -> ?prepaid_bootstrap_storage:bool -> Contract_repr.t -> balance:Tez_repr.t -> - manager:Signature.Public_key_hash.t -> - ?script:(Script_repr.t * big_map_diff option) -> + script:(Script_repr.t * big_map_diff option) -> delegate:Signature.Public_key_hash.t option -> - spendable:bool -> - delegatable:bool -> Raw_context.t tzresult Lwt.t val fresh_contract_from_current_nonce : @@ -131,10 +129,3 @@ val init: val used_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t val paid_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t val set_paid_storage_space_and_return_fees_to_pay: Raw_context.t -> Contract_repr.t -> Z.t -> (Z.t * Raw_context.t) tzresult Lwt.t - -module Big_map : sig - val mem : - Raw_context.t -> Contract_repr.t -> Script_expr_hash.t -> (Raw_context.t * bool) tzresult Lwt.t - val get_opt : - Raw_context.t -> Contract_repr.t -> Script_expr_hash.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t -end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml index 1f01c3cef..0e54e0afc 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml @@ -30,7 +30,7 @@ type info = { frozen_balance: Tez.t ; frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; staking_balance: Tez.t ; - delegated_contracts: Contract_hash.t list ; + delegated_contracts: Contract_repr.t list ; delegated_balance: Tez.t ; deactivated: bool ; grace_period: Cycle.t ; @@ -56,7 +56,7 @@ let info_encoding = (req "frozen_balance" Tez.encoding) (req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding) (req "staking_balance" Tez.encoding) - (req "delegated_contracts" (list Contract_hash.encoding)) + (req "delegated_contracts" (list Contract_repr.encoding)) (req "delegated_balance" Tez.encoding) (req "deactivated" bool) (req "grace_period" Cycle.encoding)) @@ -140,7 +140,7 @@ module S = struct ~description: "Returns the list of contracts that delegate to a given delegate." ~query: RPC_query.empty - ~output: (list Contract_hash.encoding) + ~output: (list Contract_repr.encoding) RPC_path.(path / "delegated_contracts") let delegated_balance = @@ -281,7 +281,7 @@ let requested_levels ~default ctxt cycles levels = Level.compare (List.concat (List.map (Level.from_raw ctxt) levels :: List.map (Level.levels_in_cycle ctxt) cycles)) in - map_p + map_s (fun level -> let current_level = Level.current ctxt in if Level.(level <= current_level) then @@ -410,7 +410,7 @@ module Baking_rights = struct match q.max_priority with | None -> 64 | Some max -> max in - map_p (baking_priorities ctxt max_priority) levels >>=? fun rights -> + map_s (baking_priorities ctxt max_priority) levels >>=? fun rights -> let rights = if q.all then rights @@ -516,7 +516,7 @@ module Endorsing_rights = struct requested_levels ~default: (Level.current ctxt, Some (Timestamp.current ctxt)) ctxt q.cycles q.levels >>=? fun levels -> - map_p (endorsement_slots ctxt) levels >>=? fun rights -> + map_s (endorsement_slots ctxt) levels >>=? fun rights -> let rights = List.concat rights in match q.delegates with | [] -> return rights @@ -534,10 +534,128 @@ module Endorsing_rights = struct end +module Endorsing_power = struct + + let endorsing_power ctxt (operation, chain_id) = + let Operation_data data = operation.protocol_data in + match data.contents with + | Single Endorsement _ -> + Baking.check_endorsement_rights ctxt chain_id { + shell = operation.shell ; + protocol_data = data ; + } >>=? fun (_, slots, _) -> + return (List.length slots) + | _ -> + failwith "Operation is not an endorsement" + + module S = struct + let endorsing_power = + let open Data_encoding in + RPC_service.post_service + ~description:"Get the endorsing power of an endorsement, that is, \ + the number of slots that the endorser has" + ~query: RPC_query.empty + ~input: (obj2 + (req "endorsement_operation" Operation.encoding) + (req "chain_id" Chain_id.encoding)) + ~output: int31 + RPC_path.(open_root / "endorsing_power") + end + + let register () = + let open Services_registration in + register0 S.endorsing_power begin fun ctxt () (op, chain_id) -> + endorsing_power ctxt (op, chain_id) + end + + let get ctxt block op chain_id = + RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id) + +end + +module Required_endorsements = struct + + let required_endorsements ctxt block_delay = + return (Baking.minimum_allowed_endorsements ctxt ~block_delay) + + module S = struct + + type t = { block_delay : Period.t } + + let required_endorsements_query = + let open RPC_query in + query (fun block_delay -> { block_delay }) + |+ field "block_delay" Period.rpc_arg Period.zero (fun t -> t.block_delay) + |> seal + + let required_endorsements = + let open Data_encoding in + RPC_service.get_service + ~description:"Minimum number of endorsements for a block to be \ + valid, given a delay of the block's timestamp with \ + respect to the minimum time to bake at the \ + block's priority" + ~query: required_endorsements_query + ~output: int31 + RPC_path.(open_root / "required_endorsements") + end + + let register () = + let open Services_registration in + register0 S.required_endorsements begin fun ctxt ({ block_delay }) () -> + required_endorsements ctxt block_delay + end + + let get ctxt block block_delay = + RPC_context.make_call0 S.required_endorsements ctxt block { block_delay } () + +end + +module Minimal_valid_time = struct + + let minimal_valid_time ctxt ~priority ~endorsing_power = + Baking.minimal_valid_time ctxt + ~priority ~endorsing_power + + module S = struct + + type t = { priority : int ; + endorsing_power : int } + + let minimal_valid_time_query = + let open RPC_query in + query (fun priority endorsing_power -> + { priority ; endorsing_power }) + |+ field "priority" RPC_arg.int 0 (fun t -> t.priority) + |+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power) + |> seal + + let minimal_valid_time = + RPC_service.get_service + ~description: "Minimal valid time for a block given a priority \ + and an endorsing power." + ~query: minimal_valid_time_query + ~output: Time.encoding + RPC_path.(open_root / "minimal_valid_time") + end + + let register () = + let open Services_registration in + register0 S.minimal_valid_time begin fun ctxt { priority ; endorsing_power } () -> + minimal_valid_time ctxt ~priority ~endorsing_power + end + + let get ctxt block priority endorsing_power = + RPC_context.make_call0 S.minimal_valid_time ctxt block { priority ; endorsing_power } () +end + let register () = register () ; Baking_rights.register () ; - Endorsing_rights.register () + Endorsing_rights.register () ; + Endorsing_power.register () ; + Required_endorsements.register () ; + Minimal_valid_time.register () let endorsement_rights ctxt level = Endorsing_rights.endorsement_slots ctxt (level, None) >>=? fun l -> @@ -551,3 +669,12 @@ let baking_rights ctxt max_priority = List.map (fun { Baking_rights.delegate ; timestamp ; _ } -> (delegate, timestamp)) l) + +let endorsing_power ctxt operation = + Endorsing_power.endorsing_power ctxt operation + +let required_endorsements ctxt delay = + Required_endorsements.required_endorsements ctxt delay + +let minimal_valid_time ctxt priority endorsing_power = + Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli index 4061a665c..74b282b98 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli @@ -36,7 +36,7 @@ type info = { frozen_balance: Tez.t ; frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; staking_balance: Tez.t ; - delegated_contracts: Contract_hash.t list ; + delegated_contracts: Contract_repr.t list ; delegated_balance: Tez.t ; deactivated: bool ; grace_period: Cycle.t ; @@ -72,7 +72,7 @@ val staking_balance: val delegated_contracts: 'a #RPC_context.simple -> 'a -> Signature.Public_key_hash.t -> - Contract_hash.t list shell_tzresult Lwt.t + Contract_repr.t list shell_tzresult Lwt.t val delegated_balance: 'a #RPC_context.simple -> 'a -> @@ -162,6 +162,32 @@ module Endorsing_rights : sig end +module Endorsing_power : sig + + val get: + 'a #RPC_context.simple -> 'a -> + Alpha_context.packed_operation -> + Chain_id.t -> + int shell_tzresult Lwt.t + +end + +module Required_endorsements : sig + + val get: + 'a #RPC_context.simple -> 'a -> + Period.t -> int shell_tzresult Lwt.t + +end + +module Minimal_valid_time : sig + + val get: + 'a #RPC_context.simple -> 'a -> + int -> int -> Time.t shell_tzresult Lwt.t + +end + (* temporary export for deprecated unit test *) val endorsement_rights: Alpha_context.t -> @@ -173,4 +199,20 @@ val baking_rights: int option -> (Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t +val endorsing_power: + Alpha_context.t -> + (Alpha_context.packed_operation * Chain_id.t) -> + int tzresult Lwt.t + +val required_endorsements: + Alpha_context.t -> + Alpha_context.Period.t -> + int tzresult Lwt.t + +val minimal_valid_time: + Alpha_context.t -> + int -> + int -> + Time.t tzresult Lwt.t + val register: unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml index da097d9d6..c8d5e878b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml @@ -123,7 +123,6 @@ let frozen_balance_encoding = (req "rewards" Tez_repr.encoding)) type error += - | Non_delegatable_contract of Contract_repr.contract (* `Permanent *) | No_deletion of Signature.Public_key_hash.t (* `Permanent *) | Active_delegate (* `Temporary *) | Current_delegate (* `Temporary *) @@ -134,18 +133,6 @@ type error += balance : Tez_repr.t } (* `Temporary *) let () = - register_error_kind - `Permanent - ~id:"contract.undelegatable_contract" - ~title:"Non delegatable contract" - ~description:"Tried to delegate an implicit contract \ - or a non delegatable originated contract" - ~pp:(fun ppf contract -> - Format.fprintf ppf "Contract %a is not delegatable" - Contract_repr.pp contract) - Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) - (function Non_delegatable_contract c -> Some c | _ -> None) - (fun c -> Non_delegatable_contract c) ; register_error_kind `Permanent ~id:"delegate.no_deletion" @@ -212,33 +199,21 @@ let () = Some (delegate, balance, deposit) | _ -> None) (fun (delegate, balance, deposit) -> Balance_too_low_for_deposit { delegate ; balance ; deposit } ) -let is_delegatable c contract = - match Contract_repr.is_implicit contract with - | Some _ -> - return_false - | None -> - Storage.Contract.Delegatable.mem c contract >>= return - -let link c contract delegate balance = +let link c contract delegate = + Storage.Contract.Balance.get c contract >>=? fun balance -> Roll_storage.Delegate.add_amount c delegate balance >>=? fun c -> - match Contract_repr.is_originated contract with - | None -> return c - | Some h -> - Storage.Contract.Delegated.add - (c, Contract_repr.implicit_contract delegate) h >>= fun c -> - return c + Storage.Contract.Delegated.add (c, Contract_repr.implicit_contract delegate) contract >>= fun c -> + return c -let unlink c contract balance = +let unlink c contract = + Storage.Contract.Balance.get c contract >>=? fun balance -> Storage.Contract.Delegate.get_option c contract >>=? function | None -> return c | Some delegate -> + (* Removes the balance of the contract from the delegate *) Roll_storage.Delegate.remove_amount c delegate balance >>=? fun c -> - match Contract_repr.is_originated contract with - | None -> return c - | Some h -> - Storage.Contract.Delegated.del - (c, Contract_repr.implicit_contract delegate) h >>= fun c -> - return c + Storage.Contract.Delegated.del (c, Contract_repr.implicit_contract delegate) contract >>= fun c -> + return c let known c delegate = Storage.Contract.Manager.get_option @@ -246,55 +221,55 @@ let known c delegate = | None | Some (Manager_repr.Hash _) -> return_false | Some (Manager_repr.Public_key _) -> return_true -(* A delegate is registered if its "implicit account" - delegates to itself. *) +(* A delegate is registered if its "implicit account" delegates to itself. *) let registered c delegate = - Storage.Contract.Delegate.mem - c (Contract_repr.implicit_contract delegate) + Storage.Contract.Delegate.get_option + c (Contract_repr.implicit_contract delegate) >>=? function + | Some current_delegate -> + return @@ Signature.Public_key_hash.equal delegate current_delegate + | None -> + return_false let init ctxt contract delegate = known ctxt delegate >>=? fun known_delegate -> fail_unless known_delegate (Roll_storage.Unregistered_delegate delegate) >>=? fun () -> - registered ctxt delegate >>= fun is_registered -> + registered ctxt delegate >>=? fun is_registered -> fail_unless is_registered (Roll_storage.Unregistered_delegate delegate) >>=? fun () -> Storage.Contract.Delegate.init ctxt contract delegate >>=? fun ctxt -> - Storage.Contract.Balance.get ctxt contract >>=? fun balance -> - link ctxt contract delegate balance + link ctxt contract delegate let get = Roll_storage.get_contract_delegate -let set_base c is_delegatable contract delegate = +let set c contract delegate = match delegate with | None -> begin + let delete () = + unlink c contract >>=? fun c -> + Storage.Contract.Delegate.remove c contract >>= fun c -> + return c in match Contract_repr.is_implicit contract with | Some pkh -> - fail (No_deletion pkh) - | None -> - is_delegatable c contract >>=? fun delegatable -> - if delegatable then - Storage.Contract.Balance.get c contract >>=? fun balance -> - unlink c contract balance >>=? fun c -> - Storage.Contract.Delegate.remove c contract >>= fun c -> - return c + (* check if contract is a registered delegate *) + registered c pkh >>=? fun is_registered -> + if is_registered then + fail (No_deletion pkh) else - fail (Non_delegatable_contract contract) + delete () + | None -> delete () end | Some delegate -> known c delegate >>=? fun known_delegate -> - registered c delegate >>= fun registered_delegate -> - is_delegatable c contract >>=? fun delegatable -> + registered c delegate >>=? fun registered_delegate -> let self_delegation = match Contract_repr.is_implicit contract with | Some pkh -> Signature.Public_key_hash.equal pkh delegate | None -> false in if not known_delegate || not (registered_delegate || self_delegation) then fail (Roll_storage.Unregistered_delegate delegate) - else if not (delegatable || self_delegation) then - fail (Non_delegatable_contract contract) else begin Storage.Contract.Delegate.get_option c contract >>=? function @@ -308,14 +283,26 @@ let set_base c is_delegatable contract delegate = fail Current_delegate | None | Some _ -> return_unit end >>=? fun () -> + (* check if contract is a registered delegate *) + begin + match Contract_repr.is_implicit contract with + | Some pkh -> + registered c pkh >>=? fun is_registered -> + (* allow self-delegation to re-activate *) + if not self_delegation && is_registered then + fail (No_deletion pkh) + else + return_unit + | None -> + return_unit + end >>=? fun () -> Storage.Contract.Balance.mem c contract >>= fun exists -> fail_when (self_delegation && not exists) (Empty_delegate_account delegate) >>=? fun () -> - Storage.Contract.Balance.get c contract >>=? fun balance -> - unlink c contract balance >>=? fun c -> + unlink c contract >>=? fun c -> Storage.Contract.Delegate.init_set c contract delegate >>= fun c -> - link c contract delegate balance >>=? fun c -> + link c contract delegate >>=? fun c -> begin if self_delegation then Storage.Delegates.add c delegate >>= fun c -> @@ -326,15 +313,8 @@ let set_base c is_delegatable contract delegate = end >>=? fun c -> return c -let set c contract delegate = - set_base c is_delegatable contract delegate - -let set_from_script c contract delegate = - set_base c (fun _ _ -> return_true) contract delegate - let remove ctxt contract = - Storage.Contract.Balance.get ctxt contract >>=? fun balance -> - unlink ctxt contract balance + unlink ctxt contract let delegated_contracts ctxt delegate = let contract = Contract_repr.implicit_contract delegate in diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli index 6f458403b..730cde305 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli @@ -49,10 +49,6 @@ type frozen_balance = { rewards : Tez_repr.t ; } -(** Is the contract eligible to delegation ? *) -val is_delegatable: - Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t - (** Allow to register a delegate when creating an account. *) val init: Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t -> @@ -67,26 +63,19 @@ val get: Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option tzresult Lwt.t -val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t +val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t (** Updating the delegate of a contract. - When calling this function on an "implicit contract" this function - fails, unless when the registered delegate is the contract manager. - In the that case, the manager is now registered as a delegate. One - cannot unregister a delegate for now. The associate contract is - now 'undeletable'. *) + When calling this function on an "implicit contract" and setting + the delegate to the contract manager registers it as a delegate. One + cannot unregister a delegate for now. The associate contract is now + 'undeletable'. *) val set: Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option -> Raw_context.t tzresult Lwt.t -(** Same as {!set} ignoring the [delegatable] flag. *) -val set_from_script: - Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option -> - Raw_context.t tzresult Lwt.t - type error += - | Non_delegatable_contract of Contract_repr.contract (* `Permanent *) | No_deletion of Signature.Public_key_hash.t (* `Permanent *) | Active_delegate (* `Temporary *) | Current_delegate (* `Temporary *) @@ -169,10 +158,10 @@ val staking_balance: Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t -(** Returns the list of contract that delegated towards a given delegate *) +(** Returns the list of contracts (implicit or originated) that delegated towards a given delegate *) val delegated_contracts: Raw_context.t -> Signature.Public_key_hash.t -> - Contract_hash.t list Lwt.t + Contract_repr.t list Lwt.t val delegated_balance: Raw_context.t -> Signature.Public_key_hash.t -> diff --git a/vendors/ligo-utils/tezos-protocol-alpha/dune.inc b/vendors/ligo-utils/tezos-protocol-alpha/dune.inc index f7bbe1136..cf411a5e3 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/dune.inc +++ b/vendors/ligo-utils/tezos-protocol-alpha/dune.inc @@ -11,22 +11,22 @@ (targets environment.ml) (action (write-file %{targets} - "module Name = struct let name = \"alpha\" end + "module Name = struct let name = \"005-PsBabyM1\" end include Tezos_protocol_environment.MakeV1(Name)() module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end "))) (rule (targets registerer.ml) - (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml + (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml (:src_dir TEZOS_PROTOCOL)) (action (with-stdout-to %{targets} - (chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "alpha"))))) + (chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "005_PsBabyM1"))))) (rule (targets functor.ml) - (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml + (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml (:src_dir TEZOS_PROTOCOL)) (action (with-stdout-to %{targets} (chdir %{workspace_root} @@ -34,70 +34,70 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end (rule (targets protocol.ml) - (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml) + (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml) (action (write-file %{targets} - "module Environment = Tezos_protocol_environment_alpha.Environment -let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK\" + "module Environment = Tezos_protocol_environment_005_PsBabyM1.Environment +let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS\" let name = Environment.Name.name -include Tezos_raw_protocol_alpha -include Tezos_raw_protocol_alpha.Main +include Tezos_raw_protocol_005_PsBabyM1 +include Tezos_raw_protocol_005_PsBabyM1.Main "))) (library - (name tezos_protocol_environment_alpha) - (public_name tezos-protocol-alpha.environment) + (name tezos_protocol_environment_005_PsBabyM1) + (public_name tezos-protocol-005-PsBabyM1.environment) (library_flags (:standard -linkall)) (libraries tezos-protocol-environment) (modules Environment)) (library - (name tezos_raw_protocol_alpha) - (public_name tezos-protocol-alpha.raw) - (libraries tezos_protocol_environment_alpha) + (name tezos_raw_protocol_005_PsBabyM1) + (public_name tezos-protocol-005-PsBabyM1.raw) + (libraries tezos_protocol_environment_005_PsBabyM1) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib -w +a-4-6-7-9-29-32-40..42-44-45-48 -warn-error -a+8 - -open Tezos_protocol_environment_alpha__Environment + -open Tezos_protocol_environment_005_PsBabyM1__Environment -open Pervasives -open Error_monad)) - (modules Misc Storage_description State_hash Nonce_hash Script_expr_hash Contract_hash Blinded_public_key_hash Qty_repr Tez_repr Period_repr Time_repr Constants_repr Fitness_repr Raw_level_repr Voting_period_repr Cycle_repr Level_repr Seed_repr Gas_limit_repr Script_int_repr Script_timestamp_repr Michelson_v1_primitives Script_repr Contract_repr Roll_repr Vote_repr Block_header_repr Operation_repr Manager_repr Commitment_repr Parameters_repr Raw_context Storage_sigs Storage_functors Storage Constants_storage Level_storage Nonce_storage Seed_storage Roll_storage Delegate_storage Contract_storage Bootstrap_storage Fitness_storage Vote_storage Commitment_storage Init_storage Fees_storage Alpha_context Script_typed_ir Script_tc_errors Michelson_v1_gas Script_ir_annot Script_ir_translator Script_tc_errors_registration Script_interpreter Baking Amendment Apply_results Apply Services_registration Constants_services Contract_services Delegate_services Helpers_services Voting_services Alpha_services Main)) + (modules Misc Storage_description State_hash Nonce_hash Script_expr_hash Contract_hash Blinded_public_key_hash Qty_repr Tez_repr Period_repr Time_repr Constants_repr Fitness_repr Raw_level_repr Voting_period_repr Cycle_repr Level_repr Seed_repr Gas_limit_repr Script_int_repr Script_timestamp_repr Michelson_v1_primitives Script_repr Legacy_script_support_repr Contract_repr Roll_repr Vote_repr Block_header_repr Operation_repr Manager_repr Commitment_repr Parameters_repr Raw_context Storage_sigs Storage_functors Storage Constants_storage Level_storage Nonce_storage Seed_storage Roll_storage Delegate_storage Contract_storage Bootstrap_storage Fitness_storage Vote_storage Commitment_storage Init_storage Fees_storage Alpha_context Script_typed_ir Script_tc_errors Michelson_v1_gas Script_ir_annot Script_ir_translator Script_tc_errors_registration Script_interpreter Baking Amendment Apply_results Apply Services_registration Constants_services Contract_services Delegate_services Helpers_services Voting_services Alpha_services Main)) (install (section lib) - (package tezos-protocol-alpha) + (package tezos-protocol-005-PsBabyM1) (files (TEZOS_PROTOCOL as raw/TEZOS_PROTOCOL))) (library - (name tezos_protocol_alpha) - (public_name tezos-protocol-alpha) + (name tezos_protocol_005_PsBabyM1) + (public_name tezos-protocol-005-PsBabyM1) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_alpha) + tezos_raw_protocol_005_PsBabyM1) (flags -w "+a-4-6-7-9-29-40..42-44-45-48" -warn-error "-a+8" -nopervasives) (modules Protocol)) (library - (name tezos_protocol_alpha_functor) - (public_name tezos-protocol-alpha.functor) + (name tezos_protocol_005_PsBabyM1_functor) + (public_name tezos-protocol-005-PsBabyM1.functor) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_alpha) + tezos_raw_protocol_005_PsBabyM1) (flags -w "+a-4-6-7-9-29-40..42-44-45-48" -warn-error "-a+8" -nopervasives) (modules Functor)) (library - (name tezos_embedded_protocol_alpha) - (public_name tezos-embedded-protocol-alpha) + (name tezos_embedded_protocol_005_PsBabyM1) + (public_name tezos-embedded-protocol-005-PsBabyM1) (library_flags (:standard -linkall)) - (libraries tezos-protocol-alpha + (libraries tezos-protocol-005-PsBabyM1 tezos-protocol-updater tezos-protocol-environment) (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 @@ -106,4 +106,4 @@ include Tezos_raw_protocol_alpha.Main (alias (name runtest_sandbox) - (deps .tezos_protocol_alpha.objs/native/tezos_protocol_alpha.cmx)) + (deps .tezos_protocol_005_PsBabyM1.objs/native/tezos_protocol_005_PsBabyM1.cmx)) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml index e713d96f1..67640e855 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml @@ -97,7 +97,7 @@ let burn_storage_fees c ~storage_limit ~payer = else trace Cannot_pay_storage_fee (Contract_storage.must_exist c payer >>=? fun () -> - Contract_storage.spend_from_script c payer to_burn) >>=? fun c -> + Contract_storage.spend c payer to_burn) >>=? fun c -> return c let check_storage_limit c ~storage_limit = diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml index 9e4e4e688..9bbc19e74 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml @@ -57,5 +57,10 @@ let to_int64 = function when Compare.String. (MBytes.to_string version = Constants_repr.version_number) -> int64_of_bytes fitness + | [ version ; + _fitness (* ignored since higher version takes priority *) ] + when Compare.String. + (MBytes.to_string version = Constants_repr.version_number_004) -> + ok 0L | [] -> ok 0L | _ -> error Invalid_fitness diff --git a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml index 27025d7d6..2d935809e 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml @@ -27,6 +27,8 @@ type t = | Unaccounted | Limited of { remaining : Z.t } +type internal_gas = Z.t + type cost = { allocations : Z.t ; steps : Z.t ; @@ -90,37 +92,60 @@ let write_base_weight = Z.of_int 160 let byte_read_weight = Z.of_int 10 let byte_written_weight = Z.of_int 15 -let consume block_gas operation_gas cost = match operation_gas with - | Unaccounted -> ok (block_gas, Unaccounted) - | Limited { remaining } -> - let weighted_cost = - Z.add - (Z.add - (Z.mul allocation_weight cost.allocations) - (Z.mul step_weight cost.steps)) - (Z.add - (Z.add - (Z.mul read_base_weight cost.reads) - (Z.mul write_base_weight cost.writes)) - (Z.add - (Z.mul byte_read_weight cost.bytes_read) - (Z.mul byte_written_weight cost.bytes_written))) in - let remaining = - Z.sub remaining weighted_cost in - let block_remaining = - Z.sub block_gas weighted_cost in - if Compare.Z.(remaining < Z.zero) - then error Operation_quota_exceeded - else if Compare.Z.(block_remaining < Z.zero) - then error Block_quota_exceeded - else ok (block_remaining, Limited { remaining }) +let rescaling_bits = 7 +let rescaling_mask = + Z.sub (Z.shift_left Z.one rescaling_bits) Z.one -let check_enough block_gas operation_gas cost = - consume block_gas operation_gas cost - >|? fun (_block_remainig, _remaining) -> () +let scale (z : Z.t) = Z.shift_left z rescaling_bits +let rescale (z : Z.t) = Z.shift_right z rescaling_bits + +let cost_to_internal_gas (cost : cost) : internal_gas = + Z.add + (Z.add + (Z.mul cost.allocations allocation_weight) + (Z.mul cost.steps step_weight)) + (Z.add + (Z.add + (Z.mul cost.reads read_base_weight) + (Z.mul cost.writes write_base_weight)) + (Z.add + (Z.mul cost.bytes_read byte_read_weight) + (Z.mul cost.bytes_written byte_written_weight))) + +let internal_gas_to_gas internal_gas : Z.t * internal_gas = + let gas = rescale internal_gas in + let rest = Z.logand internal_gas rescaling_mask in + (gas, rest) + +let consume block_gas operation_gas internal_gas cost = + match operation_gas with + | Unaccounted -> ok (block_gas, Unaccounted, internal_gas) + | Limited { remaining } -> + let cost_internal_gas = cost_to_internal_gas cost in + let total_internal_gas = + Z.add cost_internal_gas internal_gas in + let gas, rest = internal_gas_to_gas total_internal_gas in + if Compare.Z.(gas > Z.zero) then + let remaining = + Z.sub remaining gas in + let block_remaining = + Z.sub block_gas gas in + if Compare.Z.(remaining < Z.zero) + then error Operation_quota_exceeded + else if Compare.Z.(block_remaining < Z.zero) + then error Block_quota_exceeded + else ok (block_remaining, Limited { remaining }, rest) + else + ok (block_gas, operation_gas, total_internal_gas) + +let check_enough block_gas operation_gas internal_gas cost = + consume block_gas operation_gas internal_gas cost + >|? fun (_block_remainig, _remaining, _internal_gas) -> () + +let internal_gas_zero : internal_gas = Z.zero let alloc_cost n = - { allocations = Z.of_int (n + 1) ; + { allocations = scale (Z.of_int (n + 1)) ; steps = Z.zero ; reads = Z.zero ; writes = Z.zero ; @@ -133,9 +158,17 @@ let alloc_bytes_cost n = let alloc_bits_cost n = alloc_cost ((n + 63) / 64) +let atomic_step_cost n = + { allocations = Z.zero ; + steps = Z.of_int (2 * n) ; + reads = Z.zero ; + writes = Z.zero ; + bytes_read = Z.zero ; + bytes_written = Z.zero } + let step_cost n = { allocations = Z.zero ; - steps = Z.of_int n ; + steps = scale (Z.of_int n) ; reads = Z.zero ; writes = Z.zero ; bytes_read = Z.zero ; @@ -152,9 +185,9 @@ let free = let read_bytes_cost n = { allocations = Z.zero ; steps = Z.zero ; - reads = Z.one ; + reads = scale Z.one ; writes = Z.zero ; - bytes_read = n ; + bytes_read = scale n ; bytes_written = Z.zero } let write_bytes_cost n = @@ -163,7 +196,7 @@ let write_bytes_cost n = reads = Z.zero ; writes = Z.one ; bytes_read = Z.zero ; - bytes_written = n } + bytes_written = scale n } let ( +@ ) x y = { allocations = Z.add x.allocations y.allocations ; diff --git a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli index 00db52353..d5b58c203 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli @@ -27,6 +27,8 @@ type t = | Unaccounted | Limited of { remaining : Z.t } +type internal_gas + val encoding : t Data_encoding.encoding val pp : Format.formatter -> t -> unit @@ -38,10 +40,13 @@ val pp_cost : Format.formatter -> cost -> unit type error += Block_quota_exceeded (* `Temporary *) type error += Operation_quota_exceeded (* `Temporary *) -val consume : Z.t -> t -> cost -> (Z.t * t) tzresult -val check_enough : Z.t -> t -> cost -> unit tzresult +val consume : Z.t -> t -> internal_gas -> cost -> (Z.t * t * internal_gas) tzresult +val check_enough : Z.t -> t -> internal_gas -> cost -> unit tzresult + +val internal_gas_zero : internal_gas val free : cost +val atomic_step_cost : int -> cost val step_cost : int -> cost val alloc_cost : int -> cost val alloc_bytes_cost : int -> cost diff --git a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml index 727028507..a44c6c7f3 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml @@ -59,14 +59,16 @@ module Scripts = struct let path = RPC_path.(path / "scripts") let run_code_input_encoding = - (obj7 + (obj9 (req "script" Script.expr_encoding) (req "storage" Script.expr_encoding) (req "input" Script.expr_encoding) (req "amount" Tez.encoding) + (req "chain_id" Chain_id.encoding) (opt "source" Contract.encoding) (opt "payer" Contract.encoding) - (opt "gas" z)) + (opt "gas" z) + (dft "entrypoint" string "default")) let trace_encoding = def "scripted.trace" @@ @@ -147,10 +149,39 @@ module Scripts = struct ~description: "Run an operation without signature checks" ~query: RPC_query.empty - ~input: Operation.encoding + ~input: (obj2 + (req "operation" Operation.encoding) + (req "chain_id" Chain_id.encoding)) ~output: Apply_results.operation_data_and_metadata_encoding RPC_path.(path / "run_operation") + let entrypoint_type = + RPC_service.post_service + ~description: "Return the type of the given entrypoint" + ~query: RPC_query.empty + ~input: (obj2 + (req "script" Script.expr_encoding) + (dft "entrypoint" string "default")) + ~output: (obj1 + (req "entrypoint_type" Script.expr_encoding)) + RPC_path.(path / "entrypoint") + + + let list_entrypoints = + RPC_service.post_service + ~description: "Return the list of entrypoints of the given script" + ~query: RPC_query.empty + ~input: (obj1 + (req "script" Script.expr_encoding)) + ~output: (obj2 + (dft "unreachable" + (Data_encoding.list + (obj1 (req "path" (Data_encoding.list Michelson_v1_primitives.prim_encoding)))) + []) + (req "entrypoints" + (assoc Script.expr_encoding))) + RPC_path.(path / "entrypoints") + end let register () = @@ -163,14 +194,11 @@ module Scripts = struct | None -> assert false in Contract.originate ctxt dummy_contract ~balance - ~manager: Signature.Public_key_hash.zero ~delegate: None - ~spendable: false - ~delegatable: false ~script: (script, None) >>=? fun ctxt -> return (ctxt, dummy_contract) in register0 S.run_code begin fun ctxt () - (code, storage, parameter, amount, source, payer, gas) -> + (code, storage, parameter, amount, chain_id, source, payer, gas, entrypoint) -> let storage = Script.lazy_expr storage in let code = Script.lazy_expr code in originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) -> @@ -183,17 +211,24 @@ module Scripts = struct | Some gas -> gas | None -> Constants.hard_gas_limit_per_operation ctxt in let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + { source ; + payer ; + self = dummy_contract ; + amount ; + chain_id } in Script_interpreter.execute ctxt Readable - ~source - ~payer - ~self:(dummy_contract, { storage ; code }) - ~amount ~parameter + step_constants + ~script:{ storage ; code } + ~entrypoint + ~parameter >>=? fun { Script_interpreter.storage ; operations ; big_map_diff ; _ } -> return (storage, operations, big_map_diff) end ; register0 S.trace_code begin fun ctxt () - (code, storage, parameter, amount, source, payer, gas) -> + (code, storage, parameter, amount, chain_id, source, payer, gas, entrypoint) -> let storage = Script.lazy_expr storage in let code = Script.lazy_expr code in originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) -> @@ -206,12 +241,19 @@ module Scripts = struct | Some gas -> gas | None -> Constants.hard_gas_limit_per_operation ctxt in let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + { source ; + payer ; + self = dummy_contract ; + amount ; + chain_id } in Script_interpreter.trace ctxt Readable - ~source - ~payer - ~self:(dummy_contract, { storage ; code }) - ~amount ~parameter + step_constants + ~script:{ storage ; code } + ~entrypoint + ~parameter >>=? fun ({ Script_interpreter.storage ; operations ; big_map_diff ; _ }, trace) -> return (storage, operations, trace, big_map_diff) end ; @@ -234,13 +276,13 @@ module Scripts = struct let ctxt = match maybe_gas with | None -> Gas.set_unlimited ctxt | Some gas -> Gas.set_limit ctxt gas in - Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ, ctxt) -> - parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) -> + Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ)) >>=? fun (Ex_ty typ, ctxt) -> + parse_data ctxt ~legacy:true typ (Micheline.root expr) >>=? fun (data, ctxt) -> Script_ir_translator.pack_data ctxt typ data >>=? fun (bytes, ctxt) -> return (bytes, Gas.level ctxt) end ; register0 S.run_operation begin fun ctxt () - { shell ; protocol_data = Operation_data protocol_data } -> + ({ shell ; protocol_data = Operation_data protocol_data }, chain_id) -> (* this code is a duplicate of Apply without signature check *) let partial_precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) @@ -249,15 +291,15 @@ module Scripts = struct Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () -> let ctxt = Gas.set_limit ctxt gas_limit in Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () -> - Contract.must_be_allocated ctxt source >>=? fun () -> + Contract.must_be_allocated ctxt (Contract.implicit_contract source) >>=? fun () -> Contract.check_counter_increment ctxt source counter >>=? fun () -> begin match operation with | Reveal pk -> Contract.reveal_manager_key ctxt source pk - | Transaction { parameters = Some arg ; _ } -> + | Transaction { parameters ; _ } -> (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) - let arg_bytes = Data_encoding.Binary.to_bytes_exn Script.lazy_expr_encoding arg in + let arg_bytes = Data_encoding.Binary.to_bytes_exn Script.lazy_expr_encoding parameters in let arg = match Data_encoding.Binary.of_bytes Script.lazy_expr_encoding arg_bytes with | Some arg -> arg | None -> assert false in @@ -267,7 +309,7 @@ module Scripts = struct (* Fail if not enough gas for complete deserialization cost *) trace Apply.Gas_quota_exceeded_init_deserialize @@ Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt - | Origination { script = Some script ; _ } -> + | Origination { script = script ; _ } -> (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) let script_bytes = Data_encoding.Binary.to_bytes_exn Script.encoding script in let script = match Data_encoding.Binary.of_bytes Script.encoding script_bytes with @@ -287,7 +329,7 @@ module Scripts = struct Contract.get_manager_key ctxt source >>=? fun _public_key -> (* signature check unplugged from here *) Contract.increment_counter ctxt source >>=? fun ctxt -> - Contract.spend ctxt source fee >>=? fun ctxt -> + Contract.spend ctxt (Contract.implicit_contract source) fee >>=? fun ctxt -> return ctxt in let rec partial_precheck_manager_contents_list : type kind. @@ -310,27 +352,61 @@ module Scripts = struct match protocol_data.contents with | Single (Manager_operation _) as op -> partial_precheck_manager_contents_list ctxt op >>=? fun ctxt -> - Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) -> + Apply.apply_manager_contents_list ctxt Optimized baker chain_id op >>= fun (_ctxt, result) -> return result | Cons (Manager_operation _, _) as op -> partial_precheck_manager_contents_list ctxt op >>=? fun ctxt -> - Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) -> + Apply.apply_manager_contents_list ctxt Optimized baker chain_id op >>= fun (_ctxt, result) -> return result | _ -> Apply.apply_contents_list - ctxt ~partial:true Chain_id.zero Optimized shell.branch baker operation + ctxt chain_id Optimized shell.branch baker operation operation.protocol_data.contents >>=? fun (_ctxt, result) -> return result - + end; + register0 S.entrypoint_type begin fun ctxt () (expr, entrypoint) -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = false in + let open Script_ir_translator in + Lwt.return + begin + parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> + parse_ty ctxt ~legacy + ~allow_big_map:true ~allow_operation:false + ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.find_entrypoint ~root_name arg_type + entrypoint + end >>=? fun (_f , Ex_ty ty)-> + unparse_ty ctxt ty >>=? fun (ty_node, _) -> + return (Micheline.strip_locations ty_node) + end ; + register0 S.list_entrypoints begin fun ctxt () expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = false in + let open Script_ir_translator in + Lwt.return + begin + parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> + parse_ty ctxt ~legacy + ~allow_big_map:true ~allow_operation:false + ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.list_entrypoints ~root_name arg_type ctxt + end >>=? fun (unreachable_entrypoint,map) -> + return + (unreachable_entrypoint, + Entrypoints_map.fold + begin fun entry (_,ty) acc -> + (entry , Micheline.strip_locations ty) ::acc end + map []) end - let run_code ctxt block code (storage, input, amount, source, payer, gas) = + let run_code ctxt block code (storage, input, amount, chain_id, source, payer, gas, entrypoint) = RPC_context.make_call0 S.run_code ctxt - block () (code, storage, input, amount, source, payer, gas) + block () (code, storage, input, amount, chain_id, source, payer, gas, entrypoint) - let trace_code ctxt block code (storage, input, amount, source, payer, gas) = + let trace_code ctxt block code (storage, input, amount, chain_id, source, payer, gas, entrypoint) = RPC_context.make_call0 S.trace_code ctxt - block () (code, storage, input, amount, source, payer, gas) + block () (code, storage, input, amount, chain_id, source, payer, gas, entrypoint) let typecheck_code ctxt block = RPC_context.make_call0 S.typecheck_code ctxt block () @@ -344,6 +420,13 @@ module Scripts = struct let run_operation ctxt block = RPC_context.make_call0 S.run_operation ctxt block () + let entrypoint_type ctxt block = + RPC_context.make_call0 S.entrypoint_type ctxt block () + + let list_entrypoints ctxt block = + RPC_context.make_call0 S.list_entrypoints ctxt block () + + end module Forge = struct @@ -403,7 +486,7 @@ module Forge = struct ~gas_limit ~storage_limit operations = Contract_services.manager_key ctxt block source >>= function | Error _ as e -> Lwt.return e - | Ok (_, revealed) -> + | Ok revealed -> let ops = List.map (fun (Manager operation) -> @@ -431,28 +514,23 @@ module Forge = struct let transaction ctxt block ~branch ~source ?sourcePubKey ~counter - ~amount ~destination ?parameters + ~amount ~destination ?(entrypoint = "default") ?parameters ~gas_limit ~storage_limit ~fee ()= - let parameters = Option.map ~f:Script.lazy_expr parameters in + let parameters = Option.unopt_map ~f:Script.lazy_expr ~default:Script.unit_parameter parameters in operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee ~gas_limit ~storage_limit - [Manager (Transaction { amount ; parameters ; destination })] + [Manager (Transaction { amount ; parameters ; destination ; entrypoint })] let origination ctxt block ~branch ~source ?sourcePubKey ~counter - ~managerPubKey ~balance - ?(spendable = true) - ?(delegatable = true) - ?delegatePubKey ?script + ~balance + ?delegatePubKey ~script ~gas_limit ~storage_limit ~fee () = operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee ~gas_limit ~storage_limit - [Manager (Origination { manager = managerPubKey ; - delegate = delegatePubKey ; + [Manager (Origination { delegate = delegatePubKey ; script ; - spendable ; - delegatable ; credit = balance ; preorigination = None })] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli index 060323063..fc205d97b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli @@ -40,7 +40,7 @@ module Scripts : sig val run_code: 'a #RPC_context.simple -> 'a -> Script.expr -> - (Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option * Z.t option) -> + (Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) -> (Script.expr * packed_internal_operation list * Contract.big_map_diff option) shell_tzresult Lwt.t @@ -48,7 +48,7 @@ module Scripts : sig val trace_code: 'a #RPC_context.simple -> 'a -> Script.expr -> - (Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option* Z.t option) -> + (Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) -> (Script.expr * packed_internal_operation list * Script_interpreter.execution_trace * @@ -69,9 +69,19 @@ module Scripts : sig val run_operation: 'a #RPC_context.simple -> - 'a -> packed_operation -> + 'a -> packed_operation * Chain_id.t -> (packed_protocol_data * Apply_results.packed_operation_metadata) shell_tzresult Lwt.t + val entrypoint_type: + 'a #RPC_context.simple -> + 'a -> Script.expr * string -> Script.expr shell_tzresult Lwt.t + + val list_entrypoints: + 'a #RPC_context.simple -> + 'a -> Script.expr -> + (Michelson_v1_primitives.prim list list * + (string * Script.expr) list) shell_tzresult Lwt.t + end module Forge : sig @@ -81,7 +91,7 @@ module Forge : sig val operations: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> ?sourcePubKey:public_key -> counter:counter -> fee:Tez.t -> @@ -92,7 +102,7 @@ module Forge : sig val reveal: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> sourcePubKey:public_key -> counter:counter -> fee:Tez.t -> @@ -101,11 +111,12 @@ module Forge : sig val transaction: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> ?sourcePubKey:public_key -> counter:counter -> amount:Tez.t -> destination:Contract.t -> + ?entrypoint:string -> ?parameters:Script.expr -> gas_limit:Z.t -> storage_limit:Z.t -> @@ -115,15 +126,12 @@ module Forge : sig val origination: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> ?sourcePubKey:public_key -> counter:counter -> - managerPubKey:public_key_hash -> balance:Tez.t -> - ?spendable:bool -> - ?delegatable:bool -> ?delegatePubKey: public_key_hash -> - ?script:Script.t -> + script:Script.t -> gas_limit:Z.t -> storage_limit:Z.t -> fee:Tez.t-> @@ -132,7 +140,7 @@ module Forge : sig val delegation: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> ?sourcePubKey:public_key -> counter:counter -> fee:Tez.t -> diff --git a/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml index 9d313def8..2a098b457 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -23,10 +24,324 @@ (* *) (*****************************************************************************) -(* This is the genesis protocol: initialise the state *) +(* Delegated storage changed type of value from Contract_hash to + Contract_repr. Move all 'delegated' data into a storage with + the original type, then copy over into the new storage. *) +let migrate_delegated ctxt contract = + let path = "contracts" :: (* module Contract *) + "index" :: (* module Indexed_context *) + Contract_repr.Index.to_path contract [ + "delegated" ; (* module Delegated *) + ] in + let path_tmp = "contracts" :: (* module Contract *) + "index" :: (* module Indexed_context *) + Contract_repr.Index.to_path contract [ + "delegated_004" ; (* module Delegated *) + ] in + Raw_context.dir_mem ctxt path >>= fun exists -> + if exists then + Raw_context.copy ctxt path path_tmp >>=? fun ctxt -> + Raw_context.remove_rec ctxt path >>= fun ctxt -> + Storage.Contract.Delegated_004.fold (ctxt, contract) ~init:(Ok ctxt) ~f:(fun delegated ctxt -> + Lwt.return ctxt >>=? fun ctxt -> + let originated = Contract_repr.originated_contract_004 delegated in + Storage.Contract.Delegated.add (ctxt, contract) originated >>= fun ctxt -> + return ctxt + ) >>=? fun ctxt -> + Raw_context.remove_rec ctxt path_tmp >>= fun ctxt -> + return ctxt + else + return ctxt + +let transform_script: + (manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t) -> + manager_pkh: Signature.Public_key_hash.t -> + Raw_context.t -> + Contract_repr.t -> + Script_repr.lazy_expr -> + Raw_context.t tzresult Lwt.t = + fun transformation ~manager_pkh ctxt contract code -> + Storage.Contract.Storage.get ctxt contract >>=? fun (_ctxt, storage) -> + transformation manager_pkh code storage >>=? fun (migrated_code, migrated_storage) -> + (* Set the migrated script code for free *) + Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, code_size_diff) -> + (* Set the migrated script storage for free *) + Storage.Contract.Storage.set_free ctxt contract migrated_storage >>=? fun (ctxt, storage_size_diff) -> + Storage.Contract.Used_storage_space.get ctxt contract >>=? fun used_space -> + let total_size = Z.(add (of_int code_size_diff) (add (of_int storage_size_diff) used_space)) in + (* Free storage space for migrated contracts *) + Storage.Contract.Used_storage_space.set ctxt contract total_size >>=? fun ctxt -> + Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_space -> + if Compare.Z.(paid_space < total_size) then + Storage.Contract.Paid_storage_space.set ctxt contract total_size >>=? fun ctxt -> + return ctxt + else + return ctxt + +let manager_script_storage: Signature.Public_key_hash.t -> Script_repr.lazy_expr = + fun manager_pkh -> + let open Micheline in + Script_repr.lazy_expr @@ strip_locations @@ + (* store in optimized binary representation - as unparsed with [Optimized]. *) + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh in + Bytes (0, bytes) + +(* If the given contract is not allocated, we'll allocate it with 1 mutez, + so that the migrated contracts' managers don't have to pay origination burn *) +let allocate_contract ctxt contract = + Contract_storage.allocated ctxt contract >>=? function + | true -> + return ctxt + | false -> + Contract_storage.credit ctxt contract Tez_repr.one_mutez + +(* Process an individual contract *) +let process_contract_add_manager contract ctxt = + let open Legacy_script_support_repr in + match Contract_repr.is_originated contract with + | None -> return ctxt (* Only process originated contracts *) + | Some _ -> begin + Storage.Contract.Counter.remove ctxt contract >>= fun ctxt -> + Storage.Contract.Spendable_004.mem ctxt contract >>= fun is_spendable -> + Storage.Contract.Delegatable_004.mem ctxt contract >>= fun is_delegatable -> + Storage.Contract.Spendable_004.del ctxt contract >>= fun ctxt -> + Storage.Contract.Delegatable_004.del ctxt contract >>= fun ctxt -> + (* Try to get script code (ignore ctxt update to discard the initialization) *) + Storage.Contract.Code.get_option ctxt contract >>=? fun (_ctxt, code) -> + (* Get the manager of the originated contract *) + Contract_storage.get_manager_004 ctxt contract >>=? fun manager_pkh -> + let manager = Contract_repr.implicit_contract manager_pkh in + Storage.Contract.Manager.remove ctxt contract >>= fun ctxt -> + match code with + | Some code -> + (* + | spendable | delegatable | template | + |-----------+-------------+------------------| + | true | true | add_do | + | true | false | add_do | + | false | true | add_set_delegate | + | false | false | nothing | + *) + if is_spendable then + transform_script add_do ~manager_pkh ctxt contract code >>=? fun ctxt -> + allocate_contract ctxt manager + else if is_delegatable then + transform_script add_set_delegate ~manager_pkh ctxt contract code >>=? fun ctxt -> + allocate_contract ctxt manager + else if has_default_entrypoint code then + transform_script + (fun ~manager_pkh:_ ~script_code ~script_storage -> + add_root_entrypoint script_code >>=? fun script_code -> + return (script_code, script_storage)) + ~manager_pkh ctxt contract code + else + return ctxt + | None -> begin + (* Initialize the script code for free *) + Storage.Contract.Code.init_free ctxt contract manager_script_code >>=? fun (ctxt, code_size) -> + let storage = manager_script_storage manager_pkh in + (* Initialize the script storage for free *) + Storage.Contract.Storage.init_free ctxt contract storage >>=? fun (ctxt, storage_size) -> + let total_size = Z.(add (of_int code_size) (of_int storage_size)) in + (* Free storage space for migrated contracts *) + Storage.Contract.Paid_storage_space.init_set ctxt contract total_size >>= fun ctxt -> + Storage.Contract.Used_storage_space.init_set ctxt contract total_size >>= fun ctxt -> + allocate_contract ctxt manager + end + end + +(* The [[update_contract_script]] function returns a copy of its + argument (the Micheline AST of a contract script) with "ADDRESS" + replaced by "ADDRESS; CHAIN_ID; PAIR". + + [[Micheline.strip_locations]] should be called on the resulting + Micheline AST to get meaningful locations. *) + +let rec update_contract_script : ('l, 'p) Micheline.node -> ('l, 'p) Micheline.node + = function + | Micheline.Seq (_, + Micheline.Prim (_, Michelson_v1_primitives.I_ADDRESS, [], []) :: + l) -> + Micheline.Seq (0, + Micheline.Prim (0, Michelson_v1_primitives.I_ADDRESS, [], []) :: + Micheline.Prim (0, Michelson_v1_primitives.I_CHAIN_ID, [], []) :: + Micheline.Prim (0, Michelson_v1_primitives.I_PAIR, [], []) :: l) + | Micheline.Seq (_, a :: l) -> + let a' = update_contract_script a in + let b = Micheline.Seq (0, l) in + let b' = update_contract_script b in + begin match b' with + | Micheline.Seq (_, l') -> + Micheline.Seq (0, a' :: l') + | _ -> assert false + end + | Micheline.Prim (_, p, l, annot) -> + Micheline.Prim (0, p, List.map update_contract_script l, annot) + | script -> script + +let migrate_multisig_script (ctxt : Raw_context.t) (contract : Contract_repr.t) + (code : Script_repr.expr) : Raw_context.t tzresult Lwt.t = + let migrated_code = + Script_repr.lazy_expr @@ Micheline.strip_locations @@ + update_contract_script @@ Micheline.root code + in + Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, _code_size_diff) -> + (* Set the spendable and delegatable flags to false so that no entrypoint gets added by + the [[process_contract_add_manager]] function. *) + Storage.Contract.Spendable_004.set ctxt contract false >>= fun ctxt -> + Storage.Contract.Delegatable_004.set ctxt contract false >>= fun ctxt -> + return ctxt + +(* The hash of the multisig contract; only contracts with this exact + hash are going to be updated by the [[update_contract_script]] + function. *) +let multisig_hash : Script_expr_hash.t = + Script_expr_hash.of_bytes_exn @@ + MBytes.of_hex @@ + `Hex "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31" + +let process_contract_multisig (contract : Contract_repr.t) (ctxt : Raw_context.t) = + Contract_storage.get_script ctxt contract >>=? fun (ctxt, script_opt) -> + match script_opt with + | None -> + (* Do nothing on scriptless contracts *) + return ctxt + | Some { Script_repr.code = code ; Script_repr.storage = _storage } -> + (* The contract has some script, only try to modify it if it has + the hash of the multisig contract *) + Lwt.return (Script_repr.force_decode code) >>=? fun (code, _gas_cost) -> + let bytes = + Data_encoding.Binary.to_bytes_exn Script_repr.expr_encoding code + in + let hash = Script_expr_hash.hash_bytes [ bytes ] in + if Script_expr_hash.(hash = multisig_hash) then + migrate_multisig_script ctxt contract code + else + return ctxt + +(* Process an individual contract *) +let process_contract contract ctxt = + process_contract_multisig contract ctxt >>=? fun ctxt -> + process_contract_add_manager contract ctxt >>=? fun ctxt -> + return ctxt + +let invoice_contract ctxt kt1_addr amount = + let amount = Tez_repr.of_mutez_exn (Int64.(mul 1_000_000L (of_int amount))) in + match Contract_repr.of_b58check kt1_addr with + | Ok recipient -> begin + Contract_storage.credit ctxt recipient amount >>= function + | Ok ctxt -> return ctxt + | Error _ -> return ctxt end + | Error _ -> return ctxt + +(* Extract Big_maps from their parent contract directory, + recompute their used space, and assign them an ID. *) +let migrate_contract_big_map ctxt contract = + Storage.Contract.Code.get_option ctxt contract >>=? function + | ctxt, None -> return ctxt + | ctxt, Some code -> + Storage.Contract.Storage.get ctxt contract >>=? fun (ctxt, storage) -> + let extract_big_map_types expr = + let open Michelson_v1_primitives in + let open Micheline in + match Micheline.root expr with + | Seq (_, [ Prim (_, K_storage, [ expr ], _) ; _ ; _ ]) + | Seq (_, [ _ ; Prim (_, K_storage, [ expr ], _) ; _ ]) + | Seq (_, [ _ ; _ ; Prim (_, K_storage, [ expr ], _) ]) -> + begin match expr with + | Prim (_, T_pair, [ Prim (_, T_big_map, [ kt ; vt ], _ ) ; _ ], _) -> Some (kt, vt) + | _ -> None + end + | _ -> None in + let rewrite_big_map expr id = + let open Michelson_v1_primitives in + let open Micheline in + match Micheline.root expr with + | Prim (_, D_Pair, [ Seq (_, _ (* ignore_unused_origination_literal *)) ; pannot ], sannot) -> + Micheline.strip_locations (Prim (0, D_Pair, [ Int (0, id) ; pannot ], sannot)) + | _ -> assert false in + Lwt.return (Script_repr.force_decode code) >>=? fun (code, _) -> + match extract_big_map_types code with + | None -> return ctxt + | Some (kt, vt) -> + Lwt.return (Script_repr.force_decode storage) >>=? fun (storage, _) -> + Storage.Big_map.Next.incr ctxt >>=? fun (ctxt, id) -> + let contract_path suffix = + "contracts" :: (* module Contract *) + "index" :: (* module Indexed_context *) + Contract_repr.Index.to_path contract suffix in + let old_path = contract_path [ "big_map" ] in + let storage = rewrite_big_map storage id in + Storage.Contract.Storage.set ctxt contract (Script_repr.lazy_expr storage) >>=? fun (ctxt, _) -> + let kt = Micheline.strip_locations (Script_repr.strip_annotations kt) in + let vt = Micheline.strip_locations (Script_repr.strip_annotations vt) in + Storage.Big_map.Key_type.init ctxt id kt >>=? fun ctxt -> + Storage.Big_map.Value_type.init ctxt id vt >>=? fun ctxt -> + Raw_context.dir_mem ctxt old_path >>= fun exists -> + if exists then + let read_size ctxt key = + Raw_context.get ctxt key >>=? fun len -> + match Data_encoding.(Binary.of_bytes int31) len with + | None -> assert false + | Some len -> return len in + let iter_sizes f (ctxt, acc) = + let rec dig i path (ctxt, acc) = + if Compare.Int.(i <= 0) then + Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc -> + Lwt.return acc >>=? fun (ctxt, acc) -> + match k with + | `Dir _ -> return (ctxt, acc) + | `Key file -> + match List.rev file with + | last :: _ when Compare.String.(last = "data") -> + return (ctxt, acc) + | last :: _ when Compare.String.(last = "len") -> + read_size ctxt file >>=? fun len -> + return (ctxt, f len acc) + | _ -> assert false + end + else + Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc -> + Lwt.return acc >>=? fun (ctxt, acc) -> + match k with + | `Dir k -> dig (i-1) k (ctxt, acc) + | `Key _ -> return (ctxt, acc) + end in + dig Script_expr_hash.path_length old_path (ctxt, acc) in + iter_sizes + (fun s acc -> (acc |> Z.add (Z.of_int s) |> Z.add (Z.of_int 65))) + (ctxt, (Z.of_int 0)) >>=? fun (ctxt, total_bytes) -> + Storage.Big_map.Total_bytes.init ctxt id total_bytes >>=? fun ctxt -> + let new_path = "big_maps" :: (* module Big_map *) + "index" :: (* module Indexed_context *) + Storage.Big_map.Index.to_path id [ + "contents" ; (* module Delegated *) + ] in + Raw_context.copy ctxt old_path new_path >>=? fun ctxt -> + Raw_context.remove_rec ctxt old_path >>= fun ctxt -> + read_size ctxt (contract_path [ "len" ; "code" ]) >>=? fun code_size -> + read_size ctxt (contract_path [ "len" ; "storage" ]) >>=? fun storage_size -> + let total_bytes = + total_bytes |> + Z.add (Z.of_int 33) |> + Z.add (Z.of_int code_size) |> + Z.add (Z.of_int storage_size) in + Storage.Contract.Used_storage_space.get ctxt contract >>=? fun previous_size -> + Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_bytes -> + let change = Z.sub paid_bytes previous_size in + Storage.Contract.Used_storage_space.set ctxt contract total_bytes >>=? fun ctxt -> + Storage.Contract.Paid_storage_space.set ctxt contract (Z.add total_bytes change) + else + Storage.Big_map.Total_bytes.init ctxt id Z.zero >>=? fun ctxt -> + return ctxt + let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = Raw_context.prepare_first_block ~level ~timestamp ~fitness ctxt >>=? fun (previous_protocol, ctxt) -> + Storage.Big_map.Next.init ctxt >>=? fun ctxt -> match previous_protocol with | Genesis param -> Commitment_storage.init ctxt param.commitments >>=? fun ctxt -> @@ -41,11 +356,24 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = param.bootstrap_contracts >>=? fun ctxt -> Roll_storage.init_first_cycles ctxt >>=? fun ctxt -> Vote_storage.init ctxt >>=? fun ctxt -> - Storage.Last_block_priority.init ctxt 0 >>=? fun ctxt -> + Storage.Block_priority.init ctxt 0 >>=? fun ctxt -> Vote_storage.freeze_listings ctxt >>=? fun ctxt -> return ctxt - | Alpha_previous -> + | Athens_004 -> + Storage.Vote.Current_quorum_004.get ctxt >>=? fun quorum -> + Storage.Vote.Participation_ema.init ctxt quorum >>=? fun ctxt -> + Storage.Vote.Current_quorum_004.delete ctxt >>=? fun ctxt -> + Storage.Block_priority.init ctxt 0 >>=? fun ctxt -> + Storage.Last_block_priority.delete ctxt >>=? fun ctxt -> + Storage.Contract.fold ctxt ~init:(Ok ctxt) + ~f:(fun contract ctxt -> + Lwt.return ctxt >>=? fun ctxt -> + migrate_delegated ctxt contract >>=? fun ctxt -> + migrate_contract_big_map ctxt contract >>=? fun ctxt -> + process_contract contract ctxt) + >>=? fun ctxt -> + invoice_contract ctxt "KT1DUfaMfTRZZkvZAYQT5b3byXnvqoAykc43" 500 >>=? fun ctxt -> return ctxt -let prepare ctxt ~level ~timestamp ~fitness = - Raw_context.prepare ~level ~timestamp ~fitness ctxt +let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness = + Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml new file mode 100644 index 000000000..e9c74fae8 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml @@ -0,0 +1,532 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019 Nomadic Labs *) +(* Copyright (c) 2019 Cryptium Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let manager_script_code: Script_repr.lazy_expr = + let open Micheline in + let open Michelson_v1_primitives in + Script_repr.lazy_expr @@ strip_locations @@ + Seq (0, [ + Prim (0, K_parameter, [ + Prim (0, T_or, [ + Prim (0, T_lambda, [ + Prim (0, T_unit, [], []); + Prim (0, T_list, [ + Prim (0, T_operation, [], []) + ], []) + ], ["%do"]); + Prim (0, T_unit, [], ["%default"]) + ], []) + ], []); + Prim (0, K_storage, [ + Prim (0, T_key_hash, [], []) + ], []); + Prim (0, K_code, [ + Seq (0, [ + Seq (0, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []) + ]) + ], []) + ]) + ]); + Prim (0, I_IF_LEFT, [ + Seq (0, [ + Prim (0, I_PUSH, [ + Prim (0, T_mutez, [], []); + Int (0, Z.zero) + ], []); + Prim (0, I_AMOUNT, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) + ]); + Prim (0, I_IF, [ + Seq (0, []); + Seq (0, [ + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_FAILWITH, [], []) + ]) + ]) + ], []) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_DUP, [], []) + ]) + ], []); + Prim (0, I_SWAP, [], []) + ]); + Prim (0, I_IMPLICIT_ACCOUNT, [], []); + Prim (0, I_ADDRESS, [], []); + Prim (0, I_SENDER, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) + ]); + Prim (0, I_IF, [ + Seq (0, []); + Seq (0, [ + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_FAILWITH, [], []) + ]) + ]) + ], []) + ]); + Prim (0, I_UNIT, [], []); + Prim (0, I_EXEC, [], []); + Prim (0, I_PAIR, [], []) + ]); + Seq (0, [ + Prim (0, I_DROP, [], []); + Prim (0, I_NIL, [ + Prim (0, T_operation, [], []) + ], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ], []) + ]) + +(* Find the toplevel expression with a given prim type from list, + because they can be in arbitrary order. *) +let find_toplevel toplevel exprs = + let open Micheline in + let rec iter toplevel = function + | (Prim (_, prim, _, _) as found) :: _ + when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim) -> + Some found + | _ :: rest -> + iter toplevel rest + | [] -> + None in + iter (Michelson_v1_primitives.string_of_prim toplevel) exprs + +let add_do: + manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t = + fun ~manager_pkh ~script_code ~script_storage -> + let open Micheline in + let open Michelson_v1_primitives in + Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) -> + Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) -> + let storage_expr = root script_storage_expr in + match root script_code_expr with + | Seq (_, toplevel) + -> begin + match find_toplevel K_parameter toplevel, + find_toplevel K_storage toplevel, + find_toplevel K_code toplevel with + Some (Prim (_, K_parameter, [ + Prim (_, parameter_type, parameter_expr, parameter_annot) + ], prim_param_annot)), + Some (Prim (_, K_storage, [ + Prim (_, code_storage_type, code_storage_expr, code_storage_annot) + ], k_storage_annot)), + Some (Prim (_, K_code, [code_expr], code_annot)) -> + (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *) + + let migrated_code = + Seq (0, [ + Prim (0, K_parameter, [ + Prim (0, T_or, [ + Prim (0, T_lambda, [ + Prim (0, T_unit, [], []); + Prim (0, T_list, [ + Prim (0, T_operation, [], []) + ], []) + ], ["%do"]); + Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot) + ], []) + ], prim_param_annot); + Prim (0, K_storage, [ + Prim (0, T_pair, [ + Prim (0, T_key_hash, [], []); + Prim (0, code_storage_type, code_storage_expr, code_storage_annot) + ], []) + ], k_storage_annot); + Prim (0, K_code, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IF_LEFT, [ + Seq (0, [ + Prim (0, I_PUSH, [ + Prim (0, T_mutez, [], []); + Int (0, Z.zero) + ], []); + Prim (0, I_AMOUNT, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) + ]); + Prim (0, I_IF, [ + Seq (0, []); + Seq (0, [ + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_FAILWITH, [], []) + ]) + ]) + ], []) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_DUP, [], []) + ]) + ], []); + Prim (0, I_SWAP, [], []) + ]); + Prim (0, I_CDR, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IMPLICIT_ACCOUNT, [], []); + Prim (0, I_ADDRESS, [], []); + Prim (0, I_SENDER, [], []); + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_NEQ, [], []); + Prim (0, I_IF, [ + Seq (0, [ + Prim (0, I_SENDER, [], []); + Prim (0, I_PUSH, [ + Prim (0, T_string, [], []); + String (0, "Only the owner can operate.") + ], []); + Prim (0, I_PAIR, [], []); + Prim (0, I_FAILWITH, [], []) + ]); + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_EXEC, [], []); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []); + Prim (0, I_DUP, [], []); + Prim (0, I_CDR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []); + + code_expr; + + Prim (0, I_SWAP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_SWAP, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []) + ]) + ], []) + ]) + ]); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_SWAP, [], []); + Prim (0, I_PAIR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ], code_annot) + ]) + in + let migrated_storage = Prim (0, D_Pair, [ + (* Instead of + `String (0, Signature.Public_key_hash.to_b58check manager_pkh)` + the storage is written as unparsed with [Optimized] *) + Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ; + storage_expr + ], []) in + Script_repr.lazy_expr @@ strip_locations migrated_code, + Script_repr.lazy_expr @@ strip_locations migrated_storage + | _ -> + script_code, script_storage + end + | _ -> + script_code, script_storage + + + +let add_set_delegate: + manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t = + fun ~manager_pkh ~script_code ~script_storage -> + let open Micheline in + let open Michelson_v1_primitives in + Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) -> + Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) -> + let storage_expr = root script_storage_expr in + match root script_code_expr with + | Seq (_, toplevel) + -> begin + match find_toplevel K_parameter toplevel, + find_toplevel K_storage toplevel, + find_toplevel K_code toplevel with + Some (Prim (_, K_parameter, [ + Prim (_, parameter_type, parameter_expr, parameter_annot) + ], prim_param_annot)), + Some (Prim (_, K_storage, [ + Prim (_, code_storage_type, code_storage_expr, code_storage_annot) + ], k_storage_annot)), + Some (Prim (_, K_code, [code_expr], code_annot)) -> + (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *) + + let migrated_code = + Seq (0, [ + Prim (0, K_parameter, [ + Prim (0, T_or, [ + Prim (0, T_or, [ + Prim (0, T_key_hash, [], ["%set_delegate"]); + Prim (0, T_unit, [], ["%remove_delegate"]) + ], []); + Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot) + ], []) + ], prim_param_annot); + Prim (0, K_storage, [ + Prim (0, T_pair, [ + Prim (0, T_key_hash, [], []); + Prim (0, code_storage_type, code_storage_expr, code_storage_annot) + ], []) + ], k_storage_annot); + Prim (0, K_code, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IF_LEFT, [ + Seq (0, [ + Prim (0, I_PUSH, [ + Prim (0, T_mutez, [], []); + Int (0, Z.zero) + ], []); + Prim (0, I_AMOUNT, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) + ]); + Prim (0, I_IF, [ + Seq (0, []); + Seq (0, [ + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_FAILWITH, [], []) + ]) + ]) + ], []) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_DUP, [], []) + ]) + ], []); + Prim (0, I_SWAP, [], []) + ]); + Prim (0, I_CDR, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IMPLICIT_ACCOUNT, [], []); + Prim (0, I_ADDRESS, [], []); + Prim (0, I_SENDER, [], []); + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_NEQ, [], []); + Prim (0, I_IF, [ + Seq (0, [ + Prim (0, I_SENDER, [], []); + Prim (0, I_PUSH, [ + Prim (0, T_string, [], []); + String (0, "Only the owner can operate.") + ], []); + Prim (0, I_PAIR, [], []); + Prim (0, I_FAILWITH, [], []) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []); + Prim (0, I_NIL, [ + Prim (0, T_operation, [], []) + ], []) + ]) + ], []); + Prim (0, I_IF_LEFT, [ + Seq (0, [ + Prim (0, I_SOME, [], []); + Prim (0, I_SET_DELEGATE, [], []); + Prim (0, I_CONS, [], []); + Prim (0, I_PAIR, [], []) + ]); + Seq (0, [ + Prim (0, I_DROP, [], []); + Prim (0, I_NONE, [ + Prim (0, T_key_hash, [], []) + ], []); + Prim (0, I_SET_DELEGATE, [], []); + Prim (0, I_CONS, [], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ], []) + ]) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []); + Prim (0, I_DUP, [], []); + Prim (0, I_CDR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []); + + code_expr; + + Prim (0, I_SWAP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_SWAP, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []) + ]) + ], []) + ]) + ]); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_SWAP, [], []); + Prim (0, I_PAIR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ], code_annot) + ]) + in + let migrated_storage = Prim (0, D_Pair, [ + (* Instead of + `String (0, Signature.Public_key_hash.to_b58check manager_pkh)` + the storage is written as unparsed with [Optimized] *) + Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ; + storage_expr + ], []) in + Script_repr.lazy_expr @@ strip_locations migrated_code, + Script_repr.lazy_expr @@ strip_locations migrated_storage + | _ -> + script_code, script_storage + end + | _ -> + script_code, script_storage + +let has_default_entrypoint expr = + let open Micheline in + let open Michelson_v1_primitives in + match Script_repr.force_decode expr with + | Error _ -> false + | Ok (expr, _) -> + match root expr with + | Seq (_, toplevel) -> begin + match find_toplevel K_parameter toplevel with + | Some (Prim (_, K_parameter, [ _ ], [ "%default" ])) -> false + | Some (Prim (_, K_parameter, [ parameter_expr ], _)) -> + let rec has_default = function + | Prim (_, T_or, [ l ; r ], annots) -> + List.exists (String.equal "%default") annots || has_default l || has_default r + | Prim (_, _, _, annots) -> + List.exists (String.equal "%default") annots + | _ -> false + in + has_default parameter_expr + | Some _ | None -> false + end + | _ -> false + +let add_root_entrypoint + : script_code: Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t + = fun ~script_code -> + let open Micheline in + let open Michelson_v1_primitives in + Lwt.return (Script_repr.force_decode script_code) >>|? fun (script_code_expr, _gas_cost) -> + match root script_code_expr with + | Seq (_, toplevel) -> + let migrated_code = + Seq (0, List.map (function + | Prim (_, K_parameter, [ parameter_expr ], _) -> + Prim (0, K_parameter, [ parameter_expr ], [ "%root" ]) + | Prim (_, K_code, exprs, annots) -> + let rec rewrite_self = function + | Int _ | String _ | Bytes _ | Prim (_, I_CREATE_CONTRACT, _, _) as leaf -> leaf + | Prim (_, I_SELF, [], annots) -> + Prim (0, I_SELF, [], "%root" :: annots) + | Prim (_, name, args, annots) -> + Prim (0, name, List.map rewrite_self args, annots) + | Seq (_, args) -> + Seq (0, List.map rewrite_self args) in + Prim (0, K_code, List.map rewrite_self exprs, annots) + | other -> other) + toplevel) in + Script_repr.lazy_expr @@ strip_locations migrated_code + | _ -> + script_code diff --git a/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli new file mode 100644 index 000000000..0b69d3393 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli @@ -0,0 +1,69 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019 Nomadic Labs *) +(* Copyright (c) 2019 Cryptium Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** This code mimics the now defunct scriptless KT1s. + + The manager contract is from: + https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/manager.tz + The formal proof is at: + https://gitlab.com/nomadic-labs/mi-cho-coq/blob/a7603e12021166e15890f6d504feebec2f945502/src/contracts_coq/manager.v *) +val manager_script_code: Script_repr.lazy_expr + +(** This code mimics the now defunct "spendable" flags of KT1s by + adding a [do] entrypoint, preserving the original script's at + 'default' entrypoint. + + The pseudo-code for the applied transformations is from: + https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_do.tz *) +val add_do: + manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t + +(** This code mimics the now defunct "spendable" flags of KT1s by + adding a [do] entrypoint, preserving the original script's at + 'default' entrypoint. + + The pseudo-code for the applied transformations is from: + https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_set_delegate.tz *) +val add_set_delegate: + manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t + +(** Checks if a contract was declaring a default entrypoint somewhere + else than at the root, in which case its type changes when + entrypoints are activated. *) +val has_default_entrypoint: + Script_repr.lazy_expr -> bool + +(** Adds a [%root] annotation on the toplevel parameter construct. *) +val add_root_entrypoint: + script_code: Script_repr.lazy_expr -> + Script_repr.lazy_expr tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/main.ml b/vendors/ligo-utils/tezos-protocol-alpha/main.ml index ec05389ca..61e5ba0f2 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/main.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/main.ml @@ -54,7 +54,6 @@ type operation = Alpha_context.packed_operation = { protocol_data: operation_data ; } - let acceptable_passes = Alpha_context.Operation.acceptable_passes let max_block_length = @@ -81,10 +80,12 @@ type validation_mode = | Application of { block_header : Alpha_context.Block_header.t ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } | Partial_application of { block_header : Alpha_context.Block_header.t ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } | Partial_construction of { predecessor : Block_hash.t ; @@ -93,6 +94,7 @@ type validation_mode = predecessor : Block_hash.t ; protocol_data : Alpha_context.Block_header.contents ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } type validation_state = @@ -114,12 +116,12 @@ let begin_partial_application let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - Alpha_context.prepare ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> Apply.begin_application - ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker) -> + ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) -> let mode = Partial_application - { block_header ; baker = Signature.Public_key.hash baker } in + { block_header ; baker = Signature.Public_key.hash baker ; block_delay } in return { mode ; chain_id ; ctxt ; op_count = 0 } let begin_application @@ -131,16 +133,17 @@ let begin_application let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - Alpha_context.prepare ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> Apply.begin_application - ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker) -> - let mode = Application { block_header ; baker = Signature.Public_key.hash baker } in + ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) -> + let mode = + Application { block_header ; baker = Signature.Public_key.hash baker ; block_delay } in return { mode ; chain_id ; ctxt ; op_count = 0 } let begin_construction ~chain_id ~predecessor_context:ctxt - ~predecessor_timestamp:pred_timestamp + ~predecessor_timestamp ~predecessor_level:pred_level ~predecessor_fitness:pred_fitness ~predecessor @@ -149,7 +152,7 @@ let begin_construction () = let level = Int32.succ pred_level in let fitness = pred_fitness in - Alpha_context.prepare ~timestamp ~level ~fitness ctxt >>=? fun ctxt -> + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> begin match protocol_data with | None -> @@ -158,11 +161,11 @@ let begin_construction return (mode, ctxt) | Some proto_header -> Apply.begin_full_construction - ctxt pred_timestamp - proto_header.contents >>=? fun (ctxt, protocol_data, baker) -> + ctxt predecessor_timestamp + proto_header.contents >>=? fun (ctxt, protocol_data, baker, block_delay) -> let mode = let baker = Signature.Public_key.hash baker in - Full_construction { predecessor ; baker ; protocol_data } in + Full_construction { predecessor ; baker ; protocol_data ; block_delay } in return (mode, ctxt) end >>=? fun (mode, ctxt) -> return { mode ; chain_id ; ctxt ; op_count = 0 } @@ -192,13 +195,7 @@ let apply_operation | Partial_construction { predecessor } -> predecessor, Signature.Public_key_hash.zero in - let partial = - match mode with - | Partial_construction _ -> true - | Application _ - | Full_construction _ - | Partial_application _ -> false in - Apply.apply_operation ~partial ctxt chain_id Optimized predecessor baker + Apply.apply_operation ctxt chain_id Optimized predecessor baker (Alpha_context.Operation.hash operation) operation >>=? fun (ctxt, result) -> let op_count = op_count + 1 in @@ -224,8 +221,12 @@ let finalize_block { mode ; ctxt ; op_count } = consumed_gas = Z.zero ; deactivated = []; balance_updates = []}) - | Partial_application { baker ; _ } -> - let level = Alpha_context. Level.current ctxt in + | Partial_application { block_header ; baker ; block_delay } -> + let level = Alpha_context.Level.current ctxt in + let included_endorsements = Alpha_context.included_endorsements ctxt in + Apply.check_minimum_endorsements ctxt + block_header.protocol_data.contents + block_delay included_endorsements >>=? fun () -> Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind -> let ctxt = Alpha_context.finalize ctxt in return (ctxt, Apply_results.{ baker ; @@ -236,16 +237,16 @@ let finalize_block { mode ; ctxt ; op_count } = deactivated = []; balance_updates = []}) | Application - { baker ; block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } } - | Full_construction { protocol_data ; baker ; _ } -> - Apply.finalize_application ctxt protocol_data baker >>=? fun (ctxt, receipt) -> + { baker ; block_delay ; block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } } + | Full_construction { protocol_data ; baker ; block_delay ; _ } -> + Apply.finalize_application ctxt protocol_data baker ~block_delay >>=? fun (ctxt, receipt) -> let level = Alpha_context.Level.current ctxt in let priority = protocol_data.priority in let raw_level = Alpha_context.Raw_level.to_int32 level.level in let fitness = Alpha_context.Fitness.current ctxt in let commit_message = Format.asprintf - "lvl %ld, fit %Ld, prio %d, %d ops" + "lvl %ld, fit 1:%Ld, prio %d, %d ops" raw_level fitness priority op_count in let ctxt = Alpha_context.finalize ~commit_message ctxt in return (ctxt, receipt) @@ -298,11 +299,17 @@ let init ctxt block_header = let fitness = block_header.fitness in let timestamp = block_header.timestamp in let typecheck (ctxt:Alpha_context.context) (script:Alpha_context.Script.t) = - Script_ir_translator.parse_script ctxt script >>=? fun (ex_script, ctxt) -> - Script_ir_translator.big_map_initialization ctxt Optimized ex_script >>=? fun (big_map_diff, ctxt) -> - return ((script, big_map_diff), ctxt) + Script_ir_translator.parse_script ctxt ~legacy:false script >>=? fun (Ex_script parsed_script, ctxt) -> + Script_ir_translator.extract_big_map_diff ctxt Optimized parsed_script.storage_type parsed_script.storage + ~to_duplicate: Script_ir_translator.no_big_map_id + ~to_update: Script_ir_translator.no_big_map_id + ~temporary:false >>=? fun (storage, big_map_diff, ctxt) -> + Script_ir_translator.unparse_data ctxt Optimized parsed_script.storage_type storage >>=? fun (storage, ctxt) -> + let storage = Alpha_context.Script.lazy_expr (Micheline.strip_locations storage) in + return (({ script with storage }, big_map_diff), ctxt) in Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> return (Alpha_context.finalize ctxt) +(* Vanity nonce: 415767323 *) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/main.mli b/vendors/ligo-utils/tezos-protocol-alpha/main.mli index bde08a85e..c0d9f66c3 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/main.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/main.mli @@ -29,10 +29,12 @@ type validation_mode = | Application of { block_header : Alpha_context.Block_header.t ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } | Partial_application of { block_header : Alpha_context.Block_header.t ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } | Partial_construction of { predecessor : Block_hash.t ; @@ -41,6 +43,7 @@ type validation_mode = predecessor : Block_hash.t ; protocol_data : Alpha_context.Block_header.contents ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } type validation_state = diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml index 0e7e45617..f61e519fe 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml @@ -27,48 +27,6 @@ open Alpha_context open Gas module Cost_of = struct - let cycle = step_cost 1 - let nop = free - - let stack_op = step_cost 1 - - let bool_binop _ _ = step_cost 1 - let bool_unop _ = step_cost 1 - - let pair = alloc_cost 2 - let pair_access = step_cost 1 - - let cons = alloc_cost 2 - - let variant_no_data = alloc_cost 1 - - let branch = step_cost 2 - - let string length = - alloc_bytes_cost length - - let bytes length = - alloc_mbytes_cost length - - let zint z = - alloc_bits_cost (Z.numbits z) - - let concat cost length ss = - let rec cum acc = function - | [] -> acc - | s :: ss -> cum (cost (length s) +@ acc) ss in - cum free ss - - let concat_string ss = concat string String.length ss - let concat_bytes ss = concat bytes MBytes.length ss - - let slice_string length = string length - let slice_bytes = alloc_cost 0 - - (* Cost per cycle of a loop, fold, etc *) - let loop_cycle = step_cost 2 - - let list_size = step_cost 1 let log2 = let rec help acc = function @@ -76,174 +34,265 @@ module Cost_of = struct | n -> help (acc + 1) (n / 2) in help 1 - let module_cost = alloc_cost 10 + let z_bytes (z : Z.t) = + let bits = Z.numbits z in + (7 + bits) / 8 - let map_access : type key value. (key, value) Script_typed_ir.map -> int - = fun (module Box) -> - log2 (snd Box.boxed) + let int_bytes (z : 'a Script_int.num) = + z_bytes (Script_int.to_zint z) - let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost - = fun (module Box) -> - let size = snd Box.boxed in - 3 *@ alloc_cost size + let timestamp_bytes (t : Script_timestamp.t) = + let z = Script_timestamp.to_zint t in + z_bytes z - let map_mem _key map = step_cost (map_access map) + (* For now, returns size in bytes, but this could get more complicated... *) + let rec size_of_comparable : type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int = + fun wit v -> + match wit with + | Int_key _ -> int_bytes v + | Nat_key _ -> int_bytes v + | String_key _ -> String.length v + | Bytes_key _ -> MBytes.length v + | Bool_key _ -> 8 + | Key_hash_key _ -> Signature.Public_key_hash.size + | Timestamp_key _ -> timestamp_bytes v + | Address_key _ -> Signature.Public_key_hash.size + | Mutez_key _ -> 8 + | Pair_key ((l, _), (r, _), _) -> + let (lval, rval) = v in + size_of_comparable l lval + size_of_comparable r rval - let map_get = map_mem + let string length = + alloc_bytes_cost length - let map_update _ _ map = - map_access map *@ alloc_cost 3 - - let map_size = step_cost 2 - - let big_map_mem _key _map = step_cost 50 - let big_map_get _key _map = step_cost 50 - let big_map_update _key _value _map = step_cost 10 - - let set_access : type elt. elt -> elt Script_typed_ir.set -> int - = fun _key (module Box) -> - log2 @@ Box.size - - let set_mem key set = step_cost (set_access key set) - - let set_update key _presence set = - set_access key set *@ alloc_cost 3 - - (* for LEFT, RIGHT, SOME *) - let wrap = alloc_cost 1 - - let mul n1 n2 = - let steps = - (Z.numbits (Script_int.to_zint n1)) - * (Z.numbits (Script_int.to_zint n2)) in - let bits = - (Z.numbits (Script_int.to_zint n1)) - + (Z.numbits (Script_int.to_zint n2)) in - step_cost steps +@ alloc_bits_cost bits - - let div n1 n2 = - mul n1 n2 +@ alloc_cost 2 - - let add_sub_z n1 n2 = - let bits = - Compare.Int.max (Z.numbits n1) (Z.numbits n2) in - step_cost bits +@ alloc_cost bits - - let add n1 n2 = - add_sub_z (Script_int.to_zint n1) (Script_int.to_zint n2) - - let sub = add - - let abs n = - alloc_bits_cost (Z.numbits @@ Script_int.to_zint n) - - let neg = abs - let int _ = step_cost 1 - - let add_timestamp t n = - add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n) - - let sub_timestamp t n = - add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n) - - let diff_timestamps t1 t2 = - add_sub_z (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2) - - let empty_set = module_cost - - let set_size = step_cost 2 - - let set_to_list : type item. item Script_typed_ir.set -> cost - = fun (module Box) -> - alloc_cost @@ Pervasives.(Box.size * 2) - - let empty_map = module_cost - - let int64_op = step_cost 1 +@ alloc_cost 1 - - let z_to_int64 = step_cost 2 +@ alloc_cost 1 - - let int64_to_z = step_cost 2 +@ alloc_cost 1 - - let bitwise_binop n1 n2 = - let bits = Compare.Int.max (Z.numbits (Script_int.to_zint n1)) (Z.numbits (Script_int.to_zint n2)) in - step_cost bits +@ alloc_bits_cost bits - - let logor = bitwise_binop - let logand = bitwise_binop - let logxor = bitwise_binop - let lognot n = - let bits = Z.numbits @@ Script_int.to_zint n in - step_cost bits +@ alloc_cost bits - - let unopt ~default = function - | None -> default - | Some x -> x - - let max_int = 1073741823 - - let shift_left x y = - alloc_bits_cost - (Z.numbits (Script_int.to_zint x) + - (unopt (Script_int.to_int y) ~default:max_int)) - - let shift_right x y = - alloc_bits_cost - (Compare.Int.max 1 - (Z.numbits (Script_int.to_zint x) - - unopt (Script_int.to_int y) ~default:max_int)) - - let exec = step_cost 1 - - let push = step_cost 1 - - let compare_res = step_cost 1 - - let unpack_failed bytes = - (* We cannot instrument failed deserialization, - so we take worst case fees: a set of size 1 bytes values. *) - let len = MBytes.length bytes in - (len *@ alloc_mbytes_cost 1) +@ - (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1))) - - let address = step_cost 1 - let contract = Gas.read_bytes_cost Z.zero +@ step_cost 10000 - let transfer = step_cost 10 - let create_account = step_cost 10 - let create_contract = step_cost 10 - let implicit_account = step_cost 10 - let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32) - let balance = step_cost 1 +@ read_bytes_cost (Z.of_int 8) - let now = step_cost 5 - let check_signature = step_cost 1000 - let hash_key = step_cost 3 +@ bytes 20 - let hash data len = 10 *@ step_cost (MBytes.length data) +@ bytes len - let steps_to_quota = step_cost 1 - let source = step_cost 1 - let self = step_cost 1 - let amount = step_cost 1 - let compare_bool _ _ = step_cost 1 - let compare_string s1 s2 = - step_cost ((7 + Compare.Int.max (String.length s1) (String.length s2)) / 8) +@ step_cost 1 - let compare_bytes s1 s2 = - step_cost ((7 + Compare.Int.max (MBytes.length s1) (MBytes.length s2)) / 8) +@ step_cost 1 - let compare_tez _ _ = step_cost 1 - let compare_zint n1 n2 = step_cost ((7 + Compare.Int.max (Z.numbits n1) (Z.numbits n2)) / 8) +@ step_cost 1 - let compare_int n1 n2 = compare_zint (Script_int.to_zint n1) (Script_int.to_zint n2) - let compare_nat = compare_int - let compare_key_hash _ _ = alloc_bytes_cost 36 - let compare_timestamp t1 t2 = compare_zint (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2) - let compare_address _ _ = step_cost 20 + let bytes length = + alloc_mbytes_cost length let manager_operation = step_cost 10_000 + module Legacy = struct + let zint z = + alloc_bits_cost (Z.numbits z) + + let set_to_list : type item. item Script_typed_ir.set -> cost + = fun (module Box) -> + alloc_cost @@ Pervasives.(Box.size * 2) + + let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost + = fun (module Box) -> + let size = snd Box.boxed in + 3 *@ alloc_cost size + + let z_to_int64 = step_cost 2 +@ alloc_cost 1 + + let hash data len = 10 *@ step_cost (MBytes.length data) +@ bytes len + + let set_access : type elt. elt -> elt Script_typed_ir.set -> int + = fun _key (module Box) -> + log2 @@ Box.size + + let set_update key _presence set = + set_access key set *@ alloc_cost 3 + end + + module Interpreter = struct + let cycle = atomic_step_cost 10 + let nop = free + let stack_op = atomic_step_cost 10 + let push = atomic_step_cost 10 + let wrap = atomic_step_cost 10 + let variant_no_data = atomic_step_cost 10 + let branch = atomic_step_cost 10 + let pair = atomic_step_cost 10 + let pair_access = atomic_step_cost 10 + let cons = atomic_step_cost 10 + let loop_size = atomic_step_cost 5 + let loop_cycle = atomic_step_cost 10 + let loop_iter = atomic_step_cost 20 + let loop_map = atomic_step_cost 30 + let empty_set = atomic_step_cost 10 + let set_to_list : type elt. elt Script_typed_ir.set -> cost = + fun (module Box) -> + atomic_step_cost (Box.size * 20) + + let set_mem : type elt. elt -> elt Script_typed_ir.set -> cost = + fun elt (module Box) -> + let elt_bytes = size_of_comparable Box.elt_ty elt in + atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size) + + let set_update : type elt. elt -> bool -> elt Script_typed_ir.set -> cost = + fun elt _ (module Box) -> + let elt_bytes = size_of_comparable Box.elt_ty elt in + atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size) + + let set_size = atomic_step_cost 10 + let empty_map = atomic_step_cost 10 + let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost = + fun (module Box) -> + let size = snd Box.boxed in + atomic_step_cost (size * 20) + + let map_access : type key value. key -> (key, value) Script_typed_ir.map -> cost + = fun key (module Box) -> + let map_card = snd Box.boxed in + let key_bytes = size_of_comparable Box.key_ty key in + atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card) + + let map_mem = map_access + let map_get = map_access + + let map_update : type key value. key -> value option -> (key, value) Script_typed_ir.map -> cost + = fun key _value (module Box) -> + let map_card = snd Box.boxed in + let key_bytes = size_of_comparable Box.key_ty key in + atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card) + + let map_size = atomic_step_cost 10 + + let add_timestamp (t1 : Script_timestamp.t) (t2 : 'a Script_int.num) = + let bytes1 = timestamp_bytes t1 in + let bytes2 = int_bytes t2 in + atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62)) + let sub_timestamp = add_timestamp + let diff_timestamps (t1 : Script_timestamp.t) (t2 : Script_timestamp.t) = + let bytes1 = timestamp_bytes t1 in + let bytes2 = timestamp_bytes t2 in + atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62)) + + let rec concat_loop l acc = + match l with + | [] -> 30 + | _ :: tl -> concat_loop tl (acc + 30) + + let concat_string string_list = + atomic_step_cost (concat_loop string_list 0) + + let slice_string string_length = + atomic_step_cost (40 + (string_length / 70)) + + let concat_bytes bytes_list = + atomic_step_cost (concat_loop bytes_list 0) + + let int64_op = atomic_step_cost 61 + let z_to_int64 = atomic_step_cost 20 + let int64_to_z = atomic_step_cost 20 + let bool_binop _ _ = atomic_step_cost 10 + let bool_unop _ = atomic_step_cost 10 + + let abs int = atomic_step_cost (61 + ((int_bytes int) / 70)) + let int _int = free + let neg = abs + let add i1 i2 = atomic_step_cost (51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62)) + let sub = add + + let mul i1 i2 = + let bytes = Compare.Int.max (int_bytes i1) (int_bytes i2) in + atomic_step_cost (51 + (bytes / 6 * log2 bytes)) + + let indic_lt x y = if Compare.Int.(x < y) then 1 else 0 + + let div i1 i2 = + let bytes1 = int_bytes i1 in + let bytes2 = int_bytes i2 in + let cost = indic_lt bytes2 bytes1 * (bytes1 - bytes2) * bytes2 in + atomic_step_cost (51 + (cost / 3151)) + + let shift_left _i _shift_bits = atomic_step_cost 30 + let shift_right _i _shift_bits = atomic_step_cost 30 + let logor i1 i2 = + let bytes1 = int_bytes i1 in + let bytes2 = int_bytes i2 in + atomic_step_cost (51 + ((Compare.Int.max bytes1 bytes2) / 70)) + let logand i1 i2 = + let bytes1 = int_bytes i1 in + let bytes2 = int_bytes i2 in + atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 70)) + let logxor = logor + let lognot i = atomic_step_cost (51 + ((int_bytes i) / 20)) + let exec = atomic_step_cost 10 + let compare_bool _ _ = atomic_step_cost 30 + + let compare_string s1 s2 = + let bytes1 = String.length s1 in + let bytes2 = String.length s2 in + atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123)) + let compare_bytes b1 b2 = + let bytes1 = MBytes.length b1 in + let bytes2 = MBytes.length b2 in + atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123)) + let compare_tez _ _ = atomic_step_cost 30 + let compare_zint i1 i2 = + atomic_step_cost (51 + ((Compare.Int.min (int_bytes i1) (int_bytes i2)) / 82)) + let compare_key_hash _ _ = atomic_step_cost 92 + + let compare_timestamp t1 t2 = + let bytes1 = timestamp_bytes t1 in + let bytes2 = timestamp_bytes t2 in + atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 82)) + + let compare_address _ _ = atomic_step_cost 92 + let compare_res = atomic_step_cost 30 + let unpack_failed bytes = + (* We cannot instrument failed deserialization, + so we take worst case fees: a set of size 1 bytes values. *) + let len = MBytes.length bytes in + (len *@ alloc_mbytes_cost 1) +@ + (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1))) + let address = atomic_step_cost 10 + let contract = step_cost 10000 + let transfer = step_cost 10 + let create_account = step_cost 10 + let create_contract = step_cost 10 + let implicit_account = step_cost 10 + let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32) + let balance = atomic_step_cost 10 + let now = atomic_step_cost 10 + let check_signature_secp256k1 bytes = atomic_step_cost (10342 + (bytes / 5)) + let check_signature_ed25519 bytes = atomic_step_cost (36864 + (bytes / 5)) + let check_signature_p256 bytes = atomic_step_cost (36864 + (bytes / 5)) + let check_signature (pkey : Signature.public_key) bytes = + match pkey with + | Ed25519 _ -> check_signature_ed25519 (MBytes.length bytes) + | Secp256k1 _ -> check_signature_secp256k1 (MBytes.length bytes) + | P256 _ -> check_signature_p256 (MBytes.length bytes) + let hash_key = atomic_step_cost 30 + let hash_blake2b b = atomic_step_cost (102 + ((MBytes.length b) / 5)) + let hash_sha256 b = atomic_step_cost (409 + (MBytes.length b)) + let hash_sha512 b = + let bytes = MBytes.length b in atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4))) + let steps_to_quota = atomic_step_cost 10 + let source = atomic_step_cost 10 + let self = atomic_step_cost 10 + let amount = atomic_step_cost 10 + let chain_id = step_cost 1 + let stack_n_op n = atomic_step_cost (20 + (((n lsr 1) + (n lsr 2)) + (n lsr 4))) + let apply = alloc_cost 8 +@ step_cost 1 + + let rec compare : type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost = fun ty x y -> + match ty with + | Bool_key _ -> compare_bool x y + | String_key _ -> compare_string x y + | Bytes_key _ -> compare_bytes x y + | Mutez_key _ -> compare_tez x y + | Int_key _ -> compare_zint x y + | Nat_key _ -> compare_zint x y + | Key_hash_key _ -> compare_key_hash x y + | Timestamp_key _ -> compare_timestamp x y + | Address_key _ -> compare_address x y + | Pair_key ((tl, _), (tr, _), _) -> + (* Reasonable over-approximation of the cost of lexicographic comparison. *) + let (xl, xr) = x and (yl, yr) = y in + compare tl xl yl +@ compare tr xr yr + + end + module Typechecking = struct let cycle = step_cost 1 let bool = free let unit = free let string = string let bytes = bytes - let z = zint + let z = Legacy.zint let int_of_string str = alloc_cost @@ (Pervasives.(/) (String.length str) 5) let tez = step_cost 1 +@ alloc_cost 1 @@ -251,6 +300,7 @@ module Cost_of = struct let key = step_cost 3 +@ alloc_cost 3 let key_hash = step_cost 1 +@ alloc_cost 1 let signature = step_cost 1 +@ alloc_cost 1 + let chain_id = step_cost 1 +@ alloc_cost 1 let contract = step_cost 5 let get_script = step_cost 20 +@ alloc_cost 5 let contract_exists = step_cost 15 +@ alloc_cost 5 @@ -308,6 +358,7 @@ module Cost_of = struct | Map_get -> alloc_cost 1 | Map_update -> alloc_cost 1 | Map_size -> alloc_cost 1 + | Empty_big_map _ -> alloc_cost 2 | Big_map_mem -> alloc_cost 1 | Big_map_get -> alloc_cost 1 | Big_map_update -> alloc_cost 1 @@ -365,6 +416,7 @@ module Cost_of = struct | Loop_left _ -> alloc_cost 5 | Dip _ -> alloc_cost 4 | Exec -> alloc_cost 1 + | Apply _ -> alloc_cost 1 | Lambda _ -> alloc_cost 2 | Failwith _ -> alloc_cost 1 | Nop -> alloc_cost 0 @@ -381,6 +433,12 @@ module Cost_of = struct | Create_account -> alloc_cost 2 | Implicit_account -> alloc_cost 1 | Create_contract _ -> alloc_cost 8 + (* Deducted the cost of removed arguments manager, spendable and delegatable: + - manager: key_hash = 1 + - spendable: bool = 0 + - delegatable: bool = 0 + *) + | Create_contract_2 _ -> alloc_cost 7 | Set_delegate -> alloc_cost 1 | Now -> alloc_cost 1 | Balance -> alloc_cost 1 @@ -396,6 +454,11 @@ module Cost_of = struct | Sender -> alloc_cost 1 | Self _ -> alloc_cost 2 | Amount -> alloc_cost 1 + | Dig (n,_) -> n *@ alloc_cost 1 (* _ is a unary development of n *) + | Dug (n,_) -> n *@ alloc_cost 1 + | Dipn (n,_,_) -> n *@ alloc_cost 1 + | Dropn (n,_) -> n *@ alloc_cost 1 + | ChainId -> alloc_cost 1 end module Unparse = struct @@ -415,6 +478,7 @@ module Cost_of = struct let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *) let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int let operation bytes = Script.bytes_node_cost bytes + let chain_id bytes = Script.bytes_node_cost bytes let key = string_cost 54 let key_hash = string_cost 36 let signature = string_cost 128 @@ -429,8 +493,8 @@ module Cost_of = struct let one_arg_type = prim_cost 1 let two_arg_type = prim_cost 2 - let set_to_list = set_to_list - let map_to_list = map_to_list + let set_to_list = Legacy.set_to_list + let map_to_list = Legacy.map_to_list end end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli index cfb121cf9..c950a7496 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli @@ -26,93 +26,94 @@ open Alpha_context module Cost_of : sig - val cycle : Gas.cost - val loop_cycle : Gas.cost - val list_size : Gas.cost - val nop : Gas.cost - val stack_op : Gas.cost - val bool_binop : 'a -> 'b -> Gas.cost - val bool_unop : 'a -> Gas.cost - val pair : Gas.cost - val pair_access : Gas.cost - val cons : Gas.cost - val variant_no_data : Gas.cost - val branch : Gas.cost - val concat_string : string list -> Gas.cost - val concat_bytes : MBytes.t list -> Gas.cost - val slice_string : int -> Gas.cost - val slice_bytes : Gas.cost - val map_mem : - 'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost - val map_to_list : - ('b, 'c) Script_typed_ir.map -> Gas.cost - val map_get : - 'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost - val map_update : - 'a -> 'b -> ('c, 'd) Script_typed_ir.map -> Gas.cost - val map_size : Gas.cost - val big_map_mem : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost - val big_map_get : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost - val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost - val set_to_list : 'a Script_typed_ir.set -> Gas.cost - val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost - val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost - val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val abs : 'a Script_int.num -> Gas.cost - val neg : 'a Script_int.num -> Gas.cost - val int : 'a -> Gas.cost - val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost - val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost - val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost - val empty_set : Gas.cost - val set_size : Gas.cost - val empty_map : Gas.cost - val int64_op : Gas.cost - val z_to_int64 : Gas.cost - val int64_to_z : Gas.cost - val bitwise_binop : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val lognot : 'a Script_int.num -> Gas.cost - val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val exec : Gas.cost - val push : Gas.cost - val compare_res : Gas.cost - val unpack_failed : MBytes.t -> Gas.cost - val address : Gas.cost - val contract : Gas.cost - val transfer : Gas.cost - val create_account : Gas.cost - val create_contract : Gas.cost - val implicit_account : Gas.cost - val set_delegate : Gas.cost - val balance : Gas.cost - val now : Gas.cost - val check_signature : Gas.cost - val hash_key : Gas.cost - val hash : MBytes.t -> int -> Gas.cost - val steps_to_quota : Gas.cost - val source : Gas.cost - val self : Gas.cost - val amount : Gas.cost - val wrap : Gas.cost - val compare_bool : 'a -> 'b -> Gas.cost - val compare_string : string -> string -> Gas.cost - val compare_bytes : MBytes.t -> MBytes.t -> Gas.cost - val compare_tez : 'a -> 'b -> Gas.cost - val compare_int : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val compare_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val compare_key_hash : 'a -> 'b -> Gas.cost - val compare_timestamp : Script_timestamp.t -> Script_timestamp.t -> Gas.cost - val compare_address : Contract.t -> Contract.t -> Gas.cost val manager_operation : Gas.cost + module Legacy : sig + val z_to_int64 : Gas.cost + val hash : MBytes.t -> int -> Gas.cost + val map_to_list : + ('b, 'c) Script_typed_ir.map -> Gas.cost + val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost + end + + module Interpreter : sig + val cycle : Gas.cost + val loop_cycle : Gas.cost + val loop_size : Gas.cost + val loop_iter : Gas.cost + val loop_map : Gas.cost + val nop : Gas.cost + val stack_op : Gas.cost + val stack_n_op : int -> Gas.cost + val bool_binop : 'a -> 'b -> Gas.cost + val bool_unop : 'a -> Gas.cost + val pair : Gas.cost + val pair_access : Gas.cost + val cons : Gas.cost + val variant_no_data : Gas.cost + val branch : Gas.cost + val concat_string : string list -> Gas.cost + val concat_bytes : MBytes.t list -> Gas.cost + val slice_string : int -> Gas.cost + val map_mem : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_get : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_update : 'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_size : Gas.cost + val set_to_list : 'a Script_typed_ir.set -> Gas.cost + val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost + val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost + val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val abs : 'a Script_int.num -> Gas.cost + val neg : 'a Script_int.num -> Gas.cost + val int : 'a -> Gas.cost + val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost + val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost + val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost + val empty_set : Gas.cost + val set_size : Gas.cost + val empty_map : Gas.cost + val int64_op : Gas.cost + val z_to_int64 : Gas.cost + val int64_to_z : Gas.cost + val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val lognot : 'a Script_int.num -> Gas.cost + val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val exec : Gas.cost + val push : Gas.cost + val compare_res : Gas.cost + val unpack_failed : MBytes.t -> Gas.cost + val address : Gas.cost + val contract : Gas.cost + val transfer : Gas.cost + val create_account : Gas.cost + val create_contract : Gas.cost + val implicit_account : Gas.cost + val set_delegate : Gas.cost + val balance : Gas.cost + val now : Gas.cost + val check_signature : public_key -> MBytes.t -> Gas.cost + val hash_key : Gas.cost + val hash_blake2b : MBytes.t -> Gas.cost + val hash_sha256 : MBytes.t -> Gas.cost + val hash_sha512 : MBytes.t -> Gas.cost + val steps_to_quota : Gas.cost + val source : Gas.cost + val self : Gas.cost + val amount : Gas.cost + val chain_id : Gas.cost + val wrap : Gas.cost + val compare : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> Gas.cost + val apply : Gas.cost + end + module Typechecking : sig val cycle : Gas.cost val unit : Gas.cost @@ -126,6 +127,7 @@ module Cost_of : sig val key : Gas.cost val key_hash : Gas.cost val signature : Gas.cost + val chain_id : Gas.cost val contract : Gas.cost @@ -177,6 +179,7 @@ module Cost_of : sig val key_hash : Gas.cost val signature : Gas.cost val operation : MBytes.t -> Gas.cost + val chain_id : MBytes.t -> Gas.cost val contract : Gas.cost diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml index d80f5f7eb..6c6a1025b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml @@ -54,6 +54,7 @@ type prim = | I_BALANCE | I_CAR | I_CDR + | I_CHAIN_ID | I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT @@ -65,10 +66,12 @@ type prim = | I_DROP | I_DUP | I_EDIV + | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC + | I_APPLY | I_FAILWITH | I_GE | I_GET @@ -120,6 +123,8 @@ type prim = | I_ISNAT | I_CAST | I_RENAME + | I_DIG + | I_DUG | T_bool | T_contract | T_int @@ -142,6 +147,7 @@ type prim = | T_unit | T_operation | T_address + | T_chain_id let valid_case name = let is_lower = function '_' | 'a'..'z' -> true | _ -> false in @@ -187,6 +193,7 @@ let string_of_prim = function | I_BALANCE -> "BALANCE" | I_CAR -> "CAR" | I_CDR -> "CDR" + | I_CHAIN_ID -> "CHAIN_ID" | I_CHECK_SIGNATURE -> "CHECK_SIGNATURE" | I_COMPARE -> "COMPARE" | I_CONCAT -> "CONCAT" @@ -198,10 +205,12 @@ let string_of_prim = function | I_DROP -> "DROP" | I_DUP -> "DUP" | I_EDIV -> "EDIV" + | I_EMPTY_BIG_MAP -> "EMPTY_BIG_MAP" | I_EMPTY_MAP -> "EMPTY_MAP" | I_EMPTY_SET -> "EMPTY_SET" | I_EQ -> "EQ" | I_EXEC -> "EXEC" + | I_APPLY -> "APPLY" | I_FAILWITH -> "FAILWITH" | I_GE -> "GE" | I_GET -> "GET" @@ -253,6 +262,8 @@ let string_of_prim = function | I_ISNAT -> "ISNAT" | I_CAST -> "CAST" | I_RENAME -> "RENAME" + | I_DIG -> "DIG" + | I_DUG -> "DUG" | T_bool -> "bool" | T_contract -> "contract" | T_int -> "int" @@ -275,6 +286,7 @@ let string_of_prim = function | T_unit -> "unit" | T_operation -> "operation" | T_address -> "address" + | T_chain_id -> "chain_id" let prim_of_string = function | "parameter" -> ok K_parameter @@ -301,6 +313,7 @@ let prim_of_string = function | "BALANCE" -> ok I_BALANCE | "CAR" -> ok I_CAR | "CDR" -> ok I_CDR + | "CHAIN_ID" -> ok I_CHAIN_ID | "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE | "COMPARE" -> ok I_COMPARE | "CONCAT" -> ok I_CONCAT @@ -312,10 +325,12 @@ let prim_of_string = function | "DROP" -> ok I_DROP | "DUP" -> ok I_DUP | "EDIV" -> ok I_EDIV + | "EMPTY_BIG_MAP" -> ok I_EMPTY_BIG_MAP | "EMPTY_MAP" -> ok I_EMPTY_MAP | "EMPTY_SET" -> ok I_EMPTY_SET | "EQ" -> ok I_EQ | "EXEC" -> ok I_EXEC + | "APPLY" -> ok I_APPLY | "FAILWITH" -> ok I_FAILWITH | "GE" -> ok I_GE | "GET" -> ok I_GET @@ -367,6 +382,8 @@ let prim_of_string = function | "ISNAT" -> ok I_ISNAT | "CAST" -> ok I_CAST | "RENAME" -> ok I_RENAME + | "DIG" -> ok I_DIG + | "DUG" -> ok I_DUG | "bool" -> ok T_bool | "contract" -> ok T_contract | "int" -> ok T_int @@ -389,6 +406,7 @@ let prim_of_string = function | "unit" -> ok T_unit | "operation" -> ok T_operation | "address" -> ok T_address + | "chain_id" -> ok T_chain_id | n -> if valid_case n then error (Unknown_primitive_name n) @@ -436,6 +454,7 @@ let prim_encoding = let open Data_encoding in def "michelson.v1.primitives" @@ string_enum [ + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("parameter", K_parameter) ; ("storage", K_storage) ; ("code", K_code) ; @@ -446,6 +465,7 @@ let prim_encoding = ("Pair", D_Pair) ; ("Right", D_Right) ; ("Some", D_Some) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("True", D_True) ; ("Unit", D_Unit) ; ("PACK", I_PACK) ; @@ -456,6 +476,7 @@ let prim_encoding = ("ABS", I_ABS) ; ("ADD", I_ADD) ; ("AMOUNT", I_AMOUNT) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("AND", I_AND) ; ("BALANCE", I_BALANCE) ; ("CAR", I_CAR) ; @@ -466,6 +487,7 @@ let prim_encoding = ("CONS", I_CONS) ; ("CREATE_ACCOUNT", I_CREATE_ACCOUNT) ; ("CREATE_CONTRACT", I_CREATE_CONTRACT) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) ; ("DIP", I_DIP) ; ("DROP", I_DROP) ; @@ -476,6 +498,7 @@ let prim_encoding = ("EQ", I_EQ) ; ("EXEC", I_EXEC) ; ("FAILWITH", I_FAILWITH) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("GE", I_GE) ; ("GET", I_GET) ; ("GT", I_GT) ; @@ -486,6 +509,7 @@ let prim_encoding = ("IF_NONE", I_IF_NONE) ; ("INT", I_INT) ; ("LAMBDA", I_LAMBDA) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("LE", I_LE) ; ("LEFT", I_LEFT) ; ("LOOP", I_LOOP) ; @@ -496,6 +520,7 @@ let prim_encoding = ("MEM", I_MEM) ; ("MUL", I_MUL) ; ("NEG", I_NEG) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("NEQ", I_NEQ) ; ("NIL", I_NIL) ; ("NONE", I_NONE) ; @@ -506,6 +531,7 @@ let prim_encoding = ("PUSH", I_PUSH) ; ("RIGHT", I_RIGHT) ; ("SIZE", I_SIZE) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("SOME", I_SOME) ; ("SOURCE", I_SOURCE) ; ("SENDER", I_SENDER) ; @@ -516,6 +542,7 @@ let prim_encoding = ("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ; ("SET_DELEGATE", I_SET_DELEGATE) ; ("UNIT", I_UNIT) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("UPDATE", I_UPDATE) ; ("XOR", I_XOR) ; ("ITER", I_ITER) ; @@ -526,6 +553,7 @@ let prim_encoding = ("CAST", I_CAST) ; ("RENAME", I_RENAME) ; ("bool", T_bool) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("contract", T_contract) ; ("int", T_int) ; ("key", T_key) ; @@ -536,6 +564,7 @@ let prim_encoding = ("big_map", T_big_map) ; ("nat", T_nat) ; ("option", T_option) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("or", T_or) ; ("pair", T_pair) ; ("set", T_set) ; @@ -546,9 +575,18 @@ let prim_encoding = ("timestamp", T_timestamp) ; ("unit", T_unit) ; ("operation", T_operation) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("address", T_address) ; (* Alpha_002 addition *) ("SLICE", I_SLICE) ; + (* Alpha_005 addition *) + ("DIG", I_DIG) ; + ("DUG", I_DUG) ; + ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP) ; + ("APPLY", I_APPLY) ; + ("chain_id", T_chain_id) ; + ("CHAIN_ID", I_CHAIN_ID) + (* New instructions must be added here, for backward compatibility of the encoding. *) ] let () = diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli index c51e8b443..6a0852bf4 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli @@ -52,6 +52,7 @@ type prim = | I_BALANCE | I_CAR | I_CDR + | I_CHAIN_ID | I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT @@ -63,10 +64,12 @@ type prim = | I_DROP | I_DUP | I_EDIV + | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC + | I_APPLY | I_FAILWITH | I_GE | I_GET @@ -118,6 +121,8 @@ type prim = | I_ISNAT | I_CAST | I_RENAME + | I_DIG + | I_DUG | T_bool | T_contract | T_int @@ -140,6 +145,7 @@ type prim = | T_unit | T_operation | T_address + | T_chain_id val prim_encoding : prim Data_encoding.encoding diff --git a/vendors/ligo-utils/tezos-protocol-alpha/misc.mli b/vendors/ligo-utils/tezos-protocol-alpha/misc.mli index 6e359e0b4..407d7480b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/misc.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/misc.mli @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(** {2 Stuff} ****************************************************************) +(** {2 Helper functions} *) type 'a lazyt = unit -> 'a type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml index 17a62d71c..f07ef5c55 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml @@ -98,7 +98,7 @@ and _ contents = ballot: Vote_repr.ballot ; } -> Kind.ballot contents | Manager_operation : { - source: Contract_repr.contract ; + source: Signature.public_key_hash ; fee: Tez_repr.tez ; counter: counter ; operation: 'kind manager_operation ; @@ -110,15 +110,13 @@ and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : { amount: Tez_repr.tez ; - parameters: Script_repr.lazy_expr option ; + parameters: Script_repr.lazy_expr ; + entrypoint: string ; destination: Contract_repr.contract ; } -> Kind.transaction manager_operation | Origination : { - manager: Signature.Public_key_hash.t ; delegate: Signature.Public_key_hash.t option ; - script: Script_repr.t option ; - spendable: bool ; - delegatable: bool ; + script: Script_repr.t ; credit: Tez_repr.tez ; preorigination: Contract_repr.t option ; } -> Kind.origination manager_operation @@ -225,6 +223,22 @@ module Encoding = struct (fun pkh -> Reveal pkh) } + let entrypoint_encoding = + def + ~title:"entrypoint" + ~description:"Named entrypoint to a Michelson smart contract" + "entrypoint" @@ + let builtin_case tag name = + Data_encoding.case (Tag tag) ~title:name + (constant name) + (fun n -> if Compare.String.(n = name) then Some () else None) (fun () -> name) in + union [ builtin_case 0 "default" ; + builtin_case 1 "root" ; + builtin_case 2 "do" ; + builtin_case 3 "set_delegate" ; + builtin_case 4 "remove_delegate" ; + Data_encoding.case (Tag 255) ~title:"named" (Bounded.string 31) (fun s -> Some s) (fun s -> s) ] + let transaction_case = MCase { tag = 1 ; @@ -233,18 +247,29 @@ module Encoding = struct (obj3 (req "amount" Tez_repr.encoding) (req "destination" Contract_repr.encoding) - (opt "parameters" Script_repr.lazy_expr_encoding)) ; + (opt "parameters" + (obj2 + (req "entrypoint" entrypoint_encoding) + (req "value" Script_repr.lazy_expr_encoding)))) ; select = (function | Manager (Transaction _ as op) -> Some op | _ -> None) ; proj = (function - | Transaction { amount ; destination ; parameters } -> + | Transaction { amount ; destination ; parameters ; entrypoint } -> + let parameters = + if Script_repr.is_unit_parameter parameters && Compare.String.(entrypoint = "default") then + None + else + Some (entrypoint, parameters) in (amount, destination, parameters)) ; inj = (fun (amount, destination, parameters) -> - Transaction { amount ; destination ; parameters }) + let entrypoint, parameters = match parameters with + | None -> "default", Script_repr.unit_parameter + | Some (entrypoint, value) -> entrypoint, value in + Transaction { amount ; destination ; parameters ; entrypoint }) } let origination_case = @@ -252,32 +277,26 @@ module Encoding = struct tag = 2 ; name = "origination" ; encoding = - (obj6 - (req "manager_pubkey" Signature.Public_key_hash.encoding) + (obj3 (req "balance" Tez_repr.encoding) - (dft "spendable" bool true) - (dft "delegatable" bool true) (opt "delegate" Signature.Public_key_hash.encoding) - (opt "script" Script_repr.encoding)) ; + (req "script" Script_repr.encoding)) ; select = (function | Manager (Origination _ as op) -> Some op | _ -> None) ; proj = (function - | Origination { manager ; credit ; spendable ; - delegatable ; delegate ; script ; + | Origination { credit ; delegate ; script ; preorigination = _ (* the hash is only used internally when originating from smart contracts, don't serialize it *) } -> - (manager, credit, spendable, - delegatable, delegate, script)) ; + (credit, delegate, script)) ; inj = - (fun (manager, credit, spendable, delegatable, delegate, script) -> + (fun (credit, delegate, script) -> Origination - {manager ; credit ; spendable ; delegatable ; - delegate ; script ; preorigination = None }) + {credit ; delegate ; script ; preorigination = None }) } let delegation_case = @@ -482,7 +501,7 @@ module Encoding = struct let manager_encoding = (obj5 - (req "source" Contract_repr.encoding) + (req "source" Signature.Public_key_hash.encoding) (req "fee" Tez_repr.encoding) (req "counter" (check_size 10 n)) (req "gas_limit" (check_size 10 n)) @@ -526,10 +545,10 @@ module Encoding = struct (rebuild op (mcase.inj contents))) } - let reveal_case = make_manager_case 7 Manager_operations.reveal_case - let transaction_case = make_manager_case 8 Manager_operations.transaction_case - let origination_case = make_manager_case 9 Manager_operations.origination_case - let delegation_case = make_manager_case 10 Manager_operations.delegation_case + let reveal_case = make_manager_case 107 Manager_operations.reveal_case + let transaction_case = make_manager_case 108 Manager_operations.transaction_case + let origination_case = make_manager_case 109 Manager_operations.origination_case + let delegation_case = make_manager_case 110 Manager_operations.delegation_case let contents_encoding = let make (Case { tag ; name ; encoding ; select ; proj ; inj }) = @@ -668,12 +687,12 @@ let check_signature_sync (type kind) key chain_id ({ shell ; protocol_data } : k if Signature.check ~watermark key signature unsigned_operation then Ok () else - Error [Invalid_signature] in + error Invalid_signature in match protocol_data.contents, protocol_data.signature with | Single _, None -> - Error [Missing_signature] + error Missing_signature | Cons _, None -> - Error [Missing_signature] + error Missing_signature | Single (Endorsement _) as contents, Some signature -> check ~watermark:(Endorsement chain_id) (Contents_list contents) signature | Single _ as contents, Some signature -> diff --git a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli index fe1dcb754..dd46b15c9 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli @@ -99,7 +99,7 @@ and _ contents = ballot: Vote_repr.ballot ; } -> Kind.ballot contents | Manager_operation : { - source: Contract_repr.contract ; + source: Signature.Public_key_hash.t ; fee: Tez_repr.tez ; counter: counter ; operation: 'kind manager_operation ; @@ -111,15 +111,13 @@ and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : { amount: Tez_repr.tez ; - parameters: Script_repr.lazy_expr option ; + parameters: Script_repr.lazy_expr ; + entrypoint: string ; destination: Contract_repr.contract ; } -> Kind.transaction manager_operation | Origination : { - manager: Signature.Public_key_hash.t ; delegate: Signature.Public_key_hash.t option ; - script: Script_repr.t option ; - spendable: bool ; - delegatable: bool ; + script: Script_repr.t ; credit: Tez_repr.tez ; preorigination: Contract_repr.t option ; } -> Kind.origination manager_operation diff --git a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml index b8c7b150d..bbf9c18fb 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml @@ -85,196 +85,6 @@ let bootstrap_contract_encoding = (req "amount" Tez_repr.encoding) (req "script" Script_repr.encoding)) -(* This encoding is used to read configuration files (e.g. sandbox.json) - where some fields can be missing, in that case they are replaced by - the default. *) -let constants_encoding = - let open Data_encoding in - conv - (fun (c : Constants_repr.parametric) -> - let module Compare_time_between_blocks = Compare.List (Period_repr) in - let module Compare_keys = Compare.List (Ed25519.Public_key) in - let opt (=) def v = if def = v then None else Some v in - let default = Constants_repr.default in - let preserved_cycles = - opt Compare.Int.(=) - default.preserved_cycles c.preserved_cycles - and blocks_per_cycle = - opt Compare.Int32.(=) - default.blocks_per_cycle c.blocks_per_cycle - and blocks_per_commitment = - opt Compare.Int32.(=) - default.blocks_per_commitment c.blocks_per_commitment - and blocks_per_roll_snapshot = - opt Compare.Int32.(=) - default.blocks_per_roll_snapshot c.blocks_per_roll_snapshot - and blocks_per_voting_period = - opt Compare.Int32.(=) - default.blocks_per_voting_period c.blocks_per_voting_period - and time_between_blocks = - opt Compare_time_between_blocks.(=) - default.time_between_blocks c.time_between_blocks - and endorsers_per_block = - opt Compare.Int.(=) - default.endorsers_per_block c.endorsers_per_block - and hard_gas_limit_per_operation = - opt Compare.Z.(=) - default.hard_gas_limit_per_operation c.hard_gas_limit_per_operation - and hard_gas_limit_per_block = - opt Compare.Z.(=) - default.hard_gas_limit_per_block c.hard_gas_limit_per_block - and proof_of_work_threshold = - opt Compare.Int64.(=) - default.proof_of_work_threshold c.proof_of_work_threshold - and tokens_per_roll = - opt Tez_repr.(=) - default.tokens_per_roll c.tokens_per_roll - and michelson_maximum_type_size = - opt Compare.Int.(=) - default.michelson_maximum_type_size c.michelson_maximum_type_size - and seed_nonce_revelation_tip = - opt Tez_repr.(=) - default.seed_nonce_revelation_tip c.seed_nonce_revelation_tip - and origination_size = - opt Compare.Int.(=) - default.origination_size c.origination_size - and block_security_deposit = - opt Tez_repr.(=) - default.block_security_deposit c.block_security_deposit - and endorsement_security_deposit = - opt Tez_repr.(=) - default.endorsement_security_deposit c.endorsement_security_deposit - and block_reward = - opt Tez_repr.(=) - default.block_reward c.block_reward - and endorsement_reward = - opt Tez_repr.(=) - default.endorsement_reward c.endorsement_reward - and cost_per_byte = - opt Tez_repr.(=) - default.cost_per_byte c.cost_per_byte - and hard_storage_limit_per_operation = - opt Compare.Z.(=) - default.hard_storage_limit_per_operation c.hard_storage_limit_per_operation - and test_chain_duration = - opt Compare.Int64.(=) - default.test_chain_duration c.test_chain_duration - in - (( preserved_cycles, - blocks_per_cycle, - blocks_per_commitment, - blocks_per_roll_snapshot, - blocks_per_voting_period, - time_between_blocks, - endorsers_per_block, - hard_gas_limit_per_operation, - hard_gas_limit_per_block), - ((proof_of_work_threshold, - tokens_per_roll, - michelson_maximum_type_size, - seed_nonce_revelation_tip, - origination_size, - block_security_deposit, - endorsement_security_deposit, - block_reward), - (endorsement_reward, - cost_per_byte, - hard_storage_limit_per_operation, - test_chain_duration)))) - (fun (( preserved_cycles, - blocks_per_cycle, - blocks_per_commitment, - blocks_per_roll_snapshot, - blocks_per_voting_period, - time_between_blocks, - endorsers_per_block, - hard_gas_limit_per_operation, - hard_gas_limit_per_block), - ((proof_of_work_threshold, - tokens_per_roll, - michelson_maximum_type_size, - seed_nonce_revelation_tip, - origination_size, - block_security_deposit, - endorsement_security_deposit, - block_reward), - (endorsement_reward, - cost_per_byte, - hard_storage_limit_per_operation, - test_chain_duration))) -> - let unopt def = function None -> def | Some v -> v in - let default = Constants_repr.default in - { Constants_repr.preserved_cycles = - unopt default.preserved_cycles preserved_cycles ; - blocks_per_cycle = - unopt default.blocks_per_cycle blocks_per_cycle ; - blocks_per_commitment = - unopt default.blocks_per_commitment blocks_per_commitment ; - blocks_per_roll_snapshot = - unopt default.blocks_per_roll_snapshot blocks_per_roll_snapshot ; - blocks_per_voting_period = - unopt default.blocks_per_voting_period blocks_per_voting_period ; - time_between_blocks = - unopt default.time_between_blocks @@ - time_between_blocks ; - endorsers_per_block = - unopt default.endorsers_per_block endorsers_per_block ; - hard_gas_limit_per_operation = - unopt default.hard_gas_limit_per_operation hard_gas_limit_per_operation ; - hard_gas_limit_per_block = - unopt default.hard_gas_limit_per_block hard_gas_limit_per_block ; - proof_of_work_threshold = - unopt default.proof_of_work_threshold proof_of_work_threshold ; - tokens_per_roll = - unopt default.tokens_per_roll tokens_per_roll ; - michelson_maximum_type_size = - unopt default.michelson_maximum_type_size michelson_maximum_type_size ; - seed_nonce_revelation_tip = - unopt default.seed_nonce_revelation_tip seed_nonce_revelation_tip ; - origination_size = - unopt default.origination_size origination_size ; - block_security_deposit = - unopt default.block_security_deposit block_security_deposit ; - endorsement_security_deposit = - unopt default.endorsement_security_deposit endorsement_security_deposit ; - block_reward = - unopt default.block_reward block_reward ; - endorsement_reward = - unopt default.endorsement_reward endorsement_reward ; - cost_per_byte = - unopt default.cost_per_byte cost_per_byte ; - hard_storage_limit_per_operation = - unopt default.hard_storage_limit_per_operation hard_storage_limit_per_operation ; - test_chain_duration = - unopt default.test_chain_duration test_chain_duration ; - } ) - (merge_objs - (obj9 - (opt "preserved_cycles" uint8) - (opt "blocks_per_cycle" int32) - (opt "blocks_per_commitment" int32) - (opt "blocks_per_roll_snapshot" int32) - (opt "blocks_per_voting_period" int32) - (opt "time_between_blocks" (list Period_repr.encoding)) - (opt "endorsers_per_block" uint16) - (opt "hard_gas_limit_per_operation" z) - (opt "hard_gas_limit_per_block" z)) - (merge_objs - (obj8 - (opt "proof_of_work_threshold" int64) - (opt "tokens_per_roll" Tez_repr.encoding) - (opt "michelson_maximum_type_size" uint16) - (opt "seed_nonce_revelation_tip" Tez_repr.encoding) - (opt "origination_size" int31) - (opt "block_security_deposit" Tez_repr.encoding) - (opt "endorsement_security_deposit" Tez_repr.encoding) - (opt "block_reward" Tez_repr.encoding)) - (obj4 - (opt "endorsement_reward" Tez_repr.encoding) - (opt "cost_per_byte" Tez_repr.encoding) - (opt "hard_storage_limit_per_operation" z) - (opt "test_chain_duration" int64)))) - let encoding = let open Data_encoding in conv @@ -295,4 +105,254 @@ let encoding = (dft "commitments" (list Commitment_repr.encoding) []) (opt "security_deposit_ramp_up_cycles" int31) (opt "no_reward_cycles" int31)) - constants_encoding) + Constants_repr.parametric_encoding) + + +(* Only for migration from 004 to 005 *) + +module Proto_004 = struct + + type parametric = { + preserved_cycles: int ; + blocks_per_cycle: int32 ; + blocks_per_commitment: int32 ; + blocks_per_roll_snapshot: int32 ; + blocks_per_voting_period: int32 ; + time_between_blocks: Period_repr.t list ; + endorsers_per_block: int ; + hard_gas_limit_per_operation: Z.t ; + hard_gas_limit_per_block: Z.t ; + proof_of_work_threshold: int64 ; + tokens_per_roll: Tez_repr.t ; + michelson_maximum_type_size: int; + seed_nonce_revelation_tip: Tez_repr.t ; + origination_size: int ; + block_security_deposit: Tez_repr.t ; + endorsement_security_deposit: Tez_repr.t ; + block_reward: Tez_repr.t ; + endorsement_reward: Tez_repr.t ; + cost_per_byte: Tez_repr.t ; + hard_storage_limit_per_operation: Z.t ; + test_chain_duration: int64 ; (* in seconds *) + } + + let default = { + preserved_cycles = 5 ; + blocks_per_cycle = 4096l ; + blocks_per_commitment = 32l ; + blocks_per_roll_snapshot = 256l ; + blocks_per_voting_period = 32768l ; + time_between_blocks = + List.map Period_repr.of_seconds_exn [ 60L ; 75L ] ; + endorsers_per_block = 32 ; + hard_gas_limit_per_operation = Z.of_int 800_000 ; + hard_gas_limit_per_block = Z.of_int 8_000_000 ; + proof_of_work_threshold = + Int64.(sub (shift_left 1L 46) 1L) ; + tokens_per_roll = + Tez_repr.(mul_exn one 8_000) ; + michelson_maximum_type_size = 1000 ; + seed_nonce_revelation_tip = begin + match Tez_repr.(one /? 8L) with + | Ok c -> c + | Error _ -> assert false + end ; + origination_size = 257 ; + block_security_deposit = Tez_repr.(mul_exn one 512) ; + endorsement_security_deposit = Tez_repr.(mul_exn one 64) ; + block_reward = Tez_repr.(mul_exn one 16) ; + endorsement_reward = Tez_repr.(mul_exn one 2) ; + hard_storage_limit_per_operation = Z.of_int 60_000 ; + cost_per_byte = Tez_repr.of_mutez_exn 1_000L ; + test_chain_duration = Int64.mul 32768L 60L; + } + + (* This encoding is used to read configuration files (e.g. sandbox.json) + where some fields can be missing, in that case they are replaced by + the default. *) + let constants_encoding = + let open Data_encoding in + conv + (fun (c : parametric) -> + let module Compare_time_between_blocks = Compare.List (Period_repr) in + let module Compare_keys = Compare.List (Ed25519.Public_key) in + let opt (=) def v = if def = v then None else Some v in + let preserved_cycles = + opt Compare.Int.(=) + default.preserved_cycles c.preserved_cycles + and blocks_per_cycle = + opt Compare.Int32.(=) + default.blocks_per_cycle c.blocks_per_cycle + and blocks_per_commitment = + opt Compare.Int32.(=) + default.blocks_per_commitment c.blocks_per_commitment + and blocks_per_roll_snapshot = + opt Compare.Int32.(=) + default.blocks_per_roll_snapshot c.blocks_per_roll_snapshot + and blocks_per_voting_period = + opt Compare.Int32.(=) + default.blocks_per_voting_period c.blocks_per_voting_period + and time_between_blocks = + opt Compare_time_between_blocks.(=) + default.time_between_blocks c.time_between_blocks + and endorsers_per_block = + opt Compare.Int.(=) + default.endorsers_per_block c.endorsers_per_block + and hard_gas_limit_per_operation = + opt Compare.Z.(=) + default.hard_gas_limit_per_operation c.hard_gas_limit_per_operation + and hard_gas_limit_per_block = + opt Compare.Z.(=) + default.hard_gas_limit_per_block c.hard_gas_limit_per_block + and proof_of_work_threshold = + opt Compare.Int64.(=) + default.proof_of_work_threshold c.proof_of_work_threshold + and tokens_per_roll = + opt Tez_repr.(=) + default.tokens_per_roll c.tokens_per_roll + and michelson_maximum_type_size = + opt Compare.Int.(=) + default.michelson_maximum_type_size c.michelson_maximum_type_size + and seed_nonce_revelation_tip = + opt Tez_repr.(=) + default.seed_nonce_revelation_tip c.seed_nonce_revelation_tip + and origination_size = + opt Compare.Int.(=) + default.origination_size c.origination_size + and block_security_deposit = + opt Tez_repr.(=) + default.block_security_deposit c.block_security_deposit + and endorsement_security_deposit = + opt Tez_repr.(=) + default.endorsement_security_deposit c.endorsement_security_deposit + and block_reward = + opt Tez_repr.(=) + default.block_reward c.block_reward + and endorsement_reward = + opt Tez_repr.(=) + default.endorsement_reward c.endorsement_reward + and cost_per_byte = + opt Tez_repr.(=) + default.cost_per_byte c.cost_per_byte + and hard_storage_limit_per_operation = + opt Compare.Z.(=) + default.hard_storage_limit_per_operation c.hard_storage_limit_per_operation + and test_chain_duration = + opt Compare.Int64.(=) + default.test_chain_duration c.test_chain_duration + in + (( preserved_cycles, + blocks_per_cycle, + blocks_per_commitment, + blocks_per_roll_snapshot, + blocks_per_voting_period, + time_between_blocks, + endorsers_per_block, + hard_gas_limit_per_operation, + hard_gas_limit_per_block), + ((proof_of_work_threshold, + tokens_per_roll, + michelson_maximum_type_size, + seed_nonce_revelation_tip, + origination_size, + block_security_deposit, + endorsement_security_deposit, + block_reward), + (endorsement_reward, + cost_per_byte, + hard_storage_limit_per_operation, + test_chain_duration)))) + (fun (( preserved_cycles, + blocks_per_cycle, + blocks_per_commitment, + blocks_per_roll_snapshot, + blocks_per_voting_period, + time_between_blocks, + endorsers_per_block, + hard_gas_limit_per_operation, + hard_gas_limit_per_block), + ((proof_of_work_threshold, + tokens_per_roll, + michelson_maximum_type_size, + seed_nonce_revelation_tip, + origination_size, + block_security_deposit, + endorsement_security_deposit, + block_reward), + (endorsement_reward, + cost_per_byte, + hard_storage_limit_per_operation, + test_chain_duration))) -> + let unopt def = function None -> def | Some v -> v in + { preserved_cycles = + unopt default.preserved_cycles preserved_cycles ; + blocks_per_cycle = + unopt default.blocks_per_cycle blocks_per_cycle ; + blocks_per_commitment = + unopt default.blocks_per_commitment blocks_per_commitment ; + blocks_per_roll_snapshot = + unopt default.blocks_per_roll_snapshot blocks_per_roll_snapshot ; + blocks_per_voting_period = + unopt default.blocks_per_voting_period blocks_per_voting_period ; + time_between_blocks = + unopt default.time_between_blocks @@ + time_between_blocks ; + endorsers_per_block = + unopt default.endorsers_per_block endorsers_per_block ; + hard_gas_limit_per_operation = + unopt default.hard_gas_limit_per_operation hard_gas_limit_per_operation ; + hard_gas_limit_per_block = + unopt default.hard_gas_limit_per_block hard_gas_limit_per_block ; + proof_of_work_threshold = + unopt default.proof_of_work_threshold proof_of_work_threshold ; + tokens_per_roll = + unopt default.tokens_per_roll tokens_per_roll ; + michelson_maximum_type_size = + unopt default.michelson_maximum_type_size michelson_maximum_type_size ; + seed_nonce_revelation_tip = + unopt default.seed_nonce_revelation_tip seed_nonce_revelation_tip ; + origination_size = + unopt default.origination_size origination_size ; + block_security_deposit = + unopt default.block_security_deposit block_security_deposit ; + endorsement_security_deposit = + unopt default.endorsement_security_deposit endorsement_security_deposit ; + block_reward = + unopt default.block_reward block_reward ; + endorsement_reward = + unopt default.endorsement_reward endorsement_reward ; + cost_per_byte = + unopt default.cost_per_byte cost_per_byte ; + hard_storage_limit_per_operation = + unopt default.hard_storage_limit_per_operation hard_storage_limit_per_operation ; + test_chain_duration = + unopt default.test_chain_duration test_chain_duration ; + } ) + (merge_objs + (obj9 + (opt "preserved_cycles" uint8) + (opt "blocks_per_cycle" int32) + (opt "blocks_per_commitment" int32) + (opt "blocks_per_roll_snapshot" int32) + (opt "blocks_per_voting_period" int32) + (opt "time_between_blocks" (list Period_repr.encoding)) + (opt "endorsers_per_block" uint16) + (opt "hard_gas_limit_per_operation" z) + (opt "hard_gas_limit_per_block" z)) + (merge_objs + (obj8 + (opt "proof_of_work_threshold" int64) + (opt "tokens_per_roll" Tez_repr.encoding) + (opt "michelson_maximum_type_size" uint16) + (opt "seed_nonce_revelation_tip" Tez_repr.encoding) + (opt "origination_size" int31) + (opt "block_security_deposit" Tez_repr.encoding) + (opt "endorsement_security_deposit" Tez_repr.encoding) + (opt "block_reward" Tez_repr.encoding)) + (obj4 + (opt "endorsement_reward" Tez_repr.encoding) + (opt "cost_per_byte" Tez_repr.encoding) + (opt "hard_storage_limit_per_operation" z) + (opt "test_chain_duration" int64)))) + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli index 458182195..c679c58f1 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli @@ -45,4 +45,34 @@ type t = { } val encoding: t Data_encoding.t -val constants_encoding: Constants_repr.parametric Data_encoding.t + + +(* Only for migration from 004 to 005 *) + +module Proto_004 : sig + type parametric = { + preserved_cycles: int ; + blocks_per_cycle: int32 ; + blocks_per_commitment: int32 ; + blocks_per_roll_snapshot: int32 ; + blocks_per_voting_period: int32 ; + time_between_blocks: Period_repr.t list ; + endorsers_per_block: int ; + hard_gas_limit_per_operation: Z.t ; + hard_gas_limit_per_block: Z.t ; + proof_of_work_threshold: int64 ; + tokens_per_roll: Tez_repr.t ; + michelson_maximum_type_size: int; + seed_nonce_revelation_tip: Tez_repr.t ; + origination_size: int ; + block_security_deposit: Tez_repr.t ; + endorsement_security_deposit: Tez_repr.t ; + block_reward: Tez_repr.t ; + endorsement_reward: Tez_repr.t ; + cost_per_byte: Tez_repr.t ; + hard_storage_limit_per_operation: Z.t ; + test_chain_duration: int64 ; + } + + val constants_encoding: parametric Data_encoding.t +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml index f1a97d561..3719221f4 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml @@ -28,6 +28,8 @@ type period = t include (Compare.Int64 : Compare.S with type t := t) let encoding = Data_encoding.int64 +let rpc_arg = RPC_arg.int64 + let pp ppf v = Format.fprintf ppf "%Ld" v type error += (* `Permanent *) @@ -73,6 +75,7 @@ let mult i p = then error Invalid_arg else ok (Int64.mul (Int64.of_int32 i) p) +let zero = of_seconds_exn 0L let one_second = of_seconds_exn 1L let one_minute = of_seconds_exn 60L let one_hour = of_seconds_exn 3600L diff --git a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli index 555b704df..a84fba7d2 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli @@ -27,6 +27,7 @@ type t type period = t include Compare.S with type t := t val encoding : period Data_encoding.t +val rpc_arg : period RPC_arg.t val pp: Format.formatter -> period -> unit @@ -41,6 +42,7 @@ val of_seconds_exn : int64 -> period val mult : int32 -> period -> period tzresult +val zero : period val one_second : period val one_minute : period val one_hour : period diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml index e1eb7386b..c887e319b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml @@ -30,18 +30,22 @@ type t = { constants: Constants_repr.parametric ; first_level: Raw_level_repr.t ; level: Level_repr.t ; + predecessor_timestamp: Time.t ; timestamp: Time.t ; fitness: Int64.t ; deposits: Tez_repr.t Signature.Public_key_hash.Map.t ; + included_endorsements: int ; allowed_endorsements: (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ; fees: Tez_repr.t ; rewards: Tez_repr.t ; block_gas: Z.t ; operation_gas: Gas_limit_repr.t ; + internal_gas: Gas_limit_repr.internal_gas ; storage_space_to_pay: Z.t option ; allocated_contracts: int option ; origination_nonce: Contract_repr.origination_nonce option ; + temporary_big_map: Z.t ; internal_nonce: int ; internal_nonces_used: Int_set.t ; } @@ -50,6 +54,7 @@ type context = t type root_context = t let current_level ctxt = ctxt.level +let predecessor_timestamp ctxt = ctxt.predecessor_timestamp let current_timestamp ctxt = ctxt.timestamp let current_fitness ctxt = ctxt.fitness let first_level ctxt = ctxt.first_level @@ -62,6 +67,7 @@ let record_endorsement ctxt k = | Some (_, _, true) -> assert false (* right already used *) | Some (d, s, false) -> { ctxt with + included_endorsements = ctxt.included_endorsements + (List.length s); allowed_endorsements = Signature.Public_key_hash.Map.add k (d,s,true) ctxt.allowed_endorsements } @@ -77,6 +83,8 @@ let init_endorsements ctxt allowed_endorsements = let allowed_endorsements ctxt = ctxt.allowed_endorsements +let included_endorsements ctxt = ctxt.included_endorsements + type error += Too_many_internal_operations (* `Permanent *) let () = @@ -184,16 +192,22 @@ let check_gas_limit ctxt remaining = else ok () let set_gas_limit ctxt remaining = - { ctxt with operation_gas = Limited { remaining } } + { ctxt with operation_gas = Limited { remaining } ; + internal_gas = Gas_limit_repr.internal_gas_zero } let set_gas_unlimited ctxt = { ctxt with operation_gas = Unaccounted } let consume_gas ctxt cost = - Gas_limit_repr.consume ctxt.block_gas ctxt.operation_gas cost >>? fun (block_gas, operation_gas) -> - ok { ctxt with block_gas ; operation_gas } + Gas_limit_repr.consume + ctxt.block_gas + ctxt.operation_gas + ctxt.internal_gas + cost >>? fun (block_gas, operation_gas, internal_gas) -> + ok { ctxt with block_gas ; operation_gas ; internal_gas } let check_enough_gas ctxt cost = - Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas cost + Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas ctxt.internal_gas cost let gas_level ctxt = ctxt.operation_gas let block_gas_level ctxt = ctxt.block_gas + let gas_consumed ~since ~until = match gas_level since, gas_level until with | Limited { remaining = before }, Limited { remaining = after } -> Z.sub before after @@ -318,7 +332,7 @@ let storage_error err = fail (Storage_error err) (* This key should always be populated for every version of the protocol. It's absence meaning that the context is empty. *) let version_key = ["version"] -let version_value = "alpha_current" +let version_value = "babylon_005" let version = "v1" let first_level_key = [ version ; "first_level" ] @@ -400,7 +414,7 @@ let get_proto_param ctxt = let set_constants ctxt constants = let bytes = Data_encoding.Binary.to_bytes_exn - Parameters_repr.constants_encoding constants in + Constants_repr.parametric_encoding constants in Context.set ctxt constants_key bytes let get_constants ctxt = @@ -409,7 +423,20 @@ let get_constants ctxt = failwith "Internal error: cannot read constants in context." | Some bytes -> match - Data_encoding.Binary.of_bytes Parameters_repr.constants_encoding bytes + Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes + with + | None -> + failwith "Internal error: cannot parse constants in context." + | Some constants -> return constants + +(* only for migration from 004 to 005 *) +let get_004_constants ctxt = + Context.get ctxt constants_key >>= function + | None -> + failwith "Internal error: cannot read constants in context." + | Some bytes -> + match + Data_encoding.Binary.of_bytes Parameters_repr.Proto_004.constants_encoding bytes with | None -> failwith "Internal error: cannot parse constants in context." @@ -431,7 +458,7 @@ let check_inited ctxt = else storage_error (Incompatible_protocol_version s) -let prepare ~level ~timestamp ~fitness ctxt = +let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt = Lwt.return (Raw_level_repr.of_int32 level) >>=? fun level -> Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness -> check_inited ctxt >>=? fun () -> @@ -446,23 +473,27 @@ let prepare ~level ~timestamp ~fitness ctxt = level in return { context = ctxt ; constants ; level ; + predecessor_timestamp ; timestamp ; fitness ; first_level ; allowed_endorsements = Signature.Public_key_hash.Map.empty ; + included_endorsements = 0 ; fees = Tez_repr.zero ; rewards = Tez_repr.zero ; deposits = Signature.Public_key_hash.Map.empty ; operation_gas = Unaccounted ; + internal_gas = Gas_limit_repr.internal_gas_zero ; storage_space_to_pay = None ; allocated_contracts = None ; block_gas = constants.Constants_repr.hard_gas_limit_per_block ; origination_nonce = None ; + temporary_big_map = Z.sub Z.zero Z.one ; internal_nonce = 0 ; internal_nonces_used = Int_set.empty ; } type previous_protocol = | Genesis of Parameters_repr.t - | Alpha_previous + | Athens_004 let check_and_update_protocol_version ctxt = begin @@ -476,8 +507,8 @@ let check_and_update_protocol_version ctxt = else if Compare.String.(s = "genesis") then get_proto_param ctxt >>=? fun (param, ctxt) -> return (Genesis param, ctxt) - else if Compare.String.(s = "alpha_previous") then - return (Alpha_previous, ctxt) + else if Compare.String.(s = "athens_004") then + return (Athens_004, ctxt) else storage_error (Incompatible_protocol_version s) end >>=? fun (previous_proto, ctxt) -> @@ -494,10 +525,41 @@ let prepare_first_block ~level ~timestamp ~fitness ctxt = set_first_level ctxt first_level >>=? fun ctxt -> set_constants ctxt param.constants >>= fun ctxt -> return ctxt - | Alpha_previous -> + | Athens_004 -> + get_004_constants ctxt >>=? fun c -> + let constants = Constants_repr.{ + preserved_cycles = c.preserved_cycles ; + blocks_per_cycle = c.blocks_per_cycle ; + blocks_per_commitment = c.blocks_per_commitment ; + blocks_per_roll_snapshot = c.blocks_per_roll_snapshot ; + blocks_per_voting_period = c.blocks_per_voting_period ; + time_between_blocks = + List.map Period_repr.of_seconds_exn [ 60L ; 40L ] ; + endorsers_per_block = c.endorsers_per_block ; + hard_gas_limit_per_operation = c.hard_gas_limit_per_operation ; + hard_gas_limit_per_block = c.hard_gas_limit_per_block ; + proof_of_work_threshold = c.proof_of_work_threshold ; + tokens_per_roll = c.tokens_per_roll ; + michelson_maximum_type_size = c.michelson_maximum_type_size; + seed_nonce_revelation_tip = c.seed_nonce_revelation_tip ; + origination_size = c.origination_size ; + block_security_deposit = c.block_security_deposit ; + endorsement_security_deposit = c.endorsement_security_deposit ; + block_reward = c.block_reward ; + endorsement_reward = c.endorsement_reward ; + cost_per_byte = c.cost_per_byte ; + hard_storage_limit_per_operation = c.hard_storage_limit_per_operation ; + test_chain_duration = c.test_chain_duration ; + quorum_min = 20_00l ; (* quorum is in centile of a percentage *) + quorum_max = 70_00l ; + min_proposal_quorum = 5_00l ; + initial_endorsers = 24 ; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L ; + } in + set_constants ctxt constants >>= fun ctxt -> return ctxt end >>=? fun ctxt -> - prepare ctxt ~level ~timestamp ~fitness >>=? fun ctxt -> + prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness >>=? fun ctxt -> return (previous_proto, ctxt) let activate ({ context = c ; _ } as s) h = @@ -507,30 +569,6 @@ let fork_test_chain ({ context = c ; _ } as s) protocol expiration = Updater.fork_test_chain c ~protocol ~expiration >>= fun c -> Lwt.return { s with context = c } -let register_resolvers enc resolve = - let resolve context str = - let faked_context = { - context ; - constants = Constants_repr.default ; - first_level = Raw_level_repr.root ; - level = Level_repr.root Raw_level_repr.root ; - timestamp = Time.of_seconds 0L ; - fitness = 0L ; - allowed_endorsements = Signature.Public_key_hash.Map.empty ; - storage_space_to_pay = None ; - allocated_contracts = None ; - fees = Tez_repr.zero ; - rewards = Tez_repr.zero ; - deposits = Signature.Public_key_hash.Map.empty ; - block_gas = Constants_repr.default.hard_gas_limit_per_block ; - operation_gas = Unaccounted ; - origination_nonce = None ; - internal_nonce = 0 ; - internal_nonces_used = Int_set.empty ; - } in - resolve faked_context str in - Context.register_resolver enc resolve - (* Generic context ********************************************************) type key = string list @@ -650,3 +688,19 @@ let project x = x let absolute_key _ k = k let description = Storage_description.create () + +let fresh_temporary_big_map ctxt = + { ctxt with temporary_big_map = Z.sub ctxt.temporary_big_map Z.one }, + ctxt.temporary_big_map + +let reset_temporary_big_map ctxt = + { ctxt with temporary_big_map = Z.sub Z.zero Z.one } + +let temporary_big_maps ctxt f acc = + let rec iter acc id = + if Z.equal id ctxt.temporary_big_map then + Lwt.return acc + else + f acc id >>= fun acc -> + iter acc (Z.sub id Z.one) in + iter acc (Z.sub Z.zero Z.one) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli index 2dfc0ca3d..86cc62187 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(** {1 Errors} ****************************************************************) +(** {1 Errors} *) type error += Too_many_internal_operations (* `Permanent *) @@ -40,7 +40,7 @@ type error += Failed_to_decode_parameter of Data_encoding.json * string val storage_error: storage_error -> 'a tzresult Lwt.t -(** {1 Abstract Context} **************************************************) +(** {1 Abstract Context} *) (** Abstract view of the context. Includes a handle to the functional key-value database @@ -54,13 +54,14 @@ type root_context = t with this version of the protocol. *) val prepare: level: Int32.t -> + predecessor_timestamp: Time.t -> timestamp: Time.t -> fitness: Fitness.t -> Context.t -> context tzresult Lwt.t type previous_protocol = | Genesis of Parameters_repr.t - | Alpha_previous + | Athens_004 val prepare_first_block: level:int32 -> @@ -71,14 +72,12 @@ val prepare_first_block: val activate: context -> Protocol_hash.t -> t Lwt.t val fork_test_chain: context -> Protocol_hash.t -> Time.t -> t Lwt.t -val register_resolvers: - 'a Base58.encoding -> (context -> string -> 'a list Lwt.t) -> unit - (** Returns the state of the database resulting of operations on its abstract view *) val recover: context -> Context.t val current_level: context -> Level_repr.t +val predecessor_timestamp: context -> Time.t val current_timestamp: context -> Time.t val current_fitness: context -> Int64.t @@ -129,7 +128,7 @@ val origination_nonce: t -> Contract_repr.origination_nonce tzresult val increment_origination_nonce: t -> (t * Contract_repr.origination_nonce) tzresult val unset_origination_nonce: t -> t -(** {1 Generic accessors} *************************************************) +(** {1 Generic accessors} *) type key = string list @@ -241,6 +240,9 @@ val allowed_endorsements: context -> (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t +(** Keep track of the number of endorsements that are included in a block *) +val included_endorsements: context -> int + (** Initializes the map of allowed endorsements, this function must only be called once. *) val init_endorsements: @@ -251,3 +253,12 @@ val init_endorsements: (** Marks an endorsment in the map as used. *) val record_endorsement: context -> Signature.Public_key_hash.t -> context + +(** Provide a fresh identifier for a temporary big map (negative index). *) +val fresh_temporary_big_map: context -> context * Z.t + +(** Reset the temporary big_map identifier generator to [-1]. *) +val reset_temporary_big_map: context -> context + +(** Iterate over all created temporary big maps since the last {!reset_temporary_big_map}. *) +val temporary_big_maps: context -> ('a -> Z.t -> 'a Lwt.t) -> 'a -> 'a Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml index 8af1b4543..16b4f2d62 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml @@ -72,7 +72,7 @@ let () = let of_int32 l = try Ok (of_int32_exn l) - with _ -> Error [Unexpected_level l] + with _ -> error (Unexpected_level l) module Index = struct type t = raw_level diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml index 04229a1aa..3e4917b1a 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml @@ -157,677 +157,818 @@ let unparse_stack ctxt (stack, stack_ty) = return ((data, annot) :: rest) in unparse_stack (stack, stack_ty) -module Interp_costs = Michelson_v1_gas.Cost_of +module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter -let rec interp +let rec interp_stack_prefix_preserving_operation : type fbef bef faft aft result . + (fbef stack -> (faft stack * result) tzresult Lwt.t) + -> (fbef, faft, bef, aft) stack_prefix_preservation_witness + -> bef stack + -> (aft stack * result) tzresult Lwt.t = + fun f n stk -> + match n,stk with + | Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))), + Item (v0, Item (v1, Item (v2, Item (v3, Item (v4, Item (v5, Item (v6, Item (v7, Item (v8, Item (v9, Item (va, Item (vb, Item (vc, Item (vd, Item (ve, Item (vf, rest)))))))))))))))) -> + interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) -> + return (Item (v0, Item (v1, Item (v2, Item (v3, Item (v4, Item (v5, Item (v6, Item (v7, Item (v8, Item (v9, Item (va, Item (vb, Item (vc, Item (vd, Item (ve, Item (vf, rest')))))))))))))))), result) + | Prefix (Prefix (Prefix (Prefix n))), + Item (v0, Item (v1, Item (v2, Item (v3, rest)))) -> + interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) -> + return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result) + | Prefix n, Item (v, rest) -> + interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) -> + return (Item (v, rest'), result) + | Rest, v -> f v + +type step_constants = + { source : Contract.t ; + payer : Contract.t ; + self : Contract.t ; + amount : Tez.t ; + chain_id : Chain_id.t } + +let rec step + : type b a. + (?log: execution_trace ref -> + context -> step_constants -> (b, a) descr -> b stack -> + (a stack * context) tzresult Lwt.t) = + fun ?log ctxt step_constants ({ instr ; loc ; _ } as descr) stack -> + Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> + let logged_return : type a b. + (b, a) descr -> + a stack * context -> + (a stack * context) tzresult Lwt.t = + fun descr (ret, ctxt) -> + match log with + | None -> return (ret, ctxt) + | Some log -> + trace + Cannot_serialize_log + (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> + log := (descr.loc, Gas.level ctxt, stack) :: !log ; + return (ret, ctxt) in + let get_log (log : execution_trace ref option) = + Option.map ~f:(fun l -> List.rev !l) log in + let consume_gas_terop : type ret arg1 arg2 arg3 rest. + (_ * (_ * (_ * rest)), ret * rest) descr -> + ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> + (arg1 -> arg2 -> arg3 -> Gas.cost) -> + rest stack -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2, x3) cost_func rest -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2 x3, rest), ctxt) in + let consume_gas_binop : type ret arg1 arg2 rest. + (_ * (_ * rest), ret * rest) descr -> + ((arg1 -> arg2 -> ret) * arg1 * arg2) -> + (arg1 -> arg2 -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2, rest), ctxt) in + let consume_gas_unop : type ret arg rest. + (_ * rest, ret * rest) descr -> + ((arg -> ret) * arg) -> + (arg -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, arg) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> + logged_return descr (Item (op arg, rest), ctxt) in + let logged_return : + a stack * context -> + (a stack * context) tzresult Lwt.t = + logged_return descr in + match instr, stack with + (* stack ops *) + | Drop, Item (_, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (rest, ctxt) + | Dup, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (v, Item (v, rest)), ctxt) + | Swap, Item (vi, Item (vo, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (vo, Item (vi, rest)), ctxt) + | Const v, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + (* options *) + | Cons_some, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (Some v, rest), ctxt) + | Cons_none _, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | If_none (bt, _), Item (None, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bt rest + | If_none (_, bf), Item (Some v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bf (Item (v, rest)) + (* pairs *) + | Cons_pair, Item (a, Item (b, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> + logged_return (Item ((a, b), rest), ctxt) + (* Peephole optimization for UNPAIR *) + | Seq ({instr=Dup;_}, + {instr=Seq ({instr=Car;_}, + {instr=Seq ({instr=Dip {instr=Cdr}}, + {instr=Nop;_});_});_}), + Item ((a, b), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (a, Item (b, rest)), ctxt) + | Car, Item ((a, _), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (a, rest), ctxt) + | Cdr, Item ((_, b), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (b, rest), ctxt) + (* unions *) + | Left, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (L v, rest), ctxt) + | Right, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (R v, rest), ctxt) + | If_left (bt, _), Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bt (Item (v, rest)) + | If_left (_, bf), Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bf (Item (v, rest)) + (* lists *) + | Cons_list, Item (hd, Item (tl, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> + logged_return (Item (hd :: tl, rest), ctxt) + | Nil, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item ([], rest), ctxt) + | If_cons (_, bf), Item ([], rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bf rest + | If_cons (bt, _), Item (hd :: tl, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bt (Item (hd, Item (tl, rest))) + | List_map body, Item (l, rest) -> + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_map) >>=? fun ctxt -> + match l with + | [] -> return (Item (List.rev acc, rest), ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (hd :: acc) + in loop rest ctxt l [] >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | List_size, Item (list, rest) -> + Lwt.return + (List.fold_left + (fun acc _ -> + acc >>? fun (size, ctxt) -> + Gas.consume ctxt Interp_costs.loop_size >>? fun ctxt -> + ok (size + 1 (* FIXME: overflow *), ctxt)) + (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> + logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) + | List_iter body, Item (l, init) -> + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + (* sets *) + | Empty_set t, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> + logged_return (Item (empty_set t, rest), ctxt) + | Set_iter body, Item (set, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> + let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Set_mem, Item (v, Item (set, rest)) -> + consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt + | Set_update, Item (v, Item (presence, Item (set, rest))) -> + consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest + | Set_size, Item (set, rest) -> + consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt + (* maps *) + | Empty_map (t, _), rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> + logged_return (Item (empty_map t, rest), ctxt) + | Map_map body, Item (map, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_map) >>=? fun ctxt -> + match l with + | [] -> return (acc, ctxt) + | (k, _) as hd :: tl -> + step ?log ctxt step_constants body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (map_update k (Some hd) acc) + in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Map_iter body, Item (map, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Map_mem, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt + | Map_get, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt + | Map_update, Item (k, Item (v, Item (map, rest))) -> + consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest + | Map_size, Item (map, rest) -> + consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt + (* Big map operations *) + | Empty_big_map (tk, tv), rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> + logged_return (Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt) + | Big_map_mem, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff)) >>=? fun ctxt -> + Script_ir_translator.big_map_mem ctxt key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_get, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_get key map.diff)) >>=? fun ctxt -> + Script_ir_translator.big_map_get ctxt key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> + consume_gas_terop descr + (Script_ir_translator.big_map_update, key, maybe_value, map) + (fun k v m -> Interp_costs.map_update k (Some v) m.diff) rest + (* timestamp operations *) + | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> + consume_gas_binop descr + (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> + consume_gas_binop descr (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> + consume_gas_binop descr (Script_timestamp.sub_delta, t, s) + Interp_costs.sub_timestamp rest ctxt + | Diff_timestamps, Item (t1, Item (t2, rest)) -> + consume_gas_binop descr (Script_timestamp.diff, t1, t2) + Interp_costs.diff_timestamps rest ctxt + (* string operations *) + | Concat_string_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> + let s = String.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_string, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> + let s = String.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_string, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (String.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | String_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) + (* bytes operations *) + | Concat_bytes_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> + let s = MBytes.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_bytes, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> + let s = MBytes.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (MBytes.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Bytes_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) + (* currency operations *) + | Add_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x +? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Sub_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x -? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Mul_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + | Mul_nattez, Item (y, Item (x, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + (* boolean operations *) + | Or, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt + | And, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt + | Xor, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt + | Not, Item (x, rest) -> + consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt + (* integer operations *) + | Is_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt + | Abs_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt + | Int_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt + | Neg_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Neg_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Add_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt + | Sub_int, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt + | Mul_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt + | Ediv_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + let x = Script_int.of_int64 (Tez.to_mutez x) in + consume_gas_binop descr + ((fun x y -> + 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 -> + begin + match Tez.of_mutez q, Tez.of_mutez r with + | Some q, Some r -> Some (q,r) + (* Cannot overflow *) + | _ -> assert false + end + (* Cannot overflow *) + | _ -> assert false), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + 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 + consume_gas_binop descr + ((fun x y -> match Script_int.ediv_n x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 r with + | None -> assert false (* Cannot overflow *) + | Some r -> + match Tez.of_mutez r with + | None -> assert false (* Cannot overflow *) + | Some r -> Some (q, r)), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt + | Lsl_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> + begin + match Script_int.shift_left_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some x -> logged_return (Item (x, rest), ctxt) + end + | Lsr_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> + begin + match Script_int.shift_right_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some r -> logged_return (Item (r, rest), ctxt) + end + | Or_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt + | And_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | And_int_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | Xor_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt + | Not_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + | Not_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + (* control *) + | Seq (hd, tl), stack -> + step ?log ctxt step_constants hd stack >>=? fun (trans, ctxt) -> + step ?log ctxt step_constants tl trans + | If (bt, _), Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bt rest + | If (_, bf), Item (false, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bf rest + | Loop body, Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step ?log ctxt step_constants body rest >>=? fun (trans, ctxt) -> + step ?log ctxt step_constants descr trans + | Loop _, Item (false, rest) -> + logged_return (rest, ctxt) + | Loop_left body, Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step ?log ctxt step_constants body (Item (v, rest)) >>=? fun (trans, ctxt) -> + step ?log ctxt step_constants descr trans + | Loop_left _, Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + | Dip b, Item (ign, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + step ?log ctxt step_constants b rest >>=? fun (res, ctxt) -> + logged_return (Item (ign, res), ctxt) + | Exec, Item (arg, Item (lam, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> + interp ?log ctxt step_constants lam arg >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Apply capture_ty, Item (capture, Item (lam, rest)) -> ( + Lwt.return (Gas.consume ctxt Interp_costs.apply) >>=? fun ctxt -> + let (Lam (descr, expr)) = lam in + let (Item_t (full_arg_ty , _ , _)) = descr.bef in + unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> + unparse_ty ctxt capture_ty >>=? fun (ty_expr, ctxt) -> + match full_arg_ty with + | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _, _) -> ( + let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in + let const_descr = ({ + loc = descr.loc ; + bef = arg_stack_ty ; + aft = Item_t (capture_ty, arg_stack_ty, None) ; + instr = Const capture ; + } : (_, _) descr) in + let pair_descr = ({ + loc = descr.loc ; + bef = Item_t (capture_ty, arg_stack_ty, None) ; + aft = Item_t (full_arg_ty, Empty_t, None) ; + instr = Cons_pair ; + } : (_, _) descr) in + let seq_descr = ({ + loc = descr.loc ; + bef = arg_stack_ty ; + aft = Item_t (full_arg_ty, Empty_t, None) ; + instr = Seq (const_descr, pair_descr) ; + } : (_, _) descr) in + let full_descr = ({ + loc = descr.loc ; + bef = arg_stack_ty ; + aft = descr.aft ; + instr = Seq (seq_descr, descr) ; + } : (_, _) descr) in + let full_expr = Micheline.Seq (0, [ + Prim (0, I_PUSH, [ ty_expr ; const_expr ], []) ; + Prim (0, I_PAIR, [], []) ; + expr ]) in + let lam' = Lam (full_descr, full_expr) in + logged_return (Item (lam', rest), ctxt) + ) + | _ -> assert false + ) + | Lambda lam, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (lam, rest), ctxt) + | Failwith tv, Item (v, _) -> + trace Cannot_serialize_failure + (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + fail (Reject (loc, v, get_log log)) + | Nop, stack -> + logged_return (stack, ctxt) + (* comparison *) + | Compare ty, Item (a, Item (b, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b)) >>=? fun ctxt -> + logged_return (Item (Script_int.of_int @@ Script_ir_translator.compare_comparable ty a b, rest), ctxt) + (* comparators *) + | Eq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres = 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Neq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <> 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Lt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres < 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Le, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Gt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres > 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Ge, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres >= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + (* packing *) + | Pack t, Item (value, rest) -> + Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> + logged_return (Item (bytes, rest), ctxt) + | Unpack t, Item (bytes, rest) -> + Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> + if Compare.Int.(MBytes.length bytes >= 1) && + Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then + let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in + match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Some expr -> + Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> + parse_data ctxt ~legacy:false t (Micheline.root expr) >>= function + | Ok (value, ctxt) -> + logged_return (Item (Some value, rest), ctxt) + | Error _ignored -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + else + logged_return (Item (None, rest), ctxt) + (* protocol *) + | Address, Item ((_, address), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> + logged_return (Item (address, rest), ctxt) + | Contract (t, entrypoint), Item (contract, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> + begin match contract, entrypoint with + | (contract, "default"), entrypoint | (contract, entrypoint), "default" -> + Script_ir_translator.parse_contract_for_script + ~legacy:false ctxt loc t contract ~entrypoint >>=? fun (ctxt, maybe_contract) -> + logged_return (Item (maybe_contract, rest), ctxt) + | _ -> logged_return (Item (None, rest), ctxt) + end + | Transfer_tokens, + Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> + collect_big_maps ctxt tp p >>=? fun (to_duplicate, ctxt) -> + let to_update = no_big_map_id in + extract_big_map_diff ctxt Optimized tp p + ~to_duplicate ~to_update ~temporary:true >>=? fun (p, big_map_diff, ctxt) -> + unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> + let operation = + Transaction + { amount ; destination ; entrypoint ; + parameters = Script.lazy_expr (Micheline.strip_locations p) } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), rest), ctxt) + | Create_account, + Item (manager, Item (delegate, Item (_delegatable, Item (credit, rest)))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + (* store in optimized binary representation - as unparsed with [Optimized]. *) + let manager_bytes = + Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager in + let storage = + Script_repr.lazy_expr @@ Micheline.strip_locations @@ + Micheline.Bytes (0, manager_bytes) in + let script = + { code = Legacy_support.manager_script_code ; + storage ; + } in + let operation = + Origination + { credit ; delegate ; preorigination = Some contract ; script } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, None), + Item ((contract, "default"), rest)), ctxt) + | Implicit_account, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> + let contract = Contract.implicit_contract key in + logged_return (Item ((Unit_t None, (contract, "default")), rest), ctxt) + | Create_contract (storage_type, param_type, Lam (_, code), root_name), + Item (manager, Item + (delegate, Item + (spendable, Item + (delegatable, Item + (credit, Item + (init, rest)))))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> + unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> + let unparsed_param_type = + Script_ir_translator.add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None unparsed_param_type in + unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> + let code = + Script.lazy_expr @@ + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; + Prim (0, K_storage, [ unparsed_storage_type ], []) ; + Prim (0, K_code, [ code ], []) ])) in + collect_big_maps ctxt storage_type init >>=? fun (to_duplicate, ctxt) -> + let to_update = no_big_map_id in + extract_big_map_diff ctxt Optimized storage_type init + ~to_duplicate ~to_update ~temporary:true >>=? fun (init, big_map_diff, ctxt) -> + unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> + let storage = Script.lazy_expr @@ Micheline.strip_locations storage in + begin + if spendable then + Legacy_support.add_do ~manager_pkh:manager + ~script_code:code ~script_storage:storage + else if delegatable then + Legacy_support.add_set_delegate ~manager_pkh:manager + ~script_code:code ~script_storage:storage + else if Legacy_support.has_default_entrypoint code then + Legacy_support.add_root_entrypoint code >>=? fun code -> + return (code, storage) + else return (code, storage) + end >>=? fun (code, storage) -> + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; delegate ; preorigination = Some contract ; + script = { code ; storage } } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return + (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), + Item ((contract, "default"), rest)), ctxt) + | Create_contract_2 (storage_type, param_type, Lam (_, code), root_name), + (* Removed the instruction's arguments manager, spendable and delegatable *) + Item (delegate, Item + (credit, Item + (init, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> + unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> + let unparsed_param_type = + Script_ir_translator.add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None unparsed_param_type in + unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> + let code = + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; + Prim (0, K_storage, [ unparsed_storage_type ], []) ; + Prim (0, K_code, [ code ], []) ])) in + collect_big_maps ctxt storage_type init >>=? fun (to_duplicate, ctxt) -> + let to_update = no_big_map_id in + extract_big_map_diff ctxt Optimized storage_type init + ~to_duplicate ~to_update ~temporary:true >>=? fun (init, big_map_diff, ctxt) -> + unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> + let storage = Micheline.strip_locations storage in + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; delegate ; preorigination = Some contract ; + script = { code = Script.lazy_expr code ; + storage = Script.lazy_expr storage } } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return + (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), + Item ((contract, "default"), rest)), ctxt) + | Set_delegate, + Item (delegate, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + let operation = Delegation delegate in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, None), rest), ctxt) + | Balance, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> + Contract.get_balance ctxt step_constants.self >>=? fun balance -> + logged_return (Item (balance, rest), ctxt) + | Now, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> + let now = Script_timestamp.now ctxt in + logged_return (Item (now, rest), ctxt) + | Check_signature, Item (key, Item (signature, Item (message, rest))) -> + Lwt.return (Gas.consume ctxt (Interp_costs.check_signature key message)) >>=? fun ctxt -> + let res = Signature.check key signature message in + logged_return (Item (res, rest), ctxt) + | Hash_key, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> + logged_return (Item (Signature.Public_key.hash key, rest), ctxt) + | Blake2b, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash_blake2b bytes)) >>=? fun ctxt -> + let hash = Raw_hashes.blake2b bytes in + logged_return (Item (hash, rest), ctxt) + | Sha256, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha256 bytes)) >>=? fun ctxt -> + let hash = Raw_hashes.sha256 bytes in + logged_return (Item (hash, rest), ctxt) + | Sha512, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha512 bytes)) >>=? fun ctxt -> + let hash = Raw_hashes.sha512 bytes in + logged_return (Item (hash, rest), ctxt) + | Steps_to_quota, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> + let steps = match Gas.level ctxt with + | Limited { remaining } -> remaining + | Unaccounted -> Z.of_string "99999999" in + logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) + | Source, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item ((step_constants.payer, "default"), rest), ctxt) + | Sender, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item ((step_constants.source, "default"), rest), ctxt) + | Self (t, entrypoint), rest -> + Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> + logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt) + | Amount, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> + logged_return (Item (step_constants.amount, rest), ctxt) + | Dig (n, n'), stack -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> + interp_stack_prefix_preserving_operation (fun (Item (v, rest)) -> return (rest, v)) n' stack + >>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt) + | Dug (n, n'), Item (v, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> + interp_stack_prefix_preserving_operation (fun stk -> return (Item (v, stk), ())) n' rest + >>=? fun (aft, ()) -> logged_return (aft, ctxt) + | Dipn (n, n', b), stack -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> + interp_stack_prefix_preserving_operation (fun stk -> + step ?log ctxt step_constants b stk >>=? fun (res, ctxt') -> + return (res, ctxt')) n' stack + >>=? fun (aft, ctxt') -> logged_return (aft, ctxt') + | Dropn (n, n'), stack -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> + interp_stack_prefix_preserving_operation (fun stk -> return (stk, stk)) n' stack + >>=? fun (_, rest) -> logged_return (rest, ctxt) + | ChainId, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.chain_id) >>=? fun ctxt -> + logged_return (Item (step_constants.chain_id, rest), ctxt) + +and interp : type p r. (?log: execution_trace ref -> context -> - source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t -> - (p, r) lambda -> p -> + step_constants -> (p, r) lambda -> p -> (r * context) tzresult Lwt.t) - = fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg -> - let rec step - : type b a. - context -> (b, a) descr -> b stack -> - (a stack * context) tzresult Lwt.t = - fun ctxt ({ instr ; loc ; _ } as descr) stack -> - Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> - let logged_return : type a b. - (b, a) descr -> - a stack * context -> - (a stack * context) tzresult Lwt.t = - fun descr (ret, ctxt) -> - match log with - | None -> return (ret, ctxt) - | Some log -> - trace - Cannot_serialize_log - (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> - log := (descr.loc, Gas.level ctxt, stack) :: !log ; - return (ret, ctxt) in - let get_log (log : execution_trace ref option) = - Option.map ~f:(fun l -> List.rev !l) log in - let consume_gas_terop : type ret arg1 arg2 arg3 rest. - (_ * (_ * (_ * rest)), ret * rest) descr -> - ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> - (arg1 -> arg2 -> arg3 -> Gas.cost) -> - rest stack -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2, x3) cost_func rest -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2 x3, rest), ctxt) in - let consume_gas_binop : type ret arg1 arg2 rest. - (_ * (_ * rest), ret * rest) descr -> - ((arg1 -> arg2 -> ret) * arg1 * arg2) -> - (arg1 -> arg2 -> Gas.cost) -> - rest stack -> - context -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2, rest), ctxt) in - let consume_gas_unop : type ret arg rest. - (_ * rest, ret * rest) descr -> - ((arg -> ret) * arg) -> - (arg -> Gas.cost) -> - rest stack -> - context -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, arg) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> - logged_return descr (Item (op arg, rest), ctxt) in - let consume_gaz_comparison : - type t rest. - (t * (t * rest), Script_int.z Script_int.num * rest) descr -> - (t -> t -> int) -> - (t -> t -> Gas.cost) -> - t -> t -> - rest stack -> - ((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t = - fun descr op cost x1 x2 rest -> - Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt -> - logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in - let logged_return : - a stack * context -> - (a stack * context) tzresult Lwt.t = - logged_return descr in - match instr, stack with - (* stack ops *) - | Drop, Item (_, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (rest, ctxt) - | Dup, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (v, Item (v, rest)), ctxt) - | Swap, Item (vi, Item (vo, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (vo, Item (vi, rest)), ctxt) - | Const v, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - (* options *) - | Cons_some, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (Some v, rest), ctxt) - | Cons_none _, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | If_none (bt, _), Item (None, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt rest - | If_none (_, bf), Item (Some v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf (Item (v, rest)) - (* pairs *) - | Cons_pair, Item (a, Item (b, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> - logged_return (Item ((a, b), rest), ctxt) - | Car, Item ((a, _), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (a, rest), ctxt) - | Cdr, Item ((_, b), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (b, rest), ctxt) - (* unions *) - | Left, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (L v, rest), ctxt) - | Right, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (R v, rest), ctxt) - | If_left (bt, _), Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt (Item (v, rest)) - | If_left (_, bf), Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf (Item (v, rest)) - (* lists *) - | Cons_list, Item (hd, Item (tl, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> - logged_return (Item (hd :: tl, rest), ctxt) - | Nil, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item ([], rest), ctxt) - | If_cons (_, bf), Item ([], rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf rest - | If_cons (bt, _), Item (hd :: tl, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt (Item (hd, Item (tl, rest))) - | List_map body, Item (l, rest) -> - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (Item (List.rev acc, rest), ctxt) - | hd :: tl -> - step ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (hd :: acc) - in loop rest ctxt l [] >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | List_size, Item (list, rest) -> - Lwt.return - (List.fold_left - (fun acc _ -> - acc >>? fun (size, ctxt) -> - Gas.consume ctxt Interp_costs.list_size >>? fun ctxt -> - ok (size + 1 (* FIXME: overflow *), ctxt)) - (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> - logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) - | List_iter body, Item (l, init) -> - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - (* sets *) - | Empty_set t, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> - logged_return (Item (empty_set t, rest), ctxt) - | Set_iter body, Item (set, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> - let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Set_mem, Item (v, Item (set, rest)) -> - consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt - | Set_update, Item (v, Item (presence, Item (set, rest))) -> - consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest - | Set_size, Item (set, rest) -> - consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt - (* maps *) - | Empty_map (t, _), rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> - logged_return (Item (empty_map t, rest), ctxt) - | Map_map body, Item (map, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (acc, ctxt) - | (k, _) as hd :: tl -> - step ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (map_update k (Some hd) acc) - in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Map_iter body, Item (map, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Map_mem, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt - | Map_get, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt - | Map_update, Item (k, Item (v, Item (map, rest))) -> - consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest - | Map_size, Item (map, rest) -> - consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt - (* Big map operations *) - | Big_map_mem, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_get, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> - consume_gas_terop descr - (Script_ir_translator.big_map_update, key, maybe_value, map) - Interp_costs.big_map_update rest - (* timestamp operations *) - | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> - consume_gas_binop descr - (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> - consume_gas_binop descr (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> - consume_gas_binop descr (Script_timestamp.sub_delta, t, s) - Interp_costs.sub_timestamp rest ctxt - | Diff_timestamps, Item (t1, Item (t2, rest)) -> - consume_gas_binop descr (Script_timestamp.diff, t1, t2) - Interp_costs.diff_timestamps rest ctxt - (* string operations *) - | Concat_string_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> - let s = String.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_string, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> - let s = String.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_string, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (String.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | String_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) - (* bytes operations *) - | Concat_bytes_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> - let s = MBytes.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_bytes, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> - let s = MBytes.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (MBytes.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | Bytes_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) - (* currency operations *) - | Add_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x +? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Sub_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x -? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Mul_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - | Mul_nattez, Item (y, Item (x, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - (* boolean operations *) - | Or, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt - | And, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt - | Xor, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt - | Not, Item (x, rest) -> - consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt - (* integer operations *) - | Is_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt - | Abs_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt - | Int_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt - | Neg_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Neg_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Add_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt - | Sub_int, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt - | Mul_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt - | Ediv_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - let x = Script_int.of_int64 (Tez.to_mutez x) in - consume_gas_binop descr - ((fun x y -> - 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 -> - begin - match Tez.of_mutez q, Tez.of_mutez r with - | Some q, Some r -> Some (q,r) - (* Cannot overflow *) - | _ -> assert false - end - (* Cannot overflow *) - | _ -> assert false), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - 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 - consume_gas_binop descr - ((fun x y -> match Script_int.ediv_n x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 r with - | None -> assert false (* Cannot overflow *) - | Some r -> - match Tez.of_mutez r with - | None -> assert false (* Cannot overflow *) - | Some r -> Some (q, r)), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt - | Lsl_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> - begin - match Script_int.shift_left_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some x -> logged_return (Item (x, rest), ctxt) - end - | Lsr_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> - begin - match Script_int.shift_right_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some r -> logged_return (Item (r, rest), ctxt) - end - | Or_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt - | And_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | And_int_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | Xor_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt - | Not_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - | Not_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - (* control *) - | Seq (hd, tl), stack -> - step ctxt hd stack >>=? fun (trans, ctxt) -> - step ctxt tl trans - | If (bt, _), Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt rest - | If (_, bf), Item (false, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf rest - | Loop body, Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step ctxt body rest >>=? fun (trans, ctxt) -> - step ctxt descr trans - | Loop _, Item (false, rest) -> - logged_return (rest, ctxt) - | Loop_left body, Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) -> - step ctxt descr trans - | Loop_left _, Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - | Dip b, Item (ign, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - step ctxt b rest >>=? fun (res, ctxt) -> - logged_return (Item (ign, res), ctxt) - | Exec, Item (arg, Item (lam, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> - interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Lambda lam, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (lam, rest), ctxt) - | Failwith tv, Item (v, _) -> - trace Cannot_serialize_failure - (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - fail (Reject (loc, v, get_log log)) - | Nop, stack -> - logged_return (stack, ctxt) - (* comparison *) - | Compare (Bool_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest - | Compare (String_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest - | Compare (Bytes_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest - | Compare (Mutez_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest - | Compare (Int_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest - | Compare (Nat_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest - | Compare (Key_hash_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Signature.Public_key_hash.compare - Interp_costs.compare_key_hash a b rest - | Compare (Timestamp_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest - | Compare (Address_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest - (* comparators *) - | Eq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres = 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Neq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <> 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Lt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres < 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Le, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Gt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres > 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Ge, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres >= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - (* packing *) - | Pack t, Item (value, rest) -> - Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> - logged_return (Item (bytes, rest), ctxt) - | Unpack t, Item (bytes, rest) -> - Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> - if Compare.Int.(MBytes.length bytes >= 1) && - Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then - let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in - match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with - | None -> - Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | Some expr -> - Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> - parse_data ctxt t (Micheline.root expr) >>= function - | Ok (value, ctxt) -> - logged_return (Item (Some value, rest), ctxt) - | Error _ignored -> - Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - else - logged_return (Item (None, rest), ctxt) - (* protocol *) - | Address, Item ((_, contract), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> - logged_return (Item (contract, rest), ctxt) - | Contract t, Item (contract, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> - Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) -> - logged_return (Item (maybe_contract, rest), ctxt) - | Transfer_tokens, - Item (p, Item (amount, Item ((tp, destination), rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> - unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> - let operation = - Transaction - { amount ; destination ; - parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) - | Create_account, - Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; manager ; delegate ; preorigination = Some contract ; - delegatable ; script = None ; spendable = true } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, - Item (contract, rest)), ctxt) - | Implicit_account, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> - let contract = Contract.implicit_contract key in - logged_return (Item ((Unit_t None, contract), rest), ctxt) - | Create_contract (storage_type, param_type, Lam (_, code)), - Item (manager, Item - (delegate, Item - (spendable, Item - (delegatable, Item - (credit, Item - (init, rest)))))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> - unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> - unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> - let code = - Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; - Prim (0, K_storage, [ unparsed_storage_type ], []) ; - Prim (0, K_code, [ Micheline.root code ], []) ])) in - unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> - let storage = Micheline.strip_locations storage in - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; manager ; delegate ; preorigination = Some contract ; - delegatable ; spendable ; - script = Some { code = Script.lazy_expr code ; - storage = Script.lazy_expr storage } } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return - (Item (Internal_operation { source = self ; operation ; nonce }, - Item (contract, rest)), ctxt) - | Set_delegate, - Item (delegate, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - let operation = Delegation delegate in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) - | Balance, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> - Contract.get_balance ctxt self >>=? fun balance -> - logged_return (Item (balance, rest), ctxt) - | Now, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> - let now = Script_timestamp.now ctxt in - logged_return (Item (now, rest), ctxt) - | Check_signature, Item (key, Item (signature, Item (message, rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt -> - let res = Signature.check key signature message in - logged_return (Item (res, rest), ctxt) - | Hash_key, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> - logged_return (Item (Signature.Public_key.hash key, rest), ctxt) - | Blake2b, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> - let hash = Raw_hashes.blake2b bytes in - logged_return (Item (hash, rest), ctxt) - | Sha256, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> - let hash = Raw_hashes.sha256 bytes in - logged_return (Item (hash, rest), ctxt) - | Sha512, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt -> - let hash = Raw_hashes.sha512 bytes in - logged_return (Item (hash, rest), ctxt) - | Steps_to_quota, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> - let steps = match Gas.level ctxt with - | Limited { remaining } -> remaining - | Unaccounted -> Z.of_string "99999999" in - logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) - | Source, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item (payer, rest), ctxt) - | Sender, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item (source, rest), ctxt) - | Self t, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> - logged_return (Item ((t,self), rest), ctxt) - | Amount, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> - logged_return (Item (amount, rest), ctxt) in + = fun ?log ctxt step_constants (Lam (code, _)) arg -> let stack = (Item (arg, Empty)) in begin match log with | None -> return_unit @@ -837,28 +978,40 @@ let rec interp log := (code.loc, Gas.level ctxt, stack) :: !log ; return_unit end >>=? fun () -> - step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) -> + step ?log ctxt step_constants code stack >>=? fun (Item (ret, Empty), ctxt) -> return (ret, ctxt) (* ---- contract handling ---------------------------------------------------*) -and execute ?log ctxt mode ~source ~payer ~self script amount arg : - (Script.expr * packed_internal_operation list * context * - Script_typed_ir.ex_big_map option) tzresult Lwt.t = - parse_script ctxt script - >>=? fun ((Ex_script { code ; arg_type ; storage ; storage_type }), ctxt) -> +and execute ?log ctxt mode step_constants ~entrypoint unparsed_script arg : + (Script.expr * packed_internal_operation list * context * Contract.big_map_diff option) tzresult Lwt.t = + parse_script ctxt unparsed_script ~legacy:true + >>=? fun (Ex_script { code ; arg_type ; storage ; storage_type ; root_name }, ctxt) -> trace - (Bad_contract_parameter self) - (parse_data ctxt arg_type arg) >>=? fun (arg, ctxt) -> - Script.force_decode ctxt script.code >>=? fun (script_code, ctxt) -> + (Bad_contract_parameter step_constants.self) + (Lwt.return (find_entrypoint arg_type ~root_name entrypoint)) >>=? fun (box, _) -> trace - (Runtime_contract_error (self, script_code)) - (interp ?log ctxt ~source ~payer ~self amount code (arg, storage)) - >>=? fun ((ops, sto), ctxt) -> + (Bad_contract_parameter step_constants.self) + (parse_data ctxt ~legacy:false arg_type (box arg)) >>=? fun (arg, ctxt) -> + Script.force_decode ctxt unparsed_script.code >>=? fun (script_code, ctxt) -> + Script_ir_translator.collect_big_maps ctxt arg_type arg >>=? fun (to_duplicate, ctxt) -> + Script_ir_translator.collect_big_maps ctxt storage_type storage >>=? fun (to_update, ctxt) -> + trace + (Runtime_contract_error (step_constants.self, script_code)) + (interp ?log ctxt step_constants code (arg, storage)) + >>=? fun ((ops, storage), ctxt) -> + Script_ir_translator.extract_big_map_diff ctxt mode + ~temporary:false ~to_duplicate ~to_update storage_type storage + >>=? fun (storage, big_map_diff, ctxt) -> trace Cannot_serialize_storage - (unparse_data ctxt mode storage_type sto) >>=? fun (storage, ctxt) -> - return (Micheline.strip_locations storage, ops, ctxt, - Script_ir_translator.extract_big_map storage_type sto) + (unparse_data ctxt mode storage_type storage) >>=? fun (storage, ctxt) -> + let ops, op_diffs = List.split ops in + let big_map_diff = match + List.flatten (List.map (Option.unopt ~default:[]) (op_diffs @ [ big_map_diff ])) + with + | [] -> None + | diff -> Some diff in + return (Micheline.strip_locations storage, ops, ctxt, big_map_diff) type execution_result = { ctxt : context ; @@ -866,26 +1019,14 @@ type execution_result = big_map_diff : Contract.big_map_diff option ; operations : packed_internal_operation list } -let trace ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount = +let trace ctxt mode step_constants ~script ~entrypoint ~parameter = let log = ref [] in - execute ~log ctxt mode ~source ~payer ~self script amount (Micheline.root parameter) - >>=? fun (storage, operations, ctxt, big_map) -> - begin match big_map with - | None -> return (None, ctxt) - | Some big_map -> - Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) -> - return (Some big_map_diff, ctxt) - end >>=? fun (big_map_diff, ctxt) -> + execute ~log ctxt mode step_constants ~entrypoint script (Micheline.root parameter) + >>=? fun (storage, operations, ctxt, big_map_diff) -> let trace = List.rev !log in return ({ ctxt ; storage ; big_map_diff ; operations }, trace) -let execute ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount = - execute ctxt mode ~source ~payer ~self script amount (Micheline.root parameter) - >>=? fun (storage, operations, ctxt, big_map) -> - begin match big_map with - | None -> return (None, ctxt) - | Some big_map -> - Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) -> - return (Some big_map_diff, ctxt) - end >>=? fun (big_map_diff, ctxt) -> +let execute ctxt mode step_constants ~script ~entrypoint ~parameter = + execute ctxt mode step_constants ~entrypoint script (Micheline.root parameter) + >>=? fun (storage, operations, ctxt, big_map_diff) -> return { ctxt ; storage ; big_map_diff ; operations } diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli index d333515cd..7d583d37a 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli @@ -42,26 +42,38 @@ type execution_result = big_map_diff : Contract.big_map_diff option ; operations : packed_internal_operation list } +type step_constants = + { source : Contract.t ; + payer : Contract.t ; + self : Contract.t ; + amount : Tez.t ; + chain_id : Chain_id.t } + type 'tys stack = | Item : 'ty * 'rest stack -> ('ty * 'rest) stack | Empty : Script_typed_ir.end_of_stack stack +val step: + ?log: execution_trace ref -> + context -> step_constants -> + ('bef, 'aft) Script_typed_ir.descr -> + 'bef stack -> + ('aft stack * context) tzresult Lwt.t + val execute: Alpha_context.t -> Script_ir_translator.unparsing_mode -> - source: Contract.t -> - payer: Contract.t -> - self: (Contract.t * Script.t) -> + step_constants -> + script: Script.t -> + entrypoint: string -> parameter: Script.expr -> - amount: Tez.t -> execution_result tzresult Lwt.t val trace: Alpha_context.t -> Script_ir_translator.unparsing_mode -> - source: Contract.t -> - payer: Contract.t -> - self: (Contract.t * Script.t) -> + step_constants -> + script: Script.t -> + entrypoint: string -> parameter: Script.expr -> - amount: Tez.t -> (execution_result * execution_trace) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml index 57c0af937..33660d98e 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml @@ -101,26 +101,26 @@ let gen_access_annot Some (`Var_annot (String.concat "." [v; f])) let merge_type_annot - : type_annot option -> type_annot option -> type_annot option tzresult - = fun annot1 annot2 -> + : legacy: bool -> type_annot option -> type_annot option -> type_annot option tzresult + = fun ~legacy annot1 annot2 -> match annot1, annot2 with | None, None | Some _, None | None, Some _ -> ok None | Some `Type_annot a1, Some `Type_annot a2 -> - if String.equal a1 a2 + if legacy || String.equal a1 a2 then ok annot1 else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2)) let merge_field_annot - : field_annot option -> field_annot option -> field_annot option tzresult - = fun annot1 annot2 -> + : legacy: bool -> field_annot option -> field_annot option -> field_annot option tzresult + = fun ~legacy annot1 annot2 -> match annot1, annot2 with | None, None | Some _, None | None, Some _ -> ok None | Some `Field_annot a1, Some `Field_annot a2 -> - if String.equal a1 a2 + if legacy || String.equal a1 a2 then ok annot1 else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2)) @@ -257,26 +257,6 @@ let parse_composed_type_annot get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2) -let check_const_type_annot - : int -> string list -> type_annot option -> field_annot option list -> unit tzresult Lwt.t - = fun loc annot expected_name expected_fields -> - Lwt.return - (parse_composed_type_annot loc annot >>? fun (ty_name, field1, field2) -> - merge_type_annot expected_name ty_name >>? fun _ -> - match expected_fields, field1, field2 with - | [], Some _, _ | [], _, Some _ | [_], Some _, Some _ -> - (* Too many annotations *) - error (Unexpected_annotation loc) - | _ :: _ :: _ :: _, _, _ | [_], None, Some _ -> - error (Unexpected_annotation loc) - | [], None, None -> ok () - | [ f1; f2 ], _, _ -> - merge_field_annot f1 field1 >>? fun _ -> - merge_field_annot f2 field2 >|? fun _ -> () - | [ f1 ], _, None -> - merge_field_annot f1 field1 >|? fun _ -> () - ) - let parse_field_annot : int -> string list -> field_annot option tzresult = fun loc annot -> @@ -290,12 +270,18 @@ let extract_field_annot : Script.node -> (Script.node * field_annot option) tzresult = function | Prim (loc, prim, args, annot) -> - let field_annots, annot = List.partition (fun s -> - Compare.Int.(String.length s > 0) && - Compare.Char.(s.[0] = '%') - ) annot in - parse_field_annot loc field_annots >|? fun field_annot -> - Prim (loc, prim, args, annot), field_annot + let rec extract_first acc = function + | [] -> None, annot + | s :: rest -> + if Compare.Int.(String.length s > 0) && + Compare.Char.(s.[0] = '%') then + Some s, List.rev_append acc rest + else extract_first (s :: acc) rest in + let field_annot, annot = extract_first [] annot in + let field_annot = match field_annot with + | None -> None + | Some field_annot -> Some (`Field_annot (String.sub field_annot 1 (String.length field_annot - 1))) in + ok (Prim (loc, prim, args, annot), field_annot) | expr -> ok (expr, None) let check_correct_field @@ -402,6 +388,19 @@ let parse_destr_annot | None -> value_annot in (v, f) +let parse_entrypoint_annot + : int -> ?default:var_annot option -> string list -> (var_annot option * field_annot option) tzresult + = fun loc ?default annot -> + parse_annots loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc types >>? fun () -> + get_one_annot loc fields >>? fun f -> + get_one_annot loc vars >|? function + | Some _ as a -> (a, f) + | None -> match default with + | Some a -> (a, f) + | None -> (None, f) + let parse_var_type_annot : int -> string list -> (var_annot option * type_annot option) tzresult = fun loc annot -> diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli index 0ad19733a..7ac470139 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli @@ -72,28 +72,28 @@ val var_to_field_annot : var_annot option -> field_annot option (** Replace an annotation by its default value if it is [None] *) val default_annot : default:'a option -> 'a option -> 'a option -(** Generate annotation for field accesses, of the form @var.field1.field2 *) +(** Generate annotation for field accesses, of the form [var.field1.field2] *) val gen_access_annot : var_annot option -> ?default:field_annot option -> field_annot option -> var_annot option (** Merge type annotations. - @returns an error {!Inconsistent_type_annotations} if they are both present - and different *) + @return an error {!Inconsistent_type_annotations} if they are both present + and different, unless [legacy] *) val merge_type_annot : - type_annot option -> type_annot option -> type_annot option tzresult + legacy: bool -> type_annot option -> type_annot option -> type_annot option tzresult (** Merge field annotations. - @returns an error {!Inconsistent_type_annotations} if they are both present - and different *) + @return an error {!Inconsistent_type_annotations} if they are both present + and different, unless [legacy] *) val merge_field_annot : - field_annot option -> field_annot option -> field_annot option tzresult + legacy: bool -> field_annot option -> field_annot option -> field_annot option tzresult (** Merge variable annotations, does not fail ([None] if different). *) val merge_var_annot : var_annot option -> var_annot option -> var_annot option -(** @returns an error {!Unexpected_annotation} in the monad the list is not empty. *) +(** @return an error {!Unexpected_annotation} in the monad the list is not empty. *) val error_unexpected_annot : int -> 'a list -> unit tzresult (** Same as {!error_unexpected_annot} in Lwt. *) @@ -117,11 +117,6 @@ val parse_composed_type_annot : int -> string list -> (type_annot option * field_annot option * field_annot option) tzresult -(** Check that type annotations on constants are consistent *) -val check_const_type_annot : - int -> string list -> type_annot option -> field_annot option list -> - unit tzresult Lwt.t - (** Extract and remove a field annotation from a node *) val extract_field_annot : Script.node -> (Script.node * field_annot option) tzresult @@ -157,5 +152,11 @@ val parse_destr_annot : value_annot:var_annot option -> (var_annot option * field_annot option) tzresult +val parse_entrypoint_annot : + int -> + ?default:var_annot option -> + string list -> + (var_annot option * field_annot option) tzresult + val parse_var_type_annot : int -> string list -> (var_annot option * type_annot option) tzresult diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml index 7deac7920..b73d610ba 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml @@ -40,7 +40,8 @@ type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty type tc_context = | Lambda : tc_context | Dip : 'a stack_ty * tc_context -> tc_context - | Toplevel : { storage_type : 'sto ty ; param_type : 'param ty } -> tc_context + | Toplevel : { storage_type : 'sto ty ; param_type : 'param ty ; root_name : string option ; + legacy_create_contract_literal : bool } -> tc_context type unparsing_mode = Optimized | Readable @@ -54,8 +55,7 @@ let add_dip ty annot prev = (* ---- Type size accounting ------------------------------------------------*) -(* TODO include annot in size ? *) -let comparable_type_size : type t. t comparable_ty -> int = fun ty -> +let rec comparable_type_size : type t a. (t, a) comparable_struct -> int = fun ty -> (* No wildcard to force the update when comparable_ty chages. *) match ty with | Int_key _ -> 1 @@ -67,8 +67,8 @@ let comparable_type_size : type t. t comparable_ty -> int = fun ty -> | Key_hash_key _ -> 1 | Timestamp_key _ -> 1 | Address_key _ -> 1 + | Pair_key (_, (t, _), _) -> 1 + comparable_type_size t -(* TODO include annot in size ? *) let rec type_size : type t. t ty -> int = fun ty -> match ty with | Unit_t _ -> 1 @@ -84,24 +84,25 @@ let rec type_size : type t. t ty -> int = | Address_t _ -> 1 | Bool_t _ -> 1 | Operation_t _ -> 1 - | Pair_t ((l, _, _), (r, _, _), _) -> + | Pair_t ((l, _, _), (r, _, _), _, _) -> 1 + type_size l + type_size r - | Union_t ((l, _), (r, _), _) -> + | Union_t ((l, _), (r, _), _, _) -> 1 + type_size l + type_size r | Lambda_t (arg, ret, _) -> 1 + type_size arg + type_size ret - | Option_t ((t,_), _, _) -> + | Option_t (t, _, _) -> 1 + type_size t - | List_t (t, _) -> + | List_t (t, _, _) -> 1 + type_size t | Set_t (k, _) -> 1 + comparable_type_size k - | Map_t (k, v, _) -> + | Map_t (k, v, _, _) -> 1 + comparable_type_size k + type_size v | Big_map_t (k, v, _) -> 1 + comparable_type_size k + type_size v | Contract_t (arg, _) -> 1 + type_size arg + | Chain_id_t _ -> 1 let rec type_size_of_stack_head : type st. st stack_ty -> up_to:int -> int @@ -152,6 +153,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Map_get -> 0 | Map_update -> 0 | Map_size -> 0 + | Empty_big_map _ -> 1 | Big_map_get -> 0 | Big_map_update -> 0 | Big_map_mem -> 0 @@ -209,6 +211,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Loop_left _ -> 0 | Dip _ -> 0 | Exec -> 0 + | Apply _ -> 0 | Lambda _ -> 1 | Failwith _ -> 1 | Nop -> 0 @@ -225,6 +228,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Create_account -> 0 | Implicit_account -> 0 | Create_contract _ -> 1 + | Create_contract_2 _ -> 1 | Now -> 0 | Balance -> 0 | Check_signature -> 0 @@ -240,6 +244,11 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Set_delegate -> 0 | Pack _ -> 0 | Unpack _ -> 1 + | Dig _ -> 0 + | Dug _ -> 0 + | Dipn _ -> 0 + | Dropn _ -> 0 + | ChainId -> 0 (* ---- Error helpers -------------------------------------------------------*) @@ -282,6 +291,7 @@ let namespace = function | I_BALANCE | I_CAR | I_CDR + | I_CHAIN_ID | I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT @@ -293,10 +303,12 @@ let namespace = function | I_DROP | I_DUP | I_EDIV + | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC + | I_APPLY | I_FAILWITH | I_GE | I_GET @@ -347,7 +359,9 @@ let namespace = function | I_CONTRACT | I_ISNAT | I_CAST - | I_RENAME -> Instr_namespace + | I_RENAME + | I_DIG + | I_DUG -> Instr_namespace | T_bool | T_contract | T_int @@ -369,7 +383,8 @@ let namespace = function | T_timestamp | T_unit | T_operation - | T_address -> Type_namespace + | T_address + | T_chain_id -> Type_namespace let unexpected expr exp_kinds exp_ns exp_prims = @@ -397,26 +412,35 @@ let check_kind kinds expr = (* ---- Sets and Maps -------------------------------------------------------*) -let compare_comparable - : type a. a comparable_ty -> a -> a -> int - = fun kind x y -> match kind with - | String_key _ -> Compare.String.compare x y - | Bool_key _ -> Compare.Bool.compare x y - | Mutez_key _ -> Tez.compare x y - | Key_hash_key _ -> Signature.Public_key_hash.compare x y - | Int_key _ -> - let res = (Script_int.compare x y) in - if Compare.Int.(res = 0) then 0 - else if Compare.Int.(res > 0) then 1 - else -1 - | Nat_key _ -> - let res = (Script_int.compare x y) in - if Compare.Int.(res = 0) then 0 - else if Compare.Int.(res > 0) then 1 - else -1 - | Timestamp_key _ -> Script_timestamp.compare x y - | Address_key _ -> Contract.compare x y - | Bytes_key _ -> MBytes.compare x y +let wrap_compare compare a b = + let res = compare a b in + if Compare.Int.(res = 0) then 0 + else if Compare.Int.(res > 0) then 1 + else -1 + +let rec compare_comparable + : type a s. (a, s) comparable_struct -> a -> a -> int + = fun kind -> match kind with + | String_key _ -> wrap_compare Compare.String.compare + | Bool_key _ -> wrap_compare Compare.Bool.compare + | Mutez_key _ -> wrap_compare Tez.compare + | Key_hash_key _ -> wrap_compare Signature.Public_key_hash.compare + | Int_key _ -> wrap_compare Script_int.compare + | Nat_key _ -> wrap_compare Script_int.compare + | Timestamp_key _ -> wrap_compare Script_timestamp.compare + | Address_key _ -> + wrap_compare @@ fun (x, ex) (y, ey) -> + let lres = Contract.compare x y in + if Compare.Int.(lres = 0) then + Compare.String.compare ex ey + else lres + | Bytes_key _ -> wrap_compare MBytes.compare + | Pair_key ((tl, _), (tr, _), _) -> + fun (lx, rx) (ly, ry) -> + let lres = compare_comparable tl lx ly in + if Compare.Int.(lres = 0) then + compare_comparable tr rx ry + else lres let empty_set : type a. a comparable_ty -> a set @@ -427,6 +451,7 @@ let empty_set end) in (module struct type elt = a + let elt_ty = ty module OPS = OPS let boxed = OPS.empty let size = 0 @@ -437,6 +462,7 @@ let set_update = fun v b (module Box) -> (module struct type elt = a + let elt_ty = Box.elt_ty module OPS = Box.OPS let boxed = if b @@ -534,8 +560,8 @@ let map_size (* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*) -let ty_of_comparable_ty - : type a. a comparable_ty -> a ty +let rec ty_of_comparable_ty + : type a s. (a, s) comparable_struct -> a ty = function | Int_key tname -> Int_t tname | Nat_key tname -> Nat_t tname @@ -546,9 +572,47 @@ let ty_of_comparable_ty | Key_hash_key tname -> Key_hash_t tname | Timestamp_key tname -> Timestamp_t tname | Address_key tname -> Address_t tname + | Pair_key ((l, al), (r, ar), tname) -> + Pair_t ((ty_of_comparable_ty l, al, None), (ty_of_comparable_ty r, ar, None), tname, false) -let unparse_comparable_ty - : type a. a comparable_ty -> Script.node +let rec comparable_ty_of_ty + : type a. a ty -> a comparable_ty option + = function + | Int_t tname -> Some (Int_key tname) + | Nat_t tname -> Some (Nat_key tname) + | String_t tname -> Some (String_key tname) + | Bytes_t tname -> Some (Bytes_key tname) + | Mutez_t tname -> Some (Mutez_key tname) + | Bool_t tname -> Some (Bool_key tname) + | Key_hash_t tname -> Some (Key_hash_key tname) + | Timestamp_t tname -> Some (Timestamp_key tname) + | Address_t tname -> Some (Address_key tname) + | Pair_t ((l, al, _), (r, ar, _), pname, _) -> + begin match comparable_ty_of_ty r with + | None -> None + | Some rty -> + match comparable_ty_of_ty l with + | None -> None + | Some (Pair_key _) -> None (* not a comb *) + | Some (Int_key tname) -> Some (Pair_key ((Int_key tname, al), (rty, ar), pname)) + | Some (Nat_key tname) -> Some (Pair_key ((Nat_key tname, al), (rty, ar), pname)) + | Some (String_key tname) -> Some (Pair_key ((String_key tname, al), (rty, ar), pname)) + | Some (Bytes_key tname) -> Some (Pair_key ((Bytes_key tname, al), (rty, ar), pname)) + | Some (Mutez_key tname) -> Some (Pair_key ((Mutez_key tname, al), (rty, ar), pname)) + | Some (Bool_key tname) -> Some (Pair_key ((Bool_key tname, al), (rty, ar), pname)) + | Some (Key_hash_key tname) -> Some (Pair_key ((Key_hash_key tname, al), (rty, ar), pname)) + | Some (Timestamp_key tname) -> Some (Pair_key ((Timestamp_key tname, al), (rty, ar), pname)) + | Some (Address_key tname) -> Some (Pair_key ((Address_key tname, al), (rty, ar), pname)) + end + | _ -> None + +let add_field_annot a var = function + | Prim (loc, prim, args, annots) -> + Prim (loc, prim, args, annots @ unparse_field_annot a @ unparse_var_annot var ) + | expr -> expr + +let rec unparse_comparable_ty + : type a s. (a, s) comparable_struct -> Script.node = function | Int_key tname -> Prim (-1, T_int, [], unparse_type_annot tname) | Nat_key tname -> Prim (-1, T_nat, [], unparse_type_annot tname) @@ -559,11 +623,10 @@ let unparse_comparable_ty | Key_hash_key tname -> Prim (-1, T_key_hash, [], unparse_type_annot tname) | Timestamp_key tname -> Prim (-1, T_timestamp, [], unparse_type_annot tname) | Address_key tname -> Prim (-1, T_address, [], unparse_type_annot tname) - -let add_field_annot a var = function - | Prim (loc, prim, args, annots) -> - Prim (loc, prim, args, annots @ unparse_field_annot a @ unparse_var_annot var ) - | expr -> expr + | Pair_key ((l, al), (r, ar), pname) -> + let tl = add_field_annot al None (unparse_comparable_ty l) in + let tr = add_field_annot ar None (unparse_comparable_ty r) in + Prim (-1, T_pair, [ tl ; tr ], unparse_type_annot pname) let rec unparse_ty_no_lwt : type a. context -> a ty -> (Script.node * context) tzresult @@ -587,17 +650,18 @@ let rec unparse_ty_no_lwt | Address_t tname -> return ctxt (T_address, [], unparse_type_annot tname) | Signature_t tname -> return ctxt (T_signature, [], unparse_type_annot tname) | Operation_t tname -> return ctxt (T_operation, [], unparse_type_annot tname) + | Chain_id_t tname -> return ctxt (T_chain_id, [], unparse_type_annot tname) | Contract_t (ut, tname) -> unparse_ty_no_lwt ctxt ut >>? fun (t, ctxt) -> return ctxt (T_contract, [ t ], unparse_type_annot tname) - | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname) -> + | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname, _) -> let annot = unparse_type_annot tname in unparse_ty_no_lwt ctxt utl >>? fun (utl, ctxt) -> let tl = add_field_annot l_field l_var utl in unparse_ty_no_lwt ctxt utr >>? fun (utr, ctxt) -> let tr = add_field_annot r_field r_var utr in return ctxt (T_pair, [ tl; tr ], annot) - | Union_t ((utl, l_field), (utr, r_field), tname) -> + | Union_t ((utl, l_field), (utr, r_field), tname, _) -> let annot = unparse_type_annot tname in unparse_ty_no_lwt ctxt utl >>? fun (utl, ctxt) -> let tl = add_field_annot l_field None utl in @@ -608,18 +672,17 @@ let rec unparse_ty_no_lwt unparse_ty_no_lwt ctxt uta >>? fun (ta, ctxt) -> unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> return ctxt (T_lambda, [ ta; tr ], unparse_type_annot tname) - | Option_t ((ut, some_field), _none_field, tname) -> + | Option_t (ut, tname, _) -> let annot = unparse_type_annot tname in unparse_ty_no_lwt ctxt ut >>? fun (ut, ctxt) -> - let t = add_field_annot some_field None ut in - return ctxt (T_option, [ t ], annot) - | List_t (ut, tname) -> + return ctxt (T_option, [ ut ], annot) + | List_t (ut, tname, _) -> unparse_ty_no_lwt ctxt ut >>? fun (t, ctxt) -> return ctxt (T_list, [ t ], unparse_type_annot tname) | Set_t (ut, tname) -> let t = unparse_comparable_ty ut in return ctxt (T_set, [ t ], unparse_type_annot tname) - | Map_t (uta, utr, tname) -> + | Map_t (uta, utr, tname, _) -> let ta = unparse_comparable_ty uta in unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> return ctxt (T_map, [ ta; tr ], unparse_type_annot tname) @@ -671,14 +734,15 @@ let name_of_ty | Address_t tname -> tname | Signature_t tname -> tname | Operation_t tname -> tname + | Chain_id_t tname -> tname | Contract_t (_, tname) -> tname - | Pair_t (_, _, tname) -> tname - | Union_t (_, _, tname) -> tname + | Pair_t (_, _, tname, _) -> tname + | Union_t (_, _, tname, _) -> tname | Lambda_t (_, _, tname) -> tname - | Option_t (_, _, tname) -> tname - | List_t (_, tname) -> tname + | Option_t (_, tname, _) -> tname + | List_t (_, tname, _) -> tname | Set_t (_, tname) -> tname - | Map_t (_, _, tname) -> tname + | Map_t (_, _, tname, _) -> tname | Big_map_t (_, _, tname) -> tname (* ---- Equality witnesses --------------------------------------------------*) @@ -736,10 +800,11 @@ let rec ty_eq | Signature_t _, Signature_t _ -> ok Eq ctxt 0 | Mutez_t _, Mutez_t _ -> ok Eq ctxt 0 | Timestamp_t _, Timestamp_t _ -> ok Eq ctxt 0 + | Chain_id_t _, Chain_id_t _ -> ok Eq ctxt 0 | Address_t _, Address_t _ -> ok Eq ctxt 0 | Bool_t _, Bool_t _ -> ok Eq ctxt 0 | Operation_t _, Operation_t _ -> ok Eq ctxt 0 - | Map_t (tal, tar, _), Map_t (tbl, tbr, _) -> + | Map_t (tal, tar, _, _), Map_t (tbl, tbr, _, _) -> (comparable_ty_eq ctxt tal tbl >>? fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> (ok Eq ctxt 2)) |> @@ -753,13 +818,14 @@ let rec ty_eq (comparable_ty_eq ctxt ea eb >>? fun Eq -> (ok Eq ctxt 1)) |> record_inconsistent ctxt ta tb - | Pair_t ((tal, _, _), (tar, _, _), _), - Pair_t ((tbl, _, _), (tbr, _, _), _) -> + | Pair_t ((tal, _, _), (tar, _, _), _, _), + Pair_t ((tbl, _, _), (tbr, _, _), _, _) -> (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> (ok Eq ctxt 2)) |> record_inconsistent ctxt ta tb - | Union_t ((tal, _), (tar, _), _), Union_t ((tbl, _), (tbr, _), _) -> + | Union_t ((tal, _), (tar, _), _, _), + Union_t ((tbl, _), (tbr, _), _, _) -> (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> (ok Eq ctxt 2)) |> @@ -773,11 +839,11 @@ let rec ty_eq (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> (ok Eq ctxt 1)) |> record_inconsistent ctxt ta tb - | Option_t ((tva, _), _, _), Option_t ((tvb, _), _, _) -> + | Option_t (tva, _, _), Option_t (tvb, _, _) -> (ty_eq ctxt tva tvb >>? fun (Eq, ctxt) -> (ok Eq ctxt 1)) |> record_inconsistent ctxt ta tb - | List_t (tva, _), List_t (tvb, _) -> + | List_t (tva, _, _), List_t (tvb, _, _) -> (ty_eq ctxt tva tvb >>? fun (Eq, ctxt) -> (ok Eq ctxt 1)) |> record_inconsistent ctxt ta tb @@ -800,154 +866,148 @@ let rec stack_ty_eq | _, _ -> error Bad_stack_length let merge_comparable_types - : type ta. ta comparable_ty -> ta comparable_ty -> ta comparable_ty tzresult - = fun ta tb -> + : type ta. legacy: bool -> ta comparable_ty -> ta comparable_ty -> ta comparable_ty tzresult + = fun ~legacy ta tb -> match ta, tb with | Int_key annot_a, Int_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Int_key annot | Nat_key annot_a, Nat_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Nat_key annot | String_key annot_a, String_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> String_key annot | Bytes_key annot_a, Bytes_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bytes_key annot | Mutez_key annot_a, Mutez_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Mutez_key annot | Bool_key annot_a, Bool_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bool_key annot | Key_hash_key annot_a, Key_hash_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Key_hash_key annot | Timestamp_key annot_a, Timestamp_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Timestamp_key annot | Address_key annot_a, Address_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Address_key annot | _, _ -> assert false (* FIXME: fix injectivity of some types *) -let rec strip_annotations = function - | (Int (_,_) as i) -> i - | (String (_,_) as s) -> s - | (Bytes (_,_) as s) -> s - | Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, []) - | Seq (loc, items) -> Seq (loc, List.map strip_annotations items) - let merge_types : - type b. context -> Script.location -> b ty -> b ty -> (b ty * context) tzresult = + type b. legacy: bool -> context -> Script.location -> b ty -> b ty -> (b ty * context) tzresult = fun ~legacy -> let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult = fun ctxt ty1 ty2 -> match ty1, ty2 with | Unit_t tn1, Unit_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Unit_t tname, ctxt | Int_t tn1, Int_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Int_t tname, ctxt | Nat_t tn1, Nat_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Nat_t tname, ctxt | Key_t tn1, Key_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Key_t tname, ctxt | Key_hash_t tn1, Key_hash_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Key_hash_t tname, ctxt | String_t tn1, String_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> String_t tname, ctxt | Bytes_t tn1, Bytes_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Bytes_t tname, ctxt | Signature_t tn1, Signature_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Signature_t tname, ctxt | Mutez_t tn1, Mutez_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Mutez_t tname, ctxt | Timestamp_t tn1, Timestamp_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Timestamp_t tname, ctxt | Address_t tn1, Address_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Address_t tname, ctxt | Bool_t tn1, Bool_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Bool_t tname, ctxt + | Chain_id_t tn1, Chain_id_t tn2 -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> + Chain_id_t tname, ctxt | Operation_t tn1, Operation_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Operation_t tname, ctxt - | Map_t (tal, tar, tn1), Map_t (tbl, tbr, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + | Map_t (tal, tar, tn1, has_big_map), Map_t (tbl, tbr, tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tar tbr >>? fun (value, ctxt) -> ty_eq ctxt tar value >>? fun (Eq, ctxt) -> - merge_comparable_types tal tbl >|? fun tk -> - Map_t (tk, value, tname), ctxt + merge_comparable_types ~legacy tal tbl >|? fun tk -> + Map_t (tk, value, tname, has_big_map), ctxt | Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tar tbr >>? fun (value, ctxt) -> ty_eq ctxt tar value >>? fun (Eq, ctxt) -> - merge_comparable_types tal tbl >|? fun tk -> + merge_comparable_types ~legacy tal tbl >|? fun tk -> Big_map_t (tk, value, tname), ctxt | Set_t (ea, tn1), Set_t (eb, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_comparable_types ea eb >|? fun e -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> + merge_comparable_types ~legacy ea eb >|? fun e -> Set_t (e, tname), ctxt - | Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1), - Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_field_annot l_field1 l_field2 >>? fun l_field -> - merge_field_annot r_field1 r_field2 >>? fun r_field -> + | Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1, has_big_map), + Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> + merge_field_annot ~legacy l_field1 l_field2 >>? fun l_field -> + merge_field_annot ~legacy r_field1 r_field2 >>? fun r_field -> let l_var = merge_var_annot l_var1 l_var2 in let r_var = merge_var_annot r_var1 r_var2 in help ctxt tal tbl >>? fun (left_ty, ctxt) -> help ctxt tar tbr >|? fun (right_ty, ctxt) -> - Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname), + Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname, has_big_map), ctxt - | Union_t ((tal, tal_annot), (tar, tar_annot), tn1), - Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_field_annot tal_annot tbl_annot >>? fun left_annot -> - merge_field_annot tar_annot tbr_annot >>? fun right_annot -> + | Union_t ((tal, tal_annot), (tar, tar_annot), tn1, has_big_map), + Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> + merge_field_annot ~legacy tal_annot tbl_annot >>? fun left_annot -> + merge_field_annot ~legacy tar_annot tbr_annot >>? fun right_annot -> help ctxt tal tbl >>? fun (left_ty, ctxt) -> help ctxt tar tbr >|? fun (right_ty, ctxt) -> - Union_t ((left_ty, left_annot), (right_ty, right_annot), tname), + Union_t ((left_ty, left_annot), (right_ty, right_annot), tname, has_big_map), ctxt | Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tal tbl >>? fun (left_ty, ctxt) -> help ctxt tar tbr >|? fun (right_ty, ctxt) -> Lambda_t (left_ty, right_ty, tname), ctxt | Contract_t (tal, tn1), Contract_t (tbl, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tal tbl >|? fun (arg_ty, ctxt) -> Contract_t (arg_ty, tname), ctxt - | Option_t ((tva, some_annot_a), none_annot_a, tn1), - Option_t ((tvb, some_annot_b), none_annot_b, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_field_annot some_annot_a some_annot_b >>? fun some_annot -> - merge_field_annot none_annot_a none_annot_b >>? fun none_annot -> + | Option_t (tva, tn1, has_big_map), + Option_t (tvb, tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tva tvb >|? fun (ty, ctxt) -> - Option_t ((ty, some_annot), none_annot, tname), ctxt - | List_t (tva, tn1), List_t (tvb, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + Option_t (ty, tname, has_big_map), ctxt + | List_t (tva, tn1, has_big_map), List_t (tvb, tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tva tvb >|? fun (ty, ctxt) -> - List_t (ty, tname), ctxt + List_t (ty, tname, has_big_map), ctxt | _, _ -> assert false in (fun ctxt loc ty1 ty2 -> record_inconsistent_type_annotations ctxt loc ty1 ty2 (help ctxt ty1 ty2)) let merge_stacks - : type ta. Script.location -> context -> ta stack_ty -> ta stack_ty -> - (ta stack_ty * context) tzresult - = fun loc -> + : type ta. legacy: bool -> Script.location -> context -> ta stack_ty -> ta stack_ty -> + (ta stack_ty * context) tzresult + = fun ~legacy loc -> let rec help : type a. context -> a stack_ty -> a stack_ty -> (a stack_ty * context) tzresult = fun ctxt stack1 stack2 -> @@ -956,11 +1016,38 @@ let merge_stacks | Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2) -> let annot = merge_var_annot annot1 annot2 in - merge_types ctxt loc ty1 ty2 >>? fun (ty, ctxt) -> + merge_types ~legacy ctxt loc ty1 ty2 >>? fun (ty, ctxt) -> help ctxt rest1 rest2 >|? fun (rest, ctxt) -> Item_t (ty, rest, annot), ctxt in help +let has_big_map + : type t. t ty -> bool + = function + | Unit_t _ -> false + | Int_t _ -> false + | Nat_t _ -> false + | Signature_t _ -> false + | String_t _ -> false + | Bytes_t _ -> false + | Mutez_t _ -> false + | Key_hash_t _ -> false + | Key_t _ -> false + | Timestamp_t _ -> false + | Address_t _ -> false + | Bool_t _ -> false + | Lambda_t (_, _, _) -> false + | Set_t (_, _) -> false + | Big_map_t (_, _, _) -> true + | Contract_t (_, _) -> false + | Operation_t _ -> false + | Chain_id_t _ -> false + | Pair_t (_, _, _, has_big_map) -> has_big_map + | Union_t (_, _, _, has_big_map) -> has_big_map + | Option_t (_, _, has_big_map) -> has_big_map + | List_t (_, _, has_big_map) -> has_big_map + | Map_t (_, _, _, has_big_map) -> has_big_map + (* ---- Type checker results -------------------------------------------------*) type 'bef judgement = @@ -974,10 +1061,10 @@ type ('t, 'f, 'b) branch = let merge_branches - : type bef a b. context -> int -> a judgement -> b judgement -> - (a, b, bef) branch -> - (bef judgement * context) tzresult Lwt.t - = fun ctxt loc btr bfr { branch } -> + : type bef a b. legacy: bool -> context -> int -> a judgement -> b judgement -> + (a, b, bef) branch -> + (bef judgement * context) tzresult Lwt.t + = fun ~legacy ctxt loc btr bfr { branch } -> match btr, bfr with | Typed ({ aft = aftbt ; _ } as dbt), Typed ({ aft = aftbf ; _ } as dbf) -> let unmatched_branches () = @@ -986,7 +1073,7 @@ let merge_branches Unmatched_branches (loc, aftbt, aftbf) in trace_eval unmatched_branches (Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf) >>=? fun (Eq, ctxt) -> - Lwt.return (merge_stacks loc ctxt aftbt aftbf) >>=? fun (merged_stack, ctxt) -> + Lwt.return (merge_stacks ~legacy loc ctxt aftbt aftbf) >>=? fun (merged_stack, ctxt) -> return ( Typed (branch {dbt with aft=merged_stack} {dbf with aft=merged_stack}), ctxt)) @@ -1046,12 +1133,32 @@ let rec parse_comparable_ty T_string ; T_mutez ; T_bool ; T_key ; T_key_hash ; T_timestamp ] +and parse_packable_ty : + context -> legacy:bool -> + Script.node -> (ex_ty * context) tzresult + = fun ctxt ~legacy -> + parse_ty ctxt ~legacy ~allow_big_map:false ~allow_operation:false ~allow_contract:legacy + +and parse_parameter_ty : + context -> legacy:bool -> + Script.node -> (ex_ty * context) tzresult + = fun ctxt ~legacy -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:true + +and parse_any_ty : + context -> legacy:bool -> + Script.node -> (ex_ty * context) tzresult + = fun ctxt ~legacy -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:true ~allow_contract:true + and parse_ty : context -> + legacy: bool -> allow_big_map: bool -> allow_operation: bool -> + allow_contract: bool -> Script.node -> (ex_ty * context) tzresult - = fun ctxt ~allow_big_map ~allow_operation node -> + = fun ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract node -> Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> match node with | Prim (loc, T_unit, [], annot) -> @@ -1109,44 +1216,58 @@ and parse_ty : Ex_ty (Operation_t ty_name), ctxt else error (Unexpected_operation loc) - | Prim (loc, T_contract, [ utl ], annot) -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false utl >>? fun (Ex_ty tl, ctxt) -> + | Prim (loc, T_chain_id, [], annot) -> parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> - Ex_ty (Contract_t (tl, ty_name)), ctxt + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Chain_id_t ty_name), ctxt + | Prim (loc, T_contract, [ utl ], annot) -> + if allow_contract then + parse_parameter_ty ctxt ~legacy utl >>? fun (Ex_ty tl, ctxt) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> + Ex_ty (Contract_t (tl, ty_name)), ctxt + else + error (Unexpected_contract loc) | Prim (loc, T_pair, [ utl; utr ], annot) -> extract_field_annot utl >>? fun (utl, left_field) -> extract_field_annot utr >>? fun (utr, right_field) -> - parse_ty ctxt ~allow_big_map ~allow_operation utl >>? fun (Ex_ty tl, ctxt) -> - parse_ty ctxt ~allow_big_map ~allow_operation utr >>? fun (Ex_ty tr, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl >>? fun (Ex_ty tl, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr >>? fun (Ex_ty tr, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Pair_t ((tl, left_field, None), (tr, right_field, None), ty_name)), ctxt + Ex_ty (Pair_t ((tl, left_field, None), (tr, right_field, None), ty_name, has_big_map tl || has_big_map tr)), ctxt | Prim (loc, T_or, [ utl; utr ], annot) -> extract_field_annot utl >>? fun (utl, left_constr) -> extract_field_annot utr >>? fun (utr, right_constr) -> - parse_ty ctxt ~allow_big_map ~allow_operation utl >>? fun (Ex_ty tl, ctxt) -> - parse_ty ctxt ~allow_big_map ~allow_operation utr >>? fun (Ex_ty tr, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl >>? fun (Ex_ty tl, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr >>? fun (Ex_ty tr, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Union_t ((tl, left_constr), (tr, right_constr), ty_name)), ctxt + Ex_ty (Union_t ((tl, left_constr), (tr, right_constr), ty_name, has_big_map tl || has_big_map tr)), ctxt | Prim (loc, T_lambda, [ uta; utr ], annot) -> - parse_ty ctxt ~allow_big_map:true ~allow_operation:true uta >>? fun (Ex_ty ta, ctxt) -> - parse_ty ctxt ~allow_big_map:true ~allow_operation:true utr >>? fun (Ex_ty tr, ctxt) -> + parse_any_ty ctxt ~legacy uta >>? fun (Ex_ty ta, ctxt) -> + parse_any_ty ctxt ~legacy utr >>? fun (Ex_ty tr, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt | Prim (loc, T_option, [ ut ], annot) -> - extract_field_annot ut >>? fun (ut, some_constr) -> - parse_ty ctxt ~allow_big_map ~allow_operation ut >>? fun (Ex_ty t, ctxt) -> - parse_composed_type_annot loc annot >>? fun (ty_name, none_constr, _) -> + begin if legacy then + (* legacy semantics with (broken) field annotations *) + extract_field_annot ut >>? fun (ut, _some_constr) -> + parse_composed_type_annot loc annot >>? fun (ty_name, _none_constr, _) -> + ok (ut, ty_name) + else + parse_type_annot loc annot >>? fun ty_name -> + ok (ut, ty_name) + end >>? fun (ut, ty_name) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut >>? fun (Ex_ty t, ctxt) -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Option_t ((t, some_constr), none_constr, ty_name)), ctxt + Ex_ty (Option_t (t, ty_name, has_big_map t)), ctxt | Prim (loc, T_list, [ ut ], annot) -> - parse_ty ctxt ~allow_big_map ~allow_operation ut >>? fun (Ex_ty t, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut >>? fun (Ex_ty t, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> - Ex_ty (List_t (t, ty_name)), ctxt + Ex_ty (List_t (t, ty_name, has_big_map t)), ctxt | Prim (loc, T_set, [ ut ], annot) -> parse_comparable_ty ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> @@ -1154,13 +1275,13 @@ and parse_ty : Ex_ty (Set_t (t, ty_name)), ctxt | Prim (loc, T_map, [ uta; utr ], annot) -> parse_comparable_ty ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty ctxt ~allow_big_map ~allow_operation utr >>? fun (Ex_ty tr, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr >>? fun (Ex_ty tr, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Map_t (ta, tr, ty_name)), ctxt + Ex_ty (Map_t (ta, tr, ty_name, has_big_map tr)), ctxt | Prim (loc, T_big_map, args, annot) when allow_big_map -> - parse_big_map_ty ctxt loc args annot >>? fun (big_map_ty, ctxt) -> + parse_big_map_ty ctxt ~legacy loc args annot >>? fun (big_map_ty, ctxt) -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> big_map_ty, ctxt | Prim (loc, T_big_map, _, _) -> @@ -1171,9 +1292,9 @@ and parse_ty : | T_key | T_key_hash | T_timestamp | T_address as prim), l, _) -> error (Invalid_arity (loc, prim, 0, List.length l)) - | Prim (loc, (T_set | T_list | T_option as prim), l, _) -> + | Prim (loc, (T_set | T_list | T_option | T_contract as prim), l, _) -> error (Invalid_arity (loc, prim, 1, List.length l)) - | Prim (loc, (T_pair | T_or | T_map | T_lambda | T_contract as prim), l, _) -> + | Prim (loc, (T_pair | T_or | T_map | T_lambda as prim), l, _) -> error (Invalid_arity (loc, prim, 2, List.length l)) | expr -> error @@ unexpected expr [] Type_namespace @@ -1182,14 +1303,14 @@ and parse_ty : T_unit ; T_signature ; T_contract ; T_int ; T_nat ; T_operation ; T_string ; T_bytes ; T_mutez ; T_bool ; - T_key ; T_key_hash ; T_timestamp ] + T_key ; T_key_hash ; T_timestamp ; T_chain_id ] -and parse_big_map_ty ctxt big_map_loc args map_annot = +and parse_big_map_ty ctxt ~legacy big_map_loc args map_annot = Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> begin match args with | [ key_ty ; value_ty ] -> parse_comparable_ty ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false value_ty + parse_packable_ty ctxt ~legacy value_ty >>? fun (Ex_ty value_ty, ctxt) -> parse_type_annot big_map_loc map_annot >|? fun map_name -> let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in @@ -1198,27 +1319,35 @@ and parse_big_map_ty ctxt big_map_loc args map_annot = end and parse_storage_ty : - context -> Script.node -> (ex_ty * context) tzresult - = fun ctxt node -> + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult + = fun ctxt ~legacy node -> match node with | Prim (loc, T_pair, [ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ], - storage_annot) -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - parse_big_map_ty ctxt big_map_loc args map_annot >>? fun (Ex_ty big_map_ty, ctxt) -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false remaining_storage - >>? fun (Ex_ty remaining_storage, ctxt) -> - parse_composed_type_annot loc storage_annot - >>? fun (ty_name, map_field, storage_field) -> - Gas.consume ctxt (Typecheck_costs.type_ 5) >|? fun ctxt -> - Ex_ty (Pair_t ((big_map_ty, map_field, None), - (remaining_storage, storage_field, None), - ty_name)), - ctxt + storage_annot) when legacy -> + begin match storage_annot with + | [] -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy node + | [ single ] when Compare.Int.(String.length single > 0) && Compare.Char.(String.get single 0 = '%') -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy node + | _ -> + (* legacy semantics of big maps used the wrong annotation parser *) + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + parse_big_map_ty ctxt ~legacy big_map_loc args map_annot >>? fun (Ex_ty big_map_ty, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy remaining_storage + >>? fun (Ex_ty remaining_storage, ctxt) -> + parse_composed_type_annot loc storage_annot + >>? fun (ty_name, map_field, storage_field) -> + Gas.consume ctxt (Typecheck_costs.type_ 5) >|? fun ctxt -> + Ex_ty (Pair_t ((big_map_ty, map_field, None), + (remaining_storage, storage_field, None), + ty_name, true)), + ctxt + end | _ -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false node + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy node -let check_no_big_map_or_operation loc root = +let check_packable ~legacy loc root = let rec check : type t. t ty -> unit tzresult = function | Big_map_t _ -> error (Unexpected_big_map loc) | Operation_t _ -> error (Unexpected_operation loc) @@ -1234,23 +1363,55 @@ let check_no_big_map_or_operation loc root = | Timestamp_t _ -> ok () | Address_t _ -> ok () | Bool_t _ -> ok () - | Pair_t ((l_ty, _, _), (r_ty, _, _), _) -> + | Chain_id_t _ -> ok () + | Pair_t ((l_ty, _, _), (r_ty, _, _), _, _) -> check l_ty >>? fun () -> check r_ty - | Union_t ((l_ty, _), (r_ty, _), _) -> + | Union_t ((l_ty, _), (r_ty, _), _, _) -> check l_ty >>? fun () -> check r_ty - | Option_t ((v_ty, _), _, _) -> check v_ty - | List_t (elt_ty, _) -> check elt_ty + | Option_t (v_ty, _, _) -> check v_ty + | List_t (elt_ty, _, _) -> check elt_ty | Set_t (_, _) -> ok () - | Map_t (_, elt_ty, _) -> check elt_ty + | Map_t (_, elt_ty, _, _) -> check elt_ty | Lambda_t (_l_ty, _r_ty, _) -> ok () - | Contract_t (_, _) -> ok () in + | Contract_t (_, _) when legacy -> ok () + | Contract_t (_, _) -> error (Unexpected_contract loc) in check root type ex_script = Ex_script : ('a, 'c) script -> ex_script +type _ dig_proof_argument = + Dig_proof_argument + : ((('x * 'rest), 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * ('x ty * var_annot option) + * 'aft stack_ty) + -> 'bef dig_proof_argument + +type (_, _) dug_proof_argument = + Dug_proof_argument + : (('rest, ('x * 'rest), 'bef, 'aft) stack_prefix_preservation_witness + * unit + * 'aft stack_ty) + -> ('bef, 'x) dug_proof_argument + +type (_) dipn_proof_argument = + Dipn_proof_argument + : (('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + * (context * ('fbef, 'faft) descr) + * 'aft stack_ty) + -> 'bef dipn_proof_argument + +type (_) dropn_proof_argument = + Dropn_proof_argument + : (('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * 'rest stack_ty + * 'aft stack_ty) + -> 'bef dropn_proof_argument + (* Lwt versions *) let parse_var_annot loc ?default annot = Lwt.return (parse_var_annot loc ?default annot) +let parse_entrypoint_annot loc ?default annot = + Lwt.return (parse_entrypoint_annot loc ?default annot) let parse_constr_annot loc ?if_special_first ?if_special_second annot = Lwt.return (parse_constr_annot loc ?if_special_first ?if_special_second annot) let parse_two_var_annot loc annot = @@ -1260,11 +1421,105 @@ let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot ~value let parse_var_type_annot loc annot = Lwt.return (parse_var_type_annot loc annot) + +let find_entrypoint (type full) (full : full ty) ~root_name entrypoint = + let rec find_entrypoint + : type t. t ty -> string -> ((Script.node -> Script.node) * ex_ty) + = fun t entrypoint -> match t with + | Union_t ((tl, al), (tr, ar), _, _) -> + if match al with None -> false | Some (`Field_annot l) -> Compare.String.(l = entrypoint) then + ((fun e -> Prim (0, D_Left, [ e ], [])), Ex_ty tl) + else if match ar with None -> false | Some (`Field_annot r) -> Compare.String.(r = entrypoint) then + ((fun e -> Prim (0, D_Right, [ e ], [])), Ex_ty tr) + else begin try + let (f, t) = find_entrypoint tl entrypoint in + ((fun e -> Prim (0, D_Left, [ f e ], [])), t) + with Not_found -> + let (f, t) = find_entrypoint tr entrypoint in + ((fun e -> Prim (0, D_Right, [ f e ], [])), t) + end + | _ -> raise Not_found in + let entrypoint = if Compare.String.(entrypoint = "") then "default" else entrypoint in + if Compare.Int.(String.length entrypoint > 31) then + error (Entrypoint_name_too_long entrypoint) + else match root_name with + | Some root_name when Compare.String.(entrypoint = root_name) -> + ok ((fun e -> e), Ex_ty full) + | _ -> + try ok (find_entrypoint full entrypoint) with Not_found -> + match entrypoint with + | "default" -> ok ((fun e -> e), Ex_ty full) + | _ -> error (No_such_entrypoint entrypoint) + +let find_entrypoint_for_type + (type full) (type exp) ~(full : full ty) ~(expected : exp ty) ~root_name entrypoint ctxt + : (context * string * exp ty) tzresult = + match entrypoint, root_name with + | "default", Some "root" -> + begin match find_entrypoint full ~root_name entrypoint with + | Error _ as err -> err + | Ok (_, Ex_ty ty) -> + match ty_eq ctxt expected ty with + | Ok (Eq, ctxt) -> + ok (ctxt, "default", (ty : exp ty)) + | Error _ -> + ty_eq ctxt expected full >>? fun (Eq, ctxt) -> + ok (ctxt, "root", (full : exp ty)) + end + | _ -> + find_entrypoint full ~root_name entrypoint >>? fun (_, Ex_ty ty) -> + ty_eq ctxt expected ty >>? fun (Eq, ctxt) -> + ok (ctxt, entrypoint, (ty : exp ty)) + + +module Entrypoints = Set.Make (String) + +exception Duplicate of string +exception Too_long of string + +let well_formed_entrypoints (type full) (full : full ty) ~root_name = + let merge path annot (type t) (ty : t ty) reachable ((first_unreachable, all) as acc) = + match annot with + | None | Some (`Field_annot "") -> + if reachable then acc + else begin match ty with + | Union_t _ -> acc + | _ -> match first_unreachable with + | None -> (Some (List.rev path), all) + | Some _ -> acc + end + | Some (`Field_annot name) -> + if Compare.Int.(String.length name > 31) then raise (Too_long name) + else if Entrypoints.mem name all then raise (Duplicate name) + else (first_unreachable, Entrypoints.add name all) in + let rec check + : type t. t ty -> prim list -> bool -> (prim list) option * Entrypoints.t -> (prim list) option * Entrypoints.t + = fun t path reachable acc -> + match t with + | Union_t ((tl, al), (tr, ar), _, _) -> + let acc = merge (D_Left :: path) al tl reachable acc in + let acc = merge (D_Right :: path) ar tr reachable acc in + let acc = check tl (D_Left :: path) (match al with Some _ -> true | None -> reachable) acc in + check tr (D_Right :: path) (match ar with Some _ -> true | None -> reachable) acc + | _ -> acc in + try + let init, reachable = match root_name with + | None | Some "" -> Entrypoints.empty, false + | Some name -> Entrypoints.singleton name, true in + let first_unreachable, all = check full [] reachable (None, init) in + if not (Entrypoints.mem "default" all) then ok () + else match first_unreachable with + | None -> ok () + | Some path -> error (Unreachable_entrypoint path) + with + | Duplicate name -> error (Duplicate_entrypoint name) + | Too_long name -> error (Entrypoint_name_too_long name) + let rec parse_data : type a. ?type_logger: type_logger -> - context -> a ty -> Script.node -> (a * context) tzresult Lwt.t - = fun ?type_logger ctxt ty script_data -> + context -> legacy: bool -> a ty -> Script.node -> (a * context) tzresult Lwt.t + = fun ?type_logger ctxt ~legacy ty script_data -> Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> let error () = Lwt.return (serialize_ty_for_error ctxt ty) >>|? fun (ty, _ctxt) -> @@ -1279,7 +1534,7 @@ let rec parse_data match item with | Prim (_, D_Elt, [ k; v ], _) -> parse_comparable_data ?type_logger ctxt key_type k >>=? fun (k, ctxt) -> - parse_data ?type_logger ctxt value_type v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy value_type v >>=? fun (v, ctxt) -> begin match last_value with | Some value -> if Compare.Int.(0 <= (compare_comparable key_type value k)) @@ -1301,8 +1556,9 @@ let rec parse_data (items, ctxt) in match ty, script_data with (* Unit *) - | Unit_t ty_name, Prim (loc, D_Unit, [], annot) -> - check_const_type_annot loc annot ty_name [] >>=? fun () -> + | Unit_t _, Prim (loc, D_Unit, [], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.unit) >>|? fun ctxt -> ((() : a), ctxt) | Unit_t _, Prim (loc, D_Unit, l, _) -> @@ -1310,12 +1566,14 @@ let rec parse_data | Unit_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Unit ])) (* Booleans *) - | Bool_t ty_name, Prim (loc, D_True, [], annot) -> - check_const_type_annot loc annot ty_name [] >>=? fun () -> + | Bool_t _, Prim (loc, D_True, [], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> (true, ctxt) - | Bool_t ty_name, Prim (loc, D_False, [], annot) -> - check_const_type_annot loc annot ty_name [] >>=? fun () -> + | Bool_t _, Prim (loc, D_False, [], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> (false, ctxt) | Bool_t _, Prim (loc, (D_True | D_False as c), l, _) -> @@ -1361,7 +1619,7 @@ let rec parse_data | Mutez_t _, Int (_, v) -> Lwt.return ( Gas.consume ctxt Typecheck_costs.tez >>? fun ctxt -> - Gas.consume ctxt Michelson_v1_gas.Cost_of.z_to_int64 + Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64 ) >>=? fun ctxt -> begin try match Tez.of_mutez (Z.to_int64 v) with @@ -1434,64 +1692,123 @@ let rec parse_data (* operations cannot appear in parameters or storage, the protocol should never parse the bytes of an operation *) assert false - (* Addresses *) - | Address_t _, Bytes (_, bytes) (* As unparsed with [O[ptimized]. *) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> - begin - match Data_encoding.Binary.of_bytes Contract.encoding bytes with - | Some c -> return (c, ctxt) + (* Chain_ids *) + | Chain_id_t _, Bytes (_, bytes) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id) >>=? fun ctxt -> + begin match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with + | Some k -> return (k, ctxt) | None -> error () >>=? fail end - | Address_t _, String (_, s) (* As unparsed with [Readable]. *) -> + | Chain_id_t _, String (_, s) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id) >>=? fun ctxt -> + begin match Chain_id.of_b58check_opt s with + | Some s -> return (s, ctxt) + | None -> error () >>=? fail + end + | Chain_id_t _, expr -> + traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) + (* Addresses *) + | Address_t _, Bytes (loc, bytes) (* As unparsed with [O[ptimized]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> - traced (Lwt.return (Contract.of_b58check s)) >>=? fun c -> - return (c, ctxt) + begin + match Data_encoding.Binary.of_bytes + Data_encoding.(tup2 Contract.encoding Variable.string) + bytes with + | Some (c, entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + fail (Entrypoint_name_too_long entrypoint) + else + begin match entrypoint with + | "" -> return "default" + | "default" -> fail (Unexpected_annotation loc) + | name -> return name end >>=? fun entrypoint -> + return ((c, entrypoint), ctxt) + | None -> error () >>=? fail + end + | Address_t _, String (loc, s) (* As unparsed with [Readable]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> + begin match String.index_opt s '%' with + | None -> return (s, "default") + | Some pos -> + let len = String.length s - pos - 1 in + let name = String.sub s (pos + 1) len in + if Compare.Int.(len > 31) then + fail (Entrypoint_name_too_long name) + else + match String.sub s 0 pos, name with + | _, "default" -> traced (fail (Unexpected_annotation loc)) + | addr_and_name -> return addr_and_name + end >>=? fun (addr, entrypoint) -> + Lwt.return (Contract.of_b58check addr) >>=? fun c -> + return ((c, entrypoint), ctxt) | Address_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) (* Contracts *) | Contract_t (ty, _), Bytes (loc, bytes) (* As unparsed with [Optimized]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> begin - match Data_encoding.Binary.of_bytes Contract.encoding bytes with - | Some c -> - traced (parse_contract ctxt loc ty c) >>=? fun (ctxt, _) -> - return ((ty, c), ctxt) + match Data_encoding.Binary.of_bytes + Data_encoding.(tup2 Contract.encoding Variable.string) + bytes with + | Some (c, entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + fail (Entrypoint_name_too_long entrypoint) + else + begin match entrypoint with + | "" -> return "default" + | "default" -> traced (fail (Unexpected_annotation loc)) + | name -> return name end >>=? fun entrypoint -> + traced (parse_contract ~legacy ctxt loc ty c ~entrypoint) >>=? fun (ctxt, _) -> + return ((ty, (c, entrypoint)), ctxt) | None -> error () >>=? fail end | Contract_t (ty, _), String (loc, s) (* As unparsed with [Readable]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> - traced @@ - Lwt.return (Contract.of_b58check s) >>=? fun c -> - parse_contract ctxt loc ty c >>=? fun (ctxt, _) -> - return ((ty, c), ctxt) + begin match String.index_opt s '%' with + | None -> return (s, "default") + | Some pos -> + let len = String.length s - pos - 1 in + let name = String.sub s (pos + 1) len in + if Compare.Int.(len > 31) then + fail (Entrypoint_name_too_long name) + else + match String.sub s 0 pos, name with + | _, "default" -> traced (fail (Unexpected_annotation loc)) + | addr_and_name -> return addr_and_name + end >>=? fun (addr, entrypoint) -> + traced (Lwt.return (Contract.of_b58check addr)) >>=? fun c -> + parse_contract ~legacy ctxt loc ty c ~entrypoint >>=? fun (ctxt, _) -> + return ((ty, (c, entrypoint)), ctxt) | Contract_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) (* Pairs *) - | Pair_t ((ta, af, _), (tb, bf, _), ty_name), Prim (loc, D_Pair, [ va; vb ], annot) -> - check_const_type_annot loc annot ty_name [af; bf] >>=? fun () -> + | Pair_t ((ta, _, _), (tb, _, _), _, _), Prim (loc, D_Pair, [ va; vb ], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.pair) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt ta va >>=? fun (va, ctxt) -> - parse_data ?type_logger ctxt tb vb >>=? fun (vb, ctxt) -> + parse_data ?type_logger ctxt ~legacy ta va >>=? fun (va, ctxt) -> + parse_data ?type_logger ctxt ~legacy tb vb >>=? fun (vb, ctxt) -> return ((va, vb), ctxt) | Pair_t _, Prim (loc, D_Pair, l, _) -> fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) | Pair_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Pair ])) (* Unions *) - | Union_t ((tl, lconstr), _, ty_name), Prim (loc, D_Left, [ v ], annot) -> - check_const_type_annot loc annot ty_name [lconstr]>>=? fun () -> + | Union_t ((tl, _), _, _, _), Prim (loc, D_Left, [ v ], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt tl v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy tl v >>=? fun (v, ctxt) -> return (L v, ctxt) | Union_t _, Prim (loc, D_Left, l, _) -> fail @@ Invalid_arity (loc, D_Left, 1, List.length l) - | Union_t (_, (tr, rconstr), ty_name), Prim (loc, D_Right, [ v ], annot) -> - check_const_type_annot loc annot ty_name [rconstr] >>=? fun () -> + | Union_t (_, (tr, _), _, _), Prim (loc, D_Right, [ v ], annot) -> + fail_unexpected_annot loc annot >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt tr v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy tr v >>=? fun (v, ctxt) -> return (R v, ctxt) | Union_t _, Prim (loc, D_Right, l, _) -> fail @@ Invalid_arity (loc, D_Right, 1, List.length l) @@ -1501,20 +1818,22 @@ let rec parse_data | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt -> traced @@ - parse_returning Lambda ?type_logger ctxt (ta, Some (`Var_annot "@arg")) tr script_instr + parse_returning Lambda ?type_logger ctxt ~legacy (ta, Some (`Var_annot "@arg")) tr script_instr | Lambda_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Options *) - | Option_t ((t, some_constr), _, ty_name), Prim (loc, D_Some, [ v ], annot) -> - check_const_type_annot loc annot ty_name [some_constr] >>=? fun () -> + | Option_t (t, _, _), Prim (loc, D_Some, [ v ], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.some) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy t v >>=? fun (v, ctxt) -> return (Some v, ctxt) | Option_t _, Prim (loc, D_Some, l, _) -> fail @@ Invalid_arity (loc, D_Some, 1, List.length l) - | Option_t (_, none_constr, ty_name), Prim (loc, D_None, [], annot) -> - check_const_type_annot loc annot ty_name [none_constr] >>=? fun () -> + | Option_t (_, _, _), Prim (loc, D_None, [], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.none) >>=? fun ctxt -> return (None, ctxt) | Option_t _, Prim (loc, D_None, l, _) -> @@ -1522,12 +1841,12 @@ let rec parse_data | Option_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ])) (* Lists *) - | List_t (t, _ty_name), Seq (_loc, items) -> + | List_t (t, _ty_name, _), Seq (_loc, items) -> traced @@ fold_right_s (fun v (rest, ctxt) -> Lwt.return (Gas.consume ctxt Typecheck_costs.list_element) >>=? fun ctxt -> - parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy t v >>=? fun (v, ctxt) -> return ((v :: rest), ctxt)) items ([], ctxt) | List_t _, expr -> @@ -1550,38 +1869,51 @@ let rec parse_data else return_unit | None -> return_unit end >>=? fun () -> - Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.set_update v false set)) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.set_update v false set)) >>=? fun ctxt -> return (Some v, set_update v true set, ctxt)) (None, empty_set t, ctxt) vs >>|? fun (_, set, ctxt) -> (set, ctxt) | Set_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Maps *) - | Map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) -> + | Map_t (tk, tv, _ty_name, _), (Seq (loc, vs) as expr) -> parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) | Map_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) | Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) -> parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) -> - ({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) + ({ id = None ; diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) + | Big_map_t (tk, tv, _ty_name), Int (loc, id) -> + Big_map.exists ctxt id >>=? begin function + | _, None -> + traced (fail (Invalid_big_map (loc, id))) + | ctxt, Some (btk, btv) -> + Lwt.return begin + parse_comparable_ty ctxt (Micheline.root btk) >>? fun (Ex_comparable_ty btk, ctxt) -> + parse_packable_ty ctxt ~legacy (Micheline.root btv) >>? fun (Ex_ty btv, ctxt) -> + comparable_ty_eq ctxt tk btk >>? fun Eq -> + ty_eq ctxt tv btv >>? fun (Eq, ctxt) -> + ok ({ id = Some id ; diff = empty_map tk ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) + end + end | Big_map_t (_tk, _tv, _), expr -> - traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) + traced (fail (Invalid_kind (location expr, [ Seq_kind ; Int_kind ], kind expr))) and parse_comparable_data : type a. ?type_logger:type_logger -> context -> a comparable_ty -> Script.node -> (a * context) tzresult Lwt.t = fun ?type_logger ctxt ty script_data -> - parse_data ?type_logger ctxt (ty_of_comparable_ty ty) script_data + parse_data ?type_logger ctxt ~legacy: false (ty_of_comparable_ty ty) script_data and parse_returning : type arg ret. ?type_logger: type_logger -> - tc_context -> context -> - arg ty * var_annot option -> ret ty -> Script.node -> - ((arg, ret) lambda * context) tzresult Lwt.t = - fun ?type_logger tc_context ctxt (arg, arg_annot) ret script_instr -> - parse_instr ?type_logger tc_context ctxt + tc_context -> context -> legacy:bool -> + arg ty * var_annot option -> ret ty -> Script.node -> + ((arg, ret) lambda * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt ~legacy (arg, arg_annot) ret script_instr -> + parse_instr ?type_logger tc_context ctxt ~legacy script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function | (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), ctxt) -> trace_eval @@ -1590,30 +1922,70 @@ and parse_returning serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> Bad_return (loc, stack_ty, ret)) (Lwt.return (ty_eq ctxt ty ret) >>=? fun (Eq, ctxt) -> - Lwt.return (merge_types ctxt loc ty ret) >>=? fun (_ret, ctxt) -> - return ((Lam (descr, strip_locations script_instr) : (arg, ret) lambda), ctxt)) + Lwt.return (merge_types ~legacy ctxt loc ty ret) >>=? fun (_ret, ctxt) -> + return ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt)) | (Typed { loc ; aft = stack_ty ; _ }, ctxt) -> Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) -> serialize_stack_for_error ctxt stack_ty >>=? fun (stack_ty, _ctxt) -> fail (Bad_return (loc, stack_ty, ret)) | (Failed { descr }, ctxt) -> - return ((Lam (descr (Item_t (ret, Empty_t, None)), strip_locations script_instr) + return ((Lam (descr (Item_t (ret, Empty_t, None)), script_instr) : (arg, ret) lambda), ctxt) +and parse_int32 (n : (location, prim) Micheline.node) : int tzresult = + let error' () = + Invalid_syntactic_constant (location n, strip_locations n, + "a positive 32-bit integer (between 0 and " + ^ (Int32.to_string Int32.max_int) ^ ")") in + match n with + | Micheline.Int (_, n') -> + begin try + let n'' = Z.to_int n' in + if (Compare.Int.(0 <= n'')) && (Compare.Int.(n'' <= Int32.to_int Int32.max_int)) then + ok n'' + else + error @@ error' () + with _ -> + error @@ error' () + end + | _ -> error @@ error' () + and parse_instr : type bef. ?type_logger: type_logger -> - tc_context -> context -> - Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = - fun ?type_logger tc_context ctxt script_instr stack_ty -> - let check_item check loc name n m = + tc_context -> context -> legacy: bool -> + Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> + let _check_item check loc name n m = trace_eval (fun () -> serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty)) @@ trace (Bad_stack_item n) @@ Lwt.return check in - let check_item_ty ctxt exp got loc n = - check_item (ty_eq ctxt exp got) loc n in + let check_item_ty + (type a) (type b) + ctxt (exp : a ty) (got : b ty) loc name n m + : ((a, b) eq * a ty * context) tzresult Lwt.t = + trace_eval (fun () -> + serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> + Bad_stack (loc, name, m, stack_ty)) @@ + trace (Bad_stack_item n) @@ Lwt.return begin + ty_eq ctxt exp got >>? fun (Eq, ctxt) -> + merge_types ~legacy ctxt loc exp got >>? fun (ty, ctxt) -> + ok ((Eq : (a, b) eq), (ty : a ty), ctxt) + end in + let check_item_comparable_ty + (type a) (type b) + (exp : a comparable_ty) (got : b comparable_ty) loc name n m + : ((a, b) eq * a comparable_ty) tzresult Lwt.t = + trace_eval (fun () -> + serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> + Bad_stack (loc, name, m, stack_ty)) @@ + trace (Bad_stack_item n) @@ Lwt.return begin + comparable_ty_eq ctxt exp got >>? fun Eq -> + merge_comparable_types ~legacy exp got >>? fun ty -> + ok ((Eq : (a, b) eq), (ty : a comparable_ty)) + end in let log_stack ctxt loc stack_ty aft = match type_logger, script_instr with | None, _ @@ -1627,7 +1999,8 @@ and parse_instr log loc stack_ty aft; return_unit in - let return : + let outer_return = return in + let return : type bef . context -> bef judgement -> (bef judgement * context) tzresult Lwt.t = fun ctxt judgement -> match judgement with | Typed { instr ; loc ; aft ; _ } -> @@ -1650,14 +2023,83 @@ and parse_instr (* stack ops *) | Prim (loc, I_DROP, [], annot), Item_t (_, rest, _) -> - fail_unexpected_annot loc annot >>=? fun () -> - typed ctxt loc Drop - rest + (fail_unexpected_annot loc annot >>=? fun () -> + typed ctxt loc Drop rest : (bef judgement * context) tzresult Lwt.t) + | Prim (loc, I_DROP, [n], result_annot), whole_stack -> + Lwt.return (parse_int32 n) >>=? fun whole_n -> + let rec make_proof_argument + : type tstk . int -> (tstk stack_ty) -> (tstk dropn_proof_argument) tzresult Lwt.t = + fun n stk -> + match (Compare.Int.(n = 0)), stk with + true, rest -> + outer_return @@ (Dropn_proof_argument (Rest, rest, rest)) + | false, Item_t (v, rest, annot) -> + make_proof_argument (n - 1) rest + >>=? fun (Dropn_proof_argument (n', stack_after_drops, aft')) -> + outer_return @@ (Dropn_proof_argument (Prefix n', stack_after_drops, Item_t (v, aft', annot))) + | _, _ -> + serialize_stack_for_error ctxt whole_stack >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DROP, whole_n, whole_stack)) + in + fail_unexpected_annot loc result_annot >>=? fun () -> + make_proof_argument whole_n whole_stack >>=? fun (Dropn_proof_argument (n', stack_after_drops, _aft)) -> + typed ctxt loc (Dropn (whole_n, n')) stack_after_drops + | 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, rest, stack_annot) -> parse_var_annot loc annot ~default:stack_annot >>=? fun annot -> typed ctxt loc Dup (Item_t (v, Item_t (v, rest, stack_annot), annot)) + | Prim (loc, I_DIG, [n], result_annot), stack -> + let rec make_proof_argument + : type tstk . int -> (tstk stack_ty) -> (tstk dig_proof_argument) tzresult Lwt.t = + fun n stk -> + match (Compare.Int.(n = 0)), stk with + true, Item_t (v, rest, annot) -> + outer_return @@ (Dig_proof_argument (Rest, (v, annot), rest)) + | false, Item_t (v, rest, annot) -> + make_proof_argument (n - 1) rest + >>=? fun (Dig_proof_argument (n', (x, xv), aft')) -> + outer_return @@ (Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot))) + | _, _ -> + serialize_stack_for_error ctxt stack >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DIG, 1, whole_stack)) + in + Lwt.return (parse_int32 n) >>=? fun n -> + fail_unexpected_annot loc result_annot >>=? fun () -> + make_proof_argument n stack >>=? fun (Dig_proof_argument (n', (x, stack_annot), aft)) -> + typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot)) + | 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, stack_annot) -> + Lwt.return (parse_int32 n) >>=? fun whole_n -> + let rec make_proof_argument + : type tstk x . int -> x ty -> var_annot option -> (tstk stack_ty) + -> ((tstk, x) dug_proof_argument) tzresult Lwt.t = + fun n x stack_annot stk -> + match (Compare.Int.(n = 0)), stk with + true, rest -> + outer_return @@ (Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot))) + | false, Item_t (v, rest, annot) -> + make_proof_argument (n - 1) x stack_annot rest + >>=? fun (Dug_proof_argument (n', (), aft')) -> + outer_return @@ (Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot))) + | _, _ -> + serialize_stack_for_error ctxt whole_stack >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DUG, whole_n, whole_stack)) + in + fail_unexpected_annot loc result_annot >>=? fun () -> + make_proof_argument whole_n x stack_annot whole_stack >>=? fun (Dug_proof_argument (n', (), aft)) -> + typed ctxt loc (Dug (whole_n, n')) aft + | Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack) -> + fail_unexpected_annot loc result_annot >>=? fun () -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, I_DUG, 1, stack)) + | 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, stack_annot), cur_top_annot) -> fail_unexpected_annot loc annot >>=? fun () -> @@ -1666,8 +2108,8 @@ and parse_instr | Prim (loc, I_PUSH, [ t ; d ], annot), stack -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false t >>=? fun (Ex_ty t, ctxt) -> - parse_data ?type_logger ctxt t d >>=? fun (v, ctxt) -> + Lwt.return @@ parse_packable_ty ctxt ~legacy t >>=? fun (Ex_ty t, ctxt) -> + parse_data ?type_logger ctxt ~legacy t d >>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, annot)) | Prim (loc, I_UNIT, [], annot), stack -> @@ -1675,29 +2117,27 @@ and parse_instr typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot)) (* options *) | Prim (loc, I_SOME, [], annot), - Item_t (t, rest, stack_annot) -> - parse_constr_annot loc annot - ~if_special_first:(var_to_field_annot stack_annot) - >>=? fun (annot, ty_name, some_field, none_field) -> + Item_t (t, rest, _) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> typed ctxt loc Cons_some - (Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot)) + (Item_t (Option_t (t, ty_name, has_big_map t), rest, annot)) | Prim (loc, I_NONE, [ t ], annot), stack -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true t >>=? fun (Ex_ty t, ctxt) -> - parse_constr_annot loc annot >>=? fun (annot, ty_name, some_field, none_field) -> + Lwt.return @@ parse_any_ty ctxt ~legacy t >>=? fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> typed ctxt loc (Cons_none t) - (Item_t (Option_t ((t, some_field), none_field, ty_name), stack, annot)) + (Item_t (Option_t (t, ty_name, has_big_map t), stack, annot)) | Prim (loc, I_IF_NONE, [ bt ; bf ], annot), - (Item_t (Option_t ((t, some_field), _none_field, _), rest, option_annot) as bef) -> + (Item_t (Option_t (t, _, _), rest, option_annot) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> - let annot = gen_access_annot option_annot some_field ~default:default_some_annot in - parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt bf (Item_t (t, rest, annot)) >>=? fun (bfr, ctxt) -> + let annot = gen_access_annot option_annot default_some_annot in + parse_instr ?type_logger tc_context ctxt ~legacy bt rest >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bf (Item_t (t, rest, annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> return ctxt judgement (* pairs *) | Prim (loc, I_PAIR, [], annot), @@ -1707,9 +2147,9 @@ and parse_instr ~if_special_second:(var_to_field_annot snd_annot) >>=? fun (annot, ty_name, l_field, r_field) -> typed ctxt loc Cons_pair - (Item_t (Pair_t((a, l_field, fst_annot), (b, r_field, snd_annot), ty_name), rest, annot)) + (Item_t (Pair_t((a, l_field, fst_annot), (b, r_field, snd_annot), ty_name, has_big_map a || has_big_map b), rest, annot)) | Prim (loc, I_CAR, [], annot), - Item_t (Pair_t ((a, expected_field_annot, a_annot), _, _), rest, pair_annot) -> + Item_t (Pair_t ((a, expected_field_annot, a_annot), _, _, _), rest, pair_annot) -> parse_destr_annot loc annot ~pair_annot ~value_annot:a_annot @@ -1719,7 +2159,7 @@ and parse_instr Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () -> typed ctxt loc Car (Item_t (a, rest, annot)) | Prim (loc, I_CDR, [], annot), - Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _), rest, pair_annot) -> + Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _, _), rest, pair_annot) -> parse_destr_annot loc annot ~pair_annot ~value_annot:b_annot @@ -1731,69 +2171,69 @@ and parse_instr (* unions *) | Prim (loc, I_LEFT, [ tr ], annot), Item_t (tl, rest, stack_annot) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true tr >>=? fun (Ex_ty tr, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy tr >>=? fun (Ex_ty tr, ctxt) -> parse_constr_annot loc annot ~if_special_first:(var_to_field_annot stack_annot) >>=? fun (annot, tname, l_field, r_field) -> - typed ctxt loc Left (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) + typed ctxt loc Left (Item_t (Union_t ((tl, l_field), (tr, r_field), tname, has_big_map tl || has_big_map tr), rest, annot)) | Prim (loc, I_RIGHT, [ tl ], annot), Item_t (tr, rest, stack_annot) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true tl >>=? fun (Ex_ty tl, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy tl >>=? fun (Ex_ty tl, ctxt) -> parse_constr_annot loc annot ~if_special_second:(var_to_field_annot stack_annot) >>=? fun (annot, tname, l_field, r_field) -> - typed ctxt loc Right (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) + typed ctxt loc Right (Item_t (Union_t ((tl, l_field), (tr, r_field), tname, has_big_map tl || has_big_map tr), rest, annot)) | Prim (loc, I_IF_LEFT, [ bt ; bf ], annot), - (Item_t (Union_t ((tl, l_field), (tr, r_field), _), rest, union_annot) as bef) -> + (Item_t (Union_t ((tl, l_field), (tr, r_field), _, _), rest, union_annot) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let left_annot = gen_access_annot union_annot l_field ~default:default_left_annot in let right_annot = gen_access_annot union_annot r_field ~default:default_right_annot in - parse_instr ?type_logger tc_context ctxt bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> return ctxt judgement (* lists *) | Prim (loc, I_NIL, [ t ], annot), stack -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true t >>=? fun (Ex_ty t, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy t >>=? fun (Ex_ty t, ctxt) -> parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc Nil (Item_t (List_t (t, ty_name), stack, annot)) + typed ctxt loc Nil (Item_t (List_t (t, ty_name, has_big_map t), stack, annot)) | Prim (loc, I_CONS, [], annot), - Item_t (tv, Item_t (List_t (t, ty_name), rest, _), _) -> - check_item_ty ctxt tv t loc I_CONS 1 2 >>=? fun (Eq, ctxt) -> + Item_t (tv, Item_t (List_t (t, ty_name, has_big_map), rest, _), _) -> + check_item_ty ctxt tv t loc I_CONS 1 2 >>=? fun (Eq, t, ctxt) -> parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Cons_list (Item_t (List_t (t, ty_name), rest, annot)) + typed ctxt loc Cons_list (Item_t (List_t (t, ty_name, has_big_map), rest, annot)) | Prim (loc, I_IF_CONS, [ bt ; bf ], annot), - (Item_t (List_t (t, ty_name), rest, list_annot) as bef) -> + (Item_t (List_t (t, ty_name, has_big_map), rest, list_annot) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let hd_annot = gen_access_annot list_annot default_hd_annot in let tl_annot = gen_access_annot list_annot default_tl_annot in - parse_instr ?type_logger tc_context ctxt bt - (Item_t (t, Item_t (List_t (t, ty_name), rest, tl_annot), hd_annot)) + parse_instr ?type_logger tc_context ctxt ~legacy bt + (Item_t (t, Item_t (List_t (t, ty_name, has_big_map), rest, tl_annot), hd_annot)) >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt bf + parse_instr ?type_logger tc_context ctxt ~legacy bf rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> return ctxt judgement | Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _) -> parse_var_type_annot loc annot >>=? fun (annot, tname) -> typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_MAP, [ body ], annot), - (Item_t (List_t (elt, _), starting_rest, list_annot)) -> + (Item_t (List_t (elt, _, _), starting_rest, list_annot)) -> check_kind [ Seq_kind ] body >>=? fun () -> parse_var_type_annot loc annot >>=? fun (ret_annot, list_ty_name) -> let elt_annot = gen_access_annot list_annot default_elt_annot in - parse_instr ?type_logger tc_context ctxt + parse_instr ?type_logger tc_context ctxt ~legacy body (Item_t (elt, starting_rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> @@ -1802,20 +2242,20 @@ and parse_instr Invalid_map_body (loc, aft) in trace_eval invalid_map_body (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> typed ctxt loc (List_map ibody) - (Item_t (List_t (ret, list_ty_name), rest, ret_annot))) + (Item_t (List_t (ret, list_ty_name, has_big_map ret), rest, ret_annot))) | Typed { aft ; _ } -> serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft)) | Failed _ -> fail (Invalid_map_block_fail loc) end | Prim (loc, I_ITER, [ body ], annot), - Item_t (List_t (elt, _), rest, list_annot) -> + Item_t (List_t (elt, _, _), rest, list_annot) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let elt_annot = gen_access_annot list_annot default_elt_annot in - parse_instr ?type_logger tc_context ctxt + parse_instr ?type_logger tc_context ctxt ~legacy body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> @@ -1825,7 +2265,7 @@ and parse_instr Invalid_iter_body (loc, rest, aft) in trace_eval invalid_iter_body (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest >>=? fun (rest, ctxt) -> typed ctxt loc (List_iter ibody) rest) | Failed { descr } -> typed ctxt loc (List_iter (descr rest)) rest @@ -1842,7 +2282,7 @@ and parse_instr fail_unexpected_annot loc annot >>=? fun () -> let elt_annot = gen_access_annot set_annot default_elt_annot in let elt = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt + parse_instr ?type_logger tc_context ctxt ~legacy body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> @@ -1852,7 +2292,7 @@ and parse_instr Invalid_iter_body (loc, rest, aft) in trace_eval invalid_iter_body (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest >>=? fun (rest, ctxt) -> typed ctxt loc (Set_iter ibody) rest) | Failed { descr } -> typed ctxt loc (Set_iter (descr rest)) rest @@ -1861,14 +2301,19 @@ and parse_instr Item_t (v, Item_t (Set_t (elt, _), rest, _), _) -> let elt = ty_of_comparable_ty elt in parse_var_type_annot loc annot >>=? fun (annot, tname) -> - check_item_ty ctxt elt v loc I_MEM 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt elt v loc I_MEM 1 2 >>=? fun (Eq, _, ctxt) -> typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot)) | Prim (loc, I_UPDATE, [], annot), Item_t (v, Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _), _) -> - let ty = ty_of_comparable_ty elt in - parse_var_annot loc annot ~default:set_annot >>=? fun annot -> - check_item_ty ctxt ty v loc I_UPDATE 1 3 >>=? fun (Eq, ctxt) -> - typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) + begin match comparable_ty_of_ty v with + | None -> + unparse_ty ctxt v >>=? fun (v, _ctxt) -> + fail (Comparable_type_expected (loc, Micheline.strip_locations v)) + | Some v -> + parse_var_annot loc annot ~default:set_annot >>=? fun annot -> + check_item_comparable_ty elt v loc I_UPDATE 1 3 >>=? fun (Eq, elt) -> + typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) + end | Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -1877,18 +2322,18 @@ and parse_instr | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], annot), stack -> Lwt.return @@ parse_comparable_ty ctxt tk >>=? fun (Ex_comparable_ty tk, ctxt) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true tv >>=? fun (Ex_ty tv, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy tv >>=? fun (Ex_ty tv, ctxt) -> parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv, ty_name), stack, annot)) + typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv, ty_name, has_big_map tv), stack, annot)) | Prim (loc, I_MAP, [ body ], annot), - Item_t (Map_t (ck, elt, _), starting_rest, _map_annot) -> + Item_t (Map_t (ck, elt, _, _), starting_rest, _map_annot) -> let k = ty_of_comparable_ty ck in check_kind [ Seq_kind ] body >>=? fun () -> parse_var_type_annot loc annot >>=? fun (ret_annot, ty_name) -> let k_name = field_to_var_annot default_key_annot in let e_name = field_to_var_annot default_elt_annot in - parse_instr ?type_logger tc_context ctxt - body (Item_t (Pair_t ((k, None, k_name), (elt, None, e_name), None), + parse_instr ?type_logger tc_context ctxt ~legacy + body (Item_t (Pair_t ((k, None, k_name), (elt, None, e_name), None, has_big_map elt), starting_rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> @@ -1897,23 +2342,23 @@ and parse_instr Invalid_map_body (loc, aft) in trace_eval invalid_map_body (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> typed ctxt loc (Map_map ibody) - (Item_t (Map_t (ck, ret, ty_name), rest, ret_annot))) + (Item_t (Map_t (ck, ret, ty_name, has_big_map ret), rest, ret_annot))) | Typed { aft ; _ } -> serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft)) | Failed _ -> fail (Invalid_map_block_fail loc) end | Prim (loc, I_ITER, [ body ], annot), - Item_t (Map_t (comp_elt, element_ty, _), rest, _map_annot) -> + Item_t (Map_t (comp_elt, element_ty, _, _), rest, _map_annot) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let k_name = field_to_var_annot default_key_annot in let e_name = field_to_var_annot default_elt_annot in let key = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt body - (Item_t (Pair_t ((key, None, k_name), (element_ty, None, e_name), None), + parse_instr ?type_logger tc_context ctxt ~legacy body + (Item_t (Pair_t ((key, None, k_name), (element_ty, None, e_name), None, has_big_map element_ty), rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> @@ -1923,55 +2368,61 @@ and parse_instr Invalid_iter_body (loc, rest, aft) in trace_eval invalid_iter_body (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest >>=? fun (rest, ctxt) -> typed ctxt loc (Map_iter ibody) rest) | Failed { descr } -> typed ctxt loc (Map_iter (descr rest)) rest end | Prim (loc, I_MEM, [], annot), - Item_t (vk, Item_t (Map_t (ck, _, _), rest, _), _) -> + Item_t (vk, Item_t (Map_t (ck, _, _, _), rest, _), _) -> let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_MEM 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt vk k loc I_MEM 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot)) | Prim (loc, I_GET, [], annot), - Item_t (vk, Item_t (Map_t (ck, elt, _), rest, _), _) -> + Item_t (vk, Item_t (Map_t (ck, elt, _, has_big_map), rest, _), _) -> let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Map_get (Item_t (Option_t ((elt, None), None, None), rest, annot)) + typed ctxt loc Map_get (Item_t (Option_t (elt, None, has_big_map), rest, annot)) | Prim (loc, I_UPDATE, [], annot), - Item_t (vk, Item_t (Option_t ((vv, _), _, _), - Item_t (Map_t (ck, v, map_name), rest, map_annot), _), _) -> + Item_t (vk, Item_t (Option_t (vv, _, _), + Item_t (Map_t (ck, v, map_name, has_big_map), rest, map_annot), _), _) -> let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_UPDATE 1 3 >>=? fun (Eq, ctxt) -> - check_item_ty ctxt vv v loc I_UPDATE 2 3 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt vk k loc I_UPDATE 1 3 >>=? fun (Eq, _, ctxt) -> + check_item_ty ctxt vv v loc I_UPDATE 2 3 >>=? fun (Eq, v, ctxt) -> parse_var_annot loc annot ~default:map_annot >>=? fun annot -> - typed ctxt loc Map_update (Item_t (Map_t (ck, v, map_name), rest, annot)) + typed ctxt loc Map_update (Item_t (Map_t (ck, v, map_name, has_big_map), rest, annot)) | Prim (loc, I_SIZE, [], annot), - Item_t (Map_t (_, _, _), rest, _) -> + Item_t (Map_t (_, _, _, _), rest, _) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot)) (* big_map *) + | Prim (loc, I_EMPTY_BIG_MAP, [ tk ; tv ], annot), + stack -> + Lwt.return @@ parse_comparable_ty ctxt tk >>=? fun (Ex_comparable_ty tk, ctxt) -> + Lwt.return @@ parse_packable_ty ctxt ~legacy tv >>=? fun (Ex_ty tv, ctxt) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> + typed ctxt loc (Empty_big_map (tk, tv)) (Item_t (Big_map_t (tk, tv, ty_name), stack, annot)) | Prim (loc, I_MEM, [], annot), Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) -> let k = ty_of_comparable_ty map_key in - check_item_ty ctxt set_key k loc I_MEM 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt set_key k loc I_MEM 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot)) | Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) -> let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Big_map_get (Item_t (Option_t ((elt, None), None, None), rest, annot)) + typed ctxt loc Big_map_get (Item_t (Option_t (elt, None, has_big_map elt), rest, annot)) | Prim (loc, I_UPDATE, [], annot), Item_t (set_key, - Item_t (Option_t ((set_value, _), _, _), + Item_t (Option_t (set_value, _, _), Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot), _), _) -> let k = ty_of_comparable_ty map_key in - check_item_ty ctxt set_key k loc I_UPDATE 1 3 >>=? fun (Eq, ctxt) -> - check_item_ty ctxt set_value map_value loc I_UPDATE 2 3 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt set_key k loc I_UPDATE 1 3 >>=? fun (Eq, _, ctxt) -> + check_item_ty ctxt set_value map_value loc I_UPDATE 2 3 >>=? fun (Eq, map_value, ctxt) -> parse_var_annot loc annot ~default:map_annot >>=? fun annot -> typed ctxt loc Big_map_update (Item_t (Big_map_t (map_key, map_value, map_name), rest, annot)) (* control *) @@ -1980,7 +2431,7 @@ and parse_instr typed ctxt loc Nop stack | Seq (loc, [ single ]), stack -> - parse_instr ?type_logger tc_context ctxt single + parse_instr ?type_logger tc_context ctxt ~legacy single stack >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as instr) -> @@ -1995,13 +2446,13 @@ and parse_instr end | Seq (loc, hd :: tl), stack -> - parse_instr ?type_logger tc_context ctxt hd + parse_instr ?type_logger tc_context ctxt ~legacy hd stack >>=? begin fun (judgement, ctxt) -> match judgement with | Failed _ -> fail (Fail_not_in_tail_position (Micheline.location hd)) | Typed ({ aft = middle ; _ } as ihd) -> - parse_instr ?type_logger tc_context ctxt (Seq (-1, tl)) + parse_instr ?type_logger tc_context ctxt ~legacy (Seq (-1, tl)) middle >>=? fun (judgement, ctxt) -> match judgement with | Failed { descr } -> @@ -2017,17 +2468,17 @@ and parse_instr check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt bf rest >>=? fun (bfr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bt rest >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bf rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> return ctxt judgement | Prim (loc, I_LOOP, [ body ], annot), (Item_t (Bool_t _, rest, _stack_annot) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt body + parse_instr ?type_logger tc_context ctxt ~legacy body rest >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> @@ -2037,18 +2488,18 @@ and parse_instr Unmatched_branches (loc, aft, stack) in trace_eval unmatched_branches (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop ibody) rest) | Failed { descr } -> let ibody = descr stack in typed ctxt loc (Loop ibody) rest end | Prim (loc, I_LOOP_LEFT, [ body ], annot), - (Item_t (Union_t ((tl, l_field), (tr, _), _), rest, union_annot) as stack) -> + (Item_t (Union_t ((tl, l_field), (tr, _), _, _), rest, union_annot) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> parse_var_annot loc annot >>=? fun annot -> let l_annot = gen_access_annot union_annot l_field ~default:default_left_annot in - parse_instr ?type_logger tc_context ctxt body + parse_instr ?type_logger tc_context ctxt ~legacy body (Item_t (tl, rest, l_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> let unmatched_branches () = @@ -2057,7 +2508,7 @@ and parse_instr Unmatched_branches (loc, aft, stack) in trace_eval unmatched_branches (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot))) | Failed { descr } -> let ibody = descr stack in @@ -2065,31 +2516,72 @@ and parse_instr end | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], annot), stack -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true arg + Lwt.return @@ parse_any_ty ctxt ~legacy arg >>=? fun (Ex_ty arg, ctxt) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true ret + Lwt.return @@ parse_any_ty ctxt ~legacy ret >>=? fun (Ex_ty ret, ctxt) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_var_annot loc annot >>=? fun annot -> - parse_returning Lambda ?type_logger ctxt + parse_returning Lambda ?type_logger ctxt ~legacy (arg, default_arg_annot) ret code >>=? fun (lambda, ctxt) -> typed ctxt loc (Lambda lambda) (Item_t (Lambda_t (arg, ret, None), stack, annot)) | Prim (loc, I_EXEC, [], annot), Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) -> - check_item_ty ctxt arg param loc I_EXEC 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt arg param loc I_EXEC 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Exec (Item_t (ret, rest, annot)) + | Prim (loc, I_APPLY, [], annot), + Item_t (capture, Item_t (Lambda_t (Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot, _), ret, _), rest, _), _) -> + Lwt.return @@ check_packable ~legacy:false loc capture_ty >>=? fun () -> + check_item_ty ctxt capture capture_ty loc I_APPLY 1 2 >>=? fun (Eq, capture_ty, ctxt) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc (Apply capture_ty) (Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot)) | Prim (loc, I_DIP, [ code ], annot), Item_t (v, rest, stack_annot) -> fail_unexpected_annot loc annot >>=? fun () -> check_kind [ Seq_kind ] code >>=? fun () -> - parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt code + parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt ~legacy code rest >>=? begin fun (judgement, ctxt) -> match judgement with | Typed descr -> typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot)) | Failed _ -> fail (Fail_not_in_tail_position loc) end + | Prim (loc, I_DIP, [n; code], result_annot), stack + when (match parse_int32 n with Ok _ -> true | Error _ -> false) -> + let rec make_proof_argument + : type tstk . int + (* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) + -> tc_context + -> (tstk stack_ty) + -> (tstk dipn_proof_argument) tzresult Lwt.t = + fun n inner_tc_context stk -> + match (Compare.Int.(n = 0)), stk with + true, rest -> + (parse_instr ?type_logger inner_tc_context ctxt ~legacy code + rest) >>=? begin fun (judgement, ctxt) -> match judgement with + | Typed descr -> + outer_return @@ (Dipn_proof_argument (Rest, (ctxt, descr), descr.aft)) + | Failed _ -> + fail (Fail_not_in_tail_position loc) + end + | false, Item_t (v, rest, annot) -> + make_proof_argument (n - 1) (add_dip v annot tc_context) rest + >>=? fun (Dipn_proof_argument (n', descr, aft')) -> + outer_return @@ (Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot))) + | _, _ -> + serialize_stack_for_error ctxt stack >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DIP, 1, whole_stack)) + in + Lwt.return (parse_int32 n) >>=? fun n -> + fail_unexpected_annot loc result_annot >>=? fun () -> + make_proof_argument n tc_context stack >>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) -> + (* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *) + typed new_ctxt loc (Dipn (n, n', descr)) aft + | 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, _) -> fail_unexpected_annot loc annot >>=? fun () -> @@ -2098,38 +2590,35 @@ and parse_instr return ctxt (Failed { descr }) (* timestamp operations *) | Prim (loc, I_ADD, [], annot), - Item_t (Timestamp_t tn1, Item_t (Int_t tn2, rest, _), _) -> + Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> typed ctxt loc Add_timestamp_to_seconds (Item_t (Timestamp_t tname, rest, annot)) | Prim (loc, I_ADD, [], annot), - Item_t (Int_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> + Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> typed ctxt loc Add_seconds_to_timestamp (Item_t (Timestamp_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), - Item_t (Timestamp_t tn1, Item_t (Int_t tn2, rest, _), _) -> + Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> typed ctxt loc Sub_timestamp_seconds (Item_t (Timestamp_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Diff_timestamps (Item_t (Int_t tname, rest, annot)) (* string operations *) | Prim (loc, I_CONCAT, [], annot), Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Concat_string_pair (Item_t (String_t tname, rest, annot)) | Prim (loc, I_CONCAT, [], annot), - Item_t (List_t (String_t tname, _), rest, list_annot) -> + Item_t (List_t (String_t tname, _, _), rest, list_annot) -> parse_var_annot ~default:list_annot loc annot >>=? fun annot -> typed ctxt loc Concat_string (Item_t (String_t tname, rest, annot)) @@ -2139,7 +2628,7 @@ and parse_instr ~default:(gen_access_annot string_annot default_slice_annot) loc annot >>=? fun annot -> typed ctxt loc Slice_string - (Item_t (Option_t ((String_t tname, None), None, None), rest, annot)) + (Item_t (Option_t (String_t tname, None, false), rest, annot)) | Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -2148,11 +2637,11 @@ and parse_instr | Prim (loc, I_CONCAT, [], annot), Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Concat_bytes_pair (Item_t (Bytes_t tname, rest, annot)) | Prim (loc, I_CONCAT, [], annot), - Item_t (List_t (Bytes_t tname, _), rest, list_annot) -> + Item_t (List_t (Bytes_t tname, _, _), rest, list_annot) -> parse_var_annot ~default:list_annot loc annot >>=? fun annot -> typed ctxt loc Concat_bytes (Item_t (Bytes_t tname, rest, annot)) @@ -2162,7 +2651,7 @@ and parse_instr ~default:(gen_access_annot bytes_annot default_slice_annot) loc annot >>=? fun annot -> typed ctxt loc Slice_bytes - (Item_t (Option_t ((Bytes_t tname, None), None, None), rest, annot)) + (Item_t (Option_t (Bytes_t tname, None, false), rest, annot)) | Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -2171,13 +2660,13 @@ and parse_instr | Prim (loc, I_ADD, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Add_tez (Item_t (Mutez_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Sub_tez (Item_t (Mutez_t tname, rest, annot)) | Prim (loc, I_MUL, [], annot), @@ -2194,19 +2683,19 @@ and parse_instr | Prim (loc, I_OR, [], annot), Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Or (Item_t (Bool_t tname, rest, annot)) | Prim (loc, I_AND, [], annot), Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc And (Item_t (Bool_t tname, rest, annot)) | Prim (loc, I_XOR, [], annot), Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Xor (Item_t (Bool_t tname, rest, annot)) | Prim (loc, I_NOT, [], annot), @@ -2224,7 +2713,7 @@ and parse_instr Item_t (Int_t _, rest, int_annot) -> parse_var_annot loc annot ~default:int_annot >>=? fun annot -> typed ctxt loc Is_nat - (Item_t (Option_t ((Nat_t None, None), None, None), rest, annot)) + (Item_t (Option_t (Nat_t None, None, false), rest, annot)) | Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -2243,7 +2732,7 @@ and parse_instr | Prim (loc, I_ADD, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Add_intint (Item_t (Int_t tname, rest, annot)) | Prim (loc, I_ADD, [], annot), @@ -2259,13 +2748,13 @@ and parse_instr | Prim (loc, I_ADD, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Add_natnat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), @@ -2281,13 +2770,13 @@ and parse_instr | Prim (loc, I_SUB, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun _tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun _tname -> typed ctxt loc Sub_int (Item_t (Int_t None, rest, annot)) | Prim (loc, I_MUL, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Mul_intint (Item_t (Int_t tname, rest, annot)) | Prim (loc, I_MUL, [], annot), @@ -2303,7 +2792,7 @@ and parse_instr | Prim (loc, I_MUL, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Mul_natnat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_EDIV, [], annot), @@ -2311,71 +2800,71 @@ and parse_instr parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Ediv_teznat (Item_t (Option_t - ((Pair_t ((Mutez_t tname, None, None), - (Mutez_t tname, None, None), None), None), - None, None), rest, annot)) + (Pair_t ((Mutez_t tname, None, None), + (Mutez_t tname, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Ediv_tez - (Item_t (Option_t ((Pair_t ((Nat_t None, None, None), - (Mutez_t tname, None, None), None), None), - None, None), rest, annot)) + (Item_t (Option_t (Pair_t ((Nat_t None, None, None), + (Mutez_t tname, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Ediv_intint (Item_t (Option_t - ((Pair_t ((Int_t tname, None, None), - (Nat_t None, None, None), None), None), - None, None), rest, annot)) + (Pair_t ((Int_t tname, None, None), + (Nat_t None, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Ediv_intnat (Item_t (Option_t - ((Pair_t ((Int_t tname, None, None), - (Nat_t None, None, None), None), None), - None, None), rest, annot)) + (Pair_t ((Int_t tname, None, None), + (Nat_t None, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Ediv_natint - (Item_t (Option_t ((Pair_t ((Int_t None, None, None), - (Nat_t tname, None, None), None), None), - None, None), rest, annot)) + (Item_t (Option_t (Pair_t ((Int_t None, None, None), + (Nat_t tname, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Ediv_natnat - (Item_t (Option_t ((Pair_t ((Nat_t tname, None, None), - (Nat_t tname, None, None), None), None), - None, None), rest, annot)) + (Item_t (Option_t (Pair_t ((Nat_t tname, None, None), + (Nat_t tname, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_LSL, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Lsl_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_LSR, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Lsr_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_OR, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Or_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_AND, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc And_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_AND, [], annot), @@ -2386,7 +2875,7 @@ and parse_instr | Prim (loc, I_XOR, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Xor_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_NOT, [], annot), @@ -2401,59 +2890,17 @@ and parse_instr (Item_t (Int_t None, rest, annot)) (* comparison *) | Prim (loc, I_COMPARE, [], annot), - Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> + Item_t (t1, Item_t (t2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Int_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Nat_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Bool_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (String_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Mutez_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Key_hash_t tn1, Item_t (Key_hash_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Key_hash_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Timestamp_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Address_t tn1, Item_t (Address_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Address_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Bytes_key tname)) - (Item_t (Int_t None, rest, annot)) + check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 >>=? fun (Eq, t, ctxt) -> + begin match comparable_ty_of_ty t with + | None -> + Lwt.return (serialize_ty_for_error ctxt t) >>=? fun (t, _ctxt) -> + fail (Comparable_type_expected (loc, t)) + | Some key -> + typed ctxt loc (Compare key) + (Item_t (Int_t None, rest, annot)) + end (* comparators *) | Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest, _) -> @@ -2489,10 +2936,10 @@ and parse_instr | Prim (loc, I_CAST, [ cast_t ], annot), Item_t (t, stack, item_annot) -> parse_var_annot loc annot ~default:item_annot >>=? fun annot -> - (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true cast_t) + (Lwt.return @@ parse_any_ty ctxt ~legacy cast_t) >>=? fun (Ex_ty cast_t, ctxt) -> Lwt.return @@ ty_eq ctxt cast_t t >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ctxt loc cast_t t >>=? fun (_, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc cast_t t >>=? fun (_, ctxt) -> typed ctxt loc Nop (Item_t (cast_t, stack, annot)) | Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _) -> @@ -2501,20 +2948,17 @@ and parse_instr (* packing *) | Prim (loc, I_PACK, [], annot), Item_t (t, rest, unpacked_annot) -> - Lwt.return (check_no_big_map_or_operation loc t) >>=? fun () -> + Lwt.return (check_packable ~legacy:true (* allow to pack contracts for hash/signature checks *) loc t) >>=? fun () -> parse_var_annot loc annot ~default:(gen_access_annot unpacked_annot default_pack_annot) >>=? fun annot -> typed ctxt loc (Pack t) (Item_t (Bytes_t None, rest, annot)) | Prim (loc, I_UNPACK, [ ty ], annot), Item_t (Bytes_t _, rest, packed_annot) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t, ctxt) -> - let stack_annot = gen_access_annot packed_annot default_unpack_annot in - parse_constr_annot loc annot - ~if_special_first:(var_to_field_annot stack_annot) - >>=? fun (annot, ty_name, some_field, none_field) -> - typed ctxt loc (Unpack t) - (Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot)) + Lwt.return @@ parse_packable_ty ctxt ~legacy ty >>=? fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> + let annot = default_annot annot ~default:(gen_access_annot packed_annot default_unpack_annot) in + typed ctxt loc (Unpack t) (Item_t (Option_t (t, ty_name, false (* cannot unpack big_maps *)), rest, annot)) (* protocol *) | Prim (loc, I_ADDRESS, [], annot), Item_t (Contract_t _, rest, contract_annot) -> @@ -2524,31 +2968,46 @@ and parse_instr (Item_t (Address_t None, rest, annot)) | Prim (loc, I_CONTRACT, [ ty ], annot), Item_t (Address_t _, rest, addr_annot) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t, ctxt) -> - parse_var_annot loc annot ~default:(gen_access_annot addr_annot default_contract_annot) - >>=? fun annot -> - typed ctxt loc (Contract t) - (Item_t (Option_t ((Contract_t (t, None), None), None, None), rest, annot)) + Lwt.return @@ parse_parameter_ty ctxt ~legacy ty >>=? fun (Ex_ty t, ctxt) -> + parse_entrypoint_annot loc annot ~default:(gen_access_annot addr_annot default_contract_annot) + >>=? fun (annot, entrypoint) -> + Lwt.return @@ begin match entrypoint with + | None -> Ok "default" + | Some (`Field_annot "default") -> error (Unexpected_annotation loc) + | Some (`Field_annot entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + error (Entrypoint_name_too_long entrypoint) + else Ok entrypoint + end >>=? fun entrypoint -> + typed ctxt loc (Contract (t, entrypoint)) + (Item_t (Option_t (Contract_t (t, None), None, false), rest, annot)) | Prim (loc, I_TRANSFER_TOKENS, [], annot), Item_t (p, Item_t (Mutez_t _, Item_t (Contract_t (cp, _), rest, _), _), _) -> - check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot)) | Prim (loc, I_SET_DELEGATE, [], annot), - Item_t (Option_t ((Key_hash_t _, _), _, _), rest, _) -> + Item_t (Option_t (Key_hash_t _, _, _), rest, _) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot)) | Prim (loc, I_CREATE_ACCOUNT, [], annot), Item_t (Key_hash_t _, Item_t - (Option_t ((Key_hash_t _, _), _, _), Item_t + (Option_t (Key_hash_t _, _, _), Item_t (Bool_t _, Item_t (Mutez_t _, rest, _), _), _), _) -> - parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> - typed ctxt loc Create_account - (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) + if legacy + then begin + (* For existing contracts, this instruction is still allowed *) + parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> + typed ctxt loc Create_account + (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) + end + else + (* For new contracts this instruction is not allowed anymore *) + fail (Deprecated_instruction I_CREATE_ACCOUNT) | Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -2557,44 +3016,103 @@ and parse_instr | Prim (loc, I_CREATE_CONTRACT, [ (Seq _ as code)], annot), Item_t (Key_hash_t _, Item_t - (Option_t ((Key_hash_t _, _), _, _), Item_t + (Option_t (Key_hash_t _, _, _), Item_t (Bool_t _, Item_t (Bool_t _, Item_t (Mutez_t _, Item_t (ginit, rest, _), _), _), _), _), _) -> + if legacy then begin + (* For existing contracts, this instruction is still allowed *) + parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> + let cannonical_code = fst @@ Micheline.extract_locations code in + Lwt.return @@ parse_toplevel ~legacy cannonical_code >>=? fun (arg_type, storage_type, code_field, root_name) -> + trace + (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) + (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type) + >>=? fun (Ex_ty arg_type, ctxt) -> + begin + if legacy then Error_monad.return () else + Lwt.return (well_formed_entrypoints ~root_name arg_type) + end >>=? fun () -> + trace + (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) + (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type) + >>=? fun (Ex_ty storage_type, ctxt) -> + let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot in + let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot in + let arg_type_full = Pair_t ((arg_type, None, arg_annot), + (storage_type, None, storage_annot), None, + has_big_map arg_type || has_big_map storage_type) in + let ret_type_full = + Pair_t ((List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), None, + has_big_map storage_type) in + trace + (Ill_typed_contract (cannonical_code, [])) + (parse_returning (Toplevel { storage_type ; param_type = arg_type ; root_name ; + legacy_create_contract_literal = true }) + ctxt ~legacy ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? + fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; + aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> + Lwt.return @@ ty_eq ctxt arg arg_type_full >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt ret ret_type_full >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt storage_type ginit >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit >>=? fun (_, ctxt) -> + typed ctxt loc (Create_contract (storage_type, arg_type, lambda, root_name)) + (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) + end + else + (* For new contracts this instruction is not allowed anymore *) + fail (Deprecated_instruction I_CREATE_CONTRACT) + | Prim (loc, I_CREATE_CONTRACT, [ (Seq _ as code)], annot), + (* Removed the instruction's arguments manager, spendable and delegatable *) + Item_t + (Option_t (Key_hash_t _, _, _), Item_t + (Mutez_t _, Item_t + (ginit, rest, _), _), _) -> parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> let cannonical_code = fst @@ Micheline.extract_locations code in - Lwt.return @@ parse_toplevel cannonical_code >>=? fun (arg_type, storage_type, code_field) -> + Lwt.return @@ parse_toplevel ~legacy cannonical_code >>=? fun (arg_type, storage_type, code_field, root_name) -> trace (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) - (Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type) + (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type) >>=? fun (Ex_ty arg_type, ctxt) -> + begin + if legacy then Error_monad.return () else + Lwt.return (well_formed_entrypoints ~root_name arg_type) + end >>=? fun () -> trace (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) - (Lwt.return @@ parse_storage_ty ctxt storage_type) + (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type) >>=? fun (Ex_ty storage_type, ctxt) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) ~default:default_param_annot in let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) ~default:default_storage_annot in let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None) in + (storage_type, None, storage_annot), None, + has_big_map arg_type || has_big_map storage_type) in let ret_type_full = - Pair_t ((List_t (Operation_t None, None), None, None), - (storage_type, None, None), None) in + Pair_t ((List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), None, has_big_map storage_type) in trace (Ill_typed_contract (cannonical_code, [])) - (parse_returning (Toplevel { storage_type ; param_type = arg_type }) - ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? + (parse_returning (Toplevel { storage_type ; param_type = arg_type ; root_name ; + legacy_create_contract_literal = false }) + ctxt ~legacy ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> Lwt.return @@ ty_eq ctxt arg arg_type_full >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ctxt loc arg arg_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full >>=? fun (_, ctxt) -> Lwt.return @@ ty_eq ctxt ret ret_type_full >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ctxt loc ret ret_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full >>=? fun (_, ctxt) -> Lwt.return @@ ty_eq ctxt storage_type ginit >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ctxt loc storage_type ginit >>=? fun (_, ctxt) -> - typed ctxt loc (Create_contract (storage_type, arg_type, lambda)) + Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit >>=? fun (_, ctxt) -> + typed ctxt loc (Create_contract_2 (storage_type, arg_type, lambda, root_name)) (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) | Prim (loc, I_NOW, [], annot), stack -> @@ -2605,6 +3123,11 @@ and parse_instr parse_var_annot loc annot ~default:default_amount_annot >>=? fun annot -> typed ctxt loc Amount (Item_t (Mutez_t None, stack, annot)) + | Prim (loc, I_CHAIN_ID, [], annot), + stack -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc ChainId + (Item_t (Chain_id_t None, stack, annot)) | Prim (loc, I_BALANCE, [], annot), stack -> parse_var_annot loc annot ~default:default_balance_annot >>=? fun annot -> @@ -2637,9 +3160,16 @@ and parse_instr (Item_t (Bytes_t None, rest, annot)) | Prim (loc, I_STEPS_TO_QUOTA, [], annot), stack -> - parse_var_annot loc annot ~default:default_steps_annot >>=? fun annot -> - typed ctxt loc Steps_to_quota - (Item_t (Nat_t None, stack, annot)) + if legacy + then begin + (* For existing contracts, this instruction is still allowed *) + parse_var_annot loc annot ~default:default_steps_annot >>=? fun annot -> + typed ctxt loc Steps_to_quota + (Item_t (Nat_t None, stack, annot)) + end + else + (* For new contracts this instruction is not allowed anymore *) + fail (Deprecated_instruction I_STEPS_TO_QUOTA) | Prim (loc, I_SOURCE, [], annot), stack -> parse_var_annot loc annot ~default:default_source_annot >>=? fun annot -> @@ -2652,16 +3182,22 @@ and parse_instr (Item_t (Address_t None, stack, annot)) | Prim (loc, I_SELF, [], annot), stack -> - parse_var_annot loc annot ~default:default_self_annot >>=? fun annot -> + parse_entrypoint_annot loc annot ~default:default_self_annot + >>=? fun (annot, entrypoint) -> + let entrypoint = Option.unopt_map ~f:(fun (`Field_annot annot) -> annot) ~default:"default" entrypoint in let rec get_toplevel_type : tc_context -> (bef judgement * context) tzresult Lwt.t = function | Lambda -> fail (Self_in_lambda loc) | Dip (_, prev) -> get_toplevel_type prev - | Toplevel { param_type ; _ } -> - typed ctxt loc (Self param_type) + | Toplevel { param_type ; root_name ; legacy_create_contract_literal = false} -> + Lwt.return (find_entrypoint param_type ~root_name entrypoint) >>=? fun (_, Ex_ty param_type) -> + typed ctxt loc (Self (param_type, entrypoint)) + (Item_t (Contract_t (param_type, None), stack, annot)) + | Toplevel { param_type ; root_name = _ ; legacy_create_contract_literal = true} -> + typed ctxt loc (Self (param_type, "default")) (Item_t (Contract_t (param_type, None), stack, annot)) in get_toplevel_type tc_context (* Primitive parsing errors *) - | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT + | Prim (loc, (I_DUP | I_SWAP | I_SOME | I_UNIT | I_PAIR | I_CAR | I_CDR | I_CONS | I_CONCAT | I_SLICE | I_MEM | I_UPDATE | I_MAP | I_GET | I_EXEC | I_FAILWITH | I_SIZE @@ -2672,7 +3208,7 @@ and parse_instr | I_COMPARE | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE | I_TRANSFER_TOKENS | I_CREATE_ACCOUNT - | I_CREATE_CONTRACT | I_SET_DELEGATE | I_NOW + | I_SET_DELEGATE | I_NOW | I_IMPLICIT_ACCOUNT | I_AMOUNT | I_BALANCE | I_CHECK_SIGNATURE | I_HASH_KEY | I_SOURCE | I_SENDER | I_BLAKE2B | I_SHA256 | I_SHA512 | I_STEPS_TO_QUOTA | I_ADDRESS @@ -2693,8 +3229,7 @@ and parse_instr fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l)) (* Stack errors *) | Prim (loc, (I_ADD | I_SUB | I_MUL | I_EDIV - | I_AND | I_OR | I_XOR | I_LSL | I_LSR - | I_COMPARE as name), [], _), + | I_AND | I_OR | I_XOR | I_LSL | I_LSR as name), [], _), Item_t (ta, Item_t (tb, _, _), _) -> Lwt.return @@ serialize_ty_for_error ctxt ta >>=? fun (ta, ctxt) -> Lwt.return @@ serialize_ty_for_error ctxt tb >>=? fun (tb, _ctxt) -> @@ -2709,7 +3244,7 @@ and parse_instr stack -> serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 3, stack)) - | Prim (loc, I_CREATE_CONTRACT, [], _), + | Prim (loc, I_CREATE_CONTRACT, _, _), stack -> serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) @@ -2741,7 +3276,8 @@ and parse_instr (* Generic parsing errors *) | expr, _ -> fail @@ unexpected expr [ Seq_kind ] Instr_namespace - [ I_DROP ; I_DUP ; I_SWAP ; I_SOME ; I_UNIT ; + [ I_DROP ; I_DUP; I_DIG; I_DUG; + I_SWAP ; I_SOME ; I_UNIT ; I_PAIR ; I_CAR ; I_CDR ; I_CONS ; I_MEM ; I_UPDATE ; I_MAP ; I_ITER ; I_GET ; I_EXEC ; I_FAILWITH ; I_SIZE ; @@ -2762,9 +3298,9 @@ and parse_instr I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SENDER ; I_SELF ; I_LAMBDA ] and parse_contract - : type arg. context -> Script.location -> arg ty -> Contract.t -> - (context * arg typed_contract) tzresult Lwt.t - = fun ctxt loc arg contract -> + : type arg. legacy: bool -> context -> Script.location -> arg ty -> Contract.t -> entrypoint:string -> + (context * arg typed_contract) tzresult Lwt.t + = fun ~legacy ctxt loc arg contract ~entrypoint -> Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt -> Contract.exists ctxt contract >>=? function | false -> fail (Invalid_contract (loc, contract)) @@ -2772,30 +3308,36 @@ and parse_contract Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> trace (Invalid_contract (loc, contract)) @@ - Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with + Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> match code with | None -> Lwt.return (ty_eq ctxt arg (Unit_t None) >>? fun (Eq, ctxt) -> - let contract : arg typed_contract = (arg, contract) in - ok (ctxt, contract)) - | Some { code ; _ } -> + match entrypoint with + | "default" -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + ok (ctxt, contract) + | entrypoint -> error (No_such_entrypoint entrypoint)) + | Some code -> Script.force_decode ctxt code >>=? fun (code, ctxt) -> Lwt.return - (parse_toplevel code >>? fun (arg_type, _, _) -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type >>? fun (Ex_ty targ, ctxt) -> - ty_eq ctxt targ arg >>? fun (Eq, ctxt) -> - merge_types ctxt loc targ arg >>? fun (arg, ctxt) -> - let contract : arg typed_contract = (arg, contract) in - ok (ctxt, contract)) + (parse_toplevel ~legacy:true code >>? fun (arg_type, _, _, root_name) -> + parse_parameter_ty ctxt ~legacy:true arg_type >>? fun (Ex_ty targ, ctxt) -> + let return ctxt targ entrypoint = + merge_types ~legacy ctxt loc targ arg >>? fun (arg, ctxt) -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + ok (ctxt, contract) in + find_entrypoint_for_type ~full:targ ~expected:arg ~root_name entrypoint ctxt >>? fun (ctxt, entrypoint, targ) -> + merge_types ~legacy ctxt loc targ arg >>? fun (targ, ctxt) -> + return ctxt targ entrypoint) (* Same as the one above, but does not fail when the contact is missing or if the expected type doesn't match the actual one. In that case None is returned and some overapproximation of the typechecking gas is consumed. This can still fail on gas exhaustion. *) and parse_contract_for_script - : type arg. context -> Script.location -> arg ty -> Contract.t -> - (context * arg typed_contract option) tzresult Lwt.t - = fun ctxt loc arg contract -> + : type arg. legacy: bool -> context -> Script.location -> arg ty -> Contract.t -> entrypoint:string -> + (context * arg typed_contract option) tzresult Lwt.t + = fun ~legacy ctxt loc arg contract ~entrypoint -> Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt -> Contract.exists ctxt contract >>=? function | false -> return (ctxt, None) @@ -2803,43 +3345,48 @@ and parse_contract_for_script Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> trace (Invalid_contract (loc, contract)) @@ - Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with (* can only fail because of gas *) + Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> match code with (* can only fail because of gas *) | None -> - Lwt.return - (match ty_eq ctxt arg (Unit_t None) with - | Ok (Eq, ctxt) -> - let contract : arg typed_contract = (arg, contract) in - ok (ctxt, Some contract) - | Error _ -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - ok (ctxt, None)) - | Some { code ; _ } -> + begin match entrypoint with + | "default" -> + Lwt.return + (match ty_eq ctxt arg (Unit_t None) with + | Ok (Eq, ctxt) -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + ok (ctxt, Some contract) + | Error _ -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + ok (ctxt, None)) + | _ -> return (ctxt, None) + end + | Some code -> Script.force_decode ctxt code >>=? fun (code, ctxt) -> (* can only fail because of gas *) Lwt.return - (match parse_toplevel code with + (match parse_toplevel ~legacy:true code with | Error _ -> error (Invalid_contract (loc, contract)) - | Ok (arg_type, _, _) -> - match parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type with + | Ok (arg_type, _, _, root_name) -> + match parse_parameter_ty ctxt ~legacy:true arg_type with | Error _ -> error (Invalid_contract (loc, contract)) | Ok (Ex_ty targ, ctxt) -> match - (ty_eq ctxt targ arg >>? fun (Eq, ctxt) -> - merge_types ctxt loc targ arg >>? fun (arg, ctxt) -> - let contract : arg typed_contract = (arg, contract) in - ok (ctxt, Some contract)) + find_entrypoint_for_type ~full:targ ~expected:arg ~root_name entrypoint ctxt >>? fun (ctxt, entrypoint, targ) -> + merge_types ~legacy ctxt loc targ arg >>? fun (targ, ctxt) -> + merge_types ~legacy ctxt loc targ arg >>? fun (arg, ctxt) -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + ok (ctxt, Some contract) with | Ok res -> ok res | Error _ -> (* overapproximation by checking if targ = targ, - can only fail because of gas *) + can only fail because of gas *) ty_eq ctxt targ targ >>? fun (Eq, ctxt) -> - merge_types ctxt loc targ targ >>? fun (_, ctxt) -> + merge_types ~legacy ctxt loc targ targ >>? fun (_, ctxt) -> ok (ctxt, None)) and parse_toplevel - : Script.expr -> (Script.node * Script.node * Script.node) tzresult - = fun toplevel -> + : legacy: bool -> Script.expr -> (Script.node * Script.node * Script.node * string option) tzresult + = fun ~legacy toplevel -> record_trace (Ill_typed_contract (toplevel, [])) @@ match root toplevel with | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) @@ -2854,19 +3401,19 @@ and parse_toplevel | String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_kind)) | Bytes (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Bytes_kind)) | Seq (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind)) - | Prim (loc, K_parameter, [ arg ], _) :: rest -> + | Prim (loc, K_parameter, [ arg ], annot) :: rest -> begin match p with - | None -> find_fields (Some arg) s c rest + | None -> find_fields (Some (arg, loc, annot)) s c rest | Some _ -> error (Duplicate_field (loc, K_parameter)) end - | Prim (loc, K_storage, [ arg ], _) :: rest -> + | Prim (loc, K_storage, [ arg ], annot) :: rest -> begin match s with - | None -> find_fields p (Some arg) c rest + | None -> find_fields p (Some (arg, loc, annot)) c rest | Some _ -> error (Duplicate_field (loc, K_storage)) end - | Prim (loc, K_code, [ arg ], _) :: rest -> + | Prim (loc, K_code, [ arg ], annot) :: rest -> begin match c with - | None -> find_fields p s (Some arg) rest + | None -> find_fields p s (Some (arg, loc, annot)) rest | Some _ -> error (Duplicate_field (loc, K_code)) end | Prim (loc, (K_parameter | K_storage | K_code as name), args, _) :: _ -> @@ -2879,70 +3426,106 @@ and parse_toplevel | (None, _, _) -> error (Missing_field K_parameter) | (Some _, None, _) -> error (Missing_field K_storage) | (Some _, Some _, None) -> error (Missing_field K_code) - | (Some p, Some s, Some c) -> ok (p, s, c) + | (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot)) -> + let maybe_root_name = + (* root name can be attached to either the parameter + primitive or the toplevel constructor *) + Script_ir_annot.extract_field_annot p >>? fun (p, root_name) -> + match root_name with + | Some (`Field_annot root_name) -> + ok (p, pannot, Some root_name) + | None -> + match pannot with + | [ single ] when Compare.Int.(String.length single > 0) && Compare.Char.(String.get single 0 = '%') -> + ok (p, [], Some (String.sub single 1 (String.length single - 1))) + | _ -> ok (p, pannot, None) in + if legacy then + (* legacy semantics ignores spurious annotations *) + let p, root_name = match maybe_root_name with Ok (p, _, root_name) -> (p, root_name) | Error _ -> (p, None) in + ok (p, s, c, root_name) + else + (* only one field annot is allowed to set the root entrypoint name *) + maybe_root_name >>? fun (p, pannot, root_name) -> + Script_ir_annot.error_unexpected_annot ploc pannot >>? fun () -> + Script_ir_annot.error_unexpected_annot cloc carrot >>? fun () -> + Script_ir_annot.error_unexpected_annot sloc sannot >>? fun () -> + ok (p, s, c, root_name) let parse_script : ?type_logger: type_logger -> - context -> Script.t -> (ex_script * context) tzresult Lwt.t - = fun ?type_logger ctxt { code ; storage } -> + context -> legacy: bool -> Script.t -> (ex_script * context) tzresult Lwt.t + = fun ?type_logger ctxt ~legacy { code ; storage } -> Script.force_decode ctxt code >>=? fun (code, ctxt) -> Script.force_decode ctxt storage >>=? fun (storage, ctxt) -> - Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) -> + Lwt.return @@ parse_toplevel ~legacy code >>=? fun (arg_type, storage_type, code_field, root_name) -> trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) + (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type)) >>=? fun (Ex_ty arg_type, ctxt) -> + begin + if legacy then return () else + Lwt.return (well_formed_entrypoints ~root_name arg_type) + end >>=? fun () -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_storage_ty ctxt storage_type)) + (Lwt.return (parse_storage_ty ctxt ~legacy storage_type)) >>=? fun (Ex_ty storage_type, ctxt) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) ~default:default_param_annot in let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) ~default:default_storage_annot in let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None) in + (storage_type, None, storage_annot), None, + has_big_map arg_type || has_big_map storage_type) in let ret_type_full = - Pair_t ((List_t (Operation_t None, None), None, None), - (storage_type, None, None), None) in + Pair_t ((List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), None, has_big_map storage_type) in trace_eval (fun () -> Lwt.return @@ serialize_ty_for_error ctxt storage_type >>|? fun (storage_type, _ctxt) -> Ill_typed_data (None, storage, storage_type)) - (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) -> + (parse_data ?type_logger ctxt ~legacy storage_type (root storage)) >>=? fun (storage, ctxt) -> trace (Ill_typed_contract (code, [])) - (parse_returning (Toplevel { storage_type ; param_type = arg_type }) - ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> - return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt) + (parse_returning (Toplevel { storage_type ; param_type = arg_type ; root_name ; + legacy_create_contract_literal = false}) + ctxt ~legacy ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> + return (Ex_script { code ; arg_type ; storage ; storage_type ; root_name }, ctxt) let typecheck_code : context -> Script.expr -> (type_map * context) tzresult Lwt.t = fun ctxt code -> - Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) -> + let legacy = false in + Lwt.return @@ parse_toplevel ~legacy code >>=? fun (arg_type, storage_type, code_field, root_name) -> let type_map = ref [] in - (* TODO: annotation checking *) trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) + (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type)) >>=? fun (Ex_ty arg_type, ctxt) -> + begin + if legacy then return () else + Lwt.return (well_formed_entrypoints ~root_name arg_type) + end >>=? fun () -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_storage_ty ctxt storage_type)) + (Lwt.return (parse_storage_ty ctxt ~legacy storage_type)) >>=? fun (Ex_ty storage_type, ctxt) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) ~default:default_param_annot in let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) ~default:default_storage_annot in let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None) in + (storage_type, None, storage_annot), None, + has_big_map arg_type || has_big_map storage_type) in let ret_type_full = - Pair_t ((List_t (Operation_t None, None), None, None), - (storage_type, None, None), None) in + Pair_t ((List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), None, + has_big_map storage_type) in let result = parse_returning - (Toplevel { storage_type ; param_type = arg_type }) - ctxt + (Toplevel { storage_type ; param_type = arg_type ; root_name ; + legacy_create_contract_literal = false }) + ctxt ~legacy ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) (arg_type_full, None) ret_type_full code_field in trace @@ -2954,17 +3537,56 @@ let typecheck_data : ?type_logger: type_logger -> context -> Script.expr * Script.expr -> context tzresult Lwt.t = fun ?type_logger ctxt (data, exp_ty) -> + let legacy = false in trace (Ill_formed_type (None, exp_ty, 0)) - (Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false (root exp_ty)) + (Lwt.return @@ parse_packable_ty ctxt ~legacy (root exp_ty)) >>=? fun (Ex_ty exp_ty, ctxt) -> trace_eval (fun () -> Lwt.return @@ serialize_ty_for_error ctxt exp_ty >>|? fun (exp_ty, _ctxt) -> Ill_typed_data (None, data, exp_ty)) - (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, ctxt) -> + (parse_data ?type_logger ctxt ~legacy exp_ty (root data)) >>=? fun (_, ctxt) -> return ctxt +module Entrypoints_map = Map.Make (String) + +let list_entrypoints (type full) (full : full ty) ctxt ~root_name = + let merge path annot (type t) (ty : t ty) reachable ((unreachables, all) as acc) = + match annot with + | None | Some (`Field_annot "") -> + ok @@ + if reachable then acc else + begin match ty with + | Union_t _ -> acc + | _ -> ( (List.rev path)::unreachables, all ) + end + | Some (`Field_annot name) -> + if Compare.Int.(String.length name > 31) then ok ((List.rev path)::unreachables, all) + else if Entrypoints_map.mem name all then ok ((List.rev path)::unreachables, all) + else unparse_ty_no_lwt ctxt ty >>? fun (unparsed_ty , _) -> + ok (unreachables, Entrypoints_map.add name ((List.rev path),unparsed_ty) all) + in + let rec fold_tree + : type t. t ty -> + prim list -> + bool -> + prim list list * (prim list * Script.node) Entrypoints_map.t -> + (prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult + = fun t path reachable acc -> + match t with + | Union_t ((tl, al), (tr, ar), _, _) -> + merge (D_Left :: path) al tl reachable acc >>? fun acc -> + merge (D_Right :: path) ar tr reachable acc >>? fun acc -> + fold_tree tl (D_Left :: path) (match al with Some _ -> true | None -> reachable) acc >>? fun acc -> + fold_tree tr (D_Right :: path) (match ar with Some _ -> true | None -> reachable) acc + | _ -> ok acc in + unparse_ty_no_lwt ctxt full >>? fun (unparsed_full , _) -> + let init, reachable = match root_name with + | None | Some "" -> Entrypoints_map.empty, false + | Some name -> Entrypoints_map.singleton name ([],unparsed_full), true in + fold_tree full [] reachable ([], init) + (* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) let rec unparse_data @@ -3003,23 +3625,37 @@ let rec unparse_data | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) | Some s -> return (String (-1, s), ctxt) end - | Address_t _, c -> + | Address_t _, (c, entrypoint) -> Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> begin match mode with | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + let entrypoint = match entrypoint with "default" -> "" | name -> name in + let bytes = Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) in return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + | Readable -> + let notation = match entrypoint with + | "default" -> Contract.to_b58check c + | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in + return (String (-1, notation), ctxt) end - | Contract_t _, (_, c) -> + | Contract_t _, (_, (c, entrypoint)) -> Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> begin match mode with | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + let entrypoint = match entrypoint with "default" -> "" | name -> name in + let bytes = Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) in return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + | Readable -> + let notation = match entrypoint with + | "default" -> Contract.to_b58check c + | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in + return (String (-1, notation), ctxt) end | Signature_t _, s -> Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> @@ -3054,31 +3690,35 @@ let rec unparse_data | Readable -> return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) end - | Operation_t _, op -> + | Operation_t _, (op, _big_map_diff) -> let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt) - | Pair_t ((tl, _, _), (tr, _, _), _), (l, r) -> + | Chain_id_t _, chain_id -> + let bytes = Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id in + Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r) -> Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> return (Prim (-1, D_Pair, [ l; r ], []), ctxt) - | Union_t ((tl, _), _, _), L l -> + | Union_t ((tl, _), _, _, _), L l -> Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> return (Prim (-1, D_Left, [ l ], []), ctxt) - | Union_t (_, (tr, _), _), R r -> + | Union_t (_, (tr, _), _, _), R r -> Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> return (Prim (-1, D_Right, [ r ], []), ctxt) - | Option_t ((t, _), _, _), Some v -> + | Option_t (t, _, _), Some v -> Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> unparse_data ctxt mode t v >>=? fun (v, ctxt) -> return (Prim (-1, D_Some, [ v ], []), ctxt) | Option_t _, None -> Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> return (Prim (-1, D_None, [], []), ctxt) - | List_t (t, _), items -> + | List_t (t, _, _), items -> fold_left_s (fun (l, ctxt) element -> Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> @@ -3097,7 +3737,7 @@ let rec unparse_data ([], ctxt) (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt) - | Map_t (kt, vt, _), map -> + | Map_t (kt, vt, _, _), map -> let kt = ty_of_comparable_ty kt in fold_left_s (fun (l, ctxt) (k, v) -> @@ -3108,16 +3748,37 @@ let rec unparse_data ([], ctxt) (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt) - | Big_map_t (_kt, _kv, _), _map -> - return (Micheline.Seq (-1, []), ctxt) + | Big_map_t (kt, vt, _), { id = None ; diff = (module Diff) ; _ } -> + (* this branch is to allow roundtrip of big map literals *) + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_data ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data ctxt mode vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (Diff.OPS.fold + (fun k v acc -> match v with | None -> acc | Some v -> (k, v) :: acc) + (fst Diff.boxed) []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (_kt, _kv, _), { id = Some id ; diff = (module Diff) ; _ } -> + if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then + return (Micheline.Int (-1, id), ctxt) + else + (* this can only be the result of an execution and the map + must have been flushed at this point *) + assert false | Lambda_t _, Lam (_, original_code) -> - unparse_code ctxt mode (root original_code) + unparse_code ctxt mode original_code (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) -and unparse_code ctxt mode = function +and unparse_code ctxt mode = + let legacy = true in + function | Prim (loc, I_PUSH, [ ty ; data ], annot) -> - Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) -> - parse_data ctxt t data >>=? fun (data, ctxt) -> + Lwt.return (parse_packable_ty ctxt ~legacy ty) >>=? fun (Ex_ty t, ctxt) -> + parse_data ctxt ~legacy t data >>=? fun (data, ctxt) -> unparse_data ctxt mode t data >>=? fun (data, ctxt) -> Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) @@ -3140,12 +3801,13 @@ and unparse_code ctxt mode = function | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt) (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) -let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } = +let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type ; root_name } = let Lam (_, original_code) = code in - unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) -> + unparse_code ctxt mode original_code >>=? fun (code, ctxt) -> unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) -> unparse_ty ctxt arg_type >>=? fun (arg_type, ctxt) -> unparse_ty ctxt storage_type >>=? fun (storage_type, ctxt) -> + let arg_type = add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None arg_type in let open Micheline in let code = Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ; @@ -3160,8 +3822,7 @@ let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } = storage = lazy_expr (strip_locations storage) }, ctxt) let pack_data ctxt typ data = - unparse_data ctxt Optimized typ data >>=? fun (data, ctxt) -> - let unparsed = strip_annotations @@ data in + unparse_data ctxt Optimized typ data >>=? fun (unparsed, ctxt) -> let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt -> let bytes = MBytes.concat "" [ MBytes.of_string "\005" ; bytes ] in @@ -3171,29 +3832,34 @@ let pack_data ctxt typ data = let hash_data ctxt typ data = pack_data ctxt typ data >>=? fun (bytes, ctxt) -> Lwt.return @@ Gas.consume ctxt - (Michelson_v1_gas.Cost_of.hash bytes Script_expr_hash.size) >>=? fun ctxt -> + (Michelson_v1_gas.Cost_of.Legacy.hash bytes Script_expr_hash.size) >>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt) (* ---------------- Big map -------------------------------------------------*) -let big_map_mem ctxt contract key { diff ; key_type ; _ } = - match map_get key diff with - | None -> hash_data ctxt key_type key >>=? fun (hash, ctxt) -> - Alpha_context.Contract.Big_map.mem ctxt contract hash >>=? fun (ctxt, res) -> - return (res, ctxt) - | Some None -> return (false, ctxt) - | Some (Some _) -> return (true, ctxt) +let empty_big_map tk tv = + { id = None ; diff = empty_map tk ; key_type = ty_of_comparable_ty tk ; value_type = tv } -let big_map_get ctxt contract key { diff ; key_type ; value_type } = - match map_get key diff with - | Some x -> return (x, ctxt) - | None -> +let big_map_mem ctxt key { id ; diff ; key_type ; _ } = + match map_get key diff, id with + | None, None -> return (false, ctxt) + | None, Some id -> hash_data ctxt key_type key >>=? fun (hash, ctxt) -> + Alpha_context.Big_map.mem ctxt id hash >>=? fun (ctxt, res) -> + return (res, ctxt) + | Some None, _ -> return (false, ctxt) + | Some (Some _), _ -> return (true, ctxt) + +let big_map_get ctxt key { id ; diff ; key_type ; value_type } = + match map_get key diff, id with + | Some x, _ -> return (x, ctxt) + | None, None -> return (None, ctxt) + | None, Some id -> hash_data ctxt key_type key >>=? fun (hash, ctxt) -> - Alpha_context.Contract.Big_map.get_opt - ctxt contract hash >>=? begin function + Alpha_context.Big_map.get_opt + ctxt id hash >>=? begin function | (ctxt, None) -> return (None, ctxt) | (ctxt, Some value) -> - parse_data ctxt value_type + parse_data ctxt ~legacy:true value_type (Micheline.root value) >>=? fun (x, ctxt) -> return (Some x, ctxt) end @@ -3201,8 +3867,37 @@ let big_map_get ctxt contract key { diff ; key_type ; value_type } = let big_map_update key value ({ diff ; _ } as map) = { map with diff = map_set key value diff } -let diff_of_big_map ctxt mode (Ex_bm { key_type ; value_type ; diff }) = - Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.map_to_list diff)) >>=? fun ctxt -> +module Ids = Set.Make (Compare.Z) + +type big_map_ids = Ids.t + +let no_big_map_id = Ids.empty + +let diff_of_big_map ctxt fresh mode ~ids { id ; key_type ; value_type ; diff } = + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff)) >>=? fun ctxt -> + begin match id with + | Some id -> + if Ids.mem id ids then + fresh ctxt >>=? fun (ctxt, duplicate) -> + return (ctxt, [ Contract.Copy (id, duplicate) ], duplicate) + else + (* The first occurence encountered of a big_map reuses the + ID. This way, the payer is only charged for the diff. + For this to work, this diff has to be put at the end of + the global diff, otherwise the duplicates will use the + updated version as a base. This is true because we add + this diff first in the accumulator of + `extract_big_map_updates`, and this accumulator is not + reversed before being flattened. *) + return (ctxt, [], id) + | None -> + fresh ctxt >>=? fun (ctxt, id) -> + unparse_ty ctxt key_type >>=? fun (kt, ctxt) -> + unparse_ty ctxt value_type >>=? fun (kv, ctxt) -> + return (ctxt, [ Contract.Alloc { big_map = id ; + key_type = Micheline.strip_locations kt ; + value_type = Micheline.strip_locations kv } ], id) + end >>=? fun (ctxt, init, big_map) -> let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in fold_left_s (fun (acc, ctxt) (key, value) -> @@ -3219,18 +3914,146 @@ let diff_of_big_map ctxt mode (Ex_bm { key_type ; value_type ; diff }) = return (Some (Micheline.strip_locations node), ctxt) end end >>=? fun (diff_value, ctxt) -> - let diff_item = Contract.{ diff_key ; diff_key_hash ; diff_value } in + let diff_item = Contract.Update { big_map ; diff_key ; diff_key_hash ; diff_value } in return (diff_item :: acc, ctxt)) - ([], ctxt) pairs + ([], ctxt) pairs >>=? fun (diff, ctxt) -> + return (init @ diff, big_map, ctxt) -(* Get the big map from a contract's storage if one exists *) -let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x -> - match (ty, x) with - | Pair_t ((Big_map_t (_, _, _), _, _), _, _), (map, _) -> Some (Ex_bm map) - | _, _ -> None +let rec extract_big_map_updates + : type a. context -> (context -> (context * Big_map.id) tzresult Lwt.t) -> + unparsing_mode -> Ids.t -> Contract.big_map_diff list -> a ty -> a -> + (context * a * Ids.t * Contract.big_map_diff list) tzresult Lwt.t + = fun ctxt fresh mode ids acc ty x -> + match (ty, x) with + | Big_map_t (_, _, _), map -> + diff_of_big_map ctxt fresh mode ids map >>=? fun (diff, id, ctxt) -> + let (module Map) = map.diff in + let map = { map with diff = empty_map Map.key_ty ; id = Some id } in + return (ctxt, map, Ids.add id ids, diff :: acc) + | Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc tyl xl >>=? fun (ctxt, xl, ids, acc) -> + extract_big_map_updates ctxt fresh mode ids acc tyr xr >>=? fun (ctxt, xr, ids, acc) -> + return (ctxt, (xl, xr), ids, acc) + | Union_t ((ty, _), (_, _), _, true), L x -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, L x, ids, acc) + | Union_t ((_, _), (ty, _), _, true), R x -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, R x, ids, acc) + | Option_t (ty, _, true), Some x -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, Some x, ids, acc) + | List_t (ty, _, true), l -> + fold_left_s + (fun (ctxt, l, ids, acc) x -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, x :: l, ids, acc)) + (ctxt, [], ids, acc) l >>=? fun (ctxt, l, ids, acc) -> + return (ctxt, List.rev l, ids, acc) + | Map_t (_, ty, _, true), ((module M) as m) -> + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m)) >>=? fun ctxt -> + fold_left_s + (fun (ctxt, m, ids, acc) (k, x) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, M.OPS.add k x m, ids, acc)) + (ctxt, M.OPS.empty, ids, acc) (M.OPS.bindings (fst M.boxed)) >>=? fun (ctxt, m, ids, acc) -> + let module M = struct + module OPS = M.OPS + type key = M.key + type value = M.value + let key_ty = M.key_ty + let boxed = m, (snd M.boxed) + end in + return (ctxt, (module M : Boxed_map with type key = M.key and type value = M.value), ids, acc) + | Option_t (_, _, true), None -> return (ctxt, None, ids, acc) + | List_t (_, _, false), v -> return (ctxt, v, ids, acc) + | Map_t (_, _, _, false), v -> return (ctxt, v, ids, acc) + | Option_t (_, _, false), None -> return (ctxt, None, ids, acc) + | Pair_t (_, _, _, false), v -> return (ctxt, v, ids, acc) + | Union_t (_, _, _, false), v -> return (ctxt, v, ids, acc) + | Option_t (_, _, false), v -> return (ctxt, v, ids, acc) + | Chain_id_t _, v -> return (ctxt, v, ids, acc) + | Set_t (_, _), v -> return (ctxt, v, ids, acc) + | Unit_t _, v -> return (ctxt, v, ids, acc) + | Int_t _, v -> return (ctxt, v, ids, acc) + | Nat_t _, v -> return (ctxt, v, ids, acc) + | Signature_t _, v -> return (ctxt, v, ids, acc) + | String_t _, v -> return (ctxt, v, ids, acc) + | Bytes_t _, v -> return (ctxt, v, ids, acc) + | Mutez_t _, v -> return (ctxt, v, ids, acc) + | Key_hash_t _, v -> return (ctxt, v, ids, acc) + | Key_t _, v -> return (ctxt, v, ids, acc) + | Timestamp_t _, v -> return (ctxt, v, ids, acc) + | Address_t _, v -> return (ctxt, v, ids, acc) + | Bool_t _, v -> return (ctxt, v, ids, acc) + | Lambda_t (_, _, _), v -> return (ctxt, v, ids, acc) + | Contract_t (_, _), v -> return (ctxt, v, ids, acc) + | Operation_t _, _ -> assert false (* called only on parameters and storage, which cannot contain operations *) -let big_map_initialization ctxt mode (Ex_script { storage ; storage_type; _ }) = - match extract_big_map storage_type storage with - | None -> return (None, ctxt) - | Some bm -> - diff_of_big_map ctxt mode bm >>=? fun (bm, ctxt) -> return (Some bm, ctxt) +let collect_big_maps ctxt ty x = + let rec collect + : type a. context -> a ty -> a -> Ids.t -> (Ids.t * context) tzresult + = fun ctxt ty x acc -> + match (ty, x) with + | Big_map_t (_, _, _), { id = Some id } -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + ok (Ids.add id acc, ctxt) + | Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr) -> + collect ctxt tyl xl acc >>? fun (acc, ctxt) -> + collect ctxt tyr xr acc + | Union_t ((ty, _), (_, _), _, true), L x -> + collect ctxt ty x acc + | Union_t ((_, _), (ty, _), _, true), R x -> + collect ctxt ty x acc + | Option_t (ty, _, true), Some x -> + collect ctxt ty x acc + | List_t (ty, _, true), l -> + List.fold_left (fun acc x -> acc >>? fun (acc, ctxt) -> collect ctxt ty x acc) (ok (acc, ctxt)) l + | Map_t (_, ty, _, true), m -> + map_fold (fun _ v acc -> acc >>? fun (acc, ctxt) -> collect ctxt ty v acc) m (ok (acc, ctxt)) + | List_t (_, _, false), _ -> ok (acc, ctxt) + | Map_t (_, _, _, false), _ -> ok (acc, ctxt) + | Big_map_t (_, _, _), { id = None } -> ok (acc, ctxt) + | Option_t (_, _, true), None -> ok (acc, ctxt) + | Option_t (_, _, false), _ -> ok (acc, ctxt) + | Union_t (_, _, _, false), _ -> ok (acc, ctxt) + | Pair_t (_, _, _, false), _ -> ok (acc, ctxt) + | Chain_id_t _, _ -> ok (acc, ctxt) + | Set_t (_, _), _ -> ok (acc, ctxt) + | Unit_t _, _ -> ok (acc, ctxt) + | Int_t _, _ -> ok (acc, ctxt) + | Nat_t _, _ -> ok (acc, ctxt) + | Signature_t _, _ -> ok (acc, ctxt) + | String_t _, _ -> ok (acc, ctxt) + | Bytes_t _, _ -> ok (acc, ctxt) + | Mutez_t _, _ -> ok (acc, ctxt) + | Key_hash_t _, _ -> ok (acc, ctxt) + | Key_t _, _ -> ok (acc, ctxt) + | Timestamp_t _, _ -> ok (acc, ctxt) + | Address_t _, _ -> ok (acc, ctxt) + | Bool_t _, _ -> ok (acc, ctxt) + | Lambda_t (_, _, _), _ -> ok (acc, ctxt) + | Contract_t (_, _), _ -> ok (acc, ctxt) + | Operation_t _, _ -> assert false (* called only on parameters and storage, which cannot contain operations *) in + Lwt.return (collect ctxt ty x no_big_map_id) + +let extract_big_map_diff ctxt mode + ~temporary ~to_duplicate ~to_update + ty v = + let to_duplicate = Ids.diff to_duplicate to_update in + let fresh = if temporary then (fun c -> return (Big_map.fresh_temporary c)) else Big_map.fresh in + extract_big_map_updates ctxt fresh mode to_duplicate [] ty v >>=? fun (ctxt, v, alive, diffs) -> + let diffs = if temporary then diffs else + let dead = Ids.diff to_update alive in + Ids.fold (fun id acc -> Contract.Clear id :: acc) dead [] :: diffs in + match diffs with + | [] -> return (v, None, ctxt) + | diffs -> return (v, Some (List.flatten diffs (* do not reverse *)), ctxt) + +let list_of_big_map_ids ids = Ids.elements ids diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli index 64eb6f534..4781e86ef 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli @@ -32,11 +32,17 @@ type ex_comparable_ty = Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> e type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script - type tc_context = | Lambda : tc_context | Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context - | Toplevel : { storage_type : 'sto Script_typed_ir.ty ; param_type : 'param Script_typed_ir.ty } -> tc_context + | Toplevel : { storage_type : 'sto Script_typed_ir.ty ; + param_type : 'param Script_typed_ir.ty ; + root_name : string option ; + legacy_create_contract_literal : bool } -> tc_context +type 'bef judgement = + | Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement + | Failed : + { descr : 'aft. 'aft Script_typed_ir.stack_ty -> ('bef, 'aft) Script_typed_ir.descr } -> 'bef judgement type unparsing_mode = Optimized | Readable @@ -64,21 +70,20 @@ val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num +val empty_big_map : 'a Script_typed_ir.comparable_ty -> 'b Script_typed_ir.ty -> ('a, 'b) Script_typed_ir.big_map val big_map_mem : - context -> Contract.t -> 'key -> + context -> 'key -> ('key, 'value) Script_typed_ir.big_map -> (bool * context) tzresult Lwt.t val big_map_get : - context -> - Contract.t -> 'key -> + context -> 'key -> ('key, 'value) Script_typed_ir.big_map -> ('value option * context) tzresult Lwt.t val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> ('key, 'value) Script_typed_ir.big_map -val ty_of_comparable_ty : - 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.ty +val has_big_map : 't Script_typed_ir.ty -> bool val ty_eq : @@ -86,25 +91,41 @@ val ty_eq : 'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty -> (('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult +val compare_comparable : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> int + +val ty_of_comparable_ty : ('a, 's) Script_typed_ir.comparable_struct -> 'a Script_typed_ir.ty + val parse_data : ?type_logger: type_logger -> - context -> + context -> legacy: bool -> 'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t val unparse_data : context -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult Lwt.t +val parse_instr : + ?type_logger: type_logger -> + tc_context -> context -> legacy: bool -> + Script.node -> 'bef Script_typed_ir.stack_ty -> ('bef judgement * context) tzresult Lwt.t + val parse_ty : - context -> + context -> legacy: bool -> allow_big_map: bool -> allow_operation: bool -> + allow_contract: bool -> Script.node -> (ex_ty * context) tzresult +val parse_packable_ty : + context -> legacy: bool -> Script.node -> (ex_ty * context) tzresult + val unparse_ty : context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t val parse_toplevel : - Script.expr -> (Script.node * Script.node * Script.node) tzresult + legacy: bool -> Script.expr -> (Script.node * Script.node * Script.node * string option) tzresult + +val add_field_annot : + [ `Field_annot of string ] option -> [ `Var_annot of string ] option -> Script.node -> Script.node val typecheck_code : context -> Script.expr -> (type_map * context) tzresult Lwt.t @@ -113,18 +134,9 @@ val typecheck_data : ?type_logger: type_logger -> context -> Script.expr * Script.expr -> context tzresult Lwt.t -type 'bef judgement = - | Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement - | Failed : { descr : 'aft. 'aft Script_typed_ir.stack_ty -> ('bef, 'aft) Script_typed_ir.descr } -> 'bef judgement - -val parse_instr : - ?type_logger: type_logger -> - tc_context -> context -> - Script.node -> 'bef Script_typed_ir.stack_ty -> ('bef judgement * context) tzresult Lwt.t - val parse_script : ?type_logger: type_logger -> - context -> Script.t -> (ex_script * context) tzresult Lwt.t + context -> legacy: bool -> Script.t -> (ex_script * context) tzresult Lwt.t (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) val unparse_script : @@ -132,23 +144,44 @@ val unparse_script : ('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t val parse_contract : - context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + legacy: bool -> context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + entrypoint: string -> (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t val parse_contract_for_script : - context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + legacy: bool -> context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + entrypoint: string -> (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t +val find_entrypoint : + 't Script_typed_ir.ty -> root_name: string option -> string -> ((Script.node -> Script.node) * ex_ty) tzresult + +module Entrypoints_map : S.MAP with type key = string + +val list_entrypoints : + 't Script_typed_ir.ty -> + context -> + root_name: string option -> + (Michelson_v1_primitives.prim list list * + (Michelson_v1_primitives.prim list * Script.node) Entrypoints_map.t) + tzresult + val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t -val extract_big_map : - 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option +type big_map_ids -val diff_of_big_map : - context -> unparsing_mode -> Script_typed_ir.ex_big_map -> - (Contract.big_map_diff * context) tzresult Lwt.t +val no_big_map_id : big_map_ids -val big_map_initialization : - context -> unparsing_mode -> ex_script -> - (Contract.big_map_diff option * context) tzresult Lwt.t +val collect_big_maps : + context -> 'a Script_typed_ir.ty -> 'a -> (big_map_ids * context) tzresult Lwt.t + +val list_of_big_map_ids : big_map_ids -> Z.t list + +val extract_big_map_diff : + context -> unparsing_mode -> + temporary: bool -> + to_duplicate: big_map_ids -> + to_update: big_map_ids -> + 'a Script_typed_ir.ty -> 'a -> + ('a * Contract.big_map_diff option * context) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml index c51cfd8f3..81effec8f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml @@ -62,7 +62,7 @@ let lazy_expr expr = type t = { code : lazy_expr ; - storage : lazy_expr + storage : lazy_expr ; } let encoding = @@ -195,3 +195,25 @@ let minimal_deserialize_cost lexpr = ~fun_bytes:(fun b -> serialized_cost b) ~fun_combine:(fun c_free _ -> c_free) lexpr + +let unit = + Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], [])) + +let unit_parameter = + lazy_expr unit + +let is_unit_parameter = + let unit_bytes = Data_encoding.force_bytes unit_parameter in + Data_encoding.apply_lazy + ~fun_value:(fun v -> match Micheline.root v with Prim (_, Michelson_v1_primitives.D_Unit, [], []) -> true | _ -> false) + ~fun_bytes:(fun b -> MBytes.(=) b unit_bytes) + ~fun_combine:(fun res _ -> res) + +let rec strip_annotations node = + let open Micheline in + match node with + | Int (_, _) | String (_, _) | Bytes (_, _) as leaf -> leaf + | Prim (loc, name, args, _) -> + Prim (loc, name, List.map strip_annotations args, []) + | Seq (loc, args) -> + Seq (loc, List.map strip_annotations args) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli index 34dc0d90a..d44e137e4 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli @@ -69,3 +69,9 @@ val force_decode : lazy_expr -> (expr * Gas_limit_repr.cost) tzresult val force_bytes : lazy_expr -> (MBytes.t * Gas_limit_repr.cost) tzresult val minimal_deserialize_cost : lazy_expr -> Gas_limit_repr.cost + +val unit_parameter : lazy_expr + +val is_unit_parameter : lazy_expr -> bool + +val strip_annotations : node -> node diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml index e0ec2ff63..3d0e0ea85 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml @@ -44,6 +44,11 @@ type error += Missing_field of prim type error += Duplicate_field of Script.location * prim type error += Unexpected_big_map of Script.location type error += Unexpected_operation of Script.location +type error += Unexpected_contract of Script.location +type error += No_such_entrypoint of string +type error += Duplicate_entrypoint of string +type error += Unreachable_entrypoint of prim list +type error += Entrypoint_name_too_long of string (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location @@ -67,7 +72,9 @@ type error += Type_too_large : Script.location * int * int -> error (* Value typing errors *) type error += Invalid_constant : Script.location * Script.expr * Script.expr -> error +type error += Invalid_syntactic_constant : Script.location * Script.expr * string -> error type error += Invalid_contract of Script.location * Contract.t +type error += Invalid_big_map of Script.location * Big_map.id type error += Comparable_type_expected : Script.location * Script.expr -> error type error += Inconsistent_types : Script.expr * Script.expr -> error type error += Unordered_map_keys of Script.location * Script.expr @@ -82,3 +89,6 @@ type error += Ill_typed_contract : Script.expr * type_map -> error (* Gas related errors *) type error += Cannot_serialize_error + +(* Deprecation errors *) +type error += Deprecated_instruction of prim diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml index 10347b6a7..e8a33c5fe 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml @@ -170,8 +170,9 @@ let () = ~id:"michelson_v1.unexpected_bigmap" ~title: "Big map in unauthorized position (type error)" ~description: - "When parsing script, a big_map type was found somewhere else \ - than in the left component of the toplevel storage pair." + "When parsing script, a big_map type was found in a position \ + where it could end up stored inside a big_map, which is \ + forbidden for now." (obj1 (req "loc" location_encoding)) (function Unexpected_big_map loc -> Some loc | _ -> None) @@ -180,14 +181,70 @@ let () = register_error_kind `Permanent ~id:"michelson_v1.unexpected_operation" - ~title: "Big map in unauthorized position (type error)" + ~title: "Operation in unauthorized position (type error)" ~description: - "When parsing script, a operation type was found \ + "When parsing script, an operation type was found \ in the storage or parameter field." (obj1 (req "loc" location_encoding)) (function Unexpected_operation loc -> Some loc | _ -> None) (fun loc -> Unexpected_operation loc) ; + (* No such entrypoint *) + register_error_kind + `Permanent + ~id:"michelson_v1.no_such_entrypoint" + ~title: "No such entrypoint (type error)" + ~description: + "An entrypoint was not found when calling a contract." + (obj1 + (req "entrypoint" string)) + (function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> No_such_entrypoint entrypoint) ; + (* Unreachable entrypoint *) + register_error_kind + `Permanent + ~id:"michelson_v1.unreachable_entrypoint" + ~title: "Unreachable entrypoint (type error)" + ~description: + "An entrypoint in the contract is not reachable." + (obj1 + (req "path" (list prim_encoding))) + (function Unreachable_entrypoint path -> Some path | _ -> None) + (fun path -> Unreachable_entrypoint path) ; + (* Duplicate entrypoint *) + register_error_kind + `Permanent + ~id:"michelson_v1.duplicate_entrypoint" + ~title: "Duplicate entrypoint (type error)" + ~description: + "Two entrypoints have the same name." + (obj1 + (req "path" string)) + (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> Duplicate_entrypoint entrypoint) ; + (* Entrypoint name too long *) + register_error_kind + `Permanent + ~id:"michelson_v1.entrypoint_name_too_long" + ~title: "Entrypoint name too long (type error)" + ~description: + "An entrypoint name exceeds the maximum length of 31 characters." + (obj1 + (req "name" string)) + (function Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> Entrypoint_name_too_long entrypoint) ; + (* Unexpected contract *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_contract" + ~title: "Contract in unauthorized position (type error)" + ~description: + "When parsing script, a contract type was found \ + in the storage or parameter field." + (obj1 + (req "loc" location_encoding)) + (function Unexpected_contract loc -> Some loc | _ -> None) + (fun loc -> Unexpected_contract loc) ; (* -- Value typing errors ---------------------- *) (* Unordered map keys *) register_error_kind @@ -454,6 +511,22 @@ let () = | _ -> None) (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ; + (* Invalid syntactic constant *) + register_error_kind + `Permanent + ~id:"invalidSyntacticConstantError" + ~title: "Invalid constant (parse error)" + ~description: + "A compile-time constant was invalid for its expected form." + (located (obj2 + (req "expectedForm" Script.expr_encoding) + (req "wrongExpression" Script.expr_encoding))) + (function + | Invalid_constant (loc, expr, ty) -> + Some (loc, (ty, expr)) + | _ -> None) + (fun (loc, (ty, expr)) -> + Invalid_constant (loc, expr, ty)) ; (* Invalid contract *) register_error_kind `Permanent @@ -469,6 +542,21 @@ let () = | _ -> None) (fun (loc, c) -> Invalid_contract (loc, c)) ; + (* Invalid big_map *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_big_map" + ~title: "Invalid big_map" + ~description: + "A script or data expression references a big_map that does not \ + exist or assumes a wrong type for an existing big_map." + (located (obj1 (req "big_map" z))) + (function + | Invalid_big_map (loc, c) -> + Some (loc, c) + | _ -> None) + (fun (loc, c) -> + Invalid_big_map (loc, c)) ; (* Comparable type expected *) register_error_kind `Permanent @@ -619,4 +707,14 @@ let () = the provided gas" Data_encoding.empty (function Cannot_serialize_error -> Some () | _ -> None) - (fun () -> Cannot_serialize_error) + (fun () -> Cannot_serialize_error) ; + (* Deprecated instruction *) + register_error_kind + `Permanent + ~id:"michelson_v1.deprecated_instruction" + ~title:"Script is using a deprecated instruction" + ~description: + "A deprecated instruction usage is disallowed in newly created contracts" + (obj1 (req "prim" prim_encoding)) + (function Deprecated_instruction prim -> Some prim | _ -> None) + (fun prim -> Deprecated_instruction prim) ; diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml index 7656fc44a..d536ecec8 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml @@ -34,20 +34,35 @@ type field_annot = [ `Field_annot of string ] type annot = [ var_annot | type_annot | field_annot ] -type 'ty comparable_ty = - | Int_key : type_annot option -> (z num) comparable_ty - | Nat_key : type_annot option -> (n num) comparable_ty - | String_key : type_annot option -> string comparable_ty - | Bytes_key : type_annot option -> MBytes.t comparable_ty - | Mutez_key : type_annot option -> Tez.t comparable_ty - | Bool_key : type_annot option -> bool comparable_ty - | Key_hash_key : type_annot option -> public_key_hash comparable_ty - | Timestamp_key : type_annot option -> Script_timestamp.t comparable_ty - | Address_key : type_annot option -> Contract.t comparable_ty +type address = Contract.t * string +type ('a, 'b) pair = 'a * 'b + +type ('a, 'b) union = L of 'a | R of 'b + +type comb = Comb +type leaf = Leaf + +type (_, _) comparable_struct = + | Int_key : type_annot option -> (z num, _) comparable_struct + | Nat_key : type_annot option -> (n num, _) comparable_struct + | String_key : type_annot option -> (string, _) comparable_struct + | Bytes_key : type_annot option -> (MBytes.t, _) comparable_struct + | Mutez_key : type_annot option -> (Tez.t, _) comparable_struct + | Bool_key : type_annot option -> (bool, _) comparable_struct + | Key_hash_key : type_annot option -> (public_key_hash, _) comparable_struct + | Timestamp_key : type_annot option -> (Script_timestamp.t, _) comparable_struct + | Address_key : type_annot option -> (address, _) comparable_struct + | Pair_key : + (('a, leaf) comparable_struct * field_annot option) * + (('b, _) comparable_struct * field_annot option) * + type_annot option -> (('a, 'b) pair, comb) comparable_struct + +type 'a comparable_ty = ('a, comb) comparable_struct module type Boxed_set = sig type elt + val elt_ty : elt comparable_ty module OPS : S.SET with type elt = elt val boxed : OPS.t val size : int @@ -65,23 +80,21 @@ end type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value) +type operation = packed_internal_operation * Contract.big_map_diff option + type ('arg, 'storage) script = - { code : (('arg, 'storage) pair, (packed_internal_operation list, 'storage) pair) lambda ; + { code : (('arg, 'storage) pair, (operation list, 'storage) pair) lambda ; arg_type : 'arg ty ; storage : 'storage ; - storage_type : 'storage ty } - -and ('a, 'b) pair = 'a * 'b - -and ('a, 'b) union = L of 'a | R of 'b + storage_type : 'storage ty ; + root_name : string option } and end_of_stack = unit and ('arg, 'ret) lambda = - Lam of ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.expr + Lam : ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node -> ('arg, 'ret) lambda -and 'arg typed_contract = - 'arg ty * Contract.t +and 'arg typed_contract = 'arg ty * address and 'ty ty = | Unit_t : type_annot option -> unit ty @@ -94,39 +107,48 @@ and 'ty ty = | Key_hash_t : type_annot option -> public_key_hash ty | Key_t : type_annot option -> public_key ty | Timestamp_t : type_annot option -> Script_timestamp.t ty - | Address_t : type_annot option -> Contract.t ty + | Address_t : type_annot option -> address ty | Bool_t : type_annot option -> bool ty | Pair_t : ('a ty * field_annot option * var_annot option) * ('b ty * field_annot option * var_annot option) * - type_annot option -> ('a, 'b) pair ty - | Union_t : ('a ty * field_annot option) * ('b ty * field_annot option) * type_annot option -> ('a, 'b) union ty + type_annot option * + bool -> ('a, 'b) pair ty + | Union_t : + ('a ty * field_annot option) * + ('b ty * field_annot option) * + type_annot option * + bool -> ('a, 'b) union ty | Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty - | Option_t : ('v ty * field_annot option) * field_annot option * type_annot option -> 'v option ty - | List_t : 'v ty * type_annot option -> 'v list ty + | Option_t : 'v ty * type_annot option * bool -> 'v option ty + | List_t : 'v ty * type_annot option * bool -> 'v list ty | Set_t : 'v comparable_ty * type_annot option -> 'v set ty - | Map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) map ty + | Map_t : 'k comparable_ty * 'v ty * type_annot option * bool -> ('k, 'v) map ty | Big_map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) big_map ty | Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty - | Operation_t : type_annot option -> packed_internal_operation ty + | Operation_t : type_annot option -> operation ty + | Chain_id_t : type_annot option -> Chain_id.t ty and 'ty stack_ty = | Item_t : 'ty ty * 'rest stack_ty * var_annot option -> ('ty * 'rest) stack_ty | Empty_t : end_of_stack stack_ty -and ('key, 'value) big_map = { diff : ('key, 'value option) map ; +and ('key, 'value) big_map = { id : Z.t option ; + diff : ('key, 'value option) map ; key_type : 'key ty ; value_type : 'value ty } (* ---- Instructions --------------------------------------------------------*) (* The low-level, typed instructions, as a GADT whose parameters - encode the typing rules. The left parameter is the typed shape of - the stack before the instruction, the right one the shape - after. Any program whose construction is accepted by OCaml's - type-checker is guaranteed to be type-safe. Overloadings of the - concrete syntax are already resolved in this representation, either - by using different constructors or type witness parameters. *) + encode the typing rules. + + The left parameter is the typed shape of the stack before the + instruction, the right one the shape after. Any program whose + construction is accepted by OCaml's type-checker is guaranteed to + be type-safe. Overloadings of the concrete syntax are already + resolved in this representation, either by using different + constructors or type witness parameters. *) and ('bef, 'aft) instr = (* stack ops *) | Drop : @@ -195,6 +217,8 @@ and ('bef, 'aft) instr = ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr (* big maps *) + | Empty_big_map : 'a comparable_ty * 'v ty -> + ('rest, ('a, 'v) big_map * 'rest) instr | Big_map_mem : ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr | Big_map_get : @@ -232,10 +256,7 @@ and ('bef, 'aft) instr = | Diff_timestamps : (Script_timestamp.t * (Script_timestamp.t * 'rest), z num * 'rest) instr - (* currency operations *) - (* TODO: we can either just have conversions to/from integers and - do all operations on integers, or we need more operations on - Tez. Also Sub_tez should return Tez.t option (if negative) and *) + (* tez operations *) | Add_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr | Sub_tez : @@ -323,6 +344,8 @@ and ('bef, 'aft) instr = ('top * 'bef, 'top * 'aft) instr | Exec : ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr + | Apply : 'arg ty -> + ('arg * (('arg * 'remaining, 'ret) lambda * 'rest), ('remaining, 'ret) lambda * 'rest) instr | Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr | Failwith : @@ -345,24 +368,25 @@ and ('bef, 'aft) instr = (z num * 'rest, bool * 'rest) instr | Ge : (z num * 'rest, bool * 'rest) instr - (* protocol *) | Address : - (_ typed_contract * 'rest, Contract.t * 'rest) instr - | Contract : 'p ty -> - (Contract.t * 'rest, 'p typed_contract option * 'rest) instr + (_ typed_contract * 'rest, address * 'rest) instr + | Contract : 'p ty * string -> + (address * 'rest, 'p typed_contract option * 'rest) instr | Transfer_tokens : - ('arg * (Tez.t * ('arg typed_contract * 'rest)), packed_internal_operation * 'rest) instr + ('arg * (Tez.t * ('arg typed_contract * 'rest)), operation * 'rest) instr | Create_account : (public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))), - packed_internal_operation * (Contract.t * 'rest)) instr + operation * (address * 'rest)) instr | Implicit_account : (public_key_hash * 'rest, unit typed_contract * 'rest) instr - | Create_contract : 'g ty * 'p ty * ('p * 'g, packed_internal_operation list * 'g) lambda -> + | Create_contract : 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option -> (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))), - packed_internal_operation * (Contract.t * 'rest)) instr + operation * (address * 'rest)) instr + | Create_contract_2 : 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option -> + (public_key_hash option * (Tez.t * ('g * 'rest)), operation * (address * 'rest)) instr | Set_delegate : - (public_key_hash option * 'rest, packed_internal_operation * 'rest) instr + (public_key_hash option * 'rest, operation * 'rest) instr | Now : ('rest, Script_timestamp.t * 'rest) instr | Balance : @@ -384,13 +408,35 @@ and ('bef, 'aft) instr = | Steps_to_quota : (* TODO: check that it always returns a nat *) ('rest, n num * 'rest) instr | Source : - ('rest, Contract.t * 'rest) instr + ('rest, address * 'rest) instr | Sender : - ('rest, Contract.t * 'rest) instr - | Self : 'p ty -> + ('rest, address * 'rest) instr + | Self : 'p ty * string -> ('rest, 'p typed_contract * 'rest) instr | Amount : ('rest, Tez.t * 'rest) instr + | Dig : int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness -> + ('bef, 'x * 'aft) instr + | Dug : int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness -> + ('x * 'bef, 'aft) instr + | Dipn : int * ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness * ('fbef, 'faft) descr -> + ('bef, 'aft) instr + | Dropn : int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness -> + ('bef, 'rest) instr + | ChainId : + ('rest, Chain_id.t * 'rest) instr + +(* Type witness for operations that work deep in the stack ignoring + (and preserving) a prefix. + + The two right parameters are the shape of the stack with the (same) + prefix before and after the transformation. The two left + parameters are the shape of the stack without the prefix before and + after. The inductive definition makes it so by construction. *) +and ('bef, 'aft, 'bef_suffix, 'aft_suffix) stack_prefix_preservation_witness = + | Prefix : ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + -> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness + | Rest : ('bef, 'aft, 'bef, 'aft) stack_prefix_preservation_witness and ('bef, 'aft) descr = { loc : Script.location ; diff --git a/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli index ae9827c8e..d8ed774ce 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli @@ -33,7 +33,7 @@ seed such that the generated sequence is a given one. *) -(** {2 Random Generation} ****************************************************) +(** {2 Random Generation} *) (** The state of the random number generator *) type t @@ -56,7 +56,7 @@ val take : sequence -> MBytes.t * sequence (** Generates the next random value as a bounded [int32] *) val take_int32 : sequence -> int32 -> int32 * sequence -(** {2 Predefined seeds} *****************************************************) +(** {2 Predefined seeds} *) val empty : seed @@ -68,7 +68,7 @@ val deterministic_seed : seed -> seed concatenated with a constant. *) val initial_seeds : int -> seed list -(** {2 Entropy} **************************************************************) +(** {2 Entropy} *) (** A nonce for adding entropy to the generator *) type nonce @@ -88,12 +88,12 @@ val check_hash : nonce -> Nonce_hash.t -> bool (** For using nonce hashes as keys in the hierarchical database *) val nonce_hash_key_part : Nonce_hash.t -> string list -> string list -(** {2 Predefined nonce} *****************************************************) +(** {2 Predefined nonce} *) val initial_nonce_0 : nonce val initial_nonce_hash_0 : Nonce_hash.t -(** {2 Serializers} **********************************************************) +(** {2 Serializers} *) val nonce_encoding : nonce Data_encoding.t val seed_encoding : seed Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml b/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml index 120afb9cf..3113307f7 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml @@ -35,7 +35,11 @@ let rpc_init ({ block_hash ; block_header ; context } : Updater.rpc_context) = let level = block_header.level in let timestamp = block_header.timestamp in let fitness = block_header.fitness in - Alpha_context.prepare ~level ~timestamp ~fitness context >>=? fun context -> + Alpha_context.prepare + ~level + ~predecessor_timestamp:timestamp + ~timestamp + ~fitness context >>=? fun context -> return { block_hash ; block_header ; context } let rpc_services = ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage.ml index b2e3fd919..5d2ec65c9 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage.ml @@ -36,7 +36,7 @@ module Int32 = struct end module Z = struct - type t = Z.t + include Z let encoding = Data_encoding.z end @@ -66,8 +66,15 @@ module Make_index(H : Storage_description.INDEX) } end +module Block_priority = + Make_single_data_storage(Registered) + (Raw_context) + (struct let name = ["block_priority"] end) + (Int) + +(* Only for migration from 004 *) module Last_block_priority = - Make_single_data_storage + Make_single_data_storage(Ghost) (Raw_context) (struct let name = ["last_block_priority"] end) (Int) @@ -77,17 +84,17 @@ module Last_block_priority = module Contract = struct module Raw_context = - Make_subcontext(Raw_context)(struct let name = ["contracts"] end) + Make_subcontext(Registered)(Raw_context)(struct let name = ["contracts"] end) module Global_counter = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["global_counter"] end) (Z) module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Raw_context)(struct let name = ["index"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end)) (Make_index(Contract_repr.Index)) let fold = Indexed_context.fold_keys @@ -100,7 +107,7 @@ module Contract = struct module Frozen_balance_index = Make_indexed_subcontext - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) (struct let name = ["frozen_balance"] end)) (Make_index(Cycle_repr.Index)) @@ -125,12 +132,12 @@ module Contract = struct (struct let name = ["manager"] end) (Manager_repr) - module Spendable = - Indexed_context.Make_set + module Spendable_004 = + Indexed_context.Make_set(Ghost) (struct let name = ["spendable"] end) - module Delegatable = - Indexed_context.Make_set + module Delegatable_004 = + Indexed_context.Make_set(Ghost) (struct let name = ["delegatable"] end) module Delegate = @@ -139,7 +146,7 @@ module Contract = struct (Signature.Public_key_hash) module Inactive_delegate = - Indexed_context.Make_set + Indexed_context.Make_set(Registered) (struct let name = ["inactive_delegate"] end) module Delegate_desactivation = @@ -149,9 +156,17 @@ module Contract = struct module Delegated = Make_data_set_storage - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) (struct let name = ["delegated"] end)) + (Make_index(Contract_repr.Index)) + + (** Only for migration from proto_004 *) + module Delegated_004 = + Make_data_set_storage + (Make_subcontext(Ghost) + (Indexed_context.Raw_context) + (struct let name = ["delegated_004"] end)) (Make_index(Contract_hash)) module Counter = @@ -219,6 +234,14 @@ module Contract = struct let init_set ctxt contract value = consume_serialize_gas ctxt value >>=? fun ctxt -> I.init_set ctxt contract value + + (** Only for used for 005 migration to avoid gas cost. *) + let init_free ctxt contract value = + I.init_free ctxt contract value + + (** Only for used for 005 migration to avoid gas cost. *) + let set_free ctxt contract value = + I.set_free ctxt contract value end module Code = @@ -229,15 +252,146 @@ module Contract = struct Make_carbonated_map_expr (struct let name = ["storage"] end) - type bigmap_key = Raw_context.t * Contract_repr.t + module Paid_storage_space = + Indexed_context.Make_map + (struct let name = ["paid_bytes"] end) + (Z) + + module Used_storage_space = + Indexed_context.Make_map + (struct let name = ["used_bytes"] end) + (Z) + + module Roll_list = + Indexed_context.Make_map + (struct let name = ["roll_list"] end) + (Roll_repr) + + module Change = + Indexed_context.Make_map + (struct let name = ["change"] end) + (Tez_repr) + +end + +(** Big maps handling *) + +module Big_map = struct + module Raw_context = + Make_subcontext(Registered)(Raw_context)(struct let name = ["big_maps"] end) + + module Next = struct + include + Make_single_data_storage(Registered) + (Raw_context) + (struct let name = ["next"] end) + (Z) + let incr ctxt = + get ctxt >>=? fun i -> + set ctxt (Z.succ i) >>=? fun ctxt -> + return (ctxt, i) + let init ctxt = init ctxt Z.zero + end + + module Index = struct + type t = Z.t + + let rpc_arg = + let construct = Z.to_string in + let destruct hash = + match Z.of_string hash with + | exception _ -> Error "Cannot parse big map id" + | id -> Ok id in + RPC_arg.make + ~descr: "A big map identifier" + ~name: "big_map_id" + ~construct + ~destruct + () + + let encoding = + Data_encoding.def "big_map_id" + ~title:"Big map identifier" + ~description: "A big map identifier" + Z.encoding + let compare = Compare.Z.compare + + let path_length = 7 + + let to_path c l = + let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in + let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + String.sub index_key 0 2 :: + String.sub index_key 2 2 :: + String.sub index_key 4 2 :: + String.sub index_key 6 2 :: + String.sub index_key 8 2 :: + String.sub index_key 10 2 :: + Z.to_string c :: + l + + let of_path = function + | [] | [_] | [_;_] | [_;_;_] | [_;_;_;_] | [_;_;_;_;_] | [_;_;_;_;_;_] + | _::_::_::_::_::_::_::_::_ -> + None + | [ index1 ; index2 ; index3 ; index4 ; index5 ; index6 ; key ] -> + let c = Z.of_string key in + let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in + let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + assert Compare.String.(String.sub index_key 0 2 = index1) ; + assert Compare.String.(String.sub index_key 2 2 = index2) ; + assert Compare.String.(String.sub index_key 4 2 = index3) ; + assert Compare.String.(String.sub index_key 6 2 = index4) ; + assert Compare.String.(String.sub index_key 8 2 = index5) ; + assert Compare.String.(String.sub index_key 10 2 = index6) ; + Some c + end + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end)) + (Make_index(Index)) + + let rpc_arg = Index.rpc_arg + + let fold = Indexed_context.fold_keys + let list = Indexed_context.keys + + let remove_rec ctxt n = + Indexed_context.remove_rec ctxt n + + let copy ctxt ~from ~to_ = + Indexed_context.copy ctxt ~from ~to_ + + type key = Raw_context.t * Z.t + + module Total_bytes = + Indexed_context.Make_map + (struct let name = ["total_bytes"] end) + (Z) + + module Key_type = + Indexed_context.Make_map + (struct let name = ["key_type"] end) + (struct + type t = Script_repr.expr + let encoding = Script_repr.expr_encoding + end) + + module Value_type = + Indexed_context.Make_map + (struct let name = ["value_type"] end) + (struct + type t = Script_repr.expr + let encoding = Script_repr.expr_encoding + end) + + module Contents = struct - (* Consume gas for serilization and deserialization of expr in this - module *) - module Big_map = struct module I = Storage_functors.Make_indexed_carbonated_data_storage - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) - (struct let name = ["big_map"] end)) + (struct let name = ["contents"] end)) (Make_index(Script_expr_hash)) (struct type t = Script_repr.expr @@ -274,41 +428,21 @@ module Contract = struct (ctxt, value_opt) end - module Paid_storage_space = - Indexed_context.Make_map - (struct let name = ["paid_bytes"] end) - (Z) - - module Used_storage_space = - Indexed_context.Make_map - (struct let name = ["used_bytes"] end) - (Z) - - module Roll_list = - Indexed_context.Make_map - (struct let name = ["roll_list"] end) - (Roll_repr) - - module Change = - Indexed_context.Make_map - (struct let name = ["change"] end) - (Tez_repr) - end module Delegates = Make_data_set_storage - (Make_subcontext(Raw_context)(struct let name = ["delegates"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["delegates"] end)) (Make_index(Signature.Public_key_hash)) module Active_delegates_with_rolls = Make_data_set_storage - (Make_subcontext(Raw_context)(struct let name = ["active_delegates_with_rolls"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["active_delegates_with_rolls"] end)) (Make_index(Signature.Public_key_hash)) module Delegates_with_frozen_balance_index = Make_indexed_subcontext - (Make_subcontext(Raw_context) + (Make_subcontext(Registered)(Raw_context) (struct let name = ["delegates_with_frozen_balance"] end)) (Make_index(Cycle_repr.Index)) @@ -323,12 +457,12 @@ module Cycle = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Raw_context)(struct let name = ["cycle"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["cycle"] end)) (Make_index(Cycle_repr.Index)) module Last_roll = Make_indexed_data_storage - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) (struct let name = ["last_roll"] end)) (Int_index) @@ -377,7 +511,7 @@ module Cycle = struct module Nonce = Make_indexed_data_storage - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) (struct let name = ["nonces"] end)) (Make_index(Raw_level_repr.Index)) @@ -399,21 +533,21 @@ end module Roll = struct module Raw_context = - Make_subcontext(Raw_context)(struct let name = ["rolls"] end) + Make_subcontext(Registered)(Raw_context)(struct let name = ["rolls"] end) module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Raw_context)(struct let name = ["index"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end)) (Make_index(Roll_repr.Index)) module Next = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["next"] end) (Roll_repr) module Limbo = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["limbo"] end) (Roll_repr) @@ -469,7 +603,7 @@ module Roll = struct module Owner = Make_indexed_data_snapshotable_storage - (Make_subcontext(Raw_context)(struct let name = ["owner"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["owner"] end)) (Snapshoted_owner_index) (Make_index(Roll_repr.Index)) (Signature.Public_key) @@ -486,10 +620,10 @@ end module Vote = struct module Raw_context = - Make_subcontext(Raw_context)(struct let name = ["votes"] end) + Make_subcontext(Registered)(Raw_context)(struct let name = ["votes"] end) module Current_period_kind = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["current_period_kind"] end) (struct @@ -497,45 +631,51 @@ module Vote = struct let encoding = Voting_period_repr.kind_encoding end) - module Current_quorum = - Make_single_data_storage + module Current_quorum_004 = + Make_single_data_storage(Ghost) (Raw_context) (struct let name = ["current_quorum"] end) (Int32) + module Participation_ema = + Make_single_data_storage(Registered) + (Raw_context) + (struct let name = ["participation_ema"] end) + (Int32) + module Current_proposal = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["current_proposal"] end) (Protocol_hash) module Listings_size = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["listings_size"] end) (Int32) module Listings = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["listings"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["listings"] end)) (Make_index(Signature.Public_key_hash)) (Int32) module Proposals = Make_data_set_storage - (Make_subcontext(Raw_context)(struct let name = ["proposals"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["proposals"] end)) (Pair(Make_index(Protocol_hash))(Make_index(Signature.Public_key_hash))) module Proposals_count = Make_indexed_data_storage - (Make_subcontext(Raw_context) + (Make_subcontext(Registered)(Raw_context) (struct let name = ["proposals_count"] end)) (Make_index(Signature.Public_key_hash)) (Int) module Ballots = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["ballots"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["ballots"] end)) (Make_index(Signature.Public_key_hash)) (struct type t = Vote_repr.ballot @@ -580,7 +720,7 @@ end module Commitments = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["commitments"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["commitments"] end)) (Make_index(Blinded_public_key_hash.Index)) (Tez_repr) @@ -590,7 +730,7 @@ module Ramp_up = struct module Rewards = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "rewards"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["ramp_up"; "rewards"] end)) (Make_index(Cycle_repr.Index)) (struct type t = Tez_repr.t * Tez_repr.t @@ -599,7 +739,7 @@ module Ramp_up = struct module Security_deposits = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "deposits"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["ramp_up"; "deposits"] end)) (Make_index(Cycle_repr.Index)) (struct type t = Tez_repr.t * Tez_repr.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/storage.mli index 2e7f0b094..1d7c887d5 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage.mli @@ -36,12 +36,17 @@ open Storage_sigs -module Last_block_priority : sig +module Block_priority : sig val get : Raw_context.t -> int tzresult Lwt.t val set : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t val init : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t end +(* Only for migration from 004 *) +module Last_block_priority : sig + val delete : Raw_context.t -> Raw_context.t tzresult Lwt.t +end + module Roll : sig (** Storage from this submodule must only be accessed through the @@ -152,7 +157,13 @@ module Contract : sig and type value = Signature.Public_key_hash.t and type t := Raw_context.t + (** All contracts (implicit and originated) that are delegated, if any *) module Delegated : Data_set_storage + with type elt = Contract_repr.t + and type t = Raw_context.t * Contract_repr.t + + (** Only for migration from proto_004 *) + module Delegated_004 : Data_set_storage with type elt = Contract_hash.t and type t = Raw_context.t * Contract_repr.t @@ -166,11 +177,11 @@ module Contract : sig and type value = Cycle_repr.t and type t := Raw_context.t - module Spendable : Data_set_storage + module Spendable_004 : Data_set_storage with type elt = Contract_repr.t and type t := Raw_context.t - module Delegatable : Data_set_storage + module Delegatable_004 : Data_set_storage with type elt = Contract_repr.t and type t := Raw_context.t @@ -179,15 +190,39 @@ module Contract : sig and type value = Z.t and type t := Raw_context.t - module Code : Non_iterable_indexed_carbonated_data_storage - with type key = Contract_repr.t - and type value = Script_repr.lazy_expr - and type t := Raw_context.t + module Code : sig + include Non_iterable_indexed_carbonated_data_storage + with type key = Contract_repr.t + and type value = Script_repr.lazy_expr + and type t := Raw_context.t - module Storage : Non_iterable_indexed_carbonated_data_storage - with type key = Contract_repr.t - and type value = Script_repr.lazy_expr - and type t := Raw_context.t + (** Only used for 005 migration to avoid gas cost. + Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. *) + val init_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t + + (** Only used for 005 migration to avoid gas cost. + Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. *) + val set_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t + end + + module Storage : sig + include Non_iterable_indexed_carbonated_data_storage + with type key = Contract_repr.t + and type value = Script_repr.lazy_expr + and type t := Raw_context.t + + (** Only used for 005 migration to avoid gas cost. + Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. *) + val init_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t + + (** Only used for 005 migration to avoid gas cost. + Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. *) + val set_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t + end (** Current storage space in bytes. Includes code, global storage and big map elements. *) @@ -202,12 +237,50 @@ module Contract : sig and type value = Z.t and type t := Raw_context.t - type bigmap_key = Raw_context.t * Contract_repr.t +end - module Big_map : Non_iterable_indexed_carbonated_data_storage +module Big_map : sig + + module Next : sig + val incr : Raw_context.t -> (Raw_context.t * Z.t) tzresult Lwt.t + val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + end + + (** The domain of alive big maps *) + val fold : + Raw_context.t -> + init:'a -> f:(Z.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val list : Raw_context.t -> Z.t list Lwt.t + + val remove_rec : Raw_context.t -> Z.t -> Raw_context.t Lwt.t + + val copy : Raw_context.t -> from:Z.t -> to_:Z.t -> Raw_context.t tzresult Lwt.t + + type key = Raw_context.t * Z.t + + val rpc_arg : Z.t RPC_arg.t + + module Index : Storage_description.INDEX with type t = Z.t + + module Contents : Non_iterable_indexed_carbonated_data_storage with type key = Script_expr_hash.t and type value = Script_repr.expr - and type t := bigmap_key + and type t := key + + module Total_bytes : Indexed_data_storage + with type key = Z.t + and type value = Z.t + and type t := Raw_context.t + + module Key_type : Indexed_data_storage + with type key = Z.t + and type value = Script_repr.expr + and type t := Raw_context.t + + module Value_type : Indexed_data_storage + with type key = Z.t + and type value = Script_repr.expr + and type t := Raw_context.t end @@ -234,8 +307,14 @@ module Vote : sig with type value = Voting_period_repr.kind and type t := Raw_context.t - (** Expected quorum, in centile of percentage *) - module Current_quorum : Single_data_storage + (** Only for migration from 004. + Expected quorum, in centile of percentage *) + module Current_quorum_004 : Single_data_storage + with type value = int32 + and type t := Raw_context.t + + (** Participation exponential moving average, in centile of percentage *) + module Participation_ema : Single_data_storage with type value = int32 and type t := Raw_context.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml index 96aef4fea..7fa1c1dbb 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml @@ -285,7 +285,7 @@ let build_directory : type key. key t -> key RPC_directory.t = else if Compare.Int.(i = 0) then return_some [] else list k >>=? fun keys -> - map_p + map_s (fun key -> if Compare.Int.(i = 1) then return (key, None) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml index 0fdfbc06b..54c3dbbdb 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml @@ -25,10 +25,13 @@ open Storage_sigs +module Registered = struct let ghost = false end +module Ghost = struct let ghost = true end + module Make_encoder (V : VALUE) = struct let of_bytes ~key b = match Data_encoding.Binary.of_bytes V.encoding b with - | None -> Error [Raw_context.Storage_error (Corrupted_data key)] + | None -> error (Raw_context.Storage_error (Corrupted_data key)) | Some v -> Ok v let to_bytes v = match Data_encoding.Binary.to_bytes V.encoding v with @@ -54,7 +57,7 @@ let map_key f = function | `Key k -> `Key (f k) | `Dir k -> `Dir (f k) -module Make_subcontext (C : Raw_context.T) (N : NAME) +module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : Raw_context.T with type t = C.t = struct type t = C.t type context = t @@ -84,10 +87,12 @@ module Make_subcontext (C : Raw_context.T) (N : NAME) let consume_gas = C.consume_gas let check_enough_gas = C.check_enough_gas let description = - Storage_description.register_named_subcontext C.description N.name + let description = if R.ghost then Storage_description.create () + else C.description in + Storage_description.register_named_subcontext description N.name end -module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE) +module Make_single_data_storage (R : REGISTER) (C : Raw_context.T) (N : NAME) (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t = struct type t = C.t @@ -129,9 +134,11 @@ module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE) let () = let open Storage_description in + let description = if R.ghost then Storage_description.create () + else C.description in register_value ~get:get_option - (register_named_subcontext C.description N.name) + (register_named_subcontext description N.name) V.encoding end @@ -329,76 +336,76 @@ module Make_indexed_carbonated_data_storage type key = I.t type value = V.t include Make_encoder(V) - let name i = + let data_key i = I.to_path i [data_name] - let len_name i = + let len_key i = I.to_path i [len_name] let consume_mem_gas c = Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) let existing_size c i = - C.get_option c (len_name i) >>= function - | None -> return 0 - | Some len -> decode_len_value (len_name i) len + C.get_option c (len_key i) >>= function + | None -> return (0, false) + | Some len -> decode_len_value (len_key i) len >>=? fun len -> return (len, true) let consume_read_gas get c i = - get c (len_name i) >>=? fun len -> - decode_len_value (len_name i) len >>=? fun len -> + get c (len_key i) >>=? fun len -> + decode_len_value (len_key i) len >>=? fun len -> Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len))) let consume_serialize_write_gas set c i v = let bytes = to_bytes v in let len = MBytes.length bytes in Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len)) >>=? fun c -> Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len))) >>=? fun c -> - set c (len_name i) (encode_len_value bytes) >>=? fun c -> + set c (len_key i) (encode_len_value bytes) >>=? fun c -> return (c, bytes) let consume_remove_gas del c i = Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) >>=? fun c -> - del c (len_name i) + del c (len_key i) let mem s i = consume_mem_gas s >>=? fun s -> - C.mem s (name i) >>= fun exists -> + C.mem s (data_key i) >>= fun exists -> return (C.project s, exists) let get s i = consume_read_gas C.get s i >>=? fun s -> - C.get s (name i) >>=? fun b -> - let key = C.absolute_key s (name i) in + C.get s (data_key i) >>=? fun b -> + let key = C.absolute_key s (data_key i) in Lwt.return (of_bytes ~key b) >>=? fun v -> return (C.project s, v) let get_option s i = consume_mem_gas s >>=? fun s -> - C.mem s (name i) >>= fun exists -> + C.mem s (data_key i) >>= fun exists -> if exists then get s i >>=? fun (s, v) -> return (s, Some v) else return (C.project s, None) let set s i v = - existing_size s i >>=? fun prev_size -> + existing_size s i >>=? fun (prev_size, _) -> consume_serialize_write_gas C.set s i v >>=? fun (s, bytes) -> - C.set s (name i) bytes >>=? fun t -> + C.set s (data_key i) bytes >>=? fun t -> let size_diff = MBytes.length bytes - prev_size in return (C.project t, size_diff) let init s i v = consume_serialize_write_gas C.init s i v >>=? fun (s, bytes) -> - C.init s (name i) bytes >>=? fun t -> + C.init s (data_key i) bytes >>=? fun t -> let size = MBytes.length bytes in return (C.project t, size) let init_set s i v = let init_set s i v = C.init_set s i v >>= return in - existing_size s i >>=? fun prev_size -> + existing_size s i >>=? fun (prev_size, existed) -> consume_serialize_write_gas init_set s i v >>=? fun (s, bytes) -> - init_set s (name i) bytes >>=? fun t -> + init_set s (data_key i) bytes >>=? fun t -> let size_diff = MBytes.length bytes - prev_size in - return (C.project t, size_diff) + return (C.project t, size_diff, existed) let remove s i = let remove s i = C.remove s i >>= return in - existing_size s i >>=? fun prev_size -> + existing_size s i >>=? fun (prev_size, existed) -> consume_remove_gas remove s i >>=? fun s -> - remove s (name i) >>=? fun t -> - return (C.project t, prev_size) + remove s (data_key i) >>=? fun t -> + return (C.project t, prev_size, existed) let delete s i = - existing_size s i >>=? fun prev_size -> + existing_size s i >>=? fun (prev_size, _) -> consume_remove_gas C.delete s i >>=? fun s -> - C.delete s (name i) >>=? fun t -> + C.delete s (data_key i) >>=? fun t -> return (C.project t, prev_size) let set_option s i v = match v with @@ -407,14 +414,21 @@ module Make_indexed_carbonated_data_storage let fold_keys_unaccounted s ~init ~f = let rec dig i path acc = - if Compare.Int.(i <= 1) then + if Compare.Int.(i <= 0) then C.fold s path ~init:acc ~f:begin fun k acc -> match k with | `Dir _ -> Lwt.return acc | `Key file -> - match I.of_path file with - | None -> assert false - | Some path -> f path acc + match List.rev file with + | last :: _ when Compare.String.(last = len_name) -> + Lwt.return acc + | last :: rest when Compare.String.(last = data_name) -> + let file = List.rev rest in + begin match I.of_path file with + | None -> assert false + | Some path -> f path acc + end + | _ -> assert false end else C.fold s path ~init:acc ~f:begin fun k acc -> @@ -422,7 +436,7 @@ module Make_indexed_carbonated_data_storage | `Dir k -> dig (i-1) k acc | `Key _ -> Lwt.return acc end in - dig I.path_length [data_name] init + dig I.path_length [] init let keys_unaccounted s = fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) @@ -455,8 +469,8 @@ module Make_indexed_data_snapshotable_storage (C : Raw_context.T) let data_name = ["current"] let snapshot_name = ["snapshot"] - module C_data = Make_subcontext(C)(struct let name = data_name end) - module C_snapshot = Make_subcontext(C)(struct let name = snapshot_name end) + module C_data = Make_subcontext(Registered)(C)(struct let name = data_name end) + module C_snapshot = Make_subcontext(Registered)(C)(struct let name = snapshot_name end) include Make_indexed_data_storage(C_data)(I) (V) module Snapshot = Make_indexed_data_storage(C_snapshot)(Pair(Snapshot_index)(I))(V) @@ -510,6 +524,12 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) + let remove_rec t k = + C.remove_rec t (I.to_path k []) + + let copy t ~from ~to_ = + C.copy t ~from:(I.to_path from []) ~to_:(I.to_path to_ []) + let description = Storage_description.register_indexed_subcontext ~list:(fun c -> keys c >>= return) @@ -587,13 +607,13 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) end | [] -> list t prefix >>= fun prefixes -> - Lwt_list.map_p (function + Lwt_list.map_s (function | `Key prefix | `Dir prefix -> loop (i+1) prefix []) prefixes >|= List.flatten | [d] when Compare.Int.(i = I.path_length - 1) -> if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; list t prefix >>= fun prefixes -> - Lwt_list.map_p (function + Lwt_list.map_s (function | `Key prefix | `Dir prefix -> match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with | None -> Lwt.return_nil @@ -602,7 +622,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) >|= List.flatten | "" :: ds -> list t prefix >>= fun prefixes -> - Lwt_list.map_p (function + Lwt_list.map_s (function | `Key prefix | `Dir prefix -> loop (i+1) prefix ds) prefixes >|= List.flatten | d :: ds -> @@ -612,7 +632,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) | false -> Lwt.return_nil in loop 0 [] prefix - module Make_set (N : NAME) = struct + module Make_set (R : REGISTER) (N : NAME) = struct type t = C.t type context = t type elt = I.t @@ -650,13 +670,15 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) let () = let open Storage_description in let unpack = unpack I.args in + let description = if R.ghost then Storage_description.create () + else Raw_context.description in register_value ~get:(fun c -> let (c, k) = unpack c in mem c k >>= function | true -> return_some true | false -> return_none) - (register_named_subcontext Raw_context.description N.name) + (register_named_subcontext description N.name) Data_encoding.bool end @@ -755,8 +777,8 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) let existing_size c = Raw_context.get_option c len_name >>= function - | None -> return 0 - | Some len -> decode_len_value len_name len + | None -> return (0, false) + | Some len -> decode_len_value len_name len >>=? fun len -> return (len, true) let consume_read_gas get c = get c (len_name) >>=? fun len -> decode_len_value len_name len >>=? fun len -> @@ -790,31 +812,46 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) else return (C.project s, None) let set s i v = - existing_size (pack s i) >>=? fun prev_size -> + existing_size (pack s i) >>=? fun (prev_size, _) -> consume_write_gas Raw_context.set (pack s i) v >>=? fun (c, bytes) -> Raw_context.set c data_name bytes >>=? fun c -> let size_diff = MBytes.length bytes - prev_size in return (Raw_context.project c, size_diff) + let set_free s i v = + let c = pack s i in + let bytes = to_bytes v in + existing_size c >>=? fun (prev_size, _) -> + Raw_context.set c len_name (encode_len_value bytes) >>=? fun c -> + Raw_context.set c data_name bytes >>=? fun c -> + let size_diff = MBytes.length bytes - prev_size in + return (Raw_context.project c, size_diff) let init s i v = consume_write_gas Raw_context.init (pack s i) v >>=? fun (c, bytes) -> Raw_context.init c data_name bytes >>=? fun c -> let size = MBytes.length bytes in return (Raw_context.project c, size) + let init_free s i v = + let c = pack s i in + let bytes = to_bytes v in + let size = MBytes.length bytes in + Raw_context.init c len_name (encode_len_value bytes) >>=? fun c -> + Raw_context.init c data_name bytes >>=? fun c -> + return (Raw_context.project c, size) let init_set s i v = let init_set c k v = Raw_context.init_set c k v >>= return in - existing_size (pack s i) >>=? fun prev_size -> + existing_size (pack s i) >>=? fun (prev_size, existed) -> consume_write_gas init_set (pack s i) v >>=? fun (c, bytes) -> init_set c data_name bytes >>=? fun c -> let size_diff = MBytes.length bytes - prev_size in - return (Raw_context.project c, size_diff) + return (Raw_context.project c, size_diff, existed) let remove s i = let remove c k = Raw_context.remove c k >>= return in - existing_size (pack s i) >>=? fun prev_size -> + existing_size (pack s i) >>=? fun (prev_size, existed) -> consume_remove_gas remove (pack s i) >>=? fun c -> remove c data_name >>=? fun c -> - return (Raw_context.project c, prev_size) + return (Raw_context.project c, prev_size, existed) let delete s i = - existing_size (pack s i) >>=? fun prev_size -> + existing_size (pack s i) >>=? fun (prev_size, _) -> consume_remove_gas Raw_context.delete (pack s i) >>=? fun c -> Raw_context.delete c data_name >>=? fun c -> return (Raw_context.project c, prev_size) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli index 83452908c..6217cb9c0 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli @@ -27,11 +27,14 @@ open Storage_sigs -module Make_subcontext (C : Raw_context.T) (N : NAME) +module Registered : REGISTER +module Ghost : REGISTER + +module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : Raw_context.T with type t = C.t module Make_single_data_storage - (C : Raw_context.T) (N : NAME) (V : VALUE) + (R : REGISTER) (C : Raw_context.T) (N : NAME) (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml index 2831aaf71..a637af706 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(** {1 Entity Accessor Signatures} ****************************************) +(** {1 Entity Accessor Signatures} *) (** The generic signature of a single data accessor (a single value bound to a specific key in the hierarchical (key x value) @@ -118,16 +118,18 @@ module type Single_carbonated_data_storage = sig (** Allocates the data and initializes it with a value ; just updates it if the bucket exists. Consumes [Gas_repr.write_bytes_cost ]. - Returns the difference from the old (maybe 0) to the new size. *) - val init_set: context -> value -> (Raw_context.t * int) tzresult Lwt.t + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val init_set: context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t (** When the value is [Some v], allocates the data and initializes it with [v] ; just updates it if the bucket exists. When the valus is [None], delete the storage bucket when the value ; does nothing if the bucket does not exists. Consumes the same gas cost as either {!remove} or {!init_set}. - Returns the difference from the old (maybe 0) to the new size. *) - val set_option: context -> value option -> (Raw_context.t * int) tzresult Lwt.t + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val set_option: context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t (** Delete the storage bucket ; returns a {!Storage_error Missing_key} if the bucket does not exists. @@ -138,8 +140,9 @@ module type Single_carbonated_data_storage = sig (** Removes the storage bucket and its contents ; does nothing if the bucket does not exists. Consumes [Gas_repr.write_bytes_cost Z.zero]. - Returns the freed size. *) - val remove: context -> (Raw_context.t * int) tzresult Lwt.t + Returns the freed size, and a boolean + indicating if a value was already associated to this key. *) + val remove: context -> (Raw_context.t * int * bool) tzresult Lwt.t end @@ -245,8 +248,9 @@ module type Non_iterable_indexed_carbonated_data_storage = sig with a value ; just updates it if the bucket exists. Consumes serialization cost. Consumes [Gas_repr.write_bytes_cost ]. - Returns the difference from the old (maybe 0) to the new size. *) - val init_set: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val init_set: context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t (** When the value is [Some v], allocates the data and initializes it with [v] ; just updates it if the bucket exists. When the @@ -254,8 +258,9 @@ module type Non_iterable_indexed_carbonated_data_storage = sig nothing if the bucket does not exists. Consumes serialization cost. Consumes the same gas cost as either {!remove} or {!init_set}. - Returns the difference from the old (maybe 0) to the new size. *) - val set_option: context -> key -> value option -> (Raw_context.t * int) tzresult Lwt.t + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val set_option: context -> key -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t (** Delete a storage bucket and its contents ; returns a {!Storage_error Missing_key} if the bucket does not exists. @@ -266,8 +271,9 @@ module type Non_iterable_indexed_carbonated_data_storage = sig (** Removes a storage bucket and its contents ; does nothing if the bucket does not exists. Consumes [Gas_repr.write_bytes_cost Z.zero]. - Returns the freed size. *) - val remove: context -> key -> (Raw_context.t * int) tzresult Lwt.t + Returns the freed size, and a boolean + indicating if a value was already associated to this key. *) + val remove: context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t end @@ -358,6 +364,22 @@ module type VALUE = sig val encoding: t Data_encoding.t end +module type REGISTER = sig val ghost : bool end + +module type Non_iterable_indexed_carbonated_data_storage_with_free = sig + include Non_iterable_indexed_carbonated_data_storage + + (** Only used for 005 migration to avoid gas cost. + Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. *) + val init_free: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Only used for 005 migration to avoid gas cost. + Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. *) + val set_free: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t +end + module type Indexed_raw_context = sig type t @@ -373,7 +395,12 @@ module type Indexed_raw_context = sig val resolve: context -> string list -> key list Lwt.t - module Make_set (N : NAME) + val remove_rec: context -> key -> context Lwt.t + + val copy: context -> from:key -> to_:key -> context tzresult Lwt.t + + module Make_set (R : REGISTER) (N : NAME) + : Data_set_storage with type t = t and type elt = key @@ -383,7 +410,7 @@ module type Indexed_raw_context = sig and type value = V.t module Make_carbonated_map (N : NAME) (V : VALUE) - : Non_iterable_indexed_carbonated_data_storage with type t = t + : Non_iterable_indexed_carbonated_data_storage_with_free with type t = t and type key = key and type value = V.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/activation.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/activation.ml new file mode 100644 index 000000000..2078e9602 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/activation.ml @@ -0,0 +1,371 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** The activation operation creates an implicit contract from a + registered commitment present in the context. It is parametrized by + a public key hash (pkh) and a secret. + + The commitments are composed of : + - a blinded pkh that can be revealed by the secret ; + - an amount. + + The commitments and the secrets are generated from + /scripts/create_genesis/create_genenis.py and should be coherent. +*) + +open Protocol +open Alpha_context +open Test_utils +open Test_tez + +(* Generated commitments and secrets *) + +(* Commitments are hard-coded in {Tezos_proto_alpha_parameters.Default_parameters} *) + +(* let commitments = + * List.map (fun (bpkh, a) -> + * Commitment_repr.{ + * blinded_public_key_hash=Blinded_public_key_hash.of_b58check_exn bpkh ; + * amount = Tez_repr.of_mutez_exn (Int64.of_string a)} + * ) + * [ ( "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ) ; + * ( "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ) ; + * ( "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428349" ) ; + * ( "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ) ; + * ( "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ) ; + * ( "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ) ; + * ( "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ) ; + * ( "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ) ; + * ( "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ) ; + * ( "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ) ; + * ] *) + +type secret_account = { + account : public_key_hash ; + activation_code : Blinded_public_key_hash.activation_code ; + amount : Tez.t ; +} + +let secrets () = + (* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *) + let read_key mnemonic email password = + match Bip39.of_words mnemonic with + | None -> assert false + | Some t -> + (* TODO: unicode normalization (NFKD)... *) + let passphrase = MBytes.(concat "" [ + of_string email ; + of_string password ; + ]) in + let sk = Bip39.to_seed ~passphrase t in + let sk = MBytes.sub sk 0 32 in + let sk : Signature.Secret_key.t = + Ed25519 (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk) in + let pk = Signature.Secret_key.to_public_key sk in + let pkh = Signature.Public_key.hash pk in + (pkh, pk, sk) + in + List.map (fun (mnemonic, secret, amount, pkh, password, email) -> + 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 + Account.add_account account ; + { account = account.pkh ; + activation_code = Blinded_public_key_hash.activation_code_of_hex secret ; + amount = Option.unopt_exn (Invalid_argument "tez conversion") + (Tez.of_mutez (Int64.of_string amount)) + }) + [ + (["envelope"; "hospital"; "mind"; "sunset"; "cancel"; "muscle"; "leisure"; + "thumb"; "wine"; "market"; "exit"; "lucky"; "style"; "picnic"; "success"], + "0f39ed0b656509c2ecec4771712d9cddefe2afac", + "23932454669343", + "tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF", + "z0eZHQQGKt", + "cjgfoqmk.wpxnvnup@tezos.example.org" + ); + (["flag"; "quote"; "will"; "valley"; "mouse"; "chat"; "hold"; "prosper"; + "silk"; "tent"; "cruel"; "cause"; "demise"; "bottom"; "practice"], + "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4", + "72954577464032", + "tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX", + "MHErskWPE6", + "oklmcktr.ztljnpzc@tezos.example.org" + ); + (["library"; "away"; "inside"; "paper"; "wise"; "focus"; "sweet"; "expose"; + "require"; "change"; "stove"; "planet"; "zone"; "reflect"; "finger"], + "411dfef031eeecc506de71c9df9f8e44297cf5ba", + "217487035428348", + "tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc", + "0AO6BzQNfN", + "ctgnkvqm.kvtiybky@tezos.example.org" + ); + (["cruel"; "fluid"; "damage"; "demand"; "mimic"; "above"; "village"; "alpha"; + "vendor"; "staff"; "absent"; "uniform"; "fire"; "asthma"; "milk"], + "08d7d355bc3391d12d140780b39717d9f46fcf87", + "4092742372031", + "tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS", + "9kbZ7fR6im", + "bnyxxzqr.tdszcvqb@tezos.example.org" + ) ; + (["opera"; "divorce"; "easy"; "myself"; "idea"; "aim"; "dash"; "scout"; + "case"; "resource"; "vote"; "humor"; "ticket"; "client"; "edge"], + "9b7cad042fba557618bdc4b62837c5f125b50e56", + "17590039016550", + "tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM", + "suxT5H09yY", + "iilkhohu.otnyuvna@tezos.example.org" + ) ; + (["token"; "similar"; "ginger"; "tongue"; "gun"; "sort"; "piano"; "month"; + "hotel"; "vote"; "undo"; "success"; "hobby"; "shell"; "cart"], + "124c0ca217f11ffc6c7b76a743d867c8932e5afd", + "26322312350555", + "tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU", + "4odVdLykaa", + "kwhlglvr.slriitzy@tezos.example.org" + ) ; + (["shield"; "warrior"; "gorilla"; "birth"; "steak"; "neither"; "feel"; + "only"; "liberty"; "float"; "oven"; "extend"; "pulse"; "suffer"; "vapor"], + "ac7a2125beea68caf5266a647f24dce9fea018a7", + "244951387881443", + "tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur", + "A6yeMqBFG8", + "lvrmlbyj.yczltcxn@tezos.example.org" + ) ; + (["waste"; "open"; "scan"; "tip"; "subway"; "dance"; "rent"; "copper"; + "garlic"; "laundry"; "defense"; "clerk"; "another"; "staff"; "liar"], + "2b3e94be133a960fa0ef87f6c0922c19f9d87ca2", + "80065050465525", + "tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs", + "oVZqpq60sk", + "rfodmrha.zzdndvyk@tezos.example.org" + ) ; + (["fiber"; "next"; "property"; "cradle"; "silk"; "obey"; "gossip"; + "push"; "key"; "second"; "across"; "minimum"; "nice"; "boil"; "age"], + "dac31640199f2babc157aadc0021cd71128ca9ea", + "3569618927693", + "tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX", + "FfytQTTVbu", + "owecikdy.gxnyttya@tezos.example.org" + ) ; + (["print"; "labor"; "budget"; "speak"; "poem"; "diet"; "chunk"; "eternal"; + "book"; "saddle"; "pioneer"; "ankle"; "happy"; "only"; "exclude"], + "bb841227f250a066eb8429e56937ad504d7b34dd", + "9034781424478", + "tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u", + "zknAl3lrX2", + "ettilrvh.zsrqrbud@tezos.example.org" + ) ; + ] + +let activation_init () = + Context.init ~with_commitments:true 1 >>=? fun (b, cs) -> + secrets () |> fun ss -> + return (b, cs, ss) + +let simple_init_with_commitments () = + activation_init () >>=? fun (blk, _contracts, _secrets) -> + Block.bake blk >>=? fun _ -> + return_unit + +(** A single activation *) +let single_activation () = + activation_init () >>=? fun (blk, _contracts, secrets) -> + let { account ; activation_code ; amount=expected_amount ; _ } as _first_one = List.hd secrets in + + (* Contract does not exist *) + Assert.balance_is ~loc:__LOC__ (B blk) (Contract.implicit_contract account) Tez.zero >>=? fun () -> + + Op.activation (B blk) account activation_code >>=? fun operation -> + Block.bake ~operation blk >>=? fun blk -> + + (* Contract does exist *) + Assert.balance_is ~loc:__LOC__ (B blk) (Contract.implicit_contract account) expected_amount + +(** 10 activations, one per bake *) +let multi_activation_1 () = + activation_init () >>=? fun (blk, _contracts, secrets) -> + + Error_monad.fold_left_s (fun blk { account ; activation_code ; amount = expected_amount ; _ } -> + Op.activation (B blk) account activation_code >>=? fun operation -> + Block.bake ~operation blk >>=? fun blk -> + + Assert.balance_is ~loc:__LOC__ (B blk) (Contract.implicit_contract account) expected_amount >>=? fun () -> + + return blk + ) blk secrets >>=? fun _ -> + return_unit + +(** All in one bake *) +let multi_activation_2 () = + activation_init () >>=? fun (blk, _contracts, secrets) -> + + Error_monad.fold_left_s (fun ops { account ; activation_code ; _ } -> + Op.activation (B blk) account activation_code >>=? fun op -> + return (op::ops) + ) [] secrets >>=? fun ops -> + + Block.bake ~operations:ops blk >>=? fun blk -> + + Error_monad.iter_s (fun { account ; amount = expected_amount ; _ } -> + (* Contract does exist *) + Assert.balance_is ~loc:__LOC__ (B blk) (Contract.implicit_contract account) expected_amount + ) secrets + +(** Transfer with activated account *) +let activation_and_transfer () = + activation_init () >>=? fun (blk, contracts, secrets) -> + let { account ; activation_code ; _ } as _first_one = List.hd secrets in + let bootstrap_contract = List.hd contracts in + let first_contract = Contract.implicit_contract account in + + Op.activation (B blk) account activation_code >>=? fun operation -> + Block.bake ~operation blk >>=? fun blk -> + + Context.Contract.balance (B blk) bootstrap_contract >>=? fun amount -> + Tez.(/?) amount 2L >>?= fun half_amount -> + Context.Contract.balance (B blk) first_contract >>=? fun activated_amount_before -> + + Op.transaction (B blk) bootstrap_contract first_contract half_amount >>=? fun operation -> + Block.bake ~operation blk >>=? fun blk -> + + Assert.balance_was_credited ~loc:__LOC__ (B blk) (Contract.implicit_contract account) activated_amount_before half_amount + +(** Transfer to an unactivated account and then activating it *) +let transfer_to_unactivated_then_activate () = + activation_init () >>=? fun (blk, contracts, secrets) -> + let { account ; activation_code ; amount } as _first_one = List.hd secrets in + let bootstrap_contract = List.hd contracts in + let unactivated_commitment_contract = Contract.implicit_contract account in + + Context.Contract.balance (B blk) bootstrap_contract >>=? fun b_amount -> + Tez.(/?) b_amount 2L >>?= fun b_half_amount -> + + Incremental.begin_construction blk >>=? fun inc -> + Op.transaction (I inc) bootstrap_contract unactivated_commitment_contract b_half_amount >>=? fun op -> + Incremental.add_operation inc op >>=? fun inc -> + Op.activation (I inc) account activation_code >>=? fun op' -> + Incremental.add_operation inc op' >>=? fun inc -> + Incremental.finalize_block inc >>=? fun blk2 -> + + Assert.balance_was_credited ~loc:__LOC__ (B blk2) (Contract.implicit_contract account) amount b_half_amount + +(****************************************************************) +(* The following test scenarios are supposed to raise errors. *) +(****************************************************************) + +(** Invalid pkh activation : expected to fail as the context does not + contain any commitment *) +let invalid_activation_with_no_commitments () = + Context.init 1 >>=? fun (blk, _) -> + let secrets = secrets () in + let { account ; activation_code ; _ } as _first_one = List.hd secrets in + + Op.activation (B blk) account activation_code >>=? fun operation -> + Block.bake ~operation blk >>= fun res -> + + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Invalid_activation _ -> true + | _ -> false + end + +(** Wrong activation : wrong secret given in the operation *) +let invalid_activation_wrong_secret () = + activation_init () >>=? fun (blk, _, secrets) -> + let { account ; _ } as _first_one = List.nth secrets 0 in + let { activation_code ; _ } as _second_one = List.nth secrets 1 in + + Op.activation (B blk) account activation_code >>=? fun operation -> + Block.bake ~operation blk >>= fun res -> + + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Invalid_activation _ -> true + | _ -> false + end + +(** Invalid pkh activation : expected to fail as the context does not + contain an associated commitment *) +let invalid_activation_inexistent_pkh () = + activation_init () >>=? fun (blk, _, secrets) -> + let { activation_code ; _ } as _first_one = List.hd secrets in + let inexistent_pkh = Signature.Public_key_hash.of_b58check_exn + "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" in + + Op.activation (B blk) inexistent_pkh activation_code >>=? fun operation -> + Block.bake ~operation blk >>= fun res -> + + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Invalid_activation _ -> true + | _ -> false + end + +(** Invalid pkh activation : expected to fail as the commitment has + already been claimed *) +let invalid_double_activation () = + activation_init () >>=? fun (blk, _, secrets) -> + let { account ; activation_code ; _ } as _first_one = List.hd secrets in + Incremental.begin_construction blk >>=? fun inc -> + + Op.activation (I inc) account activation_code >>=? fun op -> + Incremental.add_operation inc op >>=? fun inc -> + Op.activation (I inc) account activation_code >>=? fun op' -> + Incremental.add_operation inc op' >>= fun res -> + + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Invalid_activation _ -> true + | _ -> false + end + +(** Transfer from an unactivated commitment account *) +let invalid_transfer_from_unactived_account () = + activation_init () >>=? fun (blk, contracts, secrets) -> + let { account ; _ } as _first_one = List.hd secrets in + let bootstrap_contract = List.hd contracts in + let unactivated_commitment_contract = Contract.implicit_contract account in + + (* No activation *) + + Op.transaction (B blk) unactivated_commitment_contract bootstrap_contract Tez.one >>=? fun operation -> + Block.bake ~operation blk >>= fun res -> + + Assert.proto_error ~loc:__LOC__ res begin function + | Contract_storage.Empty_implicit_contract pkh -> if pkh = account then true else false + | _ -> false + end + +let tests = [ + Test.tztest "init with commitments" `Quick simple_init_with_commitments ; + Test.tztest "single activation" `Quick single_activation ; + Test.tztest "multi-activation one-by-one" `Quick multi_activation_1 ; + Test.tztest "multi-activation all at a time" `Quick multi_activation_2 ; + Test.tztest "activation and transfer" `Quick activation_and_transfer ; + Test.tztest "transfer to unactivated account then activate" `Quick transfer_to_unactivated_then_activate ; + Test.tztest "invalid activation with no commitments" `Quick invalid_activation_with_no_commitments ; + Test.tztest "invalid activation with commitments" `Quick invalid_activation_inexistent_pkh ; + Test.tztest "invalid double activation" `Quick invalid_double_activation ; + Test.tztest "wrong activation code" `Quick invalid_activation_wrong_secret ; + Test.tztest "invalid transfer from unactivated account" `Quick invalid_transfer_from_unactived_account +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/baking.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/baking.ml new file mode 100644 index 000000000..053b29779 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/baking.ml @@ -0,0 +1,98 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Test_utils + +(** Tests for [bake_n] and [bake_until_end_cycle]. *) +let test_cycle () = + Context.init 5 >>=? fun (b,_) -> + Context.get_constants (B b) >>=? fun csts -> + let blocks_per_cycle = csts.parametric.blocks_per_cycle in + + let pp = fun fmt x -> Format.fprintf fmt "%ld" x in + + (* Tests that [bake_until_cycle_end] returns a block at + level [blocks_per_cycle]. *) + Block.bake b >>=? fun b -> + Block.bake_until_cycle_end b >>=? fun b -> + Context.get_level (B b) >>=? fun curr_level -> + Assert.equal ~loc:__LOC__ Int32.equal "not the right level" pp + (Alpha_context.Raw_level.to_int32 curr_level) + blocks_per_cycle >>=? fun () -> + + (* Tests that [bake_n n] bakes [n] blocks. *) + Context.get_level (B b) >>=? fun l -> + Block.bake_n 10 b >>=? fun b -> + Context.get_level (B b) >>=? fun curr_level -> + Assert.equal ~loc:__LOC__ Int32.equal "not the right level" pp + (Alpha_context.Raw_level.to_int32 curr_level) + (Int32.add (Alpha_context.Raw_level.to_int32 l) 10l) + + +(** Tests the formula introduced in Emmy+ for block reward: + (16/(p+1)) * (0.8 + 0.2 * e / 32) + where p is the block priority and + e is the number of included endorsements *) +let test_block_reward priority () = + begin match priority with + | 0 -> Test_tez.Tez.((of_int 128) /? Int64.of_int 10) >>?= fun min -> + return (Test_tez.Tez.of_int 16, min) + | 1 -> Test_tez.Tez.((of_int 64) /? Int64.of_int 10) >>?= fun min -> + return (Test_tez.Tez.of_int 8, min) + | 3 -> Test_tez.Tez.((of_int 32) /? Int64.of_int 10) >>?= fun min -> + return (Test_tez.Tez.of_int 4, min) + | _ -> fail (invalid_arg "prio should be 0, 1, or 3") + end >>=? fun (expected_reward_max_endo, expected_reward_min_endo) -> + let endorsers_per_block = 32 in + Context.init ~endorsers_per_block 32 >>=? fun (b, _) -> + + Context.get_endorsers (B b) >>=? fun endorsers -> + fold_left_s (fun ops (endorser : Alpha_services.Delegate.Endorsing_rights.t) -> + let delegate = endorser.delegate in + Op.endorsement ~delegate (B b) () >>=? fun op -> + return (Operation.pack op :: ops) + ) [] endorsers >>=? fun ops -> + Block.bake + ~policy:(By_priority 0) + ~operations:ops + b >>=? fun b -> + (* bake a block at priority 0 and 32 endorsements; + the reward is 16 tez *) + Context.get_baking_reward (B b) ~priority ~endorsing_power:32 >>=? fun baking_reward -> + Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_max_endo >>=? fun () -> + (* bake a block at priority 0 and 0 endorsements; + the reward is 12.8 tez *) + Context.get_baking_reward (B b) ~priority ~endorsing_power:0 >>=? fun baking_reward -> + Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_min_endo + + +let tests = [ + Test.tztest "cycle" `Quick (test_cycle) ; + Test.tztest "block_reward for priority 0" `Quick (test_block_reward 0) ; + Test.tztest "block_reward for priority 1" `Quick (test_block_reward 1) ; + Test.tztest "block_reward for priority 3" `Quick (test_block_reward 3) ; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/combined_operations.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/combined_operations.ml new file mode 100644 index 000000000..cdbd56c5e --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/combined_operations.ml @@ -0,0 +1,229 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Multiple operations can be grouped in one ensuring their + derministic application. + + If an invalid operation is present in this group of operation, the + previous applied operations are backtracked leaving the context + unchanged and the following operations are skipped. Fees attributed + to the operations are collected by the baker nonetheless. + + Only manager operations are allowed in multiple transactions. + They must all belong to the same manager as there is only one signature. *) + +open Protocol +open Test_tez +open Test_utils + +let ten_tez = Tez.of_int 10 + +(** Groups ten transactions between the same parties. *) +let multiple_transfers () = + Context.init 3 >>=? fun (blk, contracts) -> + let c1 = List.nth contracts 0 in + let c2 = List.nth contracts 1 in + let c3 = List.nth contracts 2 in + + map_s (fun _ -> + Op.transaction (B blk) c1 c2 Tez.one + ) (1--10) >>=? fun ops -> + + Op.combine_operations ~source:c1 (B blk) ops >>=? fun operation -> + + Context.Contract.balance (B blk) c1 >>=? fun c1_old_balance -> + Context.Contract.balance (B blk) c2 >>=? fun c2_old_balance -> + Context.Contract.pkh c3 >>=? fun baker_pkh -> + Block.bake ~policy:(By_account baker_pkh) ~operation blk >>=? fun blk -> + + Assert.balance_was_debited ~loc:__LOC__ + (B blk) c1 c1_old_balance (Tez.of_int 10) >>=? fun () -> + Assert.balance_was_credited ~loc:__LOC__ + (B blk) c2 c2_old_balance (Tez.of_int 10) >>=? fun () -> + return_unit + + +(** Groups ten delegated originations. *) +let multiple_origination_and_delegation () = + Context.init 2 >>=? fun (blk, contracts) -> + let c1 = List.nth contracts 0 in + let c2 = List.nth contracts 1 in + let n = 10 in + Context.get_constants (B blk) >>=? fun { parametric = { origination_size ; cost_per_byte ; _ } ; _ } -> + Context.Contract.pkh c2 >>=? fun delegate_pkh -> + + (* Deploy n smart contracts with dummy scripts from c1 *) + map_s (fun i -> + Op.origination ~delegate:delegate_pkh ~counter:(Z.of_int i) ~fee:Tez.zero ~script:Op.dummy_script + ~credit:(Tez.of_int 10) (B blk) c1 + ) (1--n) >>=? 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 + + Op.combine_operations ~source:c1 (B blk) originations_operations >>=? fun operation -> + + Context.Contract.balance (B blk) c1 >>=? fun c1_old_balance -> + Incremental.begin_construction blk >>=? fun inc -> + Incremental.add_operation inc operation >>=? fun inc -> + + (* To retrieve the originated contracts, it is easier to extract them + from the tickets. Else, we could (could we ?) hash each combined + operation individually. *) + let tickets = Incremental.rev_tickets inc in + let open Apply_results in + let tickets = + List.fold_left (fun acc -> function + | No_operation_metadata -> assert false + | Operation_metadata { contents } -> + to_list (Contents_result_list contents) @ acc + ) [] tickets |> List.rev in + let new_contracts = + List.map (function + | Contents_result + (Manager_operation_result + { operation_result = + Applied (Origination_result { originated_contracts = [ h ] ; _ }) + ; _ }) -> + h + | _ -> assert false + ) tickets in + + (* Previous balance - (Credit (n * 10tz) + Origination cost (n tz)) *) + Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn -> + Tez.(origination_burn *? (Int64.of_int n)) >>?= fun origination_total_cost -> + Lwt.return ( + Tez.( *? ) Op.dummy_script_cost 10L >>? + Tez.( +? ) (Tez.of_int (10 * n)) >>? + Tez.( +? ) origination_total_cost ) >>=? fun total_cost -> + Assert.balance_was_debited ~loc:__LOC__ + (I inc) c1 c1_old_balance total_cost >>=? fun () -> + + iter_s (fun c -> + Assert.balance_is ~loc:__LOC__ (I inc) c (Tez.of_int 10) + ) new_contracts >>=? fun () -> + + return_unit + +let expect_balance_too_low = function + | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ -> + return_unit + | _ -> + failwith "Contract should not have a sufficient balance : operation expected to fail." + +(** Groups three operations, the midlle one failing. + Checks that the receipt is consistent. + Variant without fees. *) +let failing_operation_in_the_middle () = + Context.init 2 >>=? fun (blk, contracts) -> + let c1 = List.nth contracts 0 in + let c2 = List.nth contracts 1 in + + Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op1 -> + Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.max_tez >>=? fun op2 -> + Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op3 -> + let operations = [ op1 ; op2 ; op3 ] in + + Op.combine_operations ~source:c1 (B blk) operations >>=? fun operation -> + + Context.Contract.balance (B blk) c1 >>=? fun c1_old_balance -> + Context.Contract.balance (B blk) c2 >>=? fun c2_old_balance -> + + Incremental.begin_construction blk >>=? fun inc -> + Incremental.add_operation + ~expect_failure:expect_balance_too_low inc operation >>=? fun inc -> + + let tickets = Incremental.rev_tickets inc in + let open Apply_results in + let tickets = + List.fold_left (fun acc -> function + | No_operation_metadata -> assert false + | Operation_metadata { contents } -> + to_list (Contents_result_list contents) @ acc + ) [] tickets in + begin match tickets with + | Contents_result (Manager_operation_result { operation_result = (Backtracked _) ; _ }) :: + Contents_result (Manager_operation_result { operation_result = Failed (_, [ Contract_storage.Balance_too_low _ ]) ; _ }) :: + Contents_result (Manager_operation_result { operation_result = Skipped _ ; _ }) :: + _ -> () + | _ -> assert false + end ; + + Assert.balance_is ~loc:__LOC__ (I inc) c1 c1_old_balance >>=? fun () -> + Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance >>=? fun () -> + + return_unit + +(** Groups three operations, the midlle one failing. + Checks that the receipt is consistent. + Variant with fees, that should be spent even in case of failure. *) +let failing_operation_in_the_middle_with_fees () = + Context.init 2 >>=? fun (blk, contracts) -> + let c1 = List.nth contracts 0 in + let c2 = List.nth contracts 1 in + + Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> + Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.max_tez >>=? fun op2 -> + Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op3 -> + let operations = [ op1 ; op2 ; op3 ] in + + Op.combine_operations ~source:c1 (B blk) operations >>=? fun operation -> + + Context.Contract.balance (B blk) c1 >>=? fun c1_old_balance -> + Context.Contract.balance (B blk) c2 >>=? fun c2_old_balance -> + + Incremental.begin_construction blk >>=? fun inc -> + Incremental.add_operation + ~expect_failure:expect_balance_too_low inc operation >>=? fun inc -> + + let tickets = Incremental.rev_tickets inc in + let open Apply_results in + let tickets = + List.fold_left (fun acc -> function + | No_operation_metadata -> assert false + | Operation_metadata { contents } -> + to_list (Contents_result_list contents) @ acc + ) [] tickets in + begin match tickets with + | Contents_result (Manager_operation_result { operation_result = (Backtracked _) ; _ }) :: + Contents_result (Manager_operation_result { operation_result = Failed (_, [ Contract_storage.Balance_too_low _ ]) ; _ }) :: + Contents_result (Manager_operation_result { operation_result = Skipped _ ; _ }) :: + _ -> () + | _ -> assert false + end ; + + (* In the presence of a failure, all the fees are collected. Even for skipped operations. *) + Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance (Tez.of_int 3) >>=? fun () -> + Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance >>=? fun () -> + + return_unit + +let tests = [ + Test.tztest "multiple transfers" `Quick multiple_transfers ; + Test.tztest "multiple originations and delegations" `Quick multiple_origination_and_delegation ; + Test.tztest "Failing operation in the middle" `Quick failing_operation_in_the_middle ; + Test.tztest "Failing operation in the middle (with fees)" `Quick failing_operation_in_the_middle_with_fees ; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact.tz b/vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact.tz new file mode 100644 index 000000000..445ceca44 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact.tz @@ -0,0 +1,16 @@ +storage nat ; +parameter nat ; +code { UNPAIR ; + DIP { SELF ; ADDRESS ; SOURCE; + IFCMPEQ {} { DROP ; PUSH @storage nat 1 } }; + DUP ; + PUSH nat 1 ; + IFCMPGE + { DROP ; NIL operation ; PAIR } + { PUSH nat 1 ; SWAP ; SUB @parameter ; ISNAT ; + IF_NONE + { NIL operation ; PAIR } + { DUP ; DIP { PUSH nat 1 ; ADD ; MUL @storage } ; SWAP; + DIP { DIP { SELF; PUSH mutez 0 } ; + TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS } ; + SWAP ; PAIR } } } \ No newline at end of file diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact_2.tz b/vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact_2.tz new file mode 100644 index 000000000..5dbcb6167 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact_2.tz @@ -0,0 +1,14 @@ +storage unit ; +parameter (pair nat nat) ; +code { CAR ; UNPAIR ; + DUP ; + PUSH nat 1 ; + IFCMPGE + { DROP ; DROP ; UNIT ; NIL operation ; PAIR } + { PUSH nat 1 ; SWAP ; SUB @parameter ; ISNAT ; + IF_NONE + { DROP ; UNIT ; NIL operation ; PAIR } + { DUP ; DIP { PUSH nat 1 ; ADD ; MUL @storage } ; PAIR ; + DIP { SELF; PUSH tez "0" } ; + TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; + UNIT ; SWAP ; PAIR } } } \ No newline at end of file diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/delegation.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/delegation.ml new file mode 100644 index 000000000..f27d944f2 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/delegation.ml @@ -0,0 +1,1171 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Test_tez +open Test_utils + +(**************************************************************************) +(* bootstrap contracts *) +(**************************************************************************) +(* Bootstrap contracts are heavily used in other tests. It is helpful + to test some properties of these contracts, so we can correctly + interpret the other tests that use them. *) + +let expect_error err = function + | err0 :: _ when err = err0 -> return_unit + | _ -> failwith "Unexpected successful result" + +let expect_alpha_error err = + expect_error (Environment.Ecoproto_error err) + +let expect_no_change_registered_delegate_pkh pkh = function + | Environment.Ecoproto_error (Delegate_storage.No_deletion pkh0) :: _ when pkh0 = pkh -> + return_unit + | _ -> + failwith "Delegate can not be deleted and operation should fail." + +(** bootstrap contracts delegate to themselves *) +let bootstrap_manager_is_bootstrap_delegate () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + let bootstrap0 = List.hd bootstrap_contracts in + Context.Contract.delegate (B b) bootstrap0 >>=? fun delegate0 -> + Context.Contract.manager (B b) bootstrap0 >>=? fun manager0 -> + Assert.equal_pkh ~loc:__LOC__ delegate0 manager0.pkh + +(** bootstrap contracts cannot change their delegate *) +let bootstrap_delegate_cannot_change ~fee () = + Context.init 2 >>=? fun (b, bootstrap_contracts) -> + let bootstrap0 = List.nth bootstrap_contracts 0 in + let bootstrap1 = List.nth bootstrap_contracts 1 in + Context.Contract.pkh bootstrap0 >>=? fun pkh1 -> + Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) >>=? fun i -> + Context.Contract.manager (I i) bootstrap1 >>=? fun manager1 -> + Context.Contract.balance (I i) bootstrap0 >>=? fun balance0 -> + Context.Contract.delegate (I i) bootstrap0 >>=? fun delegate0 -> + (* change delegation to bootstrap1 *) + Op.delegation ~fee (I i) bootstrap0 (Some manager1.pkh) >>=? fun set_delegate -> + if fee > balance0 then + Incremental.add_operation i set_delegate >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + else + Incremental.add_operation + ~expect_failure:(expect_no_change_registered_delegate_pkh delegate0) + i set_delegate >>=? fun i -> + Incremental.finalize_block i >>=? fun b -> + (* bootstrap0 still has same delegate *) + Context.Contract.delegate (B b) bootstrap0 >>=? fun delegate0_after -> + Assert.equal_pkh ~loc:__LOC__ delegate0_after delegate0 >>=? fun () -> + (* fee has been debited *) + Assert.balance_was_debited ~loc:__LOC__ (B b) bootstrap0 balance0 fee + +(** bootstrap contracts cannot delete their delegation *) +let bootstrap_delegate_cannot_be_removed ~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + let bootstrap = List.hd bootstrap_contracts in + Incremental.begin_construction b >>=? fun i -> + Context.Contract.balance (I i) bootstrap >>=? fun balance -> + Context.Contract.delegate (I i) bootstrap >>=? fun delegate -> + Context.Contract.manager (I i) bootstrap >>=? fun manager -> + (* remove delegation *) + Op.delegation ~fee (I i) bootstrap None >>=? fun set_delegate -> + if fee > balance then + Incremental.add_operation i set_delegate >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + else + Incremental.add_operation + ~expect_failure:(expect_no_change_registered_delegate_pkh manager.pkh) + i set_delegate + >>=? fun i -> + (* delegate has not changed *) + Context.Contract.delegate (I i) bootstrap >>=? fun delegate_after -> + Assert.equal_pkh ~loc:__LOC__ delegate delegate_after >>=? fun () -> + (* fee has been debited *) + Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee + +(** contracts not registered as delegate can change their delegation *) +let delegate_can_be_changed_from_unregistered_contract~fee () = + Context.init 2 >>=? fun (b, bootstrap_contracts) -> + let bootstrap0 = List.hd bootstrap_contracts in + let bootstrap1 = List.nth bootstrap_contracts 1 in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let unregistered = Contract.implicit_contract unregistered_pkh in + Incremental.begin_construction b >>=? fun i -> + Context.Contract.manager (I i) bootstrap0 >>=? fun manager0 -> + Context.Contract.manager (I i) bootstrap1 >>=? fun manager1 -> + let credit = Tez.of_int 10 in + Op.transaction ~fee:Tez.zero (I i) bootstrap0 unregistered credit >>=? fun credit_contract -> + Context.Contract.balance (I i) bootstrap0 >>=? fun balance -> + Incremental.add_operation i credit_contract >>=? fun i -> + (* delegate to bootstrap0 *) + Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager0.pkh) >>=? fun set_delegate -> + Incremental.add_operation i set_delegate >>=? fun i -> + Context.Contract.delegate (I i) unregistered >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate manager0.pkh >>=? fun () -> + (* change delegation to bootstrap1 *) + Op.delegation ~fee (I i) unregistered (Some manager1.pkh) >>=? fun change_delegate -> + if fee > balance then + Incremental.add_operation i change_delegate >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + else + Incremental.add_operation i change_delegate >>=? fun i -> + (* delegate has changed *) + Context.Contract.delegate (I i) unregistered >>=? fun delegate_after -> + Assert.equal_pkh ~loc:__LOC__ delegate_after manager1.pkh >>=? fun () -> + (* fee has been debited *) + Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee + +(** contracts not registered as delegate can delete their delegation *) +let delegate_can_be_removed_from_unregistered_contract~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + let bootstrap = List.hd bootstrap_contracts in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let unregistered = Contract.implicit_contract unregistered_pkh in + Incremental.begin_construction b >>=? fun i -> + Context.Contract.manager (I i) bootstrap >>=? fun manager -> + let credit = Tez.of_int 10 in + Op.transaction ~fee:Tez.zero (I i) bootstrap unregistered credit >>=? fun credit_contract -> + Context.Contract.balance (I i) bootstrap >>=? fun balance -> + Incremental.add_operation i credit_contract >>=? fun i -> + (* delegate to bootstrap *) + Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager.pkh) >>=? fun set_delegate -> + Incremental.add_operation i set_delegate >>=? fun i -> + Context.Contract.delegate (I i) unregistered >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh >>=? fun () -> + (* remove delegation *) + Op.delegation ~fee (I i) unregistered None >>=? fun delete_delegate -> + if fee > balance then + Incremental.add_operation i delete_delegate >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + else + Incremental.add_operation i delete_delegate >>=? fun i -> + (* the delegate has been removed *) + (Context.Contract.delegate_opt (I i) unregistered >>=? function + | None -> return_unit + | Some _ -> failwith "Expected delegate to be removed") + >>=? fun () -> + (* fee has been debited *) + Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee + +(** bootstrap keys are already registered as delegate keys *) +let bootstrap_manager_already_registered_delegate ~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + Context.Contract.manager (I i) bootstrap >>=? fun manager -> + let pkh = manager.pkh in + let impl_contract = Contract.implicit_contract pkh in + Context.Contract.balance (I i) impl_contract >>=? fun balance -> + Op.delegation ~fee (I i) impl_contract (Some pkh) >>=? fun sec_reg -> + if fee > balance then + begin + Incremental.add_operation i sec_reg >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else + begin + Incremental.add_operation ~expect_failure:(function + | Environment.Ecoproto_error Delegate_storage.Active_delegate :: _ -> + return_unit + | _ -> + failwith "Delegate is already active and operation should fail.") + i sec_reg >>=? fun i -> + (* fee has been debited *) + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee + end + +(** bootstrap manager can be set as delegate of an originated contract + (through origination operation) *) +let delegate_to_bootstrap_by_origination ~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + Context.Contract.manager (I i) bootstrap >>=? fun manager -> + Context.Contract.balance (I i) bootstrap >>=? fun balance -> + (* originate a contract with bootstrap's manager as delegate *) + Op.origination ~fee ~credit:Tez.zero ~delegate:manager.pkh (I i) bootstrap ~script:Op.dummy_script >>=? fun (op, orig_contract) -> + Context.get_constants (I i) >>=? fun { parametric = { origination_size ; cost_per_byte ; _ }; _ } -> (* 0.257tz *) + Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn -> + Lwt.return ( + Tez.(+?) fee origination_burn >>? + Tez.(+?) Op.dummy_script_cost) >>=? fun total_fee -> + if fee > balance then + begin + Incremental.add_operation i op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else if total_fee > balance && balance >= fee then + (* origination did not proceed; fee has been debited *) + begin + Incremental.add_operation i ~expect_failure:(function + | Environment.Ecoproto_error Contract.Balance_too_low _ :: _ -> + return_unit + | _ -> + failwith "Not enough balance for origination burn: operation should fail.") + op >>=? fun i -> + (* fee was taken *) + Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee >>=? fun () -> + (* originated contract has not been created *) + Context.Contract.balance (I i) orig_contract >>= fun err -> + Assert.error ~loc:__LOC__ err (function + | RPC_context.Not_found _ -> true + | _ -> false) + end + else + (* bootstrap is delegate, fee + origination burn have been debited *) + begin + Incremental.add_operation i op >>=? fun i -> + Context.Contract.delegate (I i) orig_contract >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh >>=? fun () -> + Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance total_fee + end + +let tests_bootstrap_contracts = [ + Test.tztest "bootstrap contracts delegate to themselves" `Quick bootstrap_manager_is_bootstrap_delegate ; + Test.tztest "bootstrap contracts can change their delegate (small fee)" `Quick (bootstrap_delegate_cannot_change ~fee:Tez.one_mutez) ; + Test.tztest "bootstrap contracts can change their delegate (max fee)" `Quick (bootstrap_delegate_cannot_change ~fee:Tez.max_tez) ; + Test.tztest "bootstrap contracts cannot remove their delegation (small fee)" `Quick (bootstrap_delegate_cannot_be_removed ~fee:Tez.one_mutez) ; + Test.tztest "bootstrap contracts cannot remove their delegation (max fee)" `Quick (bootstrap_delegate_cannot_be_removed ~fee:Tez.max_tez) ; + Test.tztest "contracts not registered as delegate can remove their delegation (small fee)" `Quick (delegate_can_be_changed_from_unregistered_contract ~fee:Tez.one_mutez) ; + Test.tztest "contracts not registered as delegate can remove their delegation (max fee)" `Quick (delegate_can_be_changed_from_unregistered_contract ~fee:Tez.max_tez) ; + Test.tztest "contracts not registered as delegate can remove their delegation (small fee)" `Quick (delegate_can_be_removed_from_unregistered_contract ~fee:Tez.one_mutez) ; + Test.tztest "contracts not registered as delegate can remove their delegation (max fee)" `Quick (delegate_can_be_removed_from_unregistered_contract ~fee:Tez.max_tez) ; + Test.tztest "bootstrap keys are already registered as delegate keys (small fee)" `Quick (bootstrap_manager_already_registered_delegate ~fee:Tez.one_mutez) ; + Test.tztest "bootstrap keys are already registered as delegate keys (max fee)" `Quick (bootstrap_manager_already_registered_delegate ~fee:Tez.max_tez) ; + Test.tztest "bootstrap manager can be delegate (init origination, small fee)" `Quick (delegate_to_bootstrap_by_origination ~fee:Tez.one_mutez) ; + (* balance enough for fee but not for fee + origination burn + dummy script storage cost *) + Test.tztest "bootstrap manager can be delegate (init origination, edge case)" `Quick (delegate_to_bootstrap_by_origination ~fee:(Tez.of_mutez_exn 3_999_999_705_000L)) ; + (* fee bigger than bootstrap's initial balance*) + Test.tztest "bootstrap manager can be delegate (init origination, large fee)" `Quick (delegate_to_bootstrap_by_origination ~fee:(Tez.of_int 10_000_000)) ; +] + +(**************************************************************************) +(* delegate registration *) +(**************************************************************************) +(* A delegate is a pkh. Delegates must be registered. Registration is + done via the self-delegation of the implicit contract corresponding + to the pkh. The implicit contract must be credited when the + self-delegation is done. Furthermore, trying to register an already + registered key raises an error. + + In this series of tests, we verify that + 1- unregistered delegate keys cannot be delegated to, + 2- registered keys can be delegated to, + 3- registering an already registered key raises an error. + + + We consider three scenarios for setting a delegate: + - through origination, + - through delegation when the implicit contract has no delegate yet, + - through delegation when the implicit contract already has a delegate. + + We also test that emptying the implicit contract linked to a + registered delegate key does not unregister the delegate key. +*) + +(* + Valid registration + + Unregistered key: + - contract not credited and no self-delegation + - contract credited but no self-delegation + - contract not credited and self-delegation + +Not credited: +- no credit operation +- credit operation of 1μꜩ and then debit operation of 1μꜩ + +*) + +(** A- unregistered delegate keys cannot be used for 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). + + 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 Roll_storage.Unregistered_delegate pkh0 :: _ + when pkh = pkh0 -> return_unit + | _ -> failwith "Delegate key is not registered: operation should fail." + +(* A1: no self-delegation *) +(* no token transfer, no self-delegation *) +let unregistered_delegate_key_init_origination ~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + (* origination with delegate argument *) + Op.origination ~fee ~delegate:unregistered_pkh (I i) bootstrap ~script:Op.dummy_script >>=? fun (op, orig_contract) -> + Context.get_constants (I i) >>=? fun { parametric = { origination_size ; cost_per_byte ; _ }; _ } -> + Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn -> + Lwt.return (Tez.(+?) fee origination_burn) >>=? fun _total_fee -> (* FIXME unused variable *) + Context.Contract.balance (I i) bootstrap >>=? fun balance -> + if fee > balance then + begin + Incremental.add_operation i op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else + (* origination did not proceed; fee has been debited *) + begin + Incremental.add_operation + ~expect_failure:(expect_unregistered_key unregistered_pkh) + i op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee >>=? fun () -> + (* originated contract has not been created *) + Context.Contract.balance (I i) orig_contract >>= fun err -> + Assert.error ~loc:__LOC__ err (function + | RPC_context.Not_found _ -> true + | _ -> false) + end + +let unregistered_delegate_key_init_delegation ~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in + (* initial credit for the delegated contract *) + let credit = Tez.of_int 10 in + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit >>=? fun _ -> + (* try to delegate *) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> + if fee > credit then + begin + Incremental.add_operation i delegate_op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else + (* fee has been debited; no delegate *) + begin + Incremental.add_operation i + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) + delegate_op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee >>=? fun () -> + (* implicit contract has no delegate *) + Context.Contract.delegate (I i) impl_contract >>= fun err -> + Assert.error ~loc:__LOC__ err (function + | RPC_context.Not_found _ -> true + | _ -> false) + end + +let unregistered_delegate_key_switch_delegation ~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in + (* initial credit for the delegated contract *) + let credit = Tez.of_int 10 in + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit >>=? fun init_credit -> + Incremental.add_operation i init_credit >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit >>=? fun _ -> + (* set and check the initial delegate *) + Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh) >>=? fun delegate_op -> + Incremental.add_operation i delegate_op >>=? fun i -> + Context.Contract.delegate (I i) bootstrap >>=? fun delegate_pkh -> + Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh >>=? fun () -> + (* try to delegate *) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> + if fee > credit then + begin + Incremental.add_operation i delegate_op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else + (* fee has been debited; no delegate *) + begin + Incremental.add_operation i + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) + delegate_op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee >>=? fun () -> + (* implicit contract delegate has not changed *) + Context.Contract.delegate (I i) bootstrap >>=? fun delegate_pkh_after -> + Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate_pkh_after + end + +(* credit of some amount, no self-delegation *) +let unregistered_delegate_key_init_origination_credit ~fee ~amount () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + (* credit + check balance *) + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* origination with delegate argument *) + Context.Contract.balance (I i) bootstrap >>=? fun balance -> + Op.origination ~fee ~delegate:unregistered_pkh (I i) bootstrap ~script:Op.dummy_script >>=? fun (op, orig_contract) -> + if fee > balance then + begin + Incremental.add_operation i op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else (* origination not done, fee taken *) + begin + Incremental.add_operation + ~expect_failure:(expect_unregistered_key unregistered_pkh) + i op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee >>=? fun () -> + Context.Contract.balance (I i) orig_contract >>= fun err -> + Assert.error ~loc:__LOC__ err (function + | RPC_context.Not_found _ -> true + | _ -> false) + end + +let unregistered_delegate_key_init_delegation_credit ~fee ~amount () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in + (* credit + check balance *) + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* initial credit for the delegated contract *) + let credit = Tez.of_int 10 in + Lwt.return Tez.(credit +? amount) >>=? fun balance -> + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit >>=? fun init_credit -> + Incremental.add_operation i init_credit >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance >>=? fun _ -> + (* try to delegate *) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> + if fee > credit then + Incremental.add_operation i delegate_op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + else + begin + (* fee has been taken, no delegate for contract *) + Incremental.add_operation + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) + i delegate_op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee >>=? fun () -> + Context.Contract.delegate (I i) impl_contract >>= fun err -> + + Assert.error ~loc:__LOC__ err (function + | RPC_context.Not_found _ -> true + | _ -> false) + end + +let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in + (* credit + check balance *) + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* initial credit for the delegated contract *) + let credit = Tez.of_int 10 in + Lwt.return Tez.(credit +? amount) >>=? fun balance -> + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit >>=? fun init_credit -> + Incremental.add_operation i init_credit >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance >>=? fun _ -> + (* set and check the initial delegate *) + Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh) >>=? fun delegate_op -> + Incremental.add_operation i delegate_op >>=? fun i -> + Context.Contract.delegate (I i) bootstrap >>=? fun delegate_pkh -> + Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh >>=? fun () -> + (* switch delegate through delegation *) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> + if fee > credit then + Incremental.add_operation i delegate_op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + else + begin + (* fee has been taken, delegate for contract has not changed *) + Incremental.add_operation + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) + i delegate_op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee >>=? fun () -> + Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> + Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh >>=? fun () -> + Assert.equal_pkh ~loc:__LOC__ delegate bootstrap_pkh + end + +(* a credit of some amount followed by a debit of the same amount, no self-delegation *) +let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + (* credit + check balance *) + Op.transaction (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* debit + check balance *) + Op.transaction (I i) impl_contract bootstrap amount >>=? fun debit_contract -> + Incremental.add_operation i debit_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> + (* origination with delegate argument *) + Context.Contract.balance (I i) bootstrap >>=? fun balance -> + Op.origination ~fee ~delegate:unregistered_pkh (I i) bootstrap ~script:Op.dummy_script >>=? fun (op, orig_contract) -> + if fee > balance then + begin + Incremental.add_operation i op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else (* fee taken, origination not processed *) + begin + Incremental.add_operation + ~expect_failure:(expect_unregistered_key unregistered_pkh) + i op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee >>=? fun () -> + Context.Contract.balance (I i) orig_contract >>= fun err -> + Assert.error ~loc:__LOC__ err (function + | RPC_context.Not_found _ -> true + | _ -> false) + end + +let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in + (* credit + check balance *) + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* debit + check balance *) + Op.transaction ~fee:Tez.zero (I i) impl_contract bootstrap amount >>=? fun debit_contract -> + Incremental.add_operation i debit_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> + (* initial credit for the delegated contract *) + let credit = Tez.of_int 10 in + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit >>=? fun _ -> + (* try to delegate *) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> + + if fee > credit then + begin + Incremental.add_operation i delegate_op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else + begin + (* fee has been taken, no delegate for contract *) + Incremental.add_operation + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) + i delegate_op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee >>=? fun () -> + Context.Contract.delegate (I i) impl_contract >>= fun err -> + + Assert.error ~loc:__LOC__ err (function + | RPC_context.Not_found _ -> true + | _ -> false) + end + +let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in + (* credit + check balance *) + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* debit + check balance *) + Op.transaction (I i) impl_contract bootstrap amount >>=? fun debit_contract -> + Incremental.add_operation i debit_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> + (* delegation - initial credit for the delegated contract *) + let credit = Tez.of_int 10 in + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit >>=? fun _ -> + (* set and check the initial delegate *) + Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh) >>=? fun delegate_op -> + Incremental.add_operation i delegate_op >>=? fun i -> + Context.Contract.delegate (I i) bootstrap >>=? fun delegate_pkh -> + Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh >>=? fun () -> + (* switch delegate through delegation *) + Op.delegation (I i) ~fee impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> + + if fee > credit then + Incremental.add_operation i delegate_op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + else + begin + (* fee has been taken, delegate for contract has not changed *) + Incremental.add_operation + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) + i delegate_op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee >>=? fun () -> + Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> + Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh + end + +(* A2- self-delegation to an empty contract fails *) +let failed_self_delegation_no_transaction () = + Context.init 1 >>=? fun (b, _) -> + Incremental.begin_construction b >>=? fun i -> + let account = Account.new_account () in + let unregistered_pkh = Account.(account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + (* check balance *) + Context.Contract.balance (I i) impl_contract >>=? fun balance -> + Assert.equal_tez ~loc:__LOC__ Tez.zero balance >>=? fun _ -> + (* self delegation fails *) + Op.delegation (I i) impl_contract (Some unregistered_pkh) >>=? fun self_delegation -> + Incremental.add_operation i self_delegation >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Empty_implicit_contract pkh -> + if pkh = unregistered_pkh then true else false + | _ -> false) + +let failed_self_delegation_emptied_implicit_contract amount () = + (* create an implicit contract *) + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let account = Account.new_account () in + let unregistered_pkh = Account.(account.pkh) in + let impl_contract = Contract.implicit_contract unregistered_pkh in + (* credit implicit contract and check balance *) + Op.transaction (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* empty implicit contract and check balance *) + Op.transaction (I i) impl_contract bootstrap amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> + (* self delegation fails *) + Op.delegation (I i) impl_contract (Some unregistered_pkh) >>=? fun self_delegation -> + Incremental.add_operation i self_delegation >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Empty_implicit_contract pkh -> + if pkh = unregistered_pkh then true else false + | _ -> false) + +(** B- valid registration: + - credit implicit contract with some ꜩ + verification of balance + - self delegation + verification + - empty contract + verification of balance + verification of not being erased / self-delegation + - create delegator implicit contract w first implicit contract as delegate + verification of delegation *) +let valid_delegate_registration_init_delegation_credit amount () = + (* create an implicit contract *) + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let delegate_account = Account.new_account () in + let delegate_pkh = Account.(delegate_account.pkh) in + let impl_contract = Contract.implicit_contract delegate_pkh in + (* credit > 0ꜩ + check balance *) + Op.transaction (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* self delegation + verification *) + Op.delegation (I i) impl_contract (Some delegate_pkh) >>=? fun self_delegation -> + Incremental.add_operation i self_delegation >>=? fun i -> + Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh >>=? fun _ -> + (* create an implicit contract with no delegate *) + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let delegator = Contract.implicit_contract unregistered_pkh in + Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> + (* check no delegate for delegator contract *) + Context.Contract.delegate (I i) delegator >>= fun err -> + Assert.error ~loc:__LOC__ err (function + | RPC_context.Not_found _ -> true + | _ -> false) >>=? fun _ -> + (* delegation to the newly registered key *) + Op.delegation (I i) delegator (Some delegate_account.pkh) >>=? fun delegation -> + Incremental.add_operation i delegation >>=? fun i -> + (* check delegation *) + Context.Contract.delegate (I i) delegator >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh + +let valid_delegate_registration_switch_delegation_credit amount () = + (* create an implicit contract *) + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let delegate_account = Account.new_account () in + let delegate_pkh = Account.(delegate_account.pkh) in + let impl_contract = Contract.implicit_contract delegate_pkh in + (* credit > 0ꜩ + check balance *) + Op.transaction (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* self delegation + verification *) + Op.delegation (I i) impl_contract (Some delegate_pkh) >>=? fun self_delegation -> + Incremental.add_operation i self_delegation >>=? fun i -> + Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh >>=? fun _ -> + (* create an implicit contract with bootstrap's account as delegate *) + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let delegator = Contract.implicit_contract unregistered_pkh in + Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> + Context.Contract.manager (I i) bootstrap >>=? fun bootstrap_manager -> + Op.delegation (I i) delegator (Some bootstrap_manager.pkh) >>=? fun delegation -> + Incremental.add_operation i delegation >>=? fun i -> + (* test delegate of new contract is bootstrap *) + Context.Contract.delegate (I i) delegator >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh >>=? fun _ -> + (* delegation with newly registered key *) + Op.delegation (I i) delegator (Some delegate_account.pkh) >>=? fun delegation -> + Incremental.add_operation i delegation >>=? fun i -> + Context.Contract.delegate (I i) delegator >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh + +let valid_delegate_registration_init_delegation_credit_debit amount () = + (* create an implicit contract *) + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let delegate_account = Account.new_account () in + let delegate_pkh = Account.(delegate_account.pkh) in + let impl_contract = Contract.implicit_contract delegate_pkh in + (* credit > 0ꜩ+ check balance *) + Op.transaction (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* self delegation + verification *) + Op.delegation (I i) impl_contract (Some delegate_pkh) >>=? fun self_delegation -> + Incremental.add_operation i self_delegation >>=? fun i -> + Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate >>=? fun _ -> + (* empty implicit contracts are usually deleted but they are kept if + they were registered as delegates. we empty the contract in + order to verify this. *) + Op.transaction (I i) impl_contract bootstrap amount >>=? fun empty_contract -> + Incremental.add_operation i empty_contract >>=? fun i -> + (* impl_contract is empty *) + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> + (* verify self-delegation after contract is emptied *) + Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate >>=? fun _ -> + (* create an implicit contract with no delegate *) + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let delegator = Contract.implicit_contract unregistered_pkh in + Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> + (* check no delegate for delegator contract *) + Context.Contract.delegate (I i) delegator >>= fun err -> + Assert.error ~loc:__LOC__ err (function + | RPC_context.Not_found _ -> true + | _ -> false) >>=? fun _ -> + (* delegation to the newly registered key *) + Op.delegation (I i) delegator (Some delegate_account.pkh) >>=? fun delegation -> + Incremental.add_operation i delegation >>=? fun i -> + (* check delegation *) + Context.Contract.delegate (I i) delegator >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh + +let valid_delegate_registration_switch_delegation_credit_debit amount () = + (* create an implicit contract *) + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let delegate_account = Account.new_account () in + let delegate_pkh = Account.(delegate_account.pkh) in + let impl_contract = Contract.implicit_contract delegate_pkh in + (* credit > 0ꜩ + check balance *) + Op.transaction (I i) bootstrap impl_contract amount >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> + (* self delegation + verification *) + Op.delegation (I i) impl_contract (Some delegate_pkh) >>=? fun self_delegation -> + Incremental.add_operation i self_delegation >>=? fun i -> + Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate >>=? fun _ -> + (* empty implicit contracts are usually deleted but they are kept if + they were registered as delegates. we empty the contract in + order to verify this. *) + Op.transaction (I i) impl_contract bootstrap amount >>=? fun empty_contract -> + Incremental.add_operation i empty_contract >>=? fun i -> + (* impl_contract is empty *) + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> + (* create an implicit contract with bootstrap's account as delegate *) + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let delegator = Contract.implicit_contract unregistered_pkh in + Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> + Context.Contract.manager (I i) bootstrap >>=? fun bootstrap_manager -> + Op.delegation (I i) delegator (Some bootstrap_manager.pkh) >>=? fun delegation -> + Incremental.add_operation i delegation >>=? fun i -> + (* test delegate of new contract is bootstrap *) + Context.Contract.delegate (I i) delegator >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh >>=? fun _ -> + (* delegation with newly registered key *) + Op.delegation (I i) delegator (Some delegate_account.pkh) >>=? fun delegation -> + Incremental.add_operation i delegation >>=? fun i -> + Context.Contract.delegate (I i) delegator >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh + +(** C- a second self-delegation should raise an `Active_delegate` error *) +(* with implicit contract with some credit *) +let double_registration () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let account = Account.new_account () in + let pkh = Account.(account.pkh) in + let impl_contract = Contract.implicit_contract pkh in + (* credit 1μꜩ+ check balance *) + Op.transaction (I i) bootstrap impl_contract (Tez.one_mutez) >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez >>=? fun _ -> + (* self-delegation *) + Op.delegation (I i) impl_contract (Some pkh) >>=? fun self_delegation -> + Incremental.add_operation i self_delegation >>=? fun i -> + (* second self-delegation *) + Op.delegation (I i) impl_contract (Some pkh) >>=? fun second_registration -> + Incremental.add_operation i second_registration >>= fun err -> + + Assert.proto_error ~loc:__LOC__ err (function + | Delegate_storage.Active_delegate -> true + | _ -> false) + +(* with implicit contract emptied after first self-delegation *) +let double_registration_when_empty () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let account = Account.new_account () in + let pkh = Account.(account.pkh) in + let impl_contract = Contract.implicit_contract pkh in + (* credit 1μꜩ+ check balance *) + Op.transaction (I i) bootstrap impl_contract Tez.one_mutez >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez >>=? fun _ -> + (* self delegation *) + Op.delegation (I i) impl_contract (Some pkh) >>=? fun self_delegation -> + Incremental.add_operation i self_delegation >>=? fun i -> + (* empty the delegate account *) + Op.transaction (I i) impl_contract bootstrap Tez.one_mutez >>=? fun empty_contract -> + Incremental.add_operation i empty_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> + (* second self-delegation *) + Op.delegation (I i) impl_contract (Some pkh) >>=? fun second_registration -> + Incremental.add_operation i second_registration >>= fun err -> + + Assert.proto_error ~loc:__LOC__ err (function + | Delegate_storage.Active_delegate -> true + | _ -> false) + +(* with implicit contract emptied then recredited after first self-delegation *) +let double_registration_when_recredited () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let account = Account.new_account () in + let pkh = Account.(account.pkh) in + let impl_contract = Contract.implicit_contract pkh in + (* credit 1μꜩ+ check balance *) + Op.transaction (I i) bootstrap impl_contract Tez.one_mutez >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez >>=? fun _ -> + (* self delegation *) + Op.delegation (I i) impl_contract (Some pkh) >>=? fun self_delegation -> + Incremental.add_operation i self_delegation >>=? fun i -> + (* empty the delegate account *) + Op.transaction (I i) impl_contract bootstrap Tez.one_mutez >>=? fun empty_contract -> + Incremental.add_operation i empty_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> + (* credit 1μꜩ+ check balance *) + Op.transaction (I i) bootstrap impl_contract Tez.one_mutez >>=? fun create_contract -> + Incremental.add_operation i create_contract >>=? fun i -> + Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez >>=? fun _ -> + (* second self-delegation *) + Op.delegation (I i) impl_contract (Some pkh) >>=? fun second_registration -> + Incremental.add_operation i second_registration >>= fun err -> + + Assert.proto_error ~loc:__LOC__ err (function + | Delegate_storage.Active_delegate -> true + | _ -> false) + +(* self-delegation on unrevealed contract *) +let unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let { Account.pkh ; _ } = Account.new_account () in + let { Account.pkh = delegate_pkh ; _ } = Account.new_account () in + let contract = Alpha_context.Contract.implicit_contract pkh in + Op.transaction (I i) bootstrap contract (Tez.of_int 10) >>=? fun op -> + Incremental.add_operation i op >>=? fun i -> + Op.delegation ~fee (I i) contract (Some delegate_pkh) >>=? fun op -> + Context.Contract.balance (I i) contract >>=? fun balance -> + if fee > balance then + begin + Incremental.add_operation i op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else + (* origination did not proceed; fee has been debited *) + begin + Incremental.add_operation + ~expect_failure:(expect_unregistered_key delegate_pkh) + i op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee + end + +(* self-delegation on revelead but not registered contract *) +let unregistered_and_revealed_self_delegate_key_init_delegation ~fee () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let { Account.pkh ; pk ; _ } = Account.new_account () in + let { Account.pkh = delegate_pkh ; _ } = Account.new_account () in + let contract = Alpha_context.Contract.implicit_contract pkh in + Op.transaction (I i) bootstrap contract (Tez.of_int 10) >>=? fun op -> + Incremental.add_operation i op >>=? fun i -> + Op.revelation (I i) pk >>=? fun op -> + Incremental.add_operation i op >>=? fun i -> + Op.delegation ~fee (I i) contract (Some delegate_pkh) >>=? fun op -> + Context.Contract.balance (I i) contract >>=? fun balance -> + if fee > balance then + begin + Incremental.add_operation i op >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> true + | _ -> false) + end + else + (* origination did not proceed; fee has been debited *) + begin + Incremental.add_operation + ~expect_failure:(expect_unregistered_key delegate_pkh) + i op >>=? fun i -> + Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee + end + +(* self-delegation on revealed and registered contract *) +let registered_self_delegate_key_init_delegation () = + Context.init 1 >>=? fun (b, bootstrap_contracts) -> + Incremental.begin_construction b >>=? fun i -> + let bootstrap = List.hd bootstrap_contracts in + let { Account.pkh ; _ } = Account.new_account () in + let { Account.pkh = delegate_pkh ; pk = delegate_pk ; _ } = Account.new_account () in + let contract = Alpha_context.Contract.implicit_contract pkh in + let delegate_contract = Alpha_context.Contract.implicit_contract delegate_pkh in + Op.transaction (I i) bootstrap contract (Tez.of_int 10) >>=? fun op -> + Incremental.add_operation i op >>=? fun i -> + Op.transaction (I i) bootstrap delegate_contract (Tez.of_int 1) >>=? fun op -> + Incremental.add_operation i op >>=? fun i -> + Op.revelation (I i) delegate_pk >>=? fun op -> + Incremental.add_operation i op >>=? fun i -> + Op.delegation (I i) delegate_contract (Some delegate_pkh) >>=? fun op -> + Incremental.add_operation i op >>=? fun i -> + Op.delegation(I i) contract (Some delegate_pkh) >>=? fun op -> + Incremental.add_operation i op >>=? fun i -> + Context.Contract.delegate (I i) contract >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh >>=? fun () -> + return_unit + +let tests_delegate_registration = + [ + (*** unregistered delegate key: no self-delegation ***) + (* no token transfer, no self-delegation *) + Test.tztest "unregistered delegate key (origination, small fee)" + `Quick (unregistered_delegate_key_init_origination ~fee:Tez.one_mutez); + Test.tztest "unregistered delegate key (origination, edge case fee)" + `Quick (unregistered_delegate_key_init_origination ~fee:(Tez.of_int 3_999_488)); + Test.tztest "unregistered delegate key (origination, large fee)" + `Quick (unregistered_delegate_key_init_origination ~fee:(Tez.of_int 10_000_000)); + + Test.tztest "unregistered delegate key (init with delegation, small fee)" + `Quick (unregistered_delegate_key_init_delegation ~fee:Tez.one_mutez); + Test.tztest "unregistered delegate key (init with delegation, max fee)" + `Quick (unregistered_delegate_key_init_delegation ~fee:Tez.max_tez); + + Test.tztest "unregistered delegate key (switch with delegation, small fee)" + `Quick (unregistered_delegate_key_switch_delegation ~fee:Tez.one_mutez) ; + Test.tztest "unregistered delegate key (switch with delegation, max fee)" + `Quick (unregistered_delegate_key_switch_delegation ~fee:Tez.max_tez) ; + + (* credit/debit 1μꜩ, no self-delegation *) + Test.tztest "unregistered delegate key - credit/debit 1μꜩ (origination, small fee)" + `Quick (unregistered_delegate_key_init_origination_credit_debit ~fee:Tez.one_mutez ~amount:Tez.one_mutez) ; + Test.tztest "unregistered delegate key - credit/debit 1μꜩ (origination, large fee)" + `Quick (unregistered_delegate_key_init_origination_credit_debit ~fee:Tez.max_tez ~amount:Tez.one_mutez) ; + + Test.tztest "unregistered delegate key - credit/debit 1μꜩ (init with delegation, small fee)" + `Quick (unregistered_delegate_key_init_delegation_credit_debit ~amount:Tez.one_mutez ~fee:Tez.one_mutez) ; + Test.tztest "unregistered delegate key - credit/debit 1μꜩ (init with delegation, large fee)" + `Quick (unregistered_delegate_key_init_delegation_credit_debit ~amount:Tez.one_mutez ~fee:Tez.max_tez) ; + + Test.tztest "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, small fee)" + `Quick (unregistered_delegate_key_switch_delegation_credit_debit ~amount:Tez.one_mutez ~fee:Tez.one_mutez) ; + Test.tztest "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, large fee)" + `Quick (unregistered_delegate_key_switch_delegation_credit_debit ~amount:Tez.one_mutez ~fee:Tez.max_tez) ; + + (* credit 1μꜩ, no self-delegation *) + Test.tztest "unregistered delegate key - credit 1μꜩ (origination, small fee)" + `Quick (unregistered_delegate_key_init_origination_credit ~fee:Tez.one_mutez ~amount:Tez.one_mutez) ; + Test.tztest "unregistered delegate key - credit 1μꜩ (origination, edge case fee)" + `Quick (unregistered_delegate_key_init_origination_credit ~fee:(Tez.of_int 3_999_488) ~amount:Tez.one_mutez) ; + Test.tztest "unregistered delegate key - credit 1μꜩ (origination, large fee)" + `Quick (unregistered_delegate_key_init_origination_credit ~fee:(Tez.of_int 10_000_000) ~amount:Tez.one_mutez) ; + + Test.tztest "unregistered delegate key - credit 1μꜩ (init with delegation, small fee)" + `Quick (unregistered_delegate_key_init_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.one_mutez) ; + Test.tztest "unregistered delegate key - credit 1μꜩ (init with delegation, large fee)" + `Quick (unregistered_delegate_key_init_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.max_tez) ; + + Test.tztest "unregistered delegate key - credit 1μꜩ (switch with delegation, small fee)" + `Quick (unregistered_delegate_key_switch_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.one_mutez) ; + Test.tztest "unregistered delegate key - credit 1μꜩ (switch with delegation, large fee)" + `Quick (unregistered_delegate_key_switch_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.max_tez) ; + + (* self delegation on unrevealed and unregistered contract *) + Test.tztest "unregistered and unrevealed self-delegation (small fee)" + `Quick (unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee:Tez.one_mutez) ; + Test.tztest "unregistered and unrevealed self-delegation (large fee)" + `Quick (unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee:Tez.max_tez) ; + + (* self delegation on unregistered contract *) + Test.tztest "unregistered and revealed self-delegation (small fee)" + `Quick (unregistered_and_revealed_self_delegate_key_init_delegation ~fee:Tez.one_mutez) ; + Test.tztest "unregistered and revealed self-delegation large fee)" + `Quick (unregistered_and_revealed_self_delegate_key_init_delegation ~fee:Tez.max_tez) ; + + (* self delegation on registered contract *) + Test.tztest "registered and revelead self-delegation" + `Quick registered_self_delegate_key_init_delegation ; + + (*** unregistered delegate key: failed self-delegation ***) + (* no token transfer, self-delegation *) + Test.tztest "failed self-delegation: no transaction" `Quick failed_self_delegation_no_transaction ; + (* credit 1μtz, debit 1μtz, self-delegation *) + Test.tztest "failed self-delegation: credit & debit 1μꜩ" `Quick (failed_self_delegation_emptied_implicit_contract Tez.one_mutez) ; + + (*** valid registration ***) + (* valid registration: credit 1 μꜩ, self delegation *) + Test.tztest "valid delegate registration: credit 1μꜩ, self delegation (init with delegation)" + `Quick (valid_delegate_registration_init_delegation_credit Tez.one_mutez) ; + Test.tztest "valid delegate registration: credit 1μꜩ, self delegation (switch with delegation)" + `Quick (valid_delegate_registration_switch_delegation_credit Tez.one_mutez) ; + (* valid registration: credit 1 μꜩ, self delegation, debit 1μꜩ *) + Test.tztest "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ (init with delegation)" + `Quick (valid_delegate_registration_init_delegation_credit_debit Tez.one_mutez) ; + Test.tztest "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ (switch with delegation)" + `Quick (valid_delegate_registration_switch_delegation_credit_debit Tez.one_mutez) ; + + (*** double registration ***) + Test.tztest "double registration" `Quick double_registration ; + Test.tztest "double registration when delegate account is emptied" `Quick double_registration_when_empty ; + Test.tztest "double registration when delegate account is emptied and then recredited" `Quick double_registration_when_recredited ; + ] + + + +(******************************************************************************) +(* Main *) +(******************************************************************************) + +let tests = + tests_bootstrap_contracts @ + tests_delegate_registration diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/double_baking.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/double_baking.ml new file mode 100644 index 000000000..4e75cca34 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/double_baking.ml @@ -0,0 +1,189 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Double baking evidence operation may happen when a baker + baked two different blocks on the same level. *) + +open Protocol +open Alpha_context + +(****************************************************************) +(* Utility functions *) +(****************************************************************) + +let get_first_different_baker baker bakers = + return @@ List.find (fun baker' -> + Signature.Public_key_hash.(<>) baker baker') + bakers + +let get_first_different_bakers ctxt = + Context.get_bakers ctxt >>=? fun bakers -> + let baker_1 = List.hd bakers in + get_first_different_baker baker_1 (List.tl bakers) >>=? fun baker_2 -> + return (baker_1, baker_2) + +let get_first_different_endorsers ctxt = + Context.get_endorsers ctxt >>=? fun endorsers -> + let endorser_1 = (List.hd endorsers).delegate in + let endorser_2 = (List.hd (List.tl endorsers)).delegate in + return (endorser_1, endorser_2) + +(** 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) = + List.hd contracts, List.hd (List.tl 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 -> + Block.bake ?policy b >>=? fun blk_b -> + return (blk_a, blk_b) + +(****************************************************************) +(* Tests *) +(****************************************************************) + +(** Simple scenario where two blocks are baked by a same baker and + exposed by a double baking evidence operation *) +let valid_double_baking_evidence () = + Context.init 2 >>=? fun (b, contracts) -> + + Context.get_bakers (B b) >>=? fun bakers -> + let priority_0_baker = List.hd bakers in + + block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> + + Op.double_baking (B blk_a) blk_a.header blk_b.header >>=? fun operation -> + Block.bake ~policy:(Excluding [ priority_0_baker ]) ~operation blk_a >>=? fun blk -> + + (* Check that the frozen deposit, the fees and rewards are removed *) + iter_s (fun kind -> + let contract = Alpha_context.Contract.implicit_contract priority_0_baker in + Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero) + [ Deposit ; Fees ; Rewards ] + +(****************************************************************) +(* The following test scenarios are supposed to raise errors. *) +(****************************************************************) + +(** Check that a double baking operation fails if it exposes the same two blocks *) +let same_blocks () = + Context.init 2 >>=? fun (b, _contracts) -> + Block.bake b >>=? fun ba -> + Op.double_baking (B ba) ba.header ba.header >>=? fun operation -> + Block.bake ~operation ba >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Invalid_double_baking_evidence _ -> true + | _ -> false end >>=? fun () -> + return_unit + +(** Check that a double baking operation exposing two blocks with + different levels fails *) +let different_levels () = + Context.init 2 >>=? fun (b, contracts) -> + + block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> + + Block.bake blk_b >>=? fun blk_b_2 -> + + Op.double_baking (B blk_a) blk_a.header blk_b_2.header >>=? fun operation -> + Block.bake ~operation blk_a >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Invalid_double_baking_evidence _ -> true + | _ -> false end + +(** Check that a double baking operation exposing two yet to be baked + blocks fails *) +let too_early_double_baking_evidence () = + Context.init 2 >>=? fun (b, contracts) -> + block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> + + Op.double_baking (B b) blk_a.header blk_b.header >>=? fun operation -> + Block.bake ~operation b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Too_early_double_baking_evidence _ -> true + | _ -> false end + +(** Check that after [preserved_cycles + 1], it is not possible to + create a double baking operation anymore *) +let too_late_double_baking_evidence () = + Context.init 2 >>=? fun (b, contracts) -> + Context.get_constants (B b) + >>=? fun Constants.{ parametric = { preserved_cycles ; _ } ; _ } -> + + block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> + + fold_left_s (fun blk _ -> Block.bake_until_cycle_end blk) + blk_a (1 -- (preserved_cycles + 1)) >>=? fun blk -> + + Op.double_baking (B blk) blk_a.header blk_b.header >>=? fun operation -> + Block.bake ~operation blk >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Outdated_double_baking_evidence _ -> true + | _ -> false end + +(** Check that an invalid double baking evidence that exposes two block + baking with same level made by different bakers fails *) +let different_delegates () = + Context.init 2 >>=? fun (b, _) -> + + get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) -> + Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a -> + Block.bake ~policy:(By_account baker_2) b >>=? fun blk_b -> + + Op.double_baking (B blk_a) blk_a.header blk_b.header >>=? fun operation -> + Block.bake ~operation blk_a >>= fun e -> + Assert.proto_error ~loc:__LOC__ e begin function + | Apply.Inconsistent_double_baking_evidence _ -> true + | _ -> false end + +let wrong_signer () = + (* Baker_2 bakes a block but baker signs it. *) + let header_custom_signer baker baker_2 b = + Block.Forge.forge_header ~policy:(By_account baker_2) b >>=? fun header -> + Block.Forge.set_baker baker header |> + Block.Forge.sign_header + in + + Context.init 2 >>=? fun (b, _) -> + get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) -> + Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a -> + header_custom_signer baker_1 baker_2 b >>=? fun header_b -> + Op.double_baking (B blk_a) blk_a.header header_b >>=? fun operation -> + Block.bake ~operation blk_a >>= fun e -> + Assert.proto_error ~loc:__LOC__ e begin function + | Baking.Invalid_block_signature _ -> true + | _ -> false end + +let tests = [ + Test.tztest "valid double baking evidence" `Quick valid_double_baking_evidence ; + + (* Should fail*) + Test.tztest "same blocks" `Quick same_blocks ; + Test.tztest "different levels" `Quick different_levels ; + Test.tztest "too early double baking evidence" `Quick too_early_double_baking_evidence ; + Test.tztest "too late double baking evidence" `Quick too_late_double_baking_evidence ; + Test.tztest "different delegates" `Quick different_delegates ; + Test.tztest "wrong delegate" `Quick wrong_signer ; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/double_endorsement.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/double_endorsement.ml new file mode 100644 index 000000000..f52f7dc96 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/double_endorsement.ml @@ -0,0 +1,204 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Double endorsement evidence operation may happen when an endorser + endorsed two different blocks on the same level. *) + +open Protocol +open Alpha_context + +(****************************************************************) +(* Utility functions *) +(****************************************************************) + +let get_first_different_baker baker bakers = + return @@ List.find (fun baker' -> + Signature.Public_key_hash.(<>) baker baker') + bakers + +let get_first_different_bakers ctxt = + Context.get_bakers ctxt >>=? fun bakers -> + let baker_1 = List.hd bakers in + get_first_different_baker baker_1 (List.tl bakers) >>=? fun baker_2 -> + return (baker_1, baker_2) + +let get_first_different_endorsers ctxt = + Context.get_endorsers ctxt >>=? fun endorsers -> + let endorser_1 = (List.hd endorsers) in + let endorser_2 = (List.hd (List.tl endorsers)) in + return (endorser_1, endorser_2) + +let block_fork b = + get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) -> + Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a -> + Block.bake ~policy:(By_account baker_2) b >>=? fun blk_b -> + return (blk_a, blk_b) + +(****************************************************************) +(* Tests *) +(****************************************************************) + +(** Simple scenario where two endorsements are made from the same + delegate and exposed by a double_endorsement operation. Also verify + that punishment is operated. *) +let valid_double_endorsement_evidence () = + Context.init 2 >>=? fun (b, _) -> + + block_fork b >>=? fun (blk_a, blk_b) -> + + Context.get_endorser (B blk_a) >>=? fun (delegate, _slots) -> + Op.endorsement ~delegate (B blk_a) () >>=? fun endorsement_a -> + Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b -> + Block.bake ~operations:[Operation.pack endorsement_a] blk_a >>=? fun blk_a -> + (* Block.bake ~operations:[endorsement_b] blk_b >>=? fun _ -> *) + + Op.double_endorsement (B blk_a) endorsement_a endorsement_b >>=? fun operation -> + + (* Bake with someone different than the bad endorser *) + Context.get_bakers (B blk_a) >>=? fun bakers -> + get_first_different_baker delegate bakers >>=? fun baker -> + + Block.bake ~policy:(By_account baker) ~operation blk_a >>=? fun blk -> + + (* Check that the frozen deposit, the fees and rewards are removed *) + iter_s (fun kind -> + let contract = Alpha_context.Contract.implicit_contract delegate in + Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero) + [ Deposit ; Fees ; Rewards ] + +(****************************************************************) +(* The following test scenarios are supposed to raise errors. *) +(****************************************************************) + +(** Check that an invalid double endorsement operation that exposes a valid + endorsement fails. *) +let invalid_double_endorsement () = + Context.init 10 >>=? fun (b, _) -> + Block.bake b >>=? fun b -> + + Op.endorsement (B b) () >>=? fun endorsement -> + Block.bake ~operation:(Operation.pack endorsement) b >>=? fun b -> + + Op.double_endorsement (B b) endorsement endorsement >>=? fun operation -> + Block.bake ~operation b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Invalid_double_endorsement_evidence -> true + | _ -> false end + +(** Check that a double endorsement added at the same time as a double + endorsement operation fails. *) +let too_early_double_endorsement_evidence () = + Context.init 2 >>=? fun (b, _) -> + block_fork b >>=? fun (blk_a, blk_b) -> + + Context.get_endorser (B blk_a) >>=? fun (delegate, _slots) -> + Op.endorsement ~delegate (B blk_a) () >>=? fun endorsement_a -> + Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b -> + + Op.double_endorsement (B b) endorsement_a endorsement_b >>=? fun operation -> + Block.bake ~operation b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Too_early_double_endorsement_evidence _ -> true + | _ -> false end + +(** Check that after [preserved_cycles + 1], it is not possible + to create a double_endorsement anymore. *) +let too_late_double_endorsement_evidence () = + Context.init 2 >>=? fun (b, _) -> + Context.get_constants (B b) + >>=? fun Constants.{ parametric = { preserved_cycles ; _ } ; _ } -> + + block_fork b >>=? fun (blk_a, blk_b) -> + + Context.get_endorser (B blk_a) >>=? fun (delegate, _slots) -> + Op.endorsement ~delegate (B blk_a) () >>=? fun endorsement_a -> + Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b -> + + fold_left_s (fun blk _ -> Block.bake_until_cycle_end blk) + blk_a (1 -- (preserved_cycles + 1)) >>=? fun blk -> + + Op.double_endorsement (B blk) endorsement_a endorsement_b >>=? fun operation -> + Block.bake ~operation blk >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Outdated_double_endorsement_evidence _ -> true + | _ -> false end + +(** Check that an invalid double endorsement evidence that expose two + endorsements made by two different endorsers fails. *) +let different_delegates () = + Context.init 2 >>=? fun (b, _) -> + + Block.bake b >>=? fun b -> + block_fork b >>=? fun (blk_a, blk_b) -> + 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 = + if Signature.Public_key_hash.(=) endorser_a endorser_b1c.delegate + then endorser_b2c.delegate + else endorser_b1c.delegate + in + + Op.endorsement ~delegate:endorser_a (B blk_a) () >>=? fun e_a -> + Op.endorsement ~delegate:endorser_b (B blk_b) () >>=? fun e_b -> + Block.bake ~operation:(Operation.pack e_b) blk_b >>=? fun _ -> + Op.double_endorsement (B blk_b) e_a e_b >>=? fun operation -> + Block.bake ~operation blk_b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Inconsistent_double_endorsement_evidence _ -> true + | _ -> false end + +(** Check that a double endorsement evidence that exposes a ill-formed + endorsement fails. *) +let wrong_delegate () = + Context.init ~endorsers_per_block:1 2 >>=? fun (b, contracts) -> + Error_monad.map_s (Context.Contract.manager (B b)) contracts >>=? fun accounts -> + let pkh1 = (List.nth accounts 0).Account.pkh in + let pkh2 = (List.nth accounts 1).Account.pkh in + + block_fork b >>=? fun (blk_a, blk_b) -> + Context.get_endorser (B blk_a) >>=? fun (endorser_a, _a_slots) -> + Op.endorsement ~delegate:endorser_a (B blk_a) () >>=? fun endorsement_a -> + Context.get_endorser (B blk_b) >>=? fun (endorser_b, _b_slots) -> + let delegate = + if Signature.Public_key_hash.equal pkh1 endorser_b + then pkh2 + else pkh1 + in + Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b -> + + Op.double_endorsement (B blk_b) endorsement_a endorsement_b >>=? fun operation -> + Block.bake ~operation blk_b >>= fun e -> + Assert.proto_error ~loc:__LOC__ e begin function + | Baking.Unexpected_endorsement -> true + | _ -> false end + +let tests = [ + Test.tztest "valid double endorsement evidence" `Quick valid_double_endorsement_evidence ; + Test.tztest "invalid double endorsement evidence" `Quick invalid_double_endorsement ; + Test.tztest "too early double endorsement evidence" `Quick too_early_double_endorsement_evidence ; + Test.tztest "too late double endorsement evidence" `Quick too_late_double_endorsement_evidence ; + Test.tztest "different delegates" `Quick different_delegates ; + Test.tztest "wrong delegate" `Quick wrong_delegate ; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/dune b/vendors/ligo-utils/tezos-protocol-alpha/test/dune new file mode 100644 index 000000000..44860d2cd --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/dune @@ -0,0 +1,46 @@ +(executable + (name main) + (libraries tezos-base + tezos-micheline + tezos-protocol-environment + alcotest-lwt + tezos-005-PsBabyM1-test-helpers + tezos-stdlib-unix + bip39 + tezos-protocol-005-PsBabyM1-parameters) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_micheline + -open Tezos_protocol_005_PsBabyM1 + -open Tezos_005_PsBabyM1_test_helpers + ))) + +(alias + (name buildtest) + (package tezos-protocol-005-PsBabyM1-tests) + (deps main.exe)) + +(rule + (copy %{lib:tezos-protocol-005-PsBabyM1-parameters:test-parameters.json} + protocol_parameters.json)) + +; runs only the `Quick tests +(alias + (name runtest_proto_005_PsBabyM1) + (package tezos-protocol-005-PsBabyM1-tests) + (action (run %{exe:main.exe} -v -q))) + +; runs both `Quick and `Slow tests +(alias + (name runtest_slow) + (package tezos-protocol-005-PsBabyM1-tests) + (action (run %{exe:main.exe} -v))) + +(alias + (name runtest) + (package tezos-protocol-005-PsBabyM1-tests) + (deps (alias runtest_proto_005_PsBabyM1))) + +(alias + (name runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/endorsement.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/endorsement.ml new file mode 100644 index 000000000..d8d9444c6 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/endorsement.ml @@ -0,0 +1,441 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Endorsing a block adds an extra layer of confidence to the Tezos's + PoS algorithm. The block endorsing operation must be included in + the following block. Each endorser possess a number of slots + corresponding to their priority. After [preserved_cycles], a reward + is given to the endorser. This reward depends on the priority of + the block that contains the endorsements. *) + +open Protocol +open Alpha_context +open Test_utils +open Test_tez + +(****************************************************************) +(* Utility functions *) +(****************************************************************) + +let get_expected_reward ctxt ~priority ~baker ~endorsing_power = + begin if baker then + Context.get_baking_reward ctxt ~priority ~endorsing_power + else + return (Test_tez.Tez.of_int 0) + end >>=? fun baking_reward -> + Context.get_endorsing_reward ctxt ~priority ~endorsing_power >>=? fun endorsing_reward -> + Test_tez.Tez.(endorsing_reward +? baking_reward) >>?= fun reward -> return reward + +let get_expected_deposit ctxt ~baker ~endorsing_power = + Context.get_constants ctxt >>=? fun Constants. + { parametric = { endorsement_security_deposit ; + block_security_deposit ; _ } ; _ } -> + let open Environment in + let open Tez in + let baking_deposit = if baker then block_security_deposit else of_int 0 in + endorsement_security_deposit *? (Int64.of_int endorsing_power) >>?= fun endorsement_deposit -> + endorsement_deposit +? baking_deposit >>?= fun deposit -> return deposit + +(* [baker] is true if the [pkh] has also baked the current block, in + which case correspoding deposit and reward should be ajusted *) +let assert_endorser_balance_consistency ~loc ?(priority=0) ?(baker=false) ~endorsing_power + ctxt pkh initial_balance = + let contract = Contract.implicit_contract pkh in + get_expected_reward ctxt ~priority ~baker ~endorsing_power >>=? fun reward -> + get_expected_deposit ctxt ~baker ~endorsing_power >>=? fun deposit -> + + Assert.balance_was_debited ~loc ctxt contract initial_balance deposit >>=? fun () -> + Context.Contract.balance ~kind:Rewards ctxt contract >>=? fun reward_balance -> + Assert.equal_tez ~loc reward_balance reward >>=? fun () -> + Context.Contract.balance ~kind:Deposit ctxt contract >>=? fun deposit_balance -> + Assert.equal_tez ~loc deposit_balance deposit + +let delegates_with_slots endorsers = + List.map (fun (endorser: Delegate_services.Endorsing_rights.t) -> + endorser.delegate) + endorsers + +let endorsing_power endorsers = + List.fold_left + (fun sum (endorser: Delegate_services.Endorsing_rights.t) -> + sum + List.length endorser.slots) + 0 endorsers + +(****************************************************************) +(* Tests *) +(****************************************************************) + +(** Apply a single endorsement from the slot 0 endorser *) +let simple_endorsement () = + Context.init 5 >>=? fun (b, _) -> + Context.get_endorser (B b) >>=? fun (delegate, slots) -> + Op.endorsement ~delegate (B b) () >>=? fun op -> + Context.Contract.balance (B b) (Contract.implicit_contract delegate) >>=? fun initial_balance -> + let policy = Block.Excluding [ delegate ] in + Block.get_next_baker ~policy b >>=? fun (_, priority, _) -> + Block.bake + ~policy + ~operations:[Operation.pack op] + b >>=? fun b2 -> + assert_endorser_balance_consistency ~loc:__LOC__ + (B b2) ~priority ~endorsing_power:(List.length slots) + delegate initial_balance + +(** Apply a maximum number of endorsements. An endorser can be + selected twice. *) +let max_endorsement () = + let endorsers_per_block = 16 in + Context.init ~endorsers_per_block 32 >>=? fun (b, _) -> + + Context.get_endorsers (B b) >>=? fun endorsers -> + Assert.equal_int ~loc:__LOC__ + (List.length + (List.concat + (List.map + (fun { Alpha_services.Delegate.Endorsing_rights.slots ; _ } -> slots) + endorsers))) + endorsers_per_block >>=? fun () -> + + fold_left_s (fun (delegates, ops, balances) + (endorser : Alpha_services.Delegate.Endorsing_rights.t) -> + let delegate = endorser.delegate in + Context.Contract.balance (B b) (Contract.implicit_contract delegate) >>=? fun balance -> + Op.endorsement ~delegate (B b) () >>=? fun op -> + return (delegate :: delegates, + Operation.pack op :: ops, + (List.length endorser.slots, balance) :: balances) + ) + ([], [], []) + endorsers >>=? fun (delegates, ops, previous_balances) -> + + Block.bake ~policy:(Excluding delegates) ~operations:(List.rev ops) b >>=? fun b -> + + (* One account can endorse more than one time per level, we must + check that the bonds are summed up *) + iter_s (fun (endorser_account, (endorsing_power, previous_balance)) -> + assert_endorser_balance_consistency ~loc:__LOC__ + (B b) ~endorsing_power endorser_account previous_balance + ) (List.combine delegates previous_balances) + +(** Check every that endorsers' balances are consistent with different priorities *) +let consistent_priorities () = + let priorities = 0 -- 64 in + Context.init 64 >>=? fun (b, _) -> + + fold_left_s (fun (b, used_pkhes) priority -> + (* Choose an endorser that has not baked nor endorsed before *) + Context.get_endorsers (B b) >>=? fun endorsers -> + let endorser = + List.find_opt + (fun (e: Delegate_services.Endorsing_rights.t) -> + not (Signature.Public_key_hash.Set.mem e.delegate used_pkhes) + ) + endorsers in + match endorser with + | None -> return (b, used_pkhes) (* not enough fresh endorsers; we "stop" *) + | Some endorser -> + + Context.Contract.balance (B b) + (Contract.implicit_contract endorser.delegate) >>=? fun balance -> + + Op.endorsement ~delegate:endorser.delegate (B b) () >>=? fun operation -> + let operation = Operation.pack operation in + + Block.get_next_baker ~policy:(By_priority priority) b >>=? fun (baker, _, _) -> + let used_pkhes = Signature.Public_key_hash.Set.add baker used_pkhes in + let used_pkhes = Signature.Public_key_hash.Set.add endorser.delegate used_pkhes in + + (* Bake with a specific priority *) + Block.bake ~policy:(By_priority priority) ~operation b >>=? fun b -> + + let is_baker = Signature.Public_key_hash.(baker = endorser.delegate) in + + assert_endorser_balance_consistency ~loc:__LOC__ ~priority ~baker:is_baker (B b) + ~endorsing_power:(List.length endorser.slots) + endorser.delegate balance >>=? fun () -> + + return (b, used_pkhes) + ) (b, Signature.Public_key_hash.Set.empty) priorities >>=? fun _b -> return_unit + +(** Check that after [preserved_cycles] cycles the endorser gets his reward *) +let reward_retrieval () = + Context.init 5 >>=? fun (b, _) -> + Context.get_constants (B b) >>=? fun Constants. + { parametric = { preserved_cycles ; _ } ; _ } -> + Context.get_endorser (B b) >>=? fun (endorser, slots) -> + Context.Contract.balance (B b) (Contract.implicit_contract endorser) >>=? fun balance -> + Op.endorsement ~delegate:endorser (B b) () >>=? fun operation -> + let operation = Operation.pack operation in + let policy = Block.Excluding [ endorser ] in + Block.get_next_baker ~policy b >>=? fun (_, priority, _) -> + Block.bake ~policy ~operation b >>=? fun b -> + (* Bake (preserved_cycles + 1) cycles *) + fold_left_s (fun b _ -> + Block.bake_until_cycle_end ~policy:(Excluding [ endorser ]) b + ) b (0 -- preserved_cycles) >>=? fun b -> + get_expected_reward (B b) ~priority ~baker:false ~endorsing_power:(List.length slots) >>=? fun reward -> + Assert.balance_was_credited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser) balance reward + +(** Check that after [preserved_cycles] cycles endorsers get their + reward. Two endorsers are used and they endorse in different + cycles. *) +let reward_retrieval_two_endorsers () = + Context.init 5 >>=? fun (b, _) -> + Context.get_constants (B b) >>=? fun Constants. + { parametric = { preserved_cycles ; endorsement_reward ; endorsement_security_deposit ; _ } ; _ } -> + Context.get_endorsers (B b) >>=? fun endorsers -> + let endorser1 = List.hd endorsers in + let endorser2 = List.hd (List.tl endorsers) in + + Context.Contract.balance (B b) (Contract.implicit_contract endorser1.delegate) >>=? fun balance1 -> + Context.Contract.balance (B b) (Contract.implicit_contract endorser2.delegate) >>=? fun balance2 -> + Lwt.return Tez.(endorsement_security_deposit *? Int64.of_int (List.length endorser1.slots)) >>=? fun security_deposit1 -> + + (* endorser1 endorses the genesis block in cycle 0 *) + Op.endorsement ~delegate:endorser1.delegate (B b) () >>=? fun operation1 -> + + let policy = Block.Excluding [ endorser1.delegate ; endorser2.delegate ] in + Block.get_next_baker ~policy b >>=? fun (_, priority, _) -> + Tez.(endorsement_reward /? Int64.(succ (of_int priority))) >>?= fun reward_per_slot -> + Lwt.return Tez.(reward_per_slot *? Int64.of_int (List.length endorser1.slots)) >>=? fun reward1 -> + + (* bake next block, include endorsement of endorser1 *) + Block.bake ~policy ~operation:(Operation.pack operation1) b >>=? fun b -> + Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 security_deposit1 >>=? fun () -> + Assert.balance_is ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 >>=? fun () -> + + (* complete cycle 0 *) + Block.bake_until_cycle_end ~policy b >>=? fun b -> + Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 security_deposit1 >>=? fun () -> + Assert.balance_is ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 >>=? fun () -> + + (* get the slots of endorser2 for the current block *) + Context.get_endorsers (B b) >>=? fun endorsers -> + let same_endorser2 endorser = + Signature.Public_key_hash.(endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate) in + let endorser2 = List.find same_endorser2 endorsers in (* No exception raised: in sandboxed mode endorsers do not change between blocks *) + Lwt.return Tez.(endorsement_security_deposit *? Int64.of_int (List.length endorser2.slots)) >>=? fun security_deposit2 -> + + (* endorser2 endorses the last block in cycle 0 *) + Op.endorsement ~delegate:endorser2.delegate (B b) () >>=? fun operation2 -> + + (* bake first block in cycle 1, include endorsement of endorser2 *) + Block.bake ~policy ~operation:(Operation.pack operation2) b >>=? fun b -> + + let priority = b.header.protocol_data.contents.priority in + Tez.(endorsement_reward /? Int64.(succ (of_int priority))) >>?= fun reward_per_slot -> + Lwt.return Tez.(reward_per_slot *? Int64.of_int (List.length endorser2.slots)) >>=? fun reward2 -> + + Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 security_deposit1 >>=? fun () -> + Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 security_deposit2 >>=? fun () -> + + (* bake [preserved_cycles] cycles *) + fold_left_s (fun b _ -> + Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 security_deposit1 >>=? fun () -> + Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 security_deposit2 >>=? fun () -> + Block.bake_until_cycle_end ~policy b + ) b (1 -- preserved_cycles) >>=? fun b -> + + Assert.balance_was_credited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 reward1 >>=? fun () -> + Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 security_deposit2 >>=? fun () -> + + (* bake cycle [preserved_cycle + 1] *) + Block.bake_until_cycle_end ~policy b >>=? fun b -> + Assert.balance_was_credited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 reward1 >>=? fun () -> + Assert.balance_was_credited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 reward2 + + + +(****************************************************************) +(* The following test scenarios are supposed to raise errors. *) +(****************************************************************) + +(** Wrong endorsement predecessor : apply an endorsement with an + incorrect block predecessor *) +let wrong_endorsement_predecessor () = + Context.init 5 >>=? fun (b, _) -> + + Context.get_endorser (B b) >>=? fun (genesis_endorser, _slots) -> + Block.bake b >>=? fun b' -> + Op.endorsement ~delegate:genesis_endorser ~signing_context:(B b) (B b') () >>=? fun operation -> + let operation = Operation.pack operation in + Block.bake ~operation b' >>= fun res -> + + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Wrong_endorsement_predecessor _ -> true + | _ -> false + end + +(** Invalid_endorsement_level : apply an endorsement with an incorrect + level (i.e. the predecessor level) *) +let invalid_endorsement_level () = + Context.init 5 >>=? fun (b, _) -> + Context.get_level (B b) >>=? fun genesis_level -> + Block.bake b >>=? fun b -> + Op.endorsement ~level:genesis_level (B b) () >>=? fun operation -> + let operation = Operation.pack operation in + Block.bake ~operation b >>= fun res -> + + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Invalid_endorsement_level -> true + | _ -> false + end + +(** Duplicate endorsement : apply an endorsement that has already been done *) +let duplicate_endorsement () = + Context.init 5 >>=? fun (b, _) -> + Incremental.begin_construction b >>=? fun inc -> + Op.endorsement (B b) () >>=? fun operation -> + let operation = Operation.pack operation in + Incremental.add_operation inc operation >>=? fun inc -> + Op.endorsement (B b) () >>=? fun operation -> + let operation = Operation.pack operation in + Incremental.add_operation inc operation >>= fun res -> + + Assert.proto_error ~loc:__LOC__ res begin function + | Apply.Duplicate_endorsement _ -> true + | _ -> false + end + +(** Apply a single endorsement from the slot 0 endorser *) +let not_enough_for_deposit () = + Context.init 5 ~endorsers_per_block:1 >>=? fun (b_init, contracts) -> + Error_monad.map_s (fun c -> + Context.Contract.manager (B b_init) c >>=? fun m -> return (m, c)) contracts >>=? + fun managers -> + Block.bake b_init >>=? fun b -> + (* retrieve the level 2's endorser *) + Context.get_endorser (B b) >>=? fun (endorser, _slots) -> + let _, contract_other_than_endorser = + List.find (fun (c, _) -> not (Signature.Public_key_hash.equal c.Account.pkh endorser)) + managers + in + let _, contract_of_endorser = + List.find (fun (c, _) -> (Signature.Public_key_hash.equal c.Account.pkh endorser)) + managers + in + Context.Contract.balance (B b) + (Contract.implicit_contract endorser) >>=? fun initial_balance -> + (* Empty the future endorser account *) + Op.transaction (B b_init) contract_of_endorser contract_other_than_endorser initial_balance >>=? fun op_trans -> + Block.bake ~operation:op_trans b_init >>=? fun b -> + (* Endorse with a zero balance *) + Op.endorsement ~delegate:endorser (B b) () >>=? fun op_endo -> + Block.bake + ~policy:(Excluding [endorser]) + ~operation:(Operation.pack op_endo) + b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Delegate_storage.Balance_too_low_for_deposit _ -> true + | _ -> false + end + +(* check that a block with not enough endorsement cannot be baked *) +let endorsement_threshold () = + let initial_endorsers = 28 in + let num_accounts = 100 in + Context.init ~initial_endorsers num_accounts >>=? fun (b, _) -> + Context.get_endorsers (B b) >>=? fun endorsers -> + let num_endorsers = List.length endorsers in + + (* we try to bake with more and more endorsers, but at each + iteration with a timestamp smaller than required *) + iter_s (fun i -> + (* the priority is chosen rather arbitrarily *) + let priority = num_endorsers - i in + let crt_endorsers = List.take_n i endorsers in + let endorsing_power = endorsing_power crt_endorsers in + let delegates = delegates_with_slots crt_endorsers in + map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates >>=? fun ops -> + Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> + (* decrease the timestamp by one second *) + let seconds = Int64.(sub (of_string (Timestamp.to_seconds_string timestamp)) 1L) in + match Timestamp.of_seconds (Int64.to_string seconds) with + | None -> failwith "timestamp to/from string manipulation failed" + | Some timestamp -> + Block.bake ~timestamp ~policy:(By_priority priority) + ~operations:(List.map Operation.pack ops) b >>= fun b2 -> + Assert.proto_error ~loc:__LOC__ b2 begin function + | Baking.Timestamp_too_early _ + | Apply.Not_enough_endorsements_for_priority _ -> true + | _ -> false + end) + (0 -- (num_endorsers-1)) >>=? fun () -> + + (* we bake with all endorsers endorsing, at the right time *) + let priority = 0 in + let endorsing_power = endorsing_power endorsers in + let delegates = delegates_with_slots endorsers in + map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates >>=? fun ops -> + Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> + Block.bake + ~policy:(By_priority priority) + ~timestamp + ~operations:(List.map Operation.pack ops) + b >>= fun _ -> return_unit + +let test_fitness_gap () = + let num_accounts = 5 in + Context.init num_accounts >>=? fun (b, _) -> + begin + match Fitness_repr.to_int64 b.header.shell.fitness with + | Ok fitness -> + return (Int64.to_int fitness) + | Error _ -> assert false + end >>=? fun fitness -> + Context.get_endorser (B b) >>=? fun (delegate, _slots) -> + Op.endorsement ~delegate (B b) () >>=? fun op -> + (* bake at priority 0 succeed thanks to enough endorsements *) + Block.bake + ~policy:(By_priority 0) + ~operations:[Operation.pack op] + b >>=? fun b -> + begin + match Fitness_repr.to_int64 b.header.shell.fitness with + | Ok new_fitness -> + return ((Int64.to_int new_fitness) - fitness) + | Error _ -> assert false + end >>=? fun res -> + (* in Emmy+, the fitness increases by 1, so the difference between + the fitness at level 1 and at level 0 is 1, independently if the + number fo endorements (here 1) *) + Assert.equal_int ~loc:__LOC__ res 1 >>=? fun () -> + return_unit + +let tests = [ + Test.tztest "Simple endorsement" `Quick simple_endorsement ; + Test.tztest "Maximum endorsement" `Quick max_endorsement ; + Test.tztest "Consistent priorities" `Quick consistent_priorities ; + Test.tztest "Reward retrieval" `Quick reward_retrieval ; + Test.tztest "Reward retrieval two endorsers" `Quick reward_retrieval_two_endorsers ; + Test.tztest "Endorsement threshold" `Quick endorsement_threshold ; + Test.tztest "Fitness gap" `Quick test_fitness_gap ; + + (* Fail scenarios *) + Test.tztest "Wrong endorsement predecessor" `Quick wrong_endorsement_predecessor ; + Test.tztest "Invalid endorsement level" `Quick invalid_endorsement_level ; + Test.tztest "Duplicate endorsement" `Quick duplicate_endorsement ; + Test.tztest "Not enough for deposit" `Quick not_enough_for_deposit ; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.ml new file mode 100644 index 000000000..985e2b0ec --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.ml @@ -0,0 +1,92 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol + +type t = { + pkh : Signature.Public_key_hash.t ; + pk : Signature.Public_key.t ; + sk : Signature.Secret_key.t ; +} +type account = t + +let known_accounts = Signature.Public_key_hash.Table.create 17 + +let new_account ?seed () = + 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 + +let add_account ({ pkh ; _ } as account) = + Signature.Public_key_hash.Table.add known_accounts pkh account + +let activator_account = new_account () + +let find pkh = + try return (Signature.Public_key_hash.Table.find known_accounts pkh) + with Not_found -> + failwith "Missing account: %a" Signature.Public_key_hash.pp pkh + +let find_alternate pkh = + let exception Found of t in + try + Signature.Public_key_hash.Table.iter + (fun pkh' account -> + if not (Signature.Public_key_hash.equal pkh pkh') then + raise (Found account)) + known_accounts ; + raise Not_found + with Found account -> account + +let dummy_account = new_account () + +let generate_accounts ?(initial_balances = []) n : (t * Tez_repr.t) list = + Signature.Public_key_hash.Table.clear known_accounts ; + let default_amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in + let amount i = match List.nth_opt initial_balances i with + | None -> default_amount + | Some a -> Tez_repr.of_mutez_exn a + in + List.map (fun i -> + let (pkh, pk, sk) = Signature.generate_key () in + let account = { pkh ; pk ; sk } in + Signature.Public_key_hash.Table.add known_accounts pkh account ; + account, amount i) + (0--(n-1)) + +let commitment_secret = + Blinded_public_key_hash.activation_code_of_hex + "aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb" + +let new_commitment ?seed () = + let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in + let unactivated_account = { pkh; pk; sk } in + let open Commitment_repr in + let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in + let bpkh = Blinded_public_key_hash.of_ed25519_pkh commitment_secret pkh in + Lwt.return @@ Environment.wrap_error @@ + Tez_repr.(one *? 4_000L) >>=? fun amount -> + return @@ (unactivated_account, { blinded_public_key_hash = bpkh ; amount }) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.mli b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.mli new file mode 100644 index 000000000..66ef7eb94 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.mli @@ -0,0 +1,57 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol + +type t = { + pkh : Signature.Public_key_hash.t ; + pk : Signature.Public_key.t ; + sk : Signature.Secret_key.t ; +} +type account = t + +val known_accounts: t Signature.Public_key_hash.Table.t + +val activator_account: account +val dummy_account: account + +val new_account: ?seed:MBytes.t -> unit -> account + +val add_account : t -> unit + +val find: Signature.Public_key_hash.t -> t tzresult Lwt.t +val find_alternate: Signature.Public_key_hash.t -> t + +(** [generate_accounts ?initial_balances n] : generates [n] random + accounts with the initial balance of the [i]th account given by the + [i]th value in the list [initial_balances] or otherwise + 4.000.000.000 tz (if the list is too short); and add them to the + global account state *) +val generate_accounts : ?initial_balances:int64 list -> int -> (t * Tez_repr.t) list + +val commitment_secret : Blinded_public_key_hash.activation_code + +val new_commitment : ?seed:MBytes.t -> unit -> + (account * Commitment_repr.t) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/assert.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/assert.ml new file mode 100644 index 000000000..bdfa1b0a8 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/assert.ml @@ -0,0 +1,124 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol + +let error ~loc v f = + match v with + | Error err when List.exists f err -> + return_unit + | Ok _ -> + failwith "Unexpected successful result (%s)" loc + | Error err -> + failwith "@[Unexpected error (%s): %a@]" loc pp_print_error err + +let proto_error ~loc v f = + error ~loc v + (function + | Environment.Ecoproto_error err -> f err + | _ -> false) + +let equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b = + if not (cmp a b) then + failwith "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" loc msg pp a pp b + else + return_unit + +let not_equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b = + if cmp a b then + failwith "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" loc msg pp a pp b + else + return_unit + +(* tez *) +let equal_tez ~loc (a:Alpha_context.Tez.t) (b:Alpha_context.Tez.t) = + let open Alpha_context in + equal ~loc Tez.(=) "Tez aren't equal" Tez.pp a b + +let not_equal_tez ~loc (a:Alpha_context.Tez.t) (b:Alpha_context.Tez.t) = + let open Alpha_context in + not_equal ~loc Tez.(=) "Tez are equal" Tez.pp a b + +(* int *) +let equal_int ~loc (a:int) (b:int) = + equal ~loc (=) "Integers aren't equal" Format.pp_print_int a b + +let not_equal_int ~loc (a:int) (b:int) = + not_equal ~loc (=) "Integers are equal" Format.pp_print_int a b + +(* bool *) +let equal_bool ~loc (a:bool) (b:bool) = + equal ~loc (=) "Booleans aren't equal" Format.pp_print_bool a b + +let not_equal_bool ~loc (a:bool) (b:bool) = + not_equal ~loc (=) "Booleans are equal" Format.pp_print_bool a b + +(* pkh *) +let equal_pkh ~loc (a:Signature.Public_key_hash.t) (b:Signature.Public_key_hash.t) = + let module PKH = Signature.Public_key_hash in + equal ~loc PKH.equal "Public key hashes aren't equal" PKH.pp a b + +let not_equal_pkh ~loc (a:Signature.Public_key_hash.t) (b:Signature.Public_key_hash.t) = + let module PKH = Signature.Public_key_hash in + not_equal ~loc PKH.equal "Public key hashes are equal" PKH.pp a b + +open Context +(* Some asserts for account operations *) + +(** [balance_is b c amount] checks that the current balance of contract [c] is + [amount]. + Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or + [Rewards] for the others. *) +let balance_is ~loc b contract ?(kind = Contract.Main) expected = + Contract.balance b contract ~kind >>=? fun balance -> + equal_tez ~loc balance expected + +(** [balance_was_operated ~operand b c old_balance amount] checks that the + current balance of contract [c] is [operand old_balance amount] and + returns the current balance. + Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or + [Rewards] for the others. *) +let balance_was_operated ~(operand) ~loc b contract ?(kind = Contract.Main) old_balance amount = + operand old_balance amount |> + Environment.wrap_error |> Lwt.return >>=? fun expected -> + balance_is ~loc b contract ~kind expected + +let balance_was_credited = balance_was_operated ~operand:Alpha_context.Tez.(+?) + +let balance_was_debited = balance_was_operated ~operand:Alpha_context.Tez.(-?) + + +(* debug *) + +let print_balances ctxt id = + Contract.balance ~kind:Main ctxt id >>=? fun main -> + Contract.balance ~kind:Deposit ctxt id >>=? fun deposit -> + Contract.balance ~kind:Fees ctxt id >>=? fun fees -> + Contract.balance ~kind:Rewards ctxt id >>|? fun rewards -> + Format.printf "\nMain: %s\nDeposit: %s\nFees: %s\nRewards: %s\n" + (Alpha_context.Tez.to_string main) + (Alpha_context.Tez.to_string deposit) + (Alpha_context.Tez.to_string fees) + (Alpha_context.Tez.to_string rewards) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.ml new file mode 100644 index 000000000..4dcc7f9e8 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.ml @@ -0,0 +1,418 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +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 *) +type t = { + hash : Block_hash.t ; + header : Block_header.t ; + operations : Operation.packed list ; + context : Tezos_protocol_environment.Context.t ; +} +type block = t + +let rpc_context block = { + Environment.Updater.block_hash = block.hash ; + block_header = block.header.shell ; + context = block.context ; +} + +let rpc_ctxt = + new Environment.proto_rpc_context_of_directory + rpc_context rpc_services + +(******** Policies ***********) + +(* Policies are functions that take a block and return a tuple + [(account, level, timestamp)] for the [forge_header] function. *) + +(* This type is used only to provide a simpler interface to the exterior. *) +type baker_policy = + | By_priority of int + | By_account of public_key_hash + | Excluding of public_key_hash list + +let get_next_baker_by_priority priority block = + Alpha_services.Delegate.Baking_rights.get rpc_ctxt + ~all:true + ~max_priority:(priority+1) block >>=? fun bakers -> + let { Alpha_services.Delegate.Baking_rights.delegate = pkh ; + timestamp; _ } = List.find (fun { Alpha_services.Delegate.Baking_rights.priority = p ; _ } -> p = priority) bakers in + return (pkh, priority, Option.unopt_exn (Failure "") timestamp) + +let get_next_baker_by_account pkh block = + Alpha_services.Delegate.Baking_rights.get rpc_ctxt + ~delegates:[pkh] + ~max_priority:256 block >>=? fun bakers -> + let { Alpha_services.Delegate.Baking_rights.delegate = pkh ; + timestamp ; priority ; _ } = List.hd bakers in + return (pkh, priority, Option.unopt_exn (Failure "") timestamp) + +let get_next_baker_excluding excludes block = + Alpha_services.Delegate.Baking_rights.get rpc_ctxt + ~max_priority:256 block >>=? fun bakers -> + let { Alpha_services.Delegate.Baking_rights.delegate = pkh ; + timestamp ; priority ; _ } = + List.find + (fun { Alpha_services.Delegate.Baking_rights.delegate ; _ } -> + not (List.mem delegate excludes)) + bakers in + return (pkh, priority, Option.unopt_exn (Failure "") timestamp) + +let dispatch_policy = function + | By_priority p -> get_next_baker_by_priority p + | By_account a -> get_next_baker_by_account a + | Excluding al -> get_next_baker_excluding al + +let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy + +let get_endorsing_power b = + fold_left_s (fun acc (op: Operation.packed) -> + let Operation_data data = op.protocol_data in + match data.contents with + | Single Endorsement _ -> + Alpha_services.Delegate.Endorsing_power.get + rpc_ctxt b op Chain_id.zero >>=? fun endorsement_power -> + return (acc + endorsement_power) + | _ -> return acc) + 0 b.operations + +module Forge = struct + + type header = { + baker : public_key_hash ; (* the signer of the block *) + shell : Block_header.shell_header ; + contents : Block_header.contents ; + } + + let default_proof_of_work_nonce = + MBytes.create Constants.proof_of_work_nonce_size + + let make_contents + ?(proof_of_work_nonce = default_proof_of_work_nonce) + ~priority ~seed_nonce_hash () = + Block_header.{ priority ; + proof_of_work_nonce ; + seed_nonce_hash } + + let make_shell + ~level ~predecessor ~timestamp ~fitness ~operations_hash = + Tezos_base.Block_header.{ + level ; + predecessor ; + timestamp ; + fitness ; + operations_hash ; + (* We don't care of the following values, only the shell validates them. *) + proto_level = 0 ; + validation_passes = 0 ; + context = Context_hash.zero ; + } + + let set_seed_nonce_hash seed_nonce_hash { baker ; shell ; contents } = + { baker ; shell ; contents = { contents with seed_nonce_hash } } + + let set_baker baker header = { header with baker } + + let sign_header { baker ; shell ; contents } = + Account.find baker >>=? fun delegate -> + let unsigned_bytes = + Data_encoding.Binary.to_bytes_exn + Block_header.unsigned_encoding + (shell, contents) in + let signature = + Signature.sign ~watermark:Signature.(Block_header Chain_id.zero) delegate.sk unsigned_bytes in + Block_header.{ shell ; protocol_data = { contents ; signature } } |> + return + + let forge_header + ?(policy = By_priority 0) + ?timestamp + ?(operations = []) pred = + dispatch_policy policy pred >>=? fun (pkh, priority, _timestamp) -> + Alpha_services.Delegate.Minimal_valid_time.get + rpc_ctxt pred priority 0 >>=? fun expected_timestamp -> + let timestamp = Option.unopt ~default:expected_timestamp timestamp in + let level = Int32.succ pred.header.shell.level in + begin + match Fitness_repr.to_int64 pred.header.shell.fitness with + | Ok old_fitness -> + return (Fitness_repr.from_int64 + (Int64.add (Int64.of_int 1) old_fitness)) + | Error _ -> assert false + end >>=? fun fitness -> + begin + Alpha_services.Helpers.current_level ~offset:1l (rpc_ctxt) pred >>|? function + | { expected_commitment = true ; _ } -> Some (fst (Proto_Nonce.generate ())) + | { expected_commitment = false ; _ } -> None + end >>=? fun seed_nonce_hash -> + let hashes = List.map Operation.hash_packed operations in + let operations_hash = Operation_list_list_hash.compute + [Operation_list_hash.compute hashes] in + let shell = make_shell ~level ~predecessor:pred.hash + ~timestamp ~fitness ~operations_hash in + let contents = make_contents ~priority ~seed_nonce_hash () in + return { baker = pkh ; shell ; contents } + + (* compatibility only, needed by incremental *) + let contents + ?(proof_of_work_nonce = default_proof_of_work_nonce) + ?(priority = 0) ?seed_nonce_hash () = + { + Block_header.priority ; + proof_of_work_nonce ; + seed_nonce_hash ; + } + +end + +(********* Genesis creation *************) + +(* Hard-coded context key *) +let protocol_param_key = [ "protocol_parameters" ] + +let check_constants_consistency constants = + let open Constants_repr in + let { blocks_per_cycle ; blocks_per_commitment ; + blocks_per_roll_snapshot ; _ } = constants in + Error_monad.unless (blocks_per_commitment <= blocks_per_cycle) + (fun () -> failwith "Inconsistent constants : blocks per commitment must be \ + less than blocks per cycle") >>=? fun () -> + Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot) + (fun () -> failwith "Inconsistent constants : blocks per cycle \ + must be superior than blocks per roll snapshot") >>=? + return + +let initial_context + ?(with_commitments = false) + constants + header + initial_accounts + = + let open Tezos_protocol_005_PsBabyM1_parameters in + let bootstrap_accounts = + List.map (fun (Account.{ pk ; pkh ; _ }, amount) -> + Default_parameters.make_bootstrap_account (pkh, pk, amount) + ) initial_accounts + in + + let parameters = + Default_parameters.parameters_of_constants + ~bootstrap_accounts + ~with_commitments + constants in + let json = Default_parameters.json_of_parameters parameters in + let proto_params = + Data_encoding.Binary.to_bytes_exn Data_encoding.json json + in + Tezos_protocol_environment.Context.( + let empty = Memory_context.empty in + set empty ["version"] (MBytes.of_string "genesis") >>= fun ctxt -> + set ctxt protocol_param_key proto_params + ) >>= fun ctxt -> + Main.init ctxt header + >|= Environment.wrap_error >>=? fun { context; _ } -> + return context + +let genesis_with_parameters parameters = + let hash = + Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" + in + let shell = Forge.make_shell + ~level:0l + ~predecessor:hash + ~timestamp:Time.Protocol.epoch + ~fitness: (Fitness_repr.from_int64 0L) + ~operations_hash: Operation_list_list_hash.zero in + let contents = Forge.make_contents + ~priority:0 + ~seed_nonce_hash:None () in + let open Tezos_protocol_005_PsBabyM1_parameters in + let json = Default_parameters.json_of_parameters parameters in + let proto_params = + Data_encoding.Binary.to_bytes_exn Data_encoding.json json + in + Tezos_protocol_environment.Context.( + let empty = Memory_context.empty in + set empty ["version"] (MBytes.of_string "genesis") >>= fun ctxt -> + set ctxt protocol_param_key proto_params + ) >>= fun ctxt -> + Main.init ctxt shell + >|= Environment.wrap_error >>=? fun { context; _ } -> + let block = { hash ; + header = { shell ; + protocol_data = { + contents = contents ; + signature = Signature.zero ; + } } ; + operations = [] ; + context ; + } in + return block + +(* if no parameter file is passed we check in the current directory + where the test is run *) +let genesis + ?with_commitments + ?endorsers_per_block + ?initial_endorsers + ?min_proposal_quorum + (initial_accounts : (Account.t * Tez_repr.t) list) + = + if initial_accounts = [] then + Pervasives.failwith "Must have one account with a roll to bake"; + + let open Tezos_protocol_005_PsBabyM1_parameters in + let constants = Default_parameters.constants_test in + let endorsers_per_block = + Option.unopt ~default:constants.endorsers_per_block endorsers_per_block in + let initial_endorsers = + Option.unopt ~default:constants.initial_endorsers initial_endorsers in + let min_proposal_quorum = + Option.unopt ~default:constants.min_proposal_quorum min_proposal_quorum in + let constants = { constants with endorsers_per_block ; initial_endorsers ; min_proposal_quorum } in + + (* Check there is at least one roll *) + begin try + let open Test_utils in + fold_left_s (fun acc (_, amount) -> + Environment.wrap_error @@ + Tez_repr.(+?) acc amount >>?= fun acc -> + if acc >= constants.tokens_per_roll then + raise Exit + else return acc + ) Tez_repr.zero initial_accounts >>=? fun _ -> + failwith "Insufficient tokens in initial accounts to create one roll" + with Exit -> return_unit + end >>=? fun () -> + + check_constants_consistency constants >>=? fun () -> + + let hash = + Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" + in + let shell = Forge.make_shell + ~level:0l + ~predecessor:hash + ~timestamp:Time.Protocol.epoch + ~fitness: (Fitness_repr.from_int64 0L) + ~operations_hash: Operation_list_list_hash.zero in + let contents = Forge.make_contents + ~priority:0 + ~seed_nonce_hash:None () in + initial_context + ?with_commitments + constants + shell + initial_accounts + >>=? fun context -> + let block = + { hash ; + header = { + shell = shell ; + protocol_data = { + contents = contents ; + signature = Signature.zero ; + } ; + }; + operations = [] ; + context ; + } + in + return block + +(********* Baking *************) + +let apply header ?(operations = []) pred = + begin + let open Environment.Error_monad in + Main.begin_application + ~chain_id: Chain_id.zero + ~predecessor_context: pred.context + ~predecessor_fitness: pred.header.shell.fitness + ~predecessor_timestamp: pred.header.shell.timestamp + header >>=? fun vstate -> + fold_left_s + (fun vstate op -> + apply_operation vstate op >>=? fun (state, _result) -> + return state) + vstate operations >>=? fun vstate -> + Main.finalize_block vstate >>=? fun (validation, _result) -> + return validation.context + end >|= Environment.wrap_error >>|? fun context -> + let hash = Block_header.hash header in + { hash ; header ; operations ; context } + +let bake ?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 + in + Forge.forge_header ?timestamp ?policy ?operations pred >>=? fun header -> + Forge.sign_header header >>=? fun header -> + apply header ?operations pred + +(********** Cycles ****************) + +(* This function is duplicated from Context to avoid a cyclic dependency *) +let get_constants b = + Alpha_services.Constants.all rpc_ctxt b + +let bake_n ?policy n b = + Error_monad.fold_left_s + (fun b _ -> bake ?policy b) b (1 -- n) + +let bake_until_cycle_end ?policy b = + get_constants b >>=? fun Constants.{ parametric = { blocks_per_cycle ; _ } ; _ } -> + let current_level = b.header.shell.level in + let current_level = Int32.rem current_level blocks_per_cycle in + let delta = Int32.sub blocks_per_cycle current_level in + bake_n ?policy (Int32.to_int delta) b + +let bake_until_n_cycle_end ?policy n b = + Error_monad.fold_left_s + (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) + +let bake_until_cycle ?policy cycle (b:t) = + get_constants b >>=? fun Constants.{ parametric = { blocks_per_cycle ; _ } ; _ } -> + let rec loop (b:t) = + let current_cycle = + let current_level = b.header.shell.level in + let current_cycle = Int32.div current_level blocks_per_cycle in + current_cycle + in + if Int32.equal (Cycle.to_int32 cycle) current_cycle then + return b + else + bake_until_cycle_end ?policy b >>=? fun b -> + loop b + in + loop b diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.mli b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.mli new file mode 100644 index 000000000..9b93f09ef --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.mli @@ -0,0 +1,137 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context + +type t = { + hash : Block_hash.t ; + header : Block_header.t ; + operations : Operation.packed list ; + context : Tezos_protocol_environment.Context.t ; (** Resulting context *) +} +type block = t + +val rpc_ctxt: t Environment.RPC_context.simple + +(** Policies to select the next baker: + - [By_priority p] selects the baker at priority [p] + - [By_account pkh] selects the first slot for baker [pkh] + - [Excluding pkhs] selects the first baker that doesn't belong to [pkhs] +*) +type baker_policy = + | By_priority of int + | By_account of public_key_hash + | Excluding of public_key_hash list + +(** Returns (account, priority, timestamp) of the next baker given + a policy, defaults to By_priority 0. *) +val get_next_baker: + ?policy:baker_policy -> + t -> (public_key_hash * int * Time.Protocol.t) tzresult Lwt.t + +val get_endorsing_power: block -> int tzresult Lwt.t + +module Forge : sig + + val contents: + ?proof_of_work_nonce:MBytes.t -> + ?priority:int -> + ?seed_nonce_hash: Nonce_hash.t -> + unit -> Block_header.contents + + type header + + (** Forges a correct header following the policy. + The header can then be modified and applied with [apply]. *) + val forge_header: + ?policy:baker_policy -> + ?timestamp: Timestamp.time -> + ?operations: Operation.packed list -> + t -> header tzresult Lwt.t + + (** Sets uniquely seed_nonce_hash of a header *) + val set_seed_nonce_hash: + Nonce_hash.t option -> header -> header + + (** Sets the baker that will sign the header to an arbitrary pkh *) + val set_baker: + public_key_hash -> header -> header + + (** Signs the header with the key of the baker configured in the header. + The header can no longer be modified, only applied. *) + val sign_header: + header -> + Block_header.block_header tzresult Lwt.t + +end + +(** [genesis accounts] : generates an initial block with the + given constants [] and initializes [accounts] with their + associated amounts. +*) +val genesis: + ?with_commitments:bool -> + ?endorsers_per_block:int -> + ?initial_endorsers: int -> + ?min_proposal_quorum: int32 -> + (Account.t * Tez_repr.tez) list -> block tzresult Lwt.t + +val genesis_with_parameters: Parameters_repr.t -> block tzresult Lwt.t + +(** Applies a signed header and its operations to a block and + obtains a new block *) +val apply: + Block_header.block_header -> + ?operations: Operation.packed list -> + t -> t tzresult Lwt.t + +(** + [bake b] returns a block [b'] which has as predecessor block [b]. + Optional parameter [policy] allows to pick the next baker in several ways. + This function bundles together [forge_header], [sign_header] and [apply]. + These functions should be used instead of bake to craft unusual blocks for + testing together with setters for properties of the headers. + For examples see seed.ml or double_baking.ml +*) +val bake: + ?policy: baker_policy -> + ?timestamp: Timestamp.time -> + ?operation: Operation.packed -> + ?operations: Operation.packed list -> + t -> t tzresult Lwt.t + +(** Bakes [n] blocks. *) +val bake_n : ?policy:baker_policy -> int -> t -> block tzresult Lwt.t + +(** Given a block [b] at level [l] bakes enough blocks to complete a cycle, + that is [blocks_per_cycle - (l % blocks_per_cycle)]. *) +val bake_until_cycle_end : ?policy:baker_policy -> t -> t tzresult Lwt.t + +(** Bakes enough blocks to end [n] cycles. *) +val bake_until_n_cycle_end : ?policy:baker_policy -> int -> t -> t tzresult Lwt.t + +(** Bakes enough blocks to reach the cycle. *) +val bake_until_cycle : ?policy:baker_policy -> Cycle.t -> t -> t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.ml new file mode 100644 index 000000000..720e37fa7 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.ml @@ -0,0 +1,285 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context + +type t = + | B of Block.t + | I of Incremental.t + +let branch = function + | B b -> b.hash + | I i -> (Incremental.predecessor i).hash + +let level = function + | B b -> b.header.shell.level + | I i -> (Incremental.level i) + +let get_level ctxt = + level ctxt + |> Raw_level.of_int32 + |> Environment.wrap_error + |> Lwt.return + +let rpc_ctxt = object + method call_proto_service0 : + 'm 'q 'i 'o. + ([< RPC_service.meth ] as 'm, Environment.RPC_context.t, Environment.RPC_context.t, 'q, 'i, 'o) RPC_service.t -> + t -> 'q -> 'i -> 'o tzresult Lwt.t = + fun s pr q i -> + match pr with + | B b -> Block.rpc_ctxt#call_proto_service0 s b q i + | I b -> Incremental.rpc_ctxt#call_proto_service0 s b q i + method call_proto_service1 : + 'm 'a 'q 'i 'o. + ([< RPC_service.meth ] as 'm, Environment.RPC_context.t, Environment.RPC_context.t * 'a, 'q, 'i, 'o) RPC_service.t -> + t -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t = + fun s pr a q i -> + match pr with + | B bl -> Block.rpc_ctxt#call_proto_service1 s bl a q i + | I bl -> Incremental.rpc_ctxt#call_proto_service1 s bl a q i + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ([< RPC_service.meth ] as 'm, Environment.RPC_context.t, (Environment.RPC_context.t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + t -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t = + fun s pr a b q i -> + match pr with + | B bl -> Block.rpc_ctxt#call_proto_service2 s bl a b q i + | I bl -> Incremental.rpc_ctxt#call_proto_service2 s bl a b q i + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ([< RPC_service.meth ] as 'm, Environment.RPC_context.t, ((Environment.RPC_context.t * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> + t -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t = + fun s pr a b c q i -> + match pr with + | B bl -> Block.rpc_ctxt#call_proto_service3 s bl a b c q i + | I bl -> Incremental.rpc_ctxt#call_proto_service3 s bl a b c q i +end + +let get_endorsers ctxt = + Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt + +let get_endorser ctxt = + Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt >>=? fun endorsers -> + let endorser = List.hd endorsers in + return (endorser.delegate, endorser.slots) + +let get_bakers ctxt = + Alpha_services.Delegate.Baking_rights.get + ~max_priority:256 + rpc_ctxt ctxt >>=? fun bakers -> + return (List.map + (fun p -> p.Alpha_services.Delegate.Baking_rights.delegate) + bakers) + +let get_seed_nonce_hash ctxt = + let header = + match ctxt with + | B { header ; _ } -> header + | I i -> Incremental.header i in + match header.protocol_data.contents.seed_nonce_hash with + | None -> failwith "No committed nonce" + | Some hash -> return hash + +let get_seed ctxt = Alpha_services.Seed.get rpc_ctxt ctxt + +let get_constants ctxt = + Alpha_services.Constants.all rpc_ctxt ctxt + +let get_minimal_valid_time ctxt ~priority ~endorsing_power = + Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt ctxt priority endorsing_power + + +let get_baking_reward ctxt ~priority ~endorsing_power = + get_constants ctxt >>=? fun Constants. + { parametric = { block_reward ; endorsers_per_block ; _ } ; _ } -> + let prio_factor_denominator = Int64.(succ (of_int priority)) in + let endo_factor_numerator = Int64.of_int (8 + 2 * endorsing_power / endorsers_per_block) in + let endo_factor_denominator = 10L in + Lwt.return + Test_tez.Tez.( + block_reward *? endo_factor_numerator >>? fun val1 -> + val1 /? endo_factor_denominator >>? fun val2 -> + val2 /? prio_factor_denominator) + +let get_endorsing_reward ctxt ~priority ~endorsing_power = + get_constants ctxt >>=? fun Constants. + { parametric = { endorsement_reward ; _ } ; _ } -> + let open Test_utils in + Test_tez.Tez.( + endorsement_reward /? Int64.(succ (of_int priority)) >>?= fun reward_per_slot -> + reward_per_slot *? (Int64.of_int endorsing_power) >>?= fun reward -> + return reward) + + +(* Voting *) + +module Vote = struct + + let get_ballots ctxt = + Alpha_services.Voting.ballots rpc_ctxt ctxt + + let get_ballot_list ctxt = + Alpha_services.Voting.ballot_list rpc_ctxt ctxt + + let get_voting_period ctxt = + Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt >>=? fun l -> + return l.voting_period + + let get_voting_period_position ctxt = + Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt >>=? fun l -> + return l.voting_period_position + + let get_current_period_kind ctxt = + Alpha_services.Voting.current_period_kind rpc_ctxt ctxt + + let get_current_quorum ctxt = + Alpha_services.Voting.current_quorum rpc_ctxt ctxt + + let get_listings ctxt = + Alpha_services.Voting.listings rpc_ctxt ctxt + + let get_proposals ctxt = + Alpha_services.Voting.proposals rpc_ctxt ctxt + + let get_current_proposal ctxt = + Alpha_services.Voting.current_proposal rpc_ctxt ctxt + + let get_protocol (b:Block.t) = + Tezos_protocol_environment.Context.get b.context ["protocol"] >>= function + | None -> assert false + | Some p -> Lwt.return (Protocol_hash.of_bytes_exn p) + + let get_participation_ema (b:Block.t) = + Environment.Context.get b.context ["votes"; "participation_ema"] >>= function + | None -> assert false + | Some bytes -> return (MBytes.get_int32 bytes 0) + + let set_participation_ema (b:Block.t) ema = + let bytes = MBytes.make 4 '\000' in + MBytes.set_int32 bytes 0 ema ; + Environment.Context.set b.context + ["votes"; "participation_ema"] bytes >>= fun context -> + Lwt.return { b with context } + +end + +module Contract = struct + + let pp = Alpha_context.Contract.pp + + let pkh c = Alpha_context.Contract.is_implicit c |> function + | Some p -> return p + | None -> failwith "pkh: only for implicit contracts" + + type balance_kind = Main | Deposit | Fees | Rewards + + let balance ?(kind = Main) ctxt contract = + begin match kind with + | Main -> + Alpha_services.Contract.balance rpc_ctxt ctxt contract + | _ -> + match Alpha_context.Contract.is_implicit contract with + | None -> + invalid_arg + "get_balance: no frozen accounts for an originated contract." + | Some pkh -> + Alpha_services.Delegate.frozen_balance_by_cycle + rpc_ctxt ctxt pkh >>=? fun map -> + Lwt.return @@ + Cycle.Map.fold + (fun _cycle { Delegate.deposit ; fees ; rewards } acc -> + acc >>?fun acc -> + match kind with + | Deposit -> Test_tez.Tez.(acc +? deposit) + | Fees -> Test_tez.Tez.(acc +? fees) + | Rewards -> Test_tez.Tez.(acc +? rewards) + | _ -> assert false) + map + (Ok Tez.zero) + end + + let counter ctxt contract = + match Contract.is_implicit contract with + | None -> invalid_arg "Helpers.Context.counter" + | Some mgr -> + Alpha_services.Contract.counter rpc_ctxt ctxt mgr + + let manager _ contract = + match Contract.is_implicit contract with + | None -> invalid_arg "Helpers.Context.manager" + | Some pkh -> Account.find pkh + + let is_manager_key_revealed ctxt contract = + match Contract.is_implicit contract with + | None -> invalid_arg "Helpers.Context.is_manager_key_revealed" + | Some mgr -> + Alpha_services.Contract.manager_key rpc_ctxt ctxt mgr >>=? fun res -> + return (res <> None) + + let delegate ctxt contract = + Alpha_services.Contract.delegate rpc_ctxt ctxt contract + + let delegate_opt ctxt contract = + Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract + +end + +module Delegate = struct + + type info = Delegate_services.info = { + balance: Tez.t ; + frozen_balance: Tez.t ; + frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; + staking_balance: Tez.t ; + delegated_contracts: Contract_repr.t list ; + delegated_balance: Tez.t ; + deactivated: bool ; + grace_period: Cycle.t ; + } + + let info ctxt pkh = + Alpha_services.Delegate.info rpc_ctxt ctxt pkh + +end + +let init + ?endorsers_per_block + ?with_commitments + ?(initial_balances = []) + ?initial_endorsers + ?min_proposal_quorum + n = + let accounts = Account.generate_accounts ~initial_balances n in + let contracts = List.map (fun (a, _) -> + Alpha_context.Contract.implicit_contract Account.(a.pkh)) accounts in + Block.genesis + ?endorsers_per_block + ?with_commitments + ?initial_endorsers + ?min_proposal_quorum + accounts >>=? fun blk -> + return (blk, contracts) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.mli b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.mli new file mode 100644 index 000000000..28805d0d1 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.mli @@ -0,0 +1,119 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Environment + +type t = + | B of Block.t + | I of Incremental.t + +val branch: t -> Block_hash.t + +val get_level: t -> Raw_level.t tzresult Lwt.t + +val get_endorsers: t -> Alpha_services.Delegate.Endorsing_rights.t list tzresult Lwt.t + +val get_endorser: t -> (public_key_hash * int list) tzresult Lwt.t + +val get_bakers: t -> public_key_hash list tzresult Lwt.t + +val get_seed_nonce_hash: t -> Nonce_hash.t tzresult Lwt.t + +(** Returns the seed of the cycle to which the block belongs to. *) +val get_seed: t -> Seed.seed tzresult Lwt.t + +(** Returns all the constants of the protocol *) +val get_constants: t -> Constants.t tzresult Lwt.t + +val get_minimal_valid_time: t -> priority:int -> endorsing_power:int -> Time.t tzresult Lwt.t + +val get_baking_reward: t -> priority:int -> endorsing_power:int -> Tez.t tzresult Lwt.t + +val get_endorsing_reward: t -> priority:int -> endorsing_power:int -> Tez.t tzresult Lwt.t + +module Vote : sig + val get_ballots: t -> Vote.ballots tzresult Lwt.t + val get_ballot_list: t -> (Signature.Public_key_hash.t * Vote.ballot) list tzresult Lwt.t + val get_voting_period: t -> Voting_period.t tzresult Lwt.t + val get_voting_period_position: t -> Int32.t tzresult Lwt.t + val get_current_period_kind: t -> Voting_period.kind tzresult Lwt.t + val get_current_quorum: t -> Int32.t tzresult Lwt.t + val get_participation_ema: Block.t -> Int32.t tzresult Lwt.t + val get_listings: t -> (Signature.Public_key_hash.t * int32) list tzresult Lwt.t + val get_proposals: t -> Int32.t Protocol_hash.Map.t tzresult Lwt.t + val get_current_proposal: t -> Protocol_hash.t option tzresult Lwt.t + val get_protocol : Block.t -> Protocol_hash.t Lwt.t + val set_participation_ema : Block.t -> int32 -> Block.t Lwt.t +end + +module Contract : sig + + val pp : Format.formatter -> Contract.t -> unit + val pkh: Contract.t -> public_key_hash tzresult Lwt.t + + type balance_kind = Main | Deposit | Fees | Rewards + + (** Returns the balance of a contract, by default the main balance. + If the contract is implicit the frozen balances are available too: + deposit, fees or rewards. *) + val balance: ?kind:balance_kind -> t -> Contract.t -> Tez.t tzresult Lwt.t + + val counter: t -> Contract.t -> Z.t tzresult Lwt.t + val manager: t -> Contract.t -> Account.t tzresult Lwt.t + val is_manager_key_revealed: t -> Contract.t -> bool tzresult Lwt.t + + val delegate: t -> Contract.t -> public_key_hash tzresult Lwt.t + val delegate_opt: t -> Contract.t -> public_key_hash option tzresult Lwt.t + +end + +module Delegate : sig + + type info = Delegate_services.info = { + balance: Tez.t ; + frozen_balance: Tez.t ; + frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; + staking_balance: Tez.t ; + delegated_contracts: Contract_repr.t list ; + delegated_balance: Tez.t ; + deactivated: bool ; + grace_period: Cycle.t ; + } + + val info: t -> public_key_hash -> Delegate_services.info tzresult Lwt.t + +end + +(** [init n] : returns an initial block with [n] initialized accounts + and the associated implicit contracts *) +val init: + ?endorsers_per_block: int -> + ?with_commitments: bool -> + ?initial_balances: int64 list -> + ?initial_endorsers: int -> + ?min_proposal_quorum: int32 -> + int -> (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/dune b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/dune new file mode 100644 index 000000000..164b3df2c --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/dune @@ -0,0 +1,19 @@ +(library + (name tezos_005_PsBabyM1_test_helpers) + (public_name tezos-005-PsBabyM1-test-helpers) + (libraries tezos-base + tezos-stdlib-unix + tezos-shell-services + tezos-protocol-environment + tezos-protocol-005-PsBabyM1 + tezos-protocol-005-PsBabyM1-parameters) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_micheline + -open Tezos_stdlib_unix + -open Tezos_protocol_005_PsBabyM1 + -open Tezos_shell_services))) + +(alias + (name runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/incremental.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/incremental.ml new file mode 100644 index 000000000..3365ade0f --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/incremental.ml @@ -0,0 +1,188 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context + +type t = { + predecessor: Block.t ; + state: validation_state ; + rev_operations: Operation.packed list ; + rev_tickets: operation_receipt list ; + header: Block_header.t ; + delegate: Account.t ; +} +type incremental = t + +let predecessor { predecessor ; _ } = predecessor +let header { header ; _ } = header +let rev_tickets { rev_tickets ; _ } = rev_tickets +let level st = st.header.shell.level + +let rpc_context st = + let result = Alpha_context.finalize st.state.ctxt in + { + Environment.Updater.block_hash = Block_hash.zero ; + block_header = { st.header.shell with fitness = result.fitness } ; + context = result.context ; + } + +let rpc_ctxt = + new Environment.proto_rpc_context_of_directory + rpc_context rpc_services + +let begin_construction ?(priority=0) ?timestamp ?seed_nonce_hash + ?(policy=Block.By_priority priority) (predecessor : Block.t) = + Block.get_next_baker ~policy + predecessor >>=? fun (delegate, priority, _timestamp) -> + Alpha_services.Delegate.Minimal_valid_time.get + Block.rpc_ctxt predecessor priority 0 >>=? fun real_timestamp -> + Account.find delegate >>=? fun delegate -> + let timestamp = Option.unopt ~default:real_timestamp timestamp in + let contents = Block.Forge.contents ~priority ?seed_nonce_hash () in + let protocol_data = { + Block_header.contents ; + signature = Signature.zero ; + } in + let header = { + Block_header.shell = { + predecessor = predecessor.hash ; + proto_level = predecessor.header.shell.proto_level ; + validation_passes = predecessor.header.shell.validation_passes ; + fitness = predecessor.header.shell.fitness ; + timestamp ; + level = predecessor.header.shell.level ; + context = Context_hash.zero ; + operations_hash = Operation_list_list_hash.zero ; + } ; + protocol_data = { + contents ; + signature = Signature.zero ; + } ; + } in + begin_construction + ~chain_id: Chain_id.zero + ~predecessor_context: predecessor.context + ~predecessor_timestamp: predecessor.header.shell.timestamp + ~predecessor_fitness: predecessor.header.shell.fitness + ~predecessor_level: predecessor.header.shell.level + ~predecessor:predecessor.hash + ~timestamp + ~protocol_data + () >>= fun state -> + Lwt.return (Environment.wrap_error state) + >>=? fun state -> + return { + predecessor ; + state ; + rev_operations = [] ; + rev_tickets = [] ; + header ; + delegate ; + } + +let detect_script_failure : + type kind. kind Apply_results.operation_metadata -> _ = + let rec detect_script_failure : + type kind. kind Apply_results.contents_result_list -> _ = + let open Apply_results in + let detect_script_failure_single + (type kind) + (Manager_operation_result { operation_result ; + internal_operation_results ; _ } + : kind Kind.manager Apply_results.contents_result) = + let detect_script_failure (type kind) (result : kind manager_operation_result) = + match result with + | Applied _ -> Ok () + | Skipped _ -> assert false + | Backtracked (_, None) -> + (* there must be another error for this to happen *) + Ok () + | Backtracked (_, Some errs) -> + Environment.wrap_error (Error errs) + | Failed (_, errs) -> + Environment.wrap_error (Error errs) in + List.fold_left + (fun acc (Internal_operation_result (_, r)) -> + acc >>? fun () -> + detect_script_failure r) + (detect_script_failure operation_result) + internal_operation_results in + function + | Single_result (Manager_operation_result _ as res) -> + detect_script_failure_single res + | Single_result _ -> + Ok () + | Cons_result (res, rest) -> + detect_script_failure_single res >>? fun () -> + detect_script_failure rest in + fun { contents } -> detect_script_failure contents + +let add_operation ?expect_failure st op = + let open Apply_results in + apply_operation st.state op >>= fun x -> + Lwt.return (Environment.wrap_error x) + >>=? function + | state, (Operation_metadata result as metadata) -> + Lwt.return @@ detect_script_failure result >>= fun result -> + begin match expect_failure with + | None -> + Lwt.return result + | Some f -> + match result with + | Ok _ -> + failwith "Error expected while adding operation" + | Error e -> + f e + end >>=? fun () -> + return { st with state ; rev_operations = op :: st.rev_operations ; + rev_tickets = metadata :: st.rev_tickets } + | state, (No_operation_metadata as metadata) -> + return { st with state ; rev_operations = op :: st.rev_operations ; + rev_tickets = metadata :: st.rev_tickets } + +let finalize_block st = + finalize_block st.state >>= fun x -> + Lwt.return (Environment.wrap_error x) + >>=? fun (result, _) -> + let operations = List.rev st.rev_operations in + let operations_hash = + Operation_list_list_hash.compute [ + Operation_list_hash.compute (List.map Operation.hash_packed operations) + ] in + let header = + { st.header with + shell = { + st.header.shell with + level = Int32.succ st.header.shell.level ; + operations_hash ; fitness = result.fitness ; + } } in + let hash = Block_header.hash header in + return { + Block.hash ; + header ; + operations ; + context = result.context ; + } diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/incremental.mli b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/incremental.mli new file mode 100644 index 000000000..e5d95fc33 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/incremental.mli @@ -0,0 +1,51 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context + +type t +type incremental = t + +val predecessor: incremental -> Block.t +val header: incremental -> Block_header.t +val rev_tickets: incremental -> operation_receipt list +val level: incremental -> int32 + +val begin_construction: + ?priority:int -> + ?timestamp:Time.Protocol.t -> + ?seed_nonce_hash: Nonce_hash.t -> + ?policy:Block.baker_policy -> + Block.t -> + incremental tzresult Lwt.t + +val add_operation: + ?expect_failure:(error list -> unit tzresult Lwt.t) -> + incremental -> Operation.packed -> incremental tzresult Lwt.t + +val finalize_block: incremental -> Block.t tzresult Lwt.t + +val rpc_ctxt: incremental Environment.RPC_context.simple diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/nonce.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/nonce.ml new file mode 100644 index 000000000..7912ecb6f --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/nonce.ml @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc.< contact@tezos.com > *) +(* *) +(* All rights reserved.No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Protocol + +module Table = Hashtbl.Make(struct + type t = Nonce_hash.t + let hash h = + Int32.to_int (MBytes.get_int32 (Nonce_hash.to_bytes h) 0) + let equal = Nonce_hash.equal + end) + +let known_nonces = Table.create 17 + +let generate () = + match + Alpha_context.Nonce.of_bytes @@ + Rand.generate Alpha_context.Constants.nonce_length + with + | Ok nonce -> + let hash = Alpha_context.Nonce.hash nonce in + Table.add known_nonces hash nonce ; + (hash, nonce) + | Error _ -> assert false + +let forget_all () = Table.clear known_nonces +let get hash = Table.find known_nonces hash diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/nonce.mli b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/nonce.mli new file mode 100644 index 000000000..c958bfd36 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/nonce.mli @@ -0,0 +1,31 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol + +(** Returns a fresh nonce and its corresponding hash (and stores them). *) +val generate: unit -> Nonce_hash.t * Alpha_context.Nonce.t +val get: Nonce_hash.t -> Alpha_context.Nonce.t +val forget_all: unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/op.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/op.ml new file mode 100644 index 000000000..33c6648f6 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/op.ml @@ -0,0 +1,337 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context + +let sign ?(watermark = Signature.Generic_operation) + sk ctxt contents = + let branch = Context.branch ctxt in + let unsigned = + Data_encoding.Binary.to_bytes_exn + Operation.unsigned_encoding + ({ branch }, Contents_list contents) in + let signature = Some (Signature.sign ~watermark sk unsigned) in + ({ shell = { branch } ; + protocol_data = { + contents ; + signature ; + } ; + } : _ Operation.t) + +let endorsement ?delegate ?level ctxt ?(signing_context = ctxt) () = + begin + match delegate with + | None -> + Context.get_endorser ctxt >>=? fun (delegate, _slots) -> + return delegate + | Some delegate -> return delegate + end >>=? fun delegate_pkh -> + Account.find delegate_pkh >>=? fun delegate -> + begin + match level with + | None -> Context.get_level ctxt + | Some level -> return level + end >>=? fun level -> + let op = Single (Endorsement { level }) in + return (sign ~watermark:Signature.(Endorsement Chain_id.zero) delegate.sk signing_context op) + +let sign ?watermark sk ctxt (Contents_list contents) = + Operation.pack (sign ?watermark sk ctxt contents) + +let combine_operations + ?public_key + ?counter + ~source ctxt + (packed_operations : packed_operation list) = + assert (List.length packed_operations > 0); + (* Hypothesis : each operation must have the same branch (is this really true?) *) + let { Tezos_base.Operation.branch } = (List.hd packed_operations).shell in + assert (List.for_all + (fun { shell = { Tezos_base.Operation.branch = b ; _} ; _} -> Block_hash.(branch = b)) + packed_operations) ; + (* TODO? : check signatures consistency *) + let unpacked_operations = + List.map (function + | ({ Alpha_context.protocol_data = Operation_data { contents ; _ } ; _ } ) -> + match Contents_list contents with + | Contents_list (Single o) -> Contents o + | Contents_list (Cons + ((Manager_operation { operation = Reveal _ ; _ }) + , (Single o))) -> Contents o + | _ -> (* TODO : decent error *) assert false + ) packed_operations in + begin match counter with + | Some counter -> return counter + | None -> Context.Contract.counter ctxt source + end >>=? fun counter -> + (* We increment the counter *) + let counter = Z.succ counter in + Context.Contract.manager ctxt source >>=? fun account -> + let public_key = Option.unopt ~default:account.pk public_key in + begin Context.Contract.is_manager_key_revealed ctxt source >>=? function + | false -> + let reveal_op = Manager_operation { + source = Signature.Public_key.hash public_key ; + fee = Tez.zero ; + counter ; + operation = Reveal public_key ; + gas_limit = Z.of_int 10000 ; + storage_limit = Z.zero ; + } in + return (Some (Contents reveal_op), Z.succ counter) + | true -> return (None, counter) + end >>=? fun (manager_op, counter) -> + (* Update counters and transform into a contents_list *) + let operations = + List.fold_left (fun (counter, acc) -> function + | Contents (Manager_operation m) -> + (Z.succ counter, + (Contents (Manager_operation { m with counter }) :: acc)) + | x -> counter, x :: acc) + (counter, (match manager_op with + | None -> [] + | Some op -> [ op ])) + unpacked_operations + |> snd |> List.rev + in + + let operations = Operation.of_list operations in + return @@ sign account.sk ctxt operations + +let manager_operation + ?counter + ?(fee = Tez.zero) + ?(gas_limit) + ?(storage_limit) + ?public_key ~source ctxt operation = + begin match counter with + | Some counter -> return counter + | None -> Context.Contract.counter ctxt source end + >>=? fun counter -> + Context.get_constants ctxt >>=? fun c -> + let gas_limit = Option.unopt + ~default:c.parametric.hard_storage_limit_per_operation gas_limit in + let storage_limit = Option.unopt + ~default:c.parametric.hard_storage_limit_per_operation storage_limit in + Context.Contract.manager ctxt source >>=? fun account -> + let public_key = Option.unopt ~default:account.pk public_key in + let counter = Z.succ counter in + Context.Contract.is_manager_key_revealed ctxt source >>=? function + | true -> + let op = + Manager_operation { + source = Signature.Public_key.hash public_key ; + fee ; + counter ; + operation ; + gas_limit ; + storage_limit ; + } in + return (Contents_list (Single op)) + | false -> + let op_reveal = + Manager_operation { + source = Signature.Public_key.hash public_key; + fee = Tez.zero ; + counter ; + operation = Reveal public_key ; + gas_limit = Z.of_int 10000 ; + storage_limit = Z.zero ; + } in + let op = + Manager_operation { + source = Signature.Public_key.hash public_key ; + fee ; + counter = Z.succ counter ; + operation ; + gas_limit ; + storage_limit ; + } in + return (Contents_list (Cons (op_reveal, Single op))) + +let revelation ctxt public_key = + let pkh = Signature.Public_key.hash public_key in + let source = Contract.implicit_contract pkh in + Context.Contract.counter ctxt source >>=? fun counter -> + Context.Contract.manager ctxt source >>=? fun account -> + let counter = Z.succ counter in + let sop = + Contents_list + (Single + (Manager_operation { + source = Signature.Public_key.hash public_key ; + fee = Tez.zero ; + counter ; + operation = Reveal public_key ; + gas_limit = Z.of_int 10000 ; + storage_limit = Z.zero ; + })) in + return @@ sign account.sk ctxt sop + +let originated_contract op = + let nonce = Contract.initial_origination_nonce (Operation.hash_packed op) in + Contract.originated_contract nonce + +exception Impossible + +let origination ?counter ?delegate ~script + ?(preorigination = None) + ?public_key ?credit ?fee ?gas_limit ?storage_limit ctxt source = + Context.Contract.manager ctxt source >>=? fun account -> + let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in + let default_credit = Option.unopt_exn Impossible default_credit in + let credit = Option.unopt ~default:default_credit credit in + let operation = + Origination { + delegate ; + script ; + credit ; + preorigination ; + } in + manager_operation ?counter ?public_key ?fee ?gas_limit ?storage_limit + ~source ctxt operation >>=? fun sop -> + let op = sign account.sk ctxt sop in + return (op , originated_contract op) + +let miss_signed_endorsement ?level ctxt = + begin + match level with + | None -> Context.get_level ctxt + | Some level -> return level + end >>=? fun level -> + Context.get_endorser ctxt >>=? fun (real_delegate_pkh, _slots) -> + let delegate = Account.find_alternate real_delegate_pkh in + endorsement ~delegate:delegate.pkh ~level ctxt () + +let transaction ?fee ?gas_limit ?storage_limit ?(parameters = Script.unit_parameter) ?(entrypoint = "default") ctxt + (src:Contract.t) (dst:Contract.t) + (amount:Tez.t) = + let top = Transaction { + amount; + parameters; + destination=dst; + entrypoint; + } in + manager_operation ?fee ?gas_limit ?storage_limit + ~source:src ctxt top >>=? fun sop -> + Context.Contract.manager ctxt src >>=? fun account -> + return @@ sign account.sk ctxt sop + +let delegation ?fee ctxt source dst = + let top = Delegation dst in + manager_operation ?fee ~source ctxt top >>=? fun sop -> + Context.Contract.manager ctxt source >>=? fun account -> + return @@ sign account.sk ctxt sop + +let activation ctxt (pkh : Signature.Public_key_hash.t) activation_code = + begin match pkh with + | Ed25519 edpkh -> return edpkh + | _ -> failwith "Wrong public key hash : %a - Commitments must be activated with an Ed25519 \ + encrypted public key hash" Signature.Public_key_hash.pp pkh + end >>=? fun id -> + let contents = + Single (Activate_account { id ; activation_code } ) in + let branch = Context.branch ctxt in + return { + shell = { branch } ; + protocol_data = Operation_data { + contents ; + signature = None ; + } ; + } + +let double_endorsement ctxt op1 op2 = + let contents = + Single (Double_endorsement_evidence {op1 ; op2}) in + let branch = Context.branch ctxt in + return { + shell = { branch } ; + protocol_data = Operation_data { + contents ; + signature = None ; + } ; + } + +let double_baking ctxt bh1 bh2 = + let contents = + Single (Double_baking_evidence {bh1 ; bh2}) in + let branch = Context.branch ctxt in + return { + shell = { branch } ; + protocol_data = Operation_data { + contents ; + signature = None ; + } ; + } + +let seed_nonce_revelation ctxt level nonce = + return + { shell = { branch = Context.branch ctxt } ; + protocol_data = Operation_data { + contents = Single (Seed_nonce_revelation { level ; nonce }) ; + signature = None ; + } ; + } + +let proposals ctxt (pkh: Contract.t) proposals = + Context.Contract.pkh pkh >>=? fun source -> + Context.Vote.get_voting_period ctxt >>=? fun period -> + let op = + Proposals { source ; + period ; + proposals } in + Account.find source >>=? fun account -> + return (sign account.sk ctxt (Contents_list (Single op))) + +let ballot ctxt (pkh: Contract.t) proposal ballot = + Context.Contract.pkh pkh >>=? fun source -> + Context.Vote.get_voting_period ctxt >>=? fun period -> + let op = + Ballot { source ; + period ; + proposal ; + ballot + } in + Account.find source >>=? fun account -> + return (sign account.sk ctxt (Contents_list (Single op))) + +let dummy_script = + let open Micheline in + Script.({ + code = lazy_expr (strip_locations (Seq (0, [ + Prim (0, K_parameter, [Prim (0, T_unit, [], [])], []) ; + Prim (0, K_storage, [Prim (0, T_unit, [], [])], []) ; + Prim (0, K_code, [ + Seq (0, [ + Prim (0, I_CDR, [], []) ; + Prim (0, I_NIL, [Prim (0, T_operation, [], [])], []) ; + Prim (0, I_PAIR, [], []) ; + ])], []) ; + ]))) ; + storage = lazy_expr (strip_locations (Prim (0, D_Unit, [], []))) ; + }) + +let dummy_script_cost = Test_tez.Tez.of_mutez_exn 38_000L diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/op.mli b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/op.mli new file mode 100644 index 000000000..743a11220 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/op.mli @@ -0,0 +1,114 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context + +val endorsement: + ?delegate:public_key_hash -> + ?level:Raw_level.t -> + Context.t -> ?signing_context:Context.t -> unit -> + Kind.endorsement Operation.t tzresult Lwt.t + +val miss_signed_endorsement: + ?level:Raw_level.t -> + Context.t -> Kind.endorsement Operation.t tzresult Lwt.t + +val transaction: + ?fee:Tez.tez -> + ?gas_limit:Z.t -> + ?storage_limit:Z.t -> + ?parameters:Script.lazy_expr -> + ?entrypoint:string -> + Context.t -> + Contract.t -> + Contract.t -> + Tez.t -> + Operation.packed tzresult Lwt.t + +val delegation: + ?fee:Tez.tez -> Context.t -> + Contract.t -> public_key_hash option -> + Operation.packed tzresult Lwt.t + +val revelation: + Context.t -> public_key -> Operation.packed tzresult Lwt.t + +val origination: + ?counter: Z.t -> + ?delegate:public_key_hash -> + script:Script.t -> + ?preorigination: Contract.contract option -> + ?public_key:public_key -> + ?credit:Tez.tez -> + ?fee:Tez.tez -> + ?gas_limit:Z.t -> + ?storage_limit:Z.t -> + Context.t -> + Contract.contract -> + (Operation.packed * Contract.contract) tzresult Lwt.t + +val originated_contract: + Operation.packed -> Contract.contract + +val double_endorsement: + Context.t -> + Kind.endorsement Operation.t -> + Kind.endorsement Operation.t -> + Operation.packed tzresult Lwt.t + +val double_baking: + Context.t -> + Block_header.block_header -> + Block_header.block_header -> + Operation.packed tzresult Lwt.t + +val activation: + Context.t -> + Signature.Public_key_hash.t -> Blinded_public_key_hash.activation_code -> + Operation.packed tzresult Lwt.t + +val combine_operations : + ?public_key:public_key -> + ?counter:counter -> + source:Contract.t -> + Context.t -> + packed_operation list -> packed_operation tzresult Lwt.t + +(** Reveals a seed_nonce that was previously committed at a certain level *) +val seed_nonce_revelation: + Context.t -> Raw_level.t -> Nonce.t -> Operation.packed tzresult Lwt.t + +(** Propose a list of protocol hashes during the approval voting *) +val proposals : Context.t -> Contract.t -> Protocol_hash.t list -> + Operation.packed tzresult Lwt.t + +(** Cast a vote yay, nay or pass *) +val ballot : Context.t -> + Contract.t -> Protocol_hash.t -> Vote.ballot -> + Operation.packed tzresult Lwt.t + +val dummy_script : Script.t +val dummy_script_cost : Test_tez.Tez.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/test_tez.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/test_tez.ml new file mode 100644 index 000000000..cb3167156 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/test_tez.ml @@ -0,0 +1,61 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Environment + +(* This module is mostly to wrap the errors from the protocol *) +module Tez = struct + include Tez + + let ( +? ) t1 t2 = (t1 +? t2) |> wrap_error + let ( -? ) t1 t2 = (t1 -? t2) |> wrap_error + let ( *? ) t1 t2 = (t1 *? t2) |> wrap_error + let ( /? ) t1 t2 = (t1 /? t2) |> wrap_error + + let ( + ) t1 t2 = + match t1 +? t2 with + | Ok r -> r + | Error _ -> + Pervasives.failwith "adding tez" + + let of_int x = + match Tez.of_mutez (Int64.mul (Int64.of_int x) 1_000_000L) with + | None -> invalid_arg "tez_of_int" + | Some x -> x + + let of_mutez_exn x = + match Tez.of_mutez x with + | None -> invalid_arg "tez_of_mutez" + | Some x -> x + + + let max_tez = + match Tez.of_mutez Int64.max_int with + | None -> assert false + | Some p -> p + +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/test_utils.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/test_utils.ml new file mode 100644 index 000000000..e71947bc7 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/test_utils.ml @@ -0,0 +1,43 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* This file should not depend on any other file from tests. *) + +let (>>?=) x y = match x with + | Ok(a) -> y a + | Error(b) -> fail @@ List.hd b + +(** Like List.find but returns the index of the found element *) +let findi p = + let rec aux p i = function + | [] -> raise Not_found + | x :: l -> if p x then (x,i) else aux p (i+1) l + in + aux p 0 + +exception Pair_of_list +let pair_of_list = function + | [a;b] -> a,b + | _ -> raise Pair_of_list diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/tezos-005-PsBabyM1-test-helpers.opam b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/tezos-005-PsBabyM1-test-helpers.opam new file mode 100644 index 000000000..0d8528023 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/helpers/tezos-005-PsBabyM1-test-helpers.opam @@ -0,0 +1,21 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "ocamlfind" { build } + "dune" { build & >= "1.7" } + "tezos-base" + "tezos-stdlib-unix" + "tezos-shell-services" + "tezos-protocol-environment" + "tezos-protocol-005-PsBabyM1" + "tezos-protocol-005-PsBabyM1-parameters" +] +build: [ + [ "dune" "build" "-p" name "-j" jobs ] +] +synopsis: "Tezos/Protocol: protocol testing framework" diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/main.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/main.ml new file mode 100644 index 000000000..4c66e24bb --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/main.ml @@ -0,0 +1,41 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let () = + Alcotest.run "protocol_005_PsBabyM1" [ + "transfer", Transfer.tests ; + "origination", Origination.tests ; + "activation", Activation.tests ; + "endorsement", Endorsement.tests ; + "double endorsement", Double_endorsement.tests ; + "double baking", Double_baking.tests ; + "seed", Seed.tests ; + "baking", Baking.tests ; + "delegation", Delegation.tests ; + "rolls", Rolls.tests ; + "combined", Combined_operations.tests ; + "qty", Qty.tests ; + "voting", Voting.tests ; + ] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/origination.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/origination.ml new file mode 100644 index 000000000..c7b2b4281 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/origination.ml @@ -0,0 +1,235 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Test_utils +open Test_tez + +let ten_tez = Tez.of_int 10 + +(** [register_origination fee credit spendable delegatable] takes four + optional parameter: fee for the fee need to be paid if set to + create an originated contract; credit is the amount of tez that + send to this originated contract; spendable default is set to true + meaning that this contract is spendable; delegatable default is + set to true meaning that this contract is able to delegate. *) +let register_origination ?(fee=Tez.zero) ?(credit=Tez.zero) () = + Context.init 1 >>=? fun (b, contracts) -> + let source = List.hd contracts in + Context.Contract.balance (B b) source >>=? fun source_balance -> + Op.origination (B b) source ~fee ~credit ~script:Op.dummy_script + >>=? fun (operation, originated) -> + Block.bake ~operation b >>=? fun b -> + (* fee + credit + block security deposit were debited from source *) + Context.get_constants (B b) >>=? fun {parametric = { origination_size ; + cost_per_byte ; + block_security_deposit ; _ }; _ } -> + Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn -> + Lwt.return ( + Tez.(+?) credit block_security_deposit >>? + Tez.(+?) fee >>? + Tez.(+?) origination_burn >>? + Tez.(+?) Op.dummy_script_cost ) >>=? fun total_fee -> + Assert.balance_was_debited ~loc:__LOC__ (B b) source source_balance total_fee >>=? fun () -> + (* originated contract has been credited *) + Assert.balance_was_credited ~loc:__LOC__ (B b) originated Tez.zero credit >>=? fun () -> + (* TODO spendable or not and delegatable or not if relevant for some + test. Not the case at the moment, cf. uses of + register_origination *) + return (b, source, originated) + + +(* [test_origination_balances fee credit spendable delegatable] + takes four optional parameter: fee is the fee that pay if require to create + an originated contract; credit is the amount of tez that will send to this + contract; delegatable default is set to true meaning that this contract is + able to delegate. + This function will create a contract, get the balance of this contract, call + the origination operation to create a new originated contract from this + contract with all the possible fees; and check the balance before/after + originated operation valid. + - the source contract has payed all the fees + - the originated has been credited correctly *) +let test_origination_balances ~loc:_ ?(fee=Tez.zero) ?(credit=Tez.zero) () = + Context.init 1 >>=? fun (b, contracts) -> + let contract = List.hd contracts in + Context.Contract.balance (B b) contract >>=? fun balance -> + Op.origination (B b) contract ~fee ~credit ~script:Op.dummy_script + >>=? fun (operation, new_contract) -> + (* The possible fees are: a given credit, an origination burn fee + (constants_repr.default.origination_burn = 257 mtez), + a fee that is paid when creating an originate contract. + + We also take into account a block security deposit. Note that it + is not related to origination but to the baking done in the + tests.*) + Context.get_constants (B b) >>=? fun + { parametric = + { origination_size ; + cost_per_byte ; + block_security_deposit + ; _ } + ; _ } -> + Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn -> + Lwt.return ( + Tez.(+?) credit block_security_deposit >>? + Tez.(+?) fee >>? + Tez.(+?) origination_burn >>? + Tez.(+?) Op.dummy_script_cost ) >>=? fun total_fee -> + Block.bake ~operation b >>=? fun b -> + (* check that after the block has been baked the source contract + was debited all the fees *) + Assert.balance_was_debited ~loc:__LOC__ (B b) contract balance total_fee + >>=? fun _ -> + (* check the balance of the originate contract is equal to credit *) + Assert.balance_is ~loc:__LOC__ (B b) new_contract credit + +(******************************************************) +(** Tests *) +(******************************************************) + +(** compute half of the balance and divided it by nth times *) + +let two_nth_of_balance incr contract nth = + Context.Contract.balance (I incr) contract >>=? fun balance -> + Tez.(/?) balance nth >>?= fun res -> + Tez.( *?) res 2L >>?= fun balance -> + return balance + +(*******************) +(** Basic test *) +(*******************) + +let balances_simple () = test_origination_balances ~loc:__LOC__ () + +let balances_credit () = + test_origination_balances ~loc:__LOC__ ~credit:ten_tez () + +let balances_credit_fee () = + test_origination_balances ~loc:__LOC__ ~credit:(Tez.of_int 2) ~fee:ten_tez () + +let balances_undelegatable () = + test_origination_balances ~loc:__LOC__ () + +(*******************) +(** ask source contract to pay a fee when originating a contract *) +(*******************) + +let pay_fee () = + register_origination ~credit:(Tez.of_int 2) ~fee:ten_tez () >>=? fun (_b, _contract, _new_contract) -> + return_unit + +(******************************************************) +(** Errors *) +(******************************************************) + +(*******************) +(** create an originate contract where the contract + does not have enough tez to pay for the fee *) +(*******************) + +let not_tez_in_contract_to_pay_fee () = + Context.init 2 >>=? fun (b, contracts) -> + let contract_1 = List.nth contracts 0 in + let contract_2 = List.nth contracts 1 in + Incremental.begin_construction b >>=? fun inc -> + (* transfer everything but one tez from 1 to 2 and check balance of 1 *) + Context.Contract.balance (I inc) contract_1 >>=? fun balance -> + Lwt.return @@ Tez.(-?) balance Tez.one >>=? fun amount -> + Op.transaction (I inc) contract_1 contract_2 amount >>=? fun operation -> + Incremental.add_operation inc operation >>=? fun inc -> + Assert.balance_was_debited ~loc:__LOC__ (I inc) contract_1 balance amount + >>=? fun _ -> + (* use this source contract to create an originate contract where it requires + to pay a fee and add an amount of credit into this new contract *) + Op.origination (I inc) ~fee:ten_tez ~credit:Tez.one contract_1 ~script:Op.dummy_script >>=? fun (op, _) -> + Incremental.add_operation inc op >>= fun inc -> + Assert.proto_error ~loc:__LOC__ inc begin function + | Contract_storage.Balance_too_low _ -> true + | _ -> false + end + +(***************************************************) +(* set the endorser of the block as manager/delegate of the originated + account *) +(***************************************************) + +let register_contract_get_endorser () = + Context.init 1 >>=? fun (b, contracts) -> + let contract = List.hd contracts in + Incremental.begin_construction b >>=? fun inc -> + Context.get_endorser (I inc) >>=? fun (account_endorser, _slots) -> + return (inc, contract, account_endorser) + +(*******************) +(** create multiple originated contracts and + ask contract to pay the fee *) +(*******************) + +let n_originations n ?credit ?fee () = + fold_left_s (fun new_contracts _ -> + register_origination ?fee ?credit () >>=? fun (_b, _source, new_contract) -> + + let contracts = new_contract :: new_contracts in + return contracts + ) [] (1 -- n) + +let multiple_originations () = + n_originations 100 ~credit:(Tez.of_int 2) ~fee:ten_tez () >>=? fun contracts -> + Assert.equal_int ~loc:__LOC__ (List.length contracts) 100 + +(*******************) +(** cannot originate two contracts with the same context's counter *) +(*******************) + +let counter () = + Context.init 1 >>=? fun (b, contracts) -> + let contract = List.hd contracts in + Incremental.begin_construction b >>=? fun inc -> + Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script >>=? fun (op1, _) -> + Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script >>=? fun (op2, _) -> + Incremental.add_operation inc op1 >>=? fun inc -> + Incremental.add_operation inc op2 >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Contract_storage.Counter_in_the_past _ -> true + | _ -> false + end + +(******************************************************) + +let tests = [ + Test.tztest "balances_simple" `Quick balances_simple ; + Test.tztest "balances_credit" `Quick balances_credit ; + Test.tztest "balances_credit_fee" `Quick balances_credit_fee ; + Test.tztest "balances_undelegatable" `Quick balances_undelegatable ; + + Test.tztest "pay_fee" `Quick pay_fee; + + Test.tztest "not enough tez in contract to pay fee" `Quick not_tez_in_contract_to_pay_fee; + + Test.tztest "multiple originations" `Quick multiple_originations; + + Test.tztest "counter" `Quick counter; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/qty.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/qty.ml new file mode 100644 index 000000000..6c5c1fd0b --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/qty.ml @@ -0,0 +1,141 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol + +let known_ok_tez_literals = + [ 0L, "0" ; + 10L, "0.00001" ; + 100L, "0.0001" ; + 1_000L, "0.001" ; + 10_000L, "0.01" ; + 100_000L, "0.1" ; + 1_000_000L, "1" ; + 10_000_000L, "10" ; + 100_000_000L, "100" ; + 1_000_000_000L, "1000" ; + 10_000_000_000L, "10000" ; + 100_000_000_000L, "100000" ; + 1_000_000_000_000L, "1000000" ; + 1_000_000_000_001L, "1000000.000001" ; + 1_000_000_000_010L, "1000000.00001" ; + 1_000_000_000_100L, "1000000.0001" ; + 1_000_000_001_000L, "1000000.001" ; + 1_000_000_010_000L, "1000000.01" ; + 1_000_000_100_000L, "1000000.1" ; + 123_123_123_123_123_123L, "123123123123.123123" ; + 999_999_999_999_999_999L, "999999999999.999999" ] + +let known_bad_tez_literals = + [ "10000." ; + "100,." ; + "100," ; + "1,0000" ; + "0.0000,1" ; + "0.00,1" ; + "0,1" ; + "HAHA" ; + "0.000,000,1" ; + "0.0000000" ; + "9,999,999,999,999.999,999"] + +let fail expected given msg = + Format.kasprintf Pervasives.failwith + "@[%s@ expected: %s@ got: %s@]" msg expected given + +let fail_msg fmt = Format.kasprintf (fail "" "") fmt + +let default_printer _ = "" + +let equal ?(eq=(=)) ?(prn=default_printer) ?(msg="") x y = + if not (eq x y) then fail (prn x) (prn y) msg + +let is_none ?(msg="") x = + if x <> None then fail "None" "Some _" msg + +let is_some ?(msg="") x = + if x = None then fail "Some _" "None" msg + +let test_known_tez_literals () = + List.iter + (fun (v, s) -> + let vv = Tez_repr.of_mutez v in + let vs = Tez_repr.of_string s in + let vs' = Tez_repr.of_string (String.concat "" (String.split_on_char ',' s)) in + let vv = match vv with None -> fail_msg "could not unopt %Ld" v | Some vv -> vv in + let vs = match vs with None -> fail_msg "could not unopt %s" s | Some vs -> vs in + let vs' = match vs' with None -> fail_msg "could not unopt %s" s | Some vs' -> vs' in + + equal ~prn:Tez_repr.to_string vv vs ; + equal ~prn:Tez_repr.to_string vv vs' ; + equal ~prn:(fun s -> s) (Tez_repr.to_string vv) s) + known_ok_tez_literals ; + List.iter + (fun s -> + let vs = Tez_repr.of_string s in + is_none ~msg:("Unexpected successful parsing of " ^ s) vs) + known_bad_tez_literals ; + return_unit + +let test_random_tez_literals () = + for _ = 0 to 100_000 do + let v = Random.int64 12L in + let vv = Tez_repr.of_mutez v in + let vv = match vv with None -> fail_msg "could not unopt %Ld" v | Some vv -> vv in + let s = Tez_repr.to_string vv in + let vs = Tez_repr.of_string s in + let s' = String.concat "" (String.split_on_char ',' s) in + let vs' = Tez_repr.of_string s' in + is_some ~msg:("Could not parse " ^ s ^ " back") vs ; + is_some ~msg:("Could not parse " ^ s ^ " back") vs' ; + begin match vs with + | None -> assert false + | Some vs -> + let rev = Tez_repr.to_int64 vs in + equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev + end ; + begin match vs' with + | None -> assert false + | Some vs' -> + let rev = Tez_repr.to_int64 vs' in + equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev + end + done ; + return_unit + +let tests = [ + "tez-literals", (fun _ -> test_known_tez_literals ()) ; + "rnd-tez-literals", (fun _ -> test_random_tez_literals ()) ; +] + +let wrap (n, f) = + Alcotest_lwt.test_case n `Quick begin fun _ () -> + f () >>= function + | Ok () -> Lwt.return_unit + | Error error -> + Format.kasprintf Pervasives.failwith "%a" pp_print_error error + end + +let tests = List.map wrap tests diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/rolls.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/rolls.ml new file mode 100644 index 000000000..9053c31dc --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/rolls.ml @@ -0,0 +1,250 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Test_tez +open Test_utils + +let account_pair = function + | [a1; a2] -> (a1, a2) + | _ -> assert false + +let wrap e = Lwt.return (Environment.wrap_error e) +let traverse_rolls ctxt head = + let rec loop acc roll = + Storage.Roll.Successor.get_option ctxt roll >>= wrap >>=? function + | None -> return (List.rev acc) + | Some next -> loop (next :: acc) next in + loop [head] head + +let get_rolls ctxt delegate = + Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>= wrap >>=? function + | None -> return_nil + | Some head_roll -> traverse_rolls ctxt head_roll + +let check_rolls b (account:Account.t) = + Context.get_constants (B b) >>=? fun constants -> + Context.Delegate.info (B b) account.pkh >>=? fun { staking_balance ; _ } -> + let token_per_roll = constants.parametric.tokens_per_roll in + let expected_rolls = Int64.div (Tez.to_mutez staking_balance) (Tez.to_mutez token_per_roll) in + Raw_context.prepare b.context + ~level:b.header.shell.level + ~predecessor_timestamp:b.header.shell.timestamp + ~timestamp:b.header.shell.timestamp + ~fitness:b.header.shell.fitness >>= wrap >>=? fun ctxt -> + get_rolls ctxt account.pkh >>=? fun rolls -> + Assert.equal_int ~loc:__LOC__ (List.length rolls) (Int64.to_int expected_rolls) + +let check_no_rolls (b : Block.t) (account:Account.t) = + Raw_context.prepare b.context + ~level:b.header.shell.level + ~predecessor_timestamp:b.header.shell.timestamp + ~timestamp:b.header.shell.timestamp + ~fitness:b.header.shell.fitness >>= wrap >>=? fun ctxt -> + get_rolls ctxt account.pkh >>=? fun rolls -> + Assert.equal_int ~loc:__LOC__ (List.length rolls) 0 + +let simple_staking_rights () = + Context.init 2 >>=? fun (b,accounts) -> + let (a1, _a2) = account_pair accounts in + + Context.Contract.balance (B b) a1 >>=? fun balance -> + Context.Contract.manager (B b) a1 >>=? fun m1 -> + + Context.Delegate.info (B b) m1.pkh >>=? fun info -> + Assert.equal_tez ~loc:__LOC__ balance info.staking_balance >>=? fun () -> + check_rolls b m1 + +let simple_staking_rights_after_baking () = + Context.init 2 >>=? fun (b,accounts) -> + let (a1, a2) = account_pair accounts in + + Context.Contract.balance (B b) a1 >>=? fun balance -> + 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 -> + + Context.Delegate.info (B b) m1.pkh >>=? fun info -> + Assert.equal_tez ~loc:__LOC__ balance info.staking_balance >>=? fun () -> + check_rolls b m1 >>=? fun () -> + check_rolls b m2 + +let frozen_deposit (info:Context.Delegate.info) = + Cycle.Map.fold (fun _ { Delegate.deposit ; _ } acc -> + Test_tez.Tez.(deposit + acc)) + info.frozen_balance_by_cycle Tez.zero + +let check_activate_staking_balance ~loc ~deactivated b (a, (m:Account.t)) = + Context.Delegate.info (B b) m.pkh >>=? fun info -> + Assert.equal_bool ~loc info.deactivated deactivated >>=? fun () -> + Context.Contract.balance (B b) a >>=? fun balance -> + let deposit = frozen_deposit info in + Assert.equal_tez ~loc Test_tez.Tez.(balance + deposit) info.staking_balance + +let run_until_deactivation () = + Context.init 2 >>=? fun (b,accounts) -> + 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 -> + + check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a1,m1) >>=? fun () -> + + Context.Delegate.info (B b) m1.pkh >>=? fun info -> + Block.bake_until_cycle ~policy:(By_account m2.pkh) info.grace_period b >>=? fun b -> + + check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a1,m1) >>=? fun () -> + + Block.bake_until_cycle_end ~policy:(By_account m2.pkh) b >>=? fun b -> + + check_activate_staking_balance ~loc:__LOC__ ~deactivated:true b (a1,m1) >>=? fun () -> + return (b, ((a1, m1), balance_start), (a2, m2)) + +let deactivation_then_bake () = + run_until_deactivation () >>=? + fun (b, ((_deactivated_contract, deactivated_account) as deactivated, _start_balance), + (_a2, _m2)) -> + + Block.bake ~policy:(By_account deactivated_account.pkh) b >>=? fun b -> + + check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated >>=? fun () -> + check_rolls b deactivated_account + +let deactivation_then_self_delegation () = + run_until_deactivation () >>=? + fun (b, ((deactivated_contract, deactivated_account) as deactivated, start_balance), + (_a2, m2)) -> + + Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh) >>=? fun self_delegation -> + + Block.bake ~policy:(By_account m2.pkh) b ~operation:self_delegation >>=? fun b -> + + check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated >>=? fun () -> + Context.Contract.balance (B b) deactivated_contract >>=? fun balance -> + Assert.equal_tez ~loc:__LOC__ start_balance balance >>=? fun () -> + check_rolls b deactivated_account + +let deactivation_then_empty_then_self_delegation () = + run_until_deactivation () >>=? + fun (b, ((deactivated_contract, deactivated_account) as deactivated, _start_balance), + (_a2, m2)) -> + (* empty the contract *) + Context.Contract.balance (B b) deactivated_contract >>=? fun balance -> + let sink_account = Account.new_account () in + let sink_contract = Contract.implicit_contract sink_account.pkh in + Context.get_constants (B b) >>=? fun { parametric = { origination_size ; cost_per_byte ; _ } ; _ } -> + Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn -> + let amount = match Tez.(balance -? origination_burn) with Ok r -> r | Error _ -> assert false in + Op.transaction (B b) deactivated_contract sink_contract amount >>=? fun empty_contract -> + Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b >>=? fun b -> + (* self delegation *) + Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh) >>=? fun self_delegation -> + Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b >>=? fun b -> + + check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated >>=? fun () -> + Context.Contract.balance (B b) deactivated_contract >>=? fun balance -> + Assert.equal_tez ~loc:__LOC__ Tez.zero balance >>=? fun () -> + check_rolls b deactivated_account + +let deactivation_then_empty_then_self_delegation_then_recredit () = + run_until_deactivation () >>=? + fun (b, ((deactivated_contract, deactivated_account) as deactivated, balance), + (_a2, m2)) -> + (* empty the contract *) + let sink_account = Account.new_account () in + let sink_contract = Contract.implicit_contract sink_account.pkh in + Context.get_constants (B b) >>=? fun { parametric = { origination_size ; cost_per_byte ; _ } ; _ } -> + Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn -> + let amount = match Tez.(balance -? origination_burn) with Ok r -> r | Error _ -> assert false in + Op.transaction (B b) deactivated_contract sink_contract amount >>=? fun empty_contract -> + Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b >>=? fun b -> + (* self delegation *) + Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh) >>=? fun self_delegation -> + Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b >>=? fun b -> + (* recredit *) + Op.transaction (B b) sink_contract deactivated_contract amount >>=? fun recredit_contract -> + Block.bake ~policy:(By_account m2.pkh) ~operation:recredit_contract b >>=? fun b -> + + check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated >>=? fun () -> + Context.Contract.balance (B b) deactivated_contract >>=? fun balance -> + Assert.equal_tez ~loc:__LOC__ amount balance >>=? fun () -> + check_rolls b deactivated_account + +let delegation () = + Context.init 2 >>=? fun (b,accounts) -> + 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 -> + Context.Contract.manager (B b) a2 >>=? fun m2 -> + let a3 = Contract.implicit_contract m3.pkh in + + Context.Contract.delegate_opt (B b) a1 >>=? fun delegate -> + begin + match delegate with + | None -> assert false + | Some pkh -> + assert (Signature.Public_key_hash.equal pkh m1.pkh) + end; + + Op.transaction (B b) a1 a3 Tez.fifty_cents >>=? fun transact -> + + Block.bake ~policy:(By_account m2.pkh) b ~operation:transact >>=? fun b -> + + Context.Contract.delegate_opt (B b) a3 >>=? fun delegate -> + begin + match delegate with + | None -> () + | Some _ -> assert false + end; + check_no_rolls b m3 >>=? fun () -> + + Op.delegation (B b) a3 (Some m3.pkh) >>=? fun delegation -> + Block.bake ~policy:(By_account m2.pkh) b ~operation:delegation >>=? fun b -> + + Context.Contract.delegate_opt (B b) a3 >>=? fun delegate -> + begin + match delegate with + | None -> assert false + | Some pkh -> + assert (Signature.Public_key_hash.equal pkh m3.pkh) + end; + check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a3,m3) >>=? fun () -> + check_rolls b m3 >>=? fun () -> + check_rolls b m1 + +let tests = [ + Test.tztest "simple staking rights" `Quick (simple_staking_rights) ; + Test.tztest "simple staking rights after baking" `Quick (simple_staking_rights_after_baking) ; + Test.tztest "deactivation then bake" `Quick (deactivation_then_bake) ; + Test.tztest "deactivation then self delegation" `Quick (deactivation_then_self_delegation) ; + Test.tztest "deactivation then empty then self delegation" `Quick (deactivation_then_empty_then_self_delegation) ; + Test.tztest "deactivation then empty then self delegation then recredit" `Quick (deactivation_then_empty_then_self_delegation_then_recredit) ; + Test.tztest "delegation" `Quick (delegation) ; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/seed.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/seed.ml new file mode 100644 index 000000000..63872ad92 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/seed.ml @@ -0,0 +1,223 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Tests about + - seed_nonce_hash included in some blocks + - revelation operation of seed_nonce that should correspond to each + seed_nonce_hash +*) + +open Protocol +open Test_tez + +(** Tests that baking [blocks_per_commitment] blocks without a + [seed_nonce_hash] commitment fails with [Invalid_commitment] *) +let no_commitment () = + Context.init 5 >>=? fun (b,_) -> + Context.get_constants (B b) >>=? fun { parametric = { blocks_per_commitment ; _ } ; _ } -> + let blocks_per_commitment = Int32.to_int blocks_per_commitment in + + (* Bake normally until before the commitment *) + Block.bake_n (blocks_per_commitment-2) b >>=? fun b -> + + (* Forge a block with empty commitment and apply it *) + Block.Forge.forge_header b >>=? fun header -> + Block.Forge.set_seed_nonce_hash None header |> + Block.Forge.sign_header >>=? fun header -> + Block.apply header b >>= fun e -> + + Assert.proto_error ~loc:__LOC__ e begin function + | Apply.Invalid_commitment _ -> true + | _ -> false + end + +let baking_reward ctxt (b: Block.t) = + let priority = b.header.protocol_data.contents.priority in + Block.get_endorsing_power b >>=? fun endorsing_power -> + Context.get_baking_reward ctxt ~priority ~endorsing_power + + +(** Choose a baker, denote it by id. In the first cycle, make id bake only once. + Test that: + - after id bakes with a commitment the bond is frozen and the reward allocated + - when id reveals the nonce too early, there's an error + - when id reveals at the right time but the wrong value, there's an error + - when another baker reveals correctly, it receives the tip + - revealing twice produces an error + - after [preserved cycles] a committer that correctly revealed + receives back the bond and the reward +*) +let revelation_early_wrong_right_twice () = + let open Assert in + + Context.init 5 >>=? fun (b,_) -> + Context.get_constants (B b) >>=? fun csts -> + let bond = csts.parametric.block_security_deposit in + let tip = csts.parametric.seed_nonce_revelation_tip in + let blocks_per_commitment = Int32.to_int csts.parametric.blocks_per_commitment in + let preserved_cycles = csts.parametric.preserved_cycles in + + (* get the pkh of a baker *) + Block.get_next_baker b >>=? fun (pkh,_,_) -> + let id = Alpha_context.Contract.implicit_contract pkh in + let policy = Block.Excluding [pkh] in + (* bake until commitment, excluding id *) + Block.bake_n ~policy (blocks_per_commitment-2) b >>=? fun b -> + Context.Contract.balance ~kind:Main (B b) id >>=? fun bal_main -> + Context.Contract.balance ~kind:Deposit (B b) id >>=? fun bal_deposit -> + Context.Contract.balance ~kind:Rewards (B b) id >>=? fun bal_rewards -> + + (* the baker [id] will include a seed_nonce commitment *) + Block.bake ~policy:(Block.By_account pkh) b >>=? fun b -> + Context.get_level (B b) >>=? fun level_commitment -> + Context.get_seed_nonce_hash (B b) >>=? fun committed_hash -> + baking_reward (B b) b >>=? fun reward -> + + (* test that the bond was frozen and the reward allocated *) + balance_was_debited ~loc:__LOC__ + (B b) id bal_main bond >>=? fun () -> + balance_was_credited ~loc:__LOC__ + (B b) id ~kind:Deposit bal_deposit bond >>=? fun () -> + balance_was_credited ~loc:__LOC__ + (B b) id ~kind:Rewards bal_rewards reward >>=? fun () -> + + (* test that revealing too early produces an error *) + Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash) >>=? fun operation -> + + Block.bake ~policy ~operation b >>= fun e -> + let expected = function + | Nonce_storage.Too_early_revelation -> true + | _ -> false in + Assert.proto_error ~loc:__LOC__ e expected >>=? fun () -> + + (* finish the cycle excluding the committing baker, id *) + 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 + Op.seed_nonce_revelation (B b) level_commitment (Nonce.get wrong_hash) >>=? fun operation -> + Block.bake ~operation b >>= fun e -> + Assert.proto_error ~loc:__LOC__ e begin function + | Nonce_storage.Unexpected_nonce -> true + | _ -> false + end >>=? fun () -> + + (* reveals correctly *) + Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash) >>=? fun operation -> + Block.get_next_baker ~policy b >>=? fun (baker_pkh,_,_) -> + let baker = Alpha_context.Contract.implicit_contract baker_pkh in + Context.Contract.balance ~kind:Main (B b) baker >>=? fun baker_bal_main -> + Context.Contract.balance ~kind:Deposit (B b) baker >>=? fun baker_bal_deposit -> + Context.Contract.balance ~kind:Rewards (B b) baker >>=? fun baker_bal_rewards -> + + (* bake the operation in a block *) + Block.bake ~policy ~operation b >>=? fun b -> + baking_reward (B b) b >>=? fun baker_reward -> + + (* test that the baker gets the tip reward *) + balance_was_debited ~loc:__LOC__ + (B b) baker ~kind:Main baker_bal_main bond >>=? fun () -> + balance_was_credited ~loc:__LOC__ + (B b) baker ~kind:Deposit baker_bal_deposit bond >>=? fun () -> + Lwt.return @@ Tez.(+?) baker_reward tip >>=? fun expected_rewards -> + balance_was_credited ~loc:__LOC__ + (B b) baker ~kind:Rewards baker_bal_rewards expected_rewards >>=? fun () -> + + (* test that revealing twice produces an error *) + Op.seed_nonce_revelation (B b) level_commitment (Nonce.get wrong_hash) >>=? fun operation -> + Block.bake ~operation ~policy b >>= fun e -> + Assert.proto_error ~loc:__LOC__ e begin function + | Nonce_storage.Previously_revealed_nonce -> true + | _ -> false + end >>=? fun () -> + + (* bake [preserved_cycles] cycles excluding [id] *) + Error_monad.fold_left_s (fun b _ -> Block.bake_until_cycle_end ~policy b) + b (1 -- preserved_cycles) >>=? fun b -> + + (* test that [id] receives back the bond and the reward *) + (* note that in order to have that new_bal = bal_main + reward, + id can only bake once; this is why we exclude id from all other bake ops. *) + balance_was_credited ~loc:__LOC__ + (B b) id ~kind:Main bal_main reward >>=? fun () -> + balance_is ~loc:__LOC__ + (B b) id ~kind:Deposit Tez.zero >>=? fun () -> + balance_is ~loc:__LOC__ + (B b) id ~kind:Rewards Tez.zero + + +(** Tests that: + - a committer at cycle 0, which doesn't reveal at cycle 1, + at the end of the cycle 1 looses the bond and the reward + - revealing too late produces an error +*) +let revelation_missing_and_late () = + let open Context in + let open Assert in + + Context.init 5 >>=? fun (b,_) -> + get_constants (B b) >>=? fun csts -> + baking_reward (B b) b >>=? fun reward -> + let blocks_per_commitment = Int32.to_int csts.parametric.blocks_per_commitment in + + (* bake until commitment *) + Block.bake_n (blocks_per_commitment-2) b >>=? fun b -> + (* the next baker [id] will include a seed_nonce commitment *) + Block.get_next_baker b >>=? fun (pkh,_,_) -> + let id = Alpha_context.Contract.implicit_contract pkh in + Block.bake b >>=? fun b -> + Context.get_level (B b) >>=? fun level_commitment -> + Context.get_seed_nonce_hash (B b) >>=? fun committed_hash -> + Context.Contract.balance ~kind:Main (B b) id >>=? fun bal_main -> + Context.Contract.balance ~kind:Deposit (B b) id >>=? fun bal_deposit -> + Context.Contract.balance ~kind:Rewards (B b) id >>=? fun bal_rewards -> + + (* finish cycle 0 excluding the committing baker [id] *) + let policy = Block.Excluding [pkh] in + Block.bake_until_cycle_end ~policy b >>=? fun b -> + (* finish cycle 1 excluding the committing baker [id] *) + Block.bake_until_cycle_end ~policy b >>=? fun b -> + + (* test that baker [id], which didn't reveal at cycle 1 like it was supposed to, + at the end of the cycle 1 looses the reward but not the bond *) + balance_is ~loc:__LOC__ (B b) id ~kind:Main bal_main >>=? fun () -> + balance_is ~loc:__LOC__ (B b) id ~kind:Deposit bal_deposit >>=? fun () -> + balance_was_debited ~loc:__LOC__ + (B b) id ~kind:Rewards bal_rewards reward >>=? fun () -> + + (* test that revealing too late (after cycle 1) produces an error *) + Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash) >>=? fun operation -> + Block.bake ~operation b >>= fun e -> + Assert.proto_error ~loc:__LOC__ e begin function + | Nonce_storage.Too_late_revelation -> true + | _ -> false + end + + +let tests = [ + Test.tztest "no commitment" `Quick no_commitment ; + Test.tztest "revelation_early_wrong_right_twice" `Quick revelation_early_wrong_right_twice ; + Test.tztest "revelation_missing_and_late" `Quick revelation_missing_and_late ; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/test.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/test.ml new file mode 100644 index 000000000..e8c2f3828 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/test.ml @@ -0,0 +1,35 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Wraps an alcotest so that it prints correcly errors from the Error_monad. *) +let tztest name speed f = + Alcotest_lwt.test_case name speed begin fun _sw () -> + f () >>= function + | Ok () -> Lwt.return_unit + | Error err -> + Tezos_stdlib_unix.Internal_event_unix.close () >>= fun () -> + Format.printf "@.%a@." pp_print_error err ; + Lwt.fail Alcotest.Test_error + end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/transfer.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/transfer.ml new file mode 100644 index 000000000..275736201 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/transfer.ml @@ -0,0 +1,597 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Test_utils +open Test_tez + +(*********************************************************************) +(* Utility functions *) +(*********************************************************************) + +(** + [transfer_and_check_balances b fee src dst amount] + this function takes a block, an optional parameter fee if fee does not + given it will be set to zero tez, a source contract, a destination contract + and the amount that one wants to transfer. + + 1- Transfer the amount of tez (w/wo fee) from a source contract to a + destination contract. + + 2- Check the equivalent of the balance of the source/destination + contract before and after transfer is valided. + + This function returns a pair: + - A block that added a valid operation + - a valid operation +*) +let transfer_and_check_balances ?(with_burn = false) ~loc b ?(fee=Tez.zero) ?expect_failure src dst amount = + Tez.(+?) fee amount >>?= fun amount_fee -> + Context.Contract.balance (I b) src >>=? fun bal_src -> + Context.Contract.balance (I b) dst >>=? fun bal_dst -> + Op.transaction (I b) ~fee src dst amount >>=? fun op -> + Incremental.add_operation ?expect_failure b op >>=? fun b -> + Context.get_constants (I b) >>=? fun { parametric = { origination_size ; cost_per_byte ; _ } ; _ } -> + Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn -> + let amount_fee_maybe_burn = + if with_burn then + match Tez.(amount_fee +? origination_burn) with + | Ok r -> r + | Error _ -> assert false + else + amount_fee in + Assert.balance_was_debited ~loc (I b) src bal_src amount_fee_maybe_burn >>=? fun () -> + Assert.balance_was_credited ~loc (I b) dst bal_dst amount >>=? fun () -> + return (b, op) + +(** + [transfer_to_itself_and_check_balances b fee contract amount] + this function takes a block, an optional parameter fee, + a contract that is a source and a destination contract, + and an amount of tez that one wants to transfer. + + 1- Transfer the amount of tez (w/wo transfer fee) from/to a contract itself. + + 2- Check the equivalent of the balance of the contract before + and after transfer. + + This function returns a pair: + - a block that added the valid transaction + - an valid transaction +*) +let transfer_to_itself_and_check_balances ~loc b ?(fee=Tez.zero) contract amount = + Context.Contract.balance (I b) contract >>=? fun bal -> + Op.transaction (I b) ~fee contract contract amount >>=? fun op -> + Incremental.add_operation b op >>=? fun b -> + Assert.balance_was_debited ~loc (I b) contract bal fee >>=? fun () -> + return (b, op) + +(** + [n_transactions n b fee source dest amount] + this function takes a number of "n" that one wish to transfer, + a block, an optional parameter fee, a source contract, + a destination contract and an amount one wants to transfer. + + This function will do a transaction from a source contract to + a destination contract with the amount "n" times. +*) +let n_transactions n b ?fee source dest amount = + fold_left_s (fun b _ -> + transfer_and_check_balances ~loc:__LOC__ b ?fee source dest amount >>=? fun (b,_) -> + return b) + b (1 -- n) + +let ten_tez = Tez.of_int 10 + +(*********************************************************************) +(* Tests *) +(*********************************************************************) + +let register_two_contracts () = + Context.init 2 >>=? fun (b, contracts) -> + let contract_1 = List.nth contracts 0 in + let contract_2 = List.nth contracts 1 in + return (b, contract_1, contract_2) + + +(** compute half of the balance and divided by nth + times *) + +let two_nth_of_balance incr contract nth = + Context.Contract.balance (I incr) contract >>=? fun balance -> + Tez.(/?) balance nth >>?= fun res -> + Tez.( *?) res 2L >>?= fun balance -> + return balance + +(********************) +(** Single transfer *) +(********************) + +let single_transfer ?fee ?expect_failure amount = + register_two_contracts () >>=? fun (b, contract_1, contract_2) -> + Incremental.begin_construction b >>=? fun b -> + transfer_and_check_balances ~loc:__LOC__ ?fee ?expect_failure + b contract_1 contract_2 amount >>=? fun (b,_) -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(** single transfer without fee *) +let block_with_a_single_transfer () = + single_transfer Tez.one + +(** single transfer with fee *) +let block_with_a_single_transfer_with_fee () = + single_transfer ~fee:Tez.one Tez.one + +(** single transfer without fee *) + +let transfer_zero_tez () = + single_transfer ~expect_failure:( + function + | Environment.Ecoproto_error (Contract_storage.Empty_transaction _) :: _ -> + return_unit + | _ -> + failwith "Empty transaction should fail") + Tez.zero + +(********************) +(** Transfer zero tez from an implicit contract *) +(********************) + +let transfer_zero_implicit () = + Context.init 1 >>=? fun (b, contracts) -> + let dest = List.nth contracts 0 in + let account = Account.new_account () in + Incremental.begin_construction b >>=? fun i -> + let src = Contract.implicit_contract account.Account.pkh in + Op.transaction (I i) src dest Tez.zero >>=? fun op -> + Incremental.add_operation i op >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Contract_storage.Empty_implicit_contract _ -> true + | _ -> false + end + +(********************) +(** Transfer to originted contract *) +(********************) + +let transfer_to_originate_with_fee () = + Context.init 1 >>=? fun (b, contracts) -> + let contract = List.nth contracts 0 in + Incremental.begin_construction b >>=? fun b -> + two_nth_of_balance b contract 10L >>=? fun fee -> + (* originated contract, paying a fee to originated this contract *) + Op.origination (I b) ~fee:ten_tez contract ~script:Op.dummy_script >>=? fun (operation, new_contract) -> + Incremental.add_operation b operation >>=? fun b -> + two_nth_of_balance b contract 3L >>=? fun amount -> + transfer_and_check_balances ~loc:__LOC__ b ~fee:fee contract + new_contract amount >>=? fun (b, _) -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(********************) +(** Transfer from balance *) +(********************) + +let transfer_amount_of_contract_balance () = + register_two_contracts () >>=? fun (b, contract_1, contract_2) -> + Context.Contract.pkh contract_1 >>=? fun pkh1 -> + (* given that contract_1 no longer has a sufficient balance to bake, + make sure it cannot be chosen as baker *) + Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) >>=? fun b -> + (* get the balance of the source contract *) + Context.Contract.balance (I b) contract_1 >>=? fun balance -> + (* transfer all the tez inside contract 1 *) + transfer_and_check_balances ~loc:__LOC__ + b contract_1 contract_2 balance >>=? fun (b,_) -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(********************) +(** Transfer to itself *) +(********************) + +let transfers_to_self () = + Context.init 1 >>=? fun (b, contracts) -> + let contract = List.nth contracts 0 in + Incremental.begin_construction b >>=? fun b -> + two_nth_of_balance b contract 3L >>=? fun amount -> + transfer_to_itself_and_check_balances ~loc:__LOC__ b contract amount + >>=? fun (b, _) -> + two_nth_of_balance b contract 5L >>=? fun fee -> + transfer_to_itself_and_check_balances ~loc:__LOC__ b ~fee:fee contract ten_tez + >>=? fun (b, _) -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(********************) +(** Forgot to add the valid transaction into the block *) +(********************) + +let missing_transaction () = + register_two_contracts () >>=? fun (b, contract_1, contract_2) -> + (* given that contract_1 no longer has a sufficient balance to bake, + make sure it cannot be chosen as baker *) + Context.Contract.pkh contract_1 >>=? fun pkh1 -> + Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) >>=? fun b -> + two_nth_of_balance b contract_1 6L >>=? fun amount -> + (* do the transfer 3 times from source contract to destination contract *) + n_transactions 3 b contract_1 contract_2 amount >>=? fun b -> + (* do the fourth transfer from source contract to destination contract *) + Op.transaction (I b) contract_1 contract_2 amount >>=? fun _ -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(********************) +(** These following tests are for different kind of contracts: + - implicit to implicit + - implicit to originated + - originated to implicit + - originted to originted *) +(********************) + +(** Implicit to Implicit *) + +let transfer_from_implicit_to_implicit_contract () = + Context.init 1 >>=? fun (b, contracts) -> + let bootstrap_contract = List.nth contracts 0 in + let account_a = Account.new_account () in + let account_b = Account.new_account () in + Incremental.begin_construction b >>=? fun b -> + let src = Contract.implicit_contract account_a.Account.pkh in + two_nth_of_balance b bootstrap_contract 3L >>=? fun amount1 -> + two_nth_of_balance b bootstrap_contract 10L >>=? fun fee1 -> + transfer_and_check_balances ~with_burn:true ~loc:__LOC__ ~fee:fee1 b + bootstrap_contract src amount1 >>=? fun (b, _) -> + (* create an implicit contract as a destination contract *) + let dest = Contract.implicit_contract account_b.pkh in + two_nth_of_balance b bootstrap_contract 4L >>=? fun amount2 -> + two_nth_of_balance b bootstrap_contract 10L >>=? fun fee2 -> + (* transfer from implicit contract to another implicit contract *) + transfer_and_check_balances ~with_burn:true ~loc:__LOC__ ~fee:fee2 b + src dest amount2 >>=? fun (b, _) -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(** Implicit to originated *) + +let transfer_from_implicit_to_originated_contract () = + Context.init 1 >>=? fun (b, contracts) -> + let bootstrap_contract = List.nth contracts 0 in + let contract = List.nth contracts 0 in + let account = Account.new_account () in + let src = Contract.implicit_contract account.Account.pkh in + Incremental.begin_construction b >>=? fun b -> + two_nth_of_balance b bootstrap_contract 3L >>=? fun amount1 -> + (* transfer the money to implicit contract *) + transfer_and_check_balances ~with_burn:true ~loc:__LOC__ b bootstrap_contract src amount1 + >>=? fun (b, _) -> + (* originated contract *) + Op.origination (I b) contract ~script:Op.dummy_script >>=? fun (operation, new_contract) -> + Incremental.add_operation b operation >>=? fun b -> + two_nth_of_balance b bootstrap_contract 4L >>=? fun amount2 -> + (* transfer from implicit contract to originated contract *) + transfer_and_check_balances ~loc:__LOC__ b src new_contract amount2 + >>=? fun (b, _) -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(********************) +(** Slow tests case *) +(********************) + +let multiple_transfer n ?fee amount = + register_two_contracts () >>=? fun (b, contract_1, contract_2) -> + Incremental.begin_construction b >>=? fun b -> + n_transactions n b ?fee contract_1 contract_2 amount >>=? fun b -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(** 1- Create a block with two contracts; + 2- Apply 100 transfers. *) +let block_with_multiple_transfers () = + multiple_transfer 99 (Tez.of_int 1000) + +(** 1- Create a block with two contracts; + 2- Apply 100 transfers with 10tz fee. *) +let block_with_multiple_transfers_pay_fee () = + multiple_transfer 10 ~fee:ten_tez (Tez.of_int 1000) + +(** 1- Create a block with 8 contracts; + 2- Apply multiple transfers without fees; + 3- Apply multiple transfers with fees. *) +(* TODO : increase the number of operations and add a `Slow tag to it in `tests` *) +let block_with_multiple_transfers_with_without_fee () = + Context.init 8 >>=? fun (b, contracts) -> + let contracts = Array.of_list contracts in + Incremental.begin_construction b >>=? fun b -> + let hundred = Tez.of_int 100 in + let ten = Tez.of_int 10 in + let twenty = Tez.of_int 20 in + n_transactions 10 b contracts.(0) contracts.(1) Tez.one >>=? fun b -> + n_transactions 30 b contracts.(1) contracts.(2) hundred >>=? fun b -> + n_transactions 30 b contracts.(1) contracts.(3) hundred >>=? fun b -> + n_transactions 30 b contracts.(4) contracts.(3) hundred >>=? fun b -> + n_transactions 20 b contracts.(0) contracts.(1) hundred >>=? fun b -> + n_transactions 10 b contracts.(1) contracts.(3) hundred >>=? fun b -> + n_transactions 10 b contracts.(1) contracts.(3) hundred >>=? fun b -> + + n_transactions 20 ~fee:ten b contracts.(3) contracts.(4) ten >>=? fun b -> + n_transactions 10 ~fee:twenty b contracts.(4) contracts.(5) ten >>=? fun b -> + n_transactions 70 ~fee:twenty b contracts.(6) contracts.(0) twenty >>=? fun b -> + n_transactions 550 ~fee:twenty b contracts.(6) contracts.(4) twenty >>=? fun b -> + n_transactions 50 ~fee:ten b contracts.(7) contracts.(5) twenty >>=? fun b -> + n_transactions 30 ~fee:ten b contracts.(0) contracts.(7) hundred >>=? fun b -> + n_transactions 20 ~fee:ten b contracts.(1) contracts.(0) twenty >>=? fun b -> + + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(********************) +(** Build a chain that has 10 blocks. *) +(********************) + +let build_a_chain () = + register_two_contracts () >>=? fun (b, contract_1, contract_2) -> + let ten = Tez.of_int 10 in + fold_left_s (fun b _ -> + Incremental.begin_construction b >>=? fun b -> + transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 ten + >>=? fun (b, _) -> + Incremental.finalize_block b + ) b (1 -- 10) >>=? fun _ -> + return_unit + +(*********************************************************************) +(* Expected error test cases *) +(*********************************************************************) + +(********************) +(** transfer zero tez is forbidden in implicit contract *) +(********************) + +let empty_implicit () = + Context.init 1 >>=? fun (b, contracts) -> + let dest = List.nth contracts 0 in + let account = Account.new_account () in + Incremental.begin_construction b >>=? fun incr -> + let src = Contract.implicit_contract account.Account.pkh in + two_nth_of_balance incr dest 3L >>=? fun amount -> + (* transfer zero tez from an implicit contract *) + Op.transaction (I incr) src dest amount >>=? fun op -> + Incremental.add_operation incr op >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Contract_storage.Empty_implicit_contract _ -> true + | _ -> false + end + +(********************) +(** Balance is too low to transfer *) +(********************) + +let balance_too_low fee () = + register_two_contracts () >>=? fun (b, contract_1, contract_2) -> + Incremental.begin_construction b >>=? fun i -> + Context.Contract.balance (I i) contract_1 >>=? fun balance1 -> + Context.Contract.balance (I i) contract_2 >>=? fun balance2 -> + (* transfer the amount of tez that is bigger than the balance in the source contract *) + Op.transaction ~fee (I i) contract_1 contract_2 Tez.max_tez >>=? fun op -> + let expect_failure = function + | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ -> + return_unit + | _ -> + failwith "balance too low should fail" + in + (* the fee is higher than the balance then raise an error "Balance_too_low" *) + if fee > balance1 then begin + Incremental.add_operation ~expect_failure i op >>= fun _res -> + return_unit + end + (* the fee is smaller than the balance, then the transfer is accepted + but it is not processed, and fees are taken *) + else begin + Incremental.add_operation ~expect_failure i op >>=? fun i -> + (* contract_1 loses the fees *) + Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee >>=? fun () -> + (* contract_2 is not credited *) + Assert.balance_was_credited ~loc:__LOC__ (I i) contract_2 balance2 Tez.zero + end + +(** 1- Create a block, and three contracts; + 2- Add a transfer that at the end the balance of a contract is + zero into this block; + 3- Add another transfer that send tez from a zero balance contract; + 4- Catch the expected error: Balance_too_low. *) +let balance_too_low_two_transfers fee () = + Context.init 3 >>=? fun (b, contracts) -> + let contract_1 = List.nth contracts 0 in + let contract_2 = List.nth contracts 1 in + let contract_3 = List.nth contracts 2 in + Incremental.begin_construction b >>=? fun i -> + Context.Contract.balance (I i) contract_1 >>=? fun balance -> + Tez.(/?) balance 3L >>?= fun res -> + Tez.( *?) res 2L >>?= fun two_third_of_balance -> + transfer_and_check_balances ~loc:__LOC__ i + contract_1 contract_2 two_third_of_balance >>=? fun (i, _) -> + Context.Contract.balance (I i) contract_1 >>=? fun balance1 -> + Context.Contract.balance (I i) contract_3 >>=? fun balance3 -> + Op.transaction ~fee (I i) contract_1 contract_3 + two_third_of_balance >>=? fun operation -> + let expect_failure = function + | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ -> + return_unit + | _ -> + failwith "balance too low should fail" + in + Incremental.add_operation ~expect_failure i operation >>=? fun i -> + (* contract_1 loses the fees *) + Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee >>=? fun () -> + (* contract_3 is not credited *) + Assert.balance_was_credited ~loc:__LOC__ (I i) contract_3 balance3 Tez.zero + +(********************) +(** The counter is already used for the previous operation *) +(********************) + +let invalid_counter () = + register_two_contracts () >>=? fun (b, contract_1, contract_2) -> + Incremental.begin_construction b >>=? fun b -> + Op.transaction (I b) contract_1 contract_2 + Tez.one >>=? fun op1 -> + Op.transaction (I b) contract_1 contract_2 + Tez.one >>=? fun op2 -> + Incremental.add_operation b op1 >>=? fun b -> + Incremental.add_operation b op2 >>= fun b -> + Assert.proto_error ~loc:__LOC__ b begin function + | Contract_storage.Counter_in_the_past _ -> true + | _ -> false + end + +(* same as before but different way to perform this error *) + +let add_the_same_operation_twice () = + register_two_contracts () >>=? fun (b, contract_1, contract_2) -> + Incremental.begin_construction b >>=? fun b -> + transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 ten_tez + >>=? fun (b, op_transfer) -> + Op.transaction (I b) contract_1 contract_2 ten_tez >>=? fun _ -> + Incremental.add_operation b op_transfer >>= fun b -> + Assert.proto_error ~loc:__LOC__ b begin function + | Contract_storage.Counter_in_the_past _ -> true + | _ -> false + end + +(********************) +(** check ownership *) +(********************) + +let ownership_sender () = + register_two_contracts () >>=? fun (b, contract_1, contract_2) -> + Incremental.begin_construction b >>=? fun b -> + (* get the manager of the contract_1 as a sender *) + Context.Contract.manager (I b) contract_1 >>=? fun manager -> + (* create an implicit_contract *) + let imcontract_1 = Alpha_context.Contract.implicit_contract manager.pkh in + transfer_and_check_balances ~loc:__LOC__ b imcontract_1 contract_2 Tez.one + >>=? fun (b,_) -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(*********************************************************************) +(** Random transfer *) + +(** Return a pair of minimum and maximum random number *) +let random_range (min, max) = + let interv = max - min + 1 in + let init = + Random.self_init (); + (Random.int interv) + min + in init + +(** Return a random contract *) +let random_contract contract_array = + let i = Random.int (Array.length contract_array) in + contract_array.(i) + +(** Transfer by randomly choose amount 10 contracts, and randomly + choose the amount in the source contract *) +let random_transfer () = + Context.init 10 >>=? fun (b, contracts) -> + let contracts = Array.of_list contracts in + let source = random_contract contracts in + let dest = random_contract contracts in + Context.Contract.pkh source >>=? fun source_pkh -> + (* given that source may not have a sufficient balance for the transfer + to bake, + make sure it cannot be chosen as baker *) + Incremental.begin_construction b ~policy:(Block.Excluding [source_pkh]) >>=? fun b -> + Context.Contract.balance (I b) source >>=? fun amount -> + begin + if source = dest + then + transfer_to_itself_and_check_balances ~loc:__LOC__ b source amount + else + transfer_and_check_balances ~loc:__LOC__ b source dest amount + end >>=? fun (b,_) -> + Incremental.finalize_block b >>=? fun _ -> + return_unit + +(** Transfer random transactions *) +let random_multi_transactions () = + let n = random_range (1, 100) in + multiple_transfer n (Tez.of_int 100) + +(*********************************************************************) + +let tests = [ + (* single transfer *) + Test.tztest "single transfer" `Quick block_with_a_single_transfer ; + Test.tztest "single transfer with fee" `Quick block_with_a_single_transfer_with_fee ; + + (* transfer zero tez *) + Test.tztest "single transfer zero tez" `Quick transfer_zero_tez ; + Test.tztest "transfer zero tez from implicit contract" `Quick transfer_zero_implicit; + + (* transfer to originated contract *) + Test.tztest "transfer to originated contract paying transaction fee" `Quick transfer_to_originate_with_fee ; + + (* transfer by the balance of contract *) + Test.tztest "transfer the amount from source contract balance" `Quick transfer_amount_of_contract_balance ; + + (* transfer to itself *) + Test.tztest "transfers to itself" `Quick transfers_to_self ; + + (* missing operation *) + + Test.tztest "missing transaction" `Quick missing_transaction ; + + (* transfer from/to implicit/originted contracts*) + Test.tztest "transfer from an implicit to implicit contract " `Quick transfer_from_implicit_to_implicit_contract ; + Test.tztest "transfer from an implicit to an originated contract" `Quick transfer_from_implicit_to_originated_contract ; + + (* Slow tests *) + Test.tztest "block with multiple transfers" `Slow block_with_multiple_transfers ; + (* TODO increase the number of transaction times *) + Test.tztest "block with multiple transfer paying fee" `Slow block_with_multiple_transfers_pay_fee ; + Test.tztest "block with multiple transfer without paying fee" `Slow block_with_multiple_transfers_with_without_fee ; + + (* build the chain *) + Test.tztest "build a chain" `Quick build_a_chain ; + + (* Erroneous *) + Test.tztest "empty implicit" `Quick empty_implicit; + Test.tztest "balance too low - transfer zero" `Quick (balance_too_low Tez.zero); + Test.tztest "balance too low" `Quick (balance_too_low Tez.one); + Test.tztest "balance too low (max fee)" `Quick (balance_too_low Tez.max_tez); + Test.tztest "balance too low with two transfers - transfer zero" `Quick (balance_too_low_two_transfers Tez.zero); + Test.tztest "balance too low with two transfers" `Quick (balance_too_low_two_transfers Tez.one); + Test.tztest "invalid_counter" `Quick invalid_counter ; + Test.tztest "add the same operation twice" `Quick add_the_same_operation_twice ; + + Test.tztest "ownership sender" `Quick ownership_sender ; + (* Random tests *) + Test.tztest "random transfer" `Quick random_transfer ; + Test.tztest "random multi transfer" `Quick random_multi_transactions ; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/test/voting.ml b/vendors/ligo-utils/tezos-protocol-alpha/test/voting.ml new file mode 100644 index 000000000..d188405ce --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/test/voting.ml @@ -0,0 +1,943 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Test_utils + +(* missing stuff in Alpha_context.Vote *) +let ballots_zero = Alpha_context.Vote.{ yay = 0l ; nay = 0l ; pass = 0l } +let ballots_equal b1 b2 = + Alpha_context.Vote.(b1.yay = b2.yay && b1.nay = b2.nay && b1.pass = b2.pass) +let ballots_pp ppf v = Alpha_context.Vote.( + Format.fprintf ppf "{ yay = %ld ; nay = %ld ; pass = %ld" v.yay v.nay v.pass) + +(* constants and ratios used in voting: + percent_mul denotes the percent multiplier + initial_participation is 7000 that is, 7/10 * percent_mul + the participation EMA ratio pr_ema_weight / den = 7 / 10 + the participation ratio pr_num / den = 2 / 10 + note: we use the same denominator for both participation EMA and participation rate. + supermajority rate is s_num / s_den = 8 / 10 *) +let percent_mul = 100_00 +let initial_participation_num = 7 +let initial_participation = initial_participation_num * percent_mul / 10 +let pr_ema_weight = 8 +let den = 10 +let pr_num = den - pr_ema_weight +let s_num = 8 +let s_den = 10 +let qr_min_num = 2 +let qr_max_num = 7 +let expected_qr_num = + Float.(of_int qr_min_num +. + of_int initial_participation_num *. (of_int qr_max_num -. of_int qr_min_num) /. of_int den) + +(* Protocol_hash.zero is "PrihK96nBAFSxVL1GLJTVhu9YnzkMFiBeuJRPA8NwuZVZCE1L6i" *) +let protos = Array.map (fun s -> Protocol_hash.of_b58check_exn s) + [| "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH" ; + "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC" ; + "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC" ; + "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ" ; + "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD" ; + "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi" ; + "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG" ; + "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh" ; + "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx" ; + "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX" ; |] + +(** helper functions *) +let mk_contracts_from_pkh pkh_list = + List.map (Alpha_context.Contract.implicit_contract) pkh_list + +(* get the list of delegates and the list of their rolls from listings *) +let get_delegates_and_rolls_from_listings b = + Context.Vote.get_listings (B b) >>=? fun l -> + return ((mk_contracts_from_pkh (List.map fst l)), List.map snd l) + +(* compute the rolls of each delegate *) +let get_rolls b delegates loc = + Context.Vote.get_listings (B b) >>=? fun l -> + map_s (fun delegate -> + Context.Contract.pkh delegate >>=? fun pkh -> + match List.find_opt (fun (del,_) -> del = pkh) l with + | None -> failwith "%s - Missing delegate" loc + | Some (_, rolls) -> return rolls + ) delegates + +let test_successful_vote num_delegates () = + let min_proposal_quorum = Int32.(of_int @@ 100_00 / num_delegates) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b,_) -> + Context.get_constants (B b) >>=? + fun { parametric = {blocks_per_voting_period ; _ } ; _ } -> + + (* no ballots in proposal period *) + Context.Vote.get_ballots (B b) >>=? fun v -> + Assert.equal ~loc:__LOC__ ballots_equal "Unexpected ballots" ballots_pp + v ballots_zero >>=? fun () -> + + (* no ballots in proposal period *) + Context.Vote.get_ballot_list (B b) >>=? begin function + | [] -> return_unit + | _ -> failwith "%s - Unexpected ballot list" __LOC__ + end >>=? fun () -> + + (* period 0 *) + Context.Vote.get_voting_period (B b) >>=? fun v -> + let open Alpha_context in + Assert.equal ~loc:__LOC__ Voting_period.equal "Unexpected period" + Voting_period.pp v Voting_period.(root) + >>=? fun () -> + + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Proposal -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* participation EMA starts at initial_participation *) + Context.Vote.get_participation_ema b >>=? fun v -> + Assert.equal_int ~loc:__LOC__ initial_participation (Int32.to_int v) >>=? fun () -> + + (* listings must be populated in proposal period *) + Context.Vote.get_listings (B b) >>=? begin function + | [] -> failwith "%s - Unexpected empty listings" __LOC__ + | _ -> return_unit + end >>=? fun () -> + + (* beginning of proposal, denoted by _p1; + take a snapshot of the active delegates and their rolls from listings *) + get_delegates_and_rolls_from_listings b >>=? fun (delegates_p1, rolls_p1) -> + + (* no proposals at the beginning of proposal period *) + Context.Vote.get_proposals (B b) >>=? fun ps -> + begin if Environment.Protocol_hash.Map.is_empty ps + then return_unit + else failwith "%s - Unexpected proposals" __LOC__ + end >>=? fun () -> + + (* no current proposal during proposal period *) + Context.Vote.get_current_proposal (B b) >>=? begin function + | None -> return_unit + | Some _ -> failwith "%s - Unexpected proposal" __LOC__ + end >>=? fun () -> + + let del1 = List.nth delegates_p1 0 in + let del2 = List.nth delegates_p1 1 in + let props = List.map (fun i -> protos.(i)) + (2 -- Constants.max_proposals_per_delegate) in + Op.proposals (B b) del1 (Protocol_hash.zero::props) >>=? fun ops1 -> + Op.proposals (B b) del2 [Protocol_hash.zero] >>=? fun ops2 -> + Block.bake ~operations:[ops1;ops2] b >>=? fun b -> + + (* proposals are now populated *) + Context.Vote.get_proposals (B b) >>=? fun ps -> + + (* correctly count the double proposal for zero *) + begin + let weight = Int32.add (List.nth rolls_p1 0) (List.nth rolls_p1 1) in + match Environment.Protocol_hash.(Map.find_opt zero ps) with + | Some v -> if v = weight then return_unit + else failwith "%s - Wrong count %ld is not %ld" __LOC__ v weight + | None -> failwith "%s - Missing proposal" __LOC__ + end >>=? fun () -> + + (* proposing more than maximum_proposals fails *) + Op.proposals (B b) del1 (Protocol_hash.zero::props) >>=? fun ops -> + Block.bake ~operations:[ops] b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Amendment.Too_many_proposals -> true + | _ -> false + end >>=? fun () -> + + (* proposing less than one proposal fails *) + Op.proposals (B b) del1 [] >>=? fun ops -> + Block.bake ~operations:[ops] b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Amendment.Empty_proposal -> true + | _ -> false + end >>=? fun () -> + + (* skip to testing_vote period + -1 because we already baked one block with the proposal *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-2) b >>=? fun b -> + + (* we moved to a testing_vote period with one proposal *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing_vote -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* period 1 *) + Context.Vote.get_voting_period (B b) >>=? fun v -> + let open Alpha_context in + Assert.equal ~loc:__LOC__ Voting_period.equal "Unexpected period" + Voting_period.pp v Voting_period.(succ root) + >>=? fun () -> + + (* listings must be populated in testing_vote period *) + Context.Vote.get_listings (B b) >>=? begin function + | [] -> failwith "%s - Unexpected empty listings" __LOC__ + | _ -> return_unit + end >>=? fun () -> + + (* beginning of testing_vote period, denoted by _p2; + take a snapshot of the active delegates and their rolls from listings *) + get_delegates_and_rolls_from_listings b >>=? fun (delegates_p2, rolls_p2) -> + + (* no proposals during testing_vote period *) + Context.Vote.get_proposals (B b) >>=? fun ps -> + begin if Environment.Protocol_hash.Map.is_empty ps + then return_unit + else failwith "%s - Unexpected proposals" __LOC__ + end >>=? fun () -> + + (* current proposal must be set during testing_vote period *) + Context.Vote.get_current_proposal (B b) >>=? begin function + | Some v -> if Protocol_hash.(equal zero v) then return_unit + else failwith "%s - Wrong proposal" __LOC__ + | None -> failwith "%s - Missing proposal" __LOC__ + end >>=? fun () -> + + (* unanimous vote: all delegates --active when p2 started-- vote *) + map_s (fun del -> + Op.ballot (B b) del Protocol_hash.zero Vote.Yay) + delegates_p2 >>=? fun operations -> + Block.bake ~operations b >>=? fun b -> + + Op.ballot (B b) del1 Protocol_hash.zero Vote.Nay >>=? fun op -> + Block.bake ~operations:[op] b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res begin function + | Amendment.Unauthorized_ballot -> true + | _ -> false + end >>=? fun () -> + + fold_left_s (fun v acc -> return Int32.(add v acc)) + 0l rolls_p2 >>=? fun rolls_sum -> + + (* # of Yays in ballots matches rolls of the delegate *) + Context.Vote.get_ballots (B b) >>=? fun v -> + Assert.equal ~loc:__LOC__ ballots_equal "Unexpected ballots" ballots_pp + v Vote.{ yay = rolls_sum ; nay = 0l ; pass = 0l } >>=? fun () -> + + (* One Yay ballot per delegate *) + Context.Vote.get_ballot_list (B b) >>=? begin function + | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ + | l -> + iter_s (fun delegate -> + Context.Contract.pkh delegate >>=? fun pkh -> + match List.find_opt (fun (del,_) -> del = pkh) l with + | None -> failwith "%s - Missing delegate" __LOC__ + | Some (_, Vote.Yay) -> return_unit + | Some _ -> failwith "%s - Wrong ballot" __LOC__ + ) delegates_p2 + end >>=? fun () -> + + + (* skip to testing period + -1 because we already baked one block with the ballot *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* period 2 *) + Context.Vote.get_voting_period (B b) >>=? fun v -> + let open Alpha_context in + Assert.equal ~loc:__LOC__ Voting_period.equal "Unexpected period" + Voting_period.pp v Voting_period.(succ (succ root)) + >>=? fun () -> + + (* no ballots in testing period *) + Context.Vote.get_ballots (B b) >>=? fun v -> + Assert.equal ~loc:__LOC__ ballots_equal "Unexpected ballots" ballots_pp + v ballots_zero >>=? fun () -> + + (* listings must be empty in testing period *) + Context.Vote.get_listings (B b) >>=? begin function + | [] -> return_unit + | _ -> failwith "%s - Unexpected listings" __LOC__ + end >>=? fun () -> + + + (* skip to promotion_vote period *) + Block.bake_n (Int32.to_int blocks_per_voting_period) b >>=? fun b -> + + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Promotion_vote -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* period 3 *) + Context.Vote.get_voting_period (B b) >>=? fun v -> + let open Alpha_context in + Assert.equal ~loc:__LOC__ Voting_period.equal "Unexpected period" + Voting_period.pp v Voting_period.(succ (succ (succ root))) + >>=? fun () -> + + (* listings must be populated in promotion_vote period *) + Context.Vote.get_listings (B b) >>=? begin function + | [] -> failwith "%s - Unexpected empty listings" __LOC__ + | _ -> return_unit + end >>=? fun () -> + + (* beginning of promotion_vote period, denoted by _p4; + take a snapshot of the active delegates and their rolls from listings *) + get_delegates_and_rolls_from_listings b >>=? fun (delegates_p4, rolls_p4) -> + + (* no proposals during promotion_vote period *) + Context.Vote.get_proposals (B b) >>=? fun ps -> + begin if Environment.Protocol_hash.Map.is_empty ps + then return_unit + else failwith "%s - Unexpected proposals" __LOC__ + end >>=? fun () -> + + (* current proposal must be set during promotion_vote period *) + Context.Vote.get_current_proposal (B b) >>=? begin function + | Some v -> if Protocol_hash.(equal zero v) then return_unit + else failwith "%s - Wrong proposal" __LOC__ + | None -> failwith "%s - Missing proposal" __LOC__ + end >>=? fun () -> + + (* unanimous vote: all delegates --active when p4 started-- vote *) + map_s (fun del -> + Op.ballot (B b) del Protocol_hash.zero Vote.Yay) + delegates_p4 >>=? fun operations -> + Block.bake ~operations b >>=? fun b -> + + fold_left_s (fun v acc -> return Int32.(add v acc)) + 0l rolls_p4 >>=? fun rolls_sum -> + + (* # of Yays in ballots matches rolls of the delegate *) + Context.Vote.get_ballots (B b) >>=? fun v -> + Assert.equal ~loc:__LOC__ ballots_equal "Unexpected ballots" ballots_pp + v Vote.{ yay = rolls_sum ; nay = 0l ; pass = 0l } >>=? fun () -> + + (* One Yay ballot per delegate *) + Context.Vote.get_ballot_list (B b) >>=? begin function + | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ + | l -> + iter_s (fun delegate -> + Context.Contract.pkh delegate >>=? fun pkh -> + match List.find_opt (fun (del,_) -> del = pkh) l with + | None -> failwith "%s - Missing delegate" __LOC__ + | Some (_, Vote.Yay) -> return_unit + | Some _ -> failwith "%s - Wrong ballot" __LOC__ + ) delegates_p4 + end >>=? fun () -> + + (* skip to end of promotion_vote period and activation*) + Block.bake_n Int32.((to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* zero is the new protocol (before the vote this value is unset) *) + Context.Vote.get_protocol b >>= fun p -> + Assert.equal ~loc:__LOC__ Protocol_hash.equal "Unexpected proposal" + Protocol_hash.pp p Protocol_hash.zero >>=? fun () -> + + return_unit + +(* given a list of active delegates, + return the first k active delegates with which one can have quorum, that is: + their roll sum divided by the total roll sum is bigger than pr_ema_weight/den *) +let get_smallest_prefix_voters_for_quorum active_delegates active_rolls = + fold_left_s (fun v acc -> return Int32.(add v acc)) + 0l active_rolls >>=? fun active_rolls_sum -> + let rec loop delegates rolls sum selected = + match delegates, rolls with + | [], [] -> selected + | del :: delegates, del_rolls :: rolls -> + if den * sum < Float.to_int (expected_qr_num *. (Int32.to_float active_rolls_sum)) then + loop delegates rolls (sum + (Int32.to_int del_rolls)) (del :: selected) + else selected + | _, _ -> [] in + return (loop active_delegates active_rolls 0 []) + +let get_expected_participation_ema rolls voter_rolls old_participation_ema = + (* formula to compute the updated participation_ema *) + let get_updated_participation_ema old_participation_ema participation = + (pr_ema_weight * (Int32.to_int old_participation_ema) + + pr_num * participation) / den + in + fold_left_s (fun v acc -> return Int32.(add v acc)) + 0l rolls >>=? fun rolls_sum -> + fold_left_s (fun v acc -> return Int32.(add v acc)) + 0l voter_rolls >>=? fun voter_rolls_sum -> + let participation = (Int32.to_int voter_rolls_sum) * percent_mul / + (Int32.to_int rolls_sum) in + return (get_updated_participation_ema old_participation_ema participation) + +(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in testing vote, + go back to proposal period *) +let test_not_enough_quorum_in_testing_vote num_delegates () = + let min_proposal_quorum = Int32.(of_int @@ 100_00 / num_delegates) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b,delegates) -> + Context.get_constants (B b) >>=? + fun { parametric = {blocks_per_voting_period ; _ } ; _ } -> + + (* proposal period *) + let open Alpha_context in + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Proposal -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + let proposer = List.nth delegates 0 in + Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun ops -> + Block.bake ~operations:[ops] b >>=? fun b -> + + (* skip to vote_testing period + -1 because we already baked one block with the proposal *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-2) b >>=? fun b -> + + (* we moved to a testing_vote period with one proposal *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing_vote -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + Context.Vote.get_participation_ema b >>=? fun initial_participation_ema -> + (* beginning of testing_vote period, denoted by _p2; + take a snapshot of the active delegates and their rolls from listings *) + get_delegates_and_rolls_from_listings b >>=? fun (delegates_p2, rolls_p2) -> + + get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2 >>=? fun voters -> + (* take the first two voters out so there cannot be quorum *) + let voters_without_quorum = List.tl voters in + get_rolls b voters_without_quorum __LOC__ >>=? fun voters_rolls_in_testing_vote -> + + (* all voters_without_quorum vote, for yays; + no nays, so supermajority is satisfied *) + map_s (fun del -> + Op.ballot (B b) del Protocol_hash.zero Vote.Yay) + voters_without_quorum >>=? fun operations -> + Block.bake ~operations b >>=? fun b -> + + (* skip to testing period *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* we move back to the proposal period because not enough quorum *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Proposal -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* check participation_ema update *) + get_expected_participation_ema rolls_p2 + voters_rolls_in_testing_vote initial_participation_ema >>=? fun expected_participation_ema -> + Context.Vote.get_participation_ema b >>=? fun new_participation_ema -> + (* assert the formula to calculate participation_ema is correct *) + Assert.equal_int ~loc:__LOC__ expected_participation_ema + (Int32.to_int new_participation_ema) >>=? fun () -> + + return_unit + +(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in promotion vote, + go back to proposal period *) +let test_not_enough_quorum_in_promotion_vote num_delegates () = + let min_proposal_quorum = Int32.(of_int @@ 100_00 / num_delegates) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b,delegates) -> + Context.get_constants (B b) >>=? + fun { parametric = {blocks_per_voting_period ; _ } ; _ } -> + + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Proposal -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + let proposer = List.nth delegates 0 in + Op.proposals (B b) proposer (Protocol_hash.zero::[]) >>=? fun ops -> + Block.bake ~operations:[ops] b >>=? fun b -> + + (* skip to vote_testing period + -1 because we already baked one block with the proposal *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-2) b >>=? fun b -> + + (* we moved to a testing_vote period with one proposal *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing_vote -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* beginning of testing_vote period, denoted by _p2; + take a snapshot of the active delegates and their rolls from listings *) + get_delegates_and_rolls_from_listings b >>=? fun (delegates_p2, rolls_p2) -> + + get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2 >>=? fun voters -> + + let open Alpha_context in + + (* all voters vote, for yays; + no nays, so supermajority is satisfied *) + map_s (fun del -> + Op.ballot (B b) del Protocol_hash.zero Vote.Yay) + voters >>=? fun operations -> + + Block.bake ~operations b >>=? fun b -> + + (* skip to testing period *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* we move to testing because we have supermajority and enough quorum *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* skip to promotion_vote period *) + Block.bake_n (Int32.to_int blocks_per_voting_period) b >>=? fun b -> + + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Promotion_vote -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + Context.Vote.get_participation_ema b >>=? fun initial_participation_ema -> + (* beginning of promotion period, denoted by _p4; + take a snapshot of the active delegates and their rolls from listings *) + get_delegates_and_rolls_from_listings b >>=? fun (delegates_p4, rolls_p4) -> + get_smallest_prefix_voters_for_quorum delegates_p4 rolls_p4 >>=? fun voters -> + + (* take the first voter out so there cannot be quorum *) + let voters_without_quorum = List.tl voters in + get_rolls b voters_without_quorum __LOC__ >>=? fun voter_rolls -> + + (* all voters_without_quorum vote, for yays; + no nays, so supermajority is satisfied *) + map_s (fun del -> + Op.ballot (B b) del Protocol_hash.zero Vote.Yay) + voters_without_quorum >>=? fun operations -> + Block.bake ~operations b >>=? fun b -> + + (* skip to end of promotion_vote period *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + get_expected_participation_ema rolls_p4 voter_rolls + initial_participation_ema >>=? fun expected_participation_ema -> + + Context.Vote.get_participation_ema b >>=? fun new_participation_ema -> + + (* assert the formula to calculate participation_ema is correct *) + Assert.equal_int ~loc:__LOC__ expected_participation_ema + (Int32.to_int new_participation_ema) >>=? fun () -> + + (* we move back to the proposal period because not enough quorum *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Proposal -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + return_unit + +let test_multiple_identical_proposals_count_as_one () = + Context.init 1 >>=? fun (b,delegates) -> + + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Proposal -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + let proposer = List.hd delegates in + Op.proposals (B b) proposer + [Protocol_hash.zero; Protocol_hash.zero] >>=? fun ops -> + Block.bake ~operations:[ops] b >>=? fun b -> + (* compute the weight of proposals *) + Context.Vote.get_proposals (B b) >>=? fun ps -> + + (* compute the rolls of proposer *) + Context.Contract.pkh proposer >>=? fun pkh -> + Context.Vote.get_listings (B b) >>=? fun l -> + begin match List.find_opt (fun (del,_) -> del = pkh) l with + | None -> failwith "%s - Missing delegate" __LOC__ + | Some (_, proposer_rolls) -> return proposer_rolls + end >>=? fun proposer_rolls -> + + (* correctly count the double proposal for zero as one proposal *) + let expected_weight_proposer = proposer_rolls in + match Environment.Protocol_hash.(Map.find_opt zero ps) with + | Some v -> if v = expected_weight_proposer then return_unit + else failwith + "%s - Wrong count %ld is not %ld; identical proposals count as one" + __LOC__ v expected_weight_proposer + | None -> failwith "%s - Missing proposal" __LOC__ + + +(* assumes the initial balance of allocated by Context.init is at + least 4 time the value of the tokens_per_roll constant *) +let test_supermajority_in_proposal there_is_a_winner () = + let min_proposal_quorum = 0l in + Context.init ~min_proposal_quorum ~initial_balances:[1L; 1L; 1L] 10 >>=? fun (b,delegates) -> + Context.get_constants (B b) + >>=? fun { parametric = {blocks_per_cycle; blocks_per_voting_period; tokens_per_roll; _ } ; _ } -> + + let del1 = List.nth delegates 0 in + let del2 = List.nth delegates 1 in + let del3 = List.nth delegates 2 in + + map_s (fun del -> Context.Contract.pkh del) [del1; del2; del3] >>=? fun pkhs -> + let policy = Block.Excluding pkhs in + + Op.transaction (B b) (List.nth delegates 3) del1 tokens_per_roll >>=? fun op1 -> + Op.transaction (B b) (List.nth delegates 4) del2 tokens_per_roll >>=? fun op2 -> + begin + if there_is_a_winner + then Test_tez.Tez.( *? ) tokens_per_roll 3L + else Test_tez.Tez.( *? ) tokens_per_roll 2L + end >>?= fun bal3 -> + Op.transaction (B b) (List.nth delegates 5) del3 bal3 >>=? fun op3 -> + + Block.bake ~policy ~operations:[op1; op2; op3] b >>=? fun b -> + + (* we let one voting period pass; we make sure that: + - the three selected delegates remain active by re-registering as delegates + - their number of rolls do not change *) + fold_left_s (fun b _ -> + Error_monad.map_s (fun del -> + Context.Contract.pkh del >>=? fun pkh -> + Op.delegation (B b) del (Some pkh) + ) delegates >>=? fun ops -> + Block.bake ~policy ~operations:ops b >>=? fun b -> + Block.bake_until_cycle_end ~policy b + ) b (1 -- + (Int32.to_int (Int32.div blocks_per_voting_period blocks_per_cycle))) >>=? fun b -> + + (* make the proposals *) + Op.proposals (B b) del1 [protos.(0)] >>=? fun ops1 -> + Op.proposals (B b) del2 [protos.(0)] >>=? fun ops2 -> + Op.proposals (B b) del3 [protos.(1)] >>=? fun ops3 -> + Block.bake ~policy ~operations:[ops1;ops2;ops3] b >>=? fun b -> + Block.bake_n ~policy ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* we remain in the proposal period when there is no winner, + otherwise we move to the testing vote period *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing_vote -> + if there_is_a_winner then return_unit + else failwith "%s - Expected period kind Proposal, obtained Testing_vote" __LOC__ + | Proposal -> + if not there_is_a_winner then return_unit + else failwith "%s - Expected period kind Testing_vote, obtained Proposal" __LOC__ + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + return_unit + + +let test_quorum_in_proposal has_quorum () = + let total_tokens = 32_000_000_000_000L in + let half_tokens = Int64.div total_tokens 2L in + Context.init + ~initial_balances:[1L; half_tokens; half_tokens] + 3 >>=? fun (b,delegates) -> + Context.get_constants (B b) >>=? fun { + parametric = { + blocks_per_cycle; + blocks_per_voting_period; + min_proposal_quorum; _ } ; _ } -> + + let del1 = List.nth delegates 0 in + let del2 = List.nth delegates 1 in + + map_s (fun del -> Context.Contract.pkh del) [del1; del2] >>=? fun pkhs -> + let policy = Block.Excluding pkhs in + + let quorum = + if has_quorum then + Int64.of_int32 min_proposal_quorum + else + Int64.(sub (of_int32 min_proposal_quorum) 10L) in + let bal = + Int64.(div (mul total_tokens quorum) 100_00L) + |> Test_tez.Tez.of_mutez_exn in + Op.transaction (B b) del2 del1 bal >>=? fun op2 -> + Block.bake ~policy ~operations:[op2] b >>=? fun b -> + + (* we let one voting period pass; we make sure that: + - the two selected delegates remain active by re-registering as delegates + - their number of rolls do not change *) + fold_left_s (fun b _ -> + Error_monad.map_s (fun del -> + Context.Contract.pkh del >>=? fun pkh -> + Op.delegation (B b) del (Some pkh) + ) [del1;del2] >>=? fun ops -> + Block.bake ~policy ~operations:ops b >>=? fun b -> + Block.bake_until_cycle_end ~policy b + ) b (1 -- + (Int32.to_int (Int32.div blocks_per_voting_period blocks_per_cycle))) >>=? fun b -> + + (* make the proposal *) + Op.proposals (B b) del1 [protos.(0)] >>=? fun ops -> + Block.bake ~policy ~operations:[ops] b >>=? fun b -> + Block.bake_n ~policy ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* we remain in the proposal period when there is no quorum, + otherwise we move to the testing vote period *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing_vote -> + if has_quorum then return_unit + else failwith "%s - Expected period kind Proposal, obtained Testing_vote" __LOC__ + | Proposal -> + if not has_quorum then return_unit + else failwith "%s - Expected period kind Testing_vote, obtained Proposal" __LOC__ + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + return_unit + + +let test_supermajority_in_testing_vote supermajority () = + let min_proposal_quorum = Int32.(of_int @@ 100_00 / 100) in + Context.init ~min_proposal_quorum 100 >>=? fun (b,delegates) -> + Context.get_constants (B b) >>=? + fun { parametric = {blocks_per_voting_period ; _ } ; _ } -> + + let del1 = List.nth delegates 0 in + let proposal = protos.(0) in + + Op.proposals (B b) del1 [proposal] >>=? fun ops1 -> + Block.bake ~operations:[ops1] b >>=? fun b -> + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* move to testing_vote *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing_vote -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* assert our proposal won *) + Context.Vote.get_current_proposal (B b) >>=? begin function + | Some v -> if Protocol_hash.(equal proposal v) then return_unit + else failwith "%s - Wrong proposal" __LOC__ + | None -> failwith "%s - Missing proposal" __LOC__ + end >>=? fun () -> + + (* beginning of testing_vote period, denoted by _p2; + take a snapshot of the active delegates and their rolls from listings *) + get_delegates_and_rolls_from_listings b >>=? fun (delegates_p2, _olls_p2) -> + + (* supermajority means [num_yays / (num_yays + num_nays) >= s_num / s_den], + which is equivalent with [num_yays >= num_nays * s_num / (s_den - s_num)] *) + let num_delegates = List.length delegates_p2 in + let num_nays = num_delegates / 5 in (* any smaller number will do as well *) + let num_yays = num_nays * s_num / (s_den - s_num) in + (* 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 + map_s (fun del -> + Op.ballot (B b) del proposal Vote.Yay) + yays_delegates >>=? fun operations_yays -> + map_s (fun del -> + Op.ballot (B b) del proposal Vote.Nay) + nays_delegates >>=? fun operations_nays -> + let operations = operations_yays @ operations_nays in + + Block.bake ~operations b >>=? fun b -> + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing -> + if supermajority then return_unit + else failwith "%s - Expected period kind Proposal, obtained Testing" __LOC__ + | Proposal -> + if not supermajority then return_unit + else failwith "%s - Expected period kind Testing_vote, obtained Proposal" __LOC__ + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + return_unit + +(* test also how the selection scales: all delegates propose max proposals *) +let test_no_winning_proposal num_delegates () = + let min_proposal_quorum = Int32.(of_int @@ 100_00 / num_delegates) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b,_) -> + Context.get_constants (B b) >>=? + fun { parametric = {blocks_per_voting_period ; _ } ; _ } -> + + (* beginning of proposal, denoted by _p1; + take a snapshot of the active delegates and their rolls from listings *) + get_delegates_and_rolls_from_listings b >>=? fun (delegates_p1, _rolls_p1) -> + + let open Alpha_context in + let props = List.map (fun i -> protos.(i)) + (1 -- Constants.max_proposals_per_delegate) in + (* all delegates active in p1 propose the same proposals *) + map_s + (fun del -> Op.proposals (B b) del props) + delegates_p1 >>=? fun ops_list -> + Block.bake ~operations:ops_list b >>=? fun b -> + + (* skip to testing_vote period + -1 because we already baked one block with the proposal *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-2) b >>=? fun b -> + + (* we stay in the same proposal period because no winning proposal *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Proposal -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + return_unit + +(** Test that for the vote to pass with maximum possible participation_ema + (100%), it is sufficient for the vote quorum to be equal or greater than + the maximum quorum cap. *) +let test_quorum_capped_maximum num_delegates () = + let min_proposal_quorum = Int32.(of_int @@ 100_00 / num_delegates) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b,delegates) -> + (* set the participation EMA to 100% *) + Context.Vote.set_participation_ema b 100_00l >>= fun b -> + Context.get_constants (B b) >>=? + fun { parametric = { blocks_per_voting_period ; quorum_max ; _ } ; _ } -> + + (* proposal period *) + let open Alpha_context in + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Proposal -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* propose a new protocol *) + let protocol = Protocol_hash.zero in + let proposer = List.nth delegates 0 in + Op.proposals (B b) proposer [protocol] >>=? fun ops -> + Block.bake ~operations:[ops] b >>=? fun b -> + + (* skip to vote_testing period + -1 because we already baked one block with the proposal *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* we moved to a testing_vote period with one proposal *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing_vote -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* take percentage of the delegates equal or greater than quorum_max *) + let minimum_to_pass = + Float.of_int (List.length delegates) *. Int32.(to_float quorum_max) /. 100_00. + |> Float.ceil + |> Float.to_int + in + let voters = List.take_n minimum_to_pass delegates in + (* all voters vote for yays; no nays, so supermajority is satisfied *) + map_s (fun del -> + Op.ballot (B b) del protocol Vote.Yay) + voters >>=? fun operations -> + Block.bake ~operations b >>=? fun b -> + + (* skip to next period *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* expect to move to testing because we have supermajority and enough quorum *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end + +(** Test that for the vote to pass with minimum possible participation_ema + (0%), it is sufficient for the vote quorum to be equal or greater than + the minimum quorum cap. *) +let test_quorum_capped_minimum num_delegates () = + let min_proposal_quorum = Int32.(of_int @@ 100_00 / num_delegates) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b,delegates) -> + (* set the participation EMA to 0% *) + Context.Vote.set_participation_ema b 0l >>= fun b -> + Context.get_constants (B b) >>=? + fun { parametric = { blocks_per_voting_period ; quorum_min ; _ } ; _ } -> + + (* proposal period *) + let open Alpha_context in + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Proposal -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* propose a new protocol *) + let protocol = Protocol_hash.zero in + let proposer = List.nth delegates 0 in + Op.proposals (B b) proposer [protocol] >>=? fun ops -> + Block.bake ~operations:[ops] b >>=? fun b -> + + (* skip to vote_testing period + -1 because we already baked one block with the proposal *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* we moved to a testing_vote period with one proposal *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing_vote -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end >>=? fun () -> + + (* take percentage of the delegates equal or greater than quorum_min *) + let minimum_to_pass = + Float.of_int (List.length delegates) *. Int32.(to_float quorum_min) /. 100_00. + |> Float.ceil + |> Float.to_int + in + let voters = List.take_n minimum_to_pass delegates in + (* all voters vote for yays; no nays, so supermajority is satisfied *) + map_s (fun del -> + Op.ballot (B b) del protocol Vote.Yay) + voters >>=? fun operations -> + Block.bake ~operations b >>=? fun b -> + + (* skip to next period *) + Block.bake_n ((Int32.to_int blocks_per_voting_period)-1) b >>=? fun b -> + + (* expect to move to testing because we have supermajority and enough quorum *) + Context.Vote.get_current_period_kind (B b) >>=? begin function + | Testing -> return_unit + | _ -> failwith "%s - Unexpected period kind" __LOC__ + end + +let tests = [ + Test.tztest "voting successful_vote" `Quick (test_successful_vote 137) ; + Test.tztest "voting testing vote, not enough quorum" `Quick (test_not_enough_quorum_in_testing_vote 245) ; + Test.tztest "voting promotion vote, not enough quorum" `Quick (test_not_enough_quorum_in_promotion_vote 432) ; + Test.tztest "voting counting double proposal" `Quick test_multiple_identical_proposals_count_as_one; + Test.tztest "voting proposal, with supermajority" `Quick (test_supermajority_in_proposal true) ; + Test.tztest "voting proposal, without supermajority" `Quick (test_supermajority_in_proposal false) ; + Test.tztest "voting proposal, with quorum" `Quick (test_quorum_in_proposal true) ; + Test.tztest "voting proposal, without quorum" `Quick (test_quorum_in_proposal false) ; + Test.tztest "voting testing vote, with supermajority" `Quick (test_supermajority_in_testing_vote true) ; + Test.tztest "voting testing vote, without supermajority" `Quick (test_supermajority_in_testing_vote false) ; + Test.tztest "voting proposal, no winning proposal" `Quick (test_no_winning_proposal 400) ; + Test.tztest "voting quorum, quorum capped maximum" `Quick (test_quorum_capped_maximum 400) ; + Test.tztest "voting quorum, quorum capped minimum" `Quick (test_quorum_capped_minimum 401) ; +] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-alpha.opam b/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-005-PsBabyM1.opam similarity index 93% rename from vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-alpha.opam rename to vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-005-PsBabyM1.opam index 15bc2a46b..d1468da55 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-alpha.opam +++ b/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-005-PsBabyM1.opam @@ -10,7 +10,7 @@ depends: [ "ocamlfind" { build } "dune" { build & >= "1.7" } "tezos-base" - "tezos-protocol-alpha" + "tezos-protocol-005-PsBabyM1" "tezos-protocol-compiler" "tezos-protocol-updater" ] @@ -19,7 +19,7 @@ build: [ "%{tezos-protocol-compiler:lib}%/replace" "%{tezos-protocol-compiler:lib}%/dune_protocol.template" "dune" - "alpha" + "005_PsBabyM1" ] ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha-tests.opam b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-005-PsBabyM1-tests.opam similarity index 87% rename from vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha-tests.opam rename to vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-005-PsBabyM1-tests.opam index 014be54fc..59f78ff77 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha-tests.opam +++ b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-005-PsBabyM1-tests.opam @@ -12,10 +12,10 @@ depends: [ "tezos-base" "tezos-protocol-compiler" "alcotest-lwt" { with-test } - "tezos-alpha-test-helpers" { with-test } + "tezos-005-PsBabyM1-test-helpers" { with-test } "tezos-stdlib-unix" { with-test } "tezos-protocol-environment" { with-test } - "tezos-protocol-alpha-parameters" { with-test } + "tezos-protocol-005-PsBabyM1-parameters" { with-test } "tezos-shell-services" { with-test } "bip39" { with-test } ] @@ -24,7 +24,7 @@ build: [ "%{tezos-protocol-compiler:lib}%/replace" "%{tezos-protocol-compiler:lib}%/dune_protocol.template" "dune" - "alpha" + "005_PsBabyM1" ] ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha.opam b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-005-PsBabyM1.opam similarity index 95% rename from vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha.opam rename to vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-005-PsBabyM1.opam index af0f2d8ef..d1497019b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-alpha.opam +++ b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-005-PsBabyM1.opam @@ -1,5 +1,4 @@ opam-version: "2.0" -version: "ligo" maintainer: "contact@tezos.com" authors: [ "Tezos devteam" ] homepage: "https://www.tezos.com/" @@ -18,7 +17,7 @@ build: [ "%{tezos-protocol-compiler:lib}%/replace" "%{tezos-protocol-compiler:lib}%/dune_protocol.template" "dune" - "alpha" + "005_PsBabyM1" ] ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} diff --git a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml index cf81a0019..1709ca358 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml @@ -27,6 +27,7 @@ include Time type time = t type error += Timestamp_add (* `Permanent *) +type error += Timestamp_sub (* `Permanent *) let () = register_error_kind @@ -38,7 +39,17 @@ let () = Format.fprintf ppf "Overflow when adding timestamps.") Data_encoding.empty (function Timestamp_add -> Some () | _ -> None) - (fun () -> Timestamp_add) + (fun () -> Timestamp_add); + register_error_kind + `Permanent + ~id:"timestamp_sub" + ~title:"Timestamp sub" + ~description:"Substracting timestamps resulted in negative period." + ~pp:(fun ppf () -> + Format.fprintf ppf "Substracting timestamps resulted in negative period.") + Data_encoding.empty + (function Timestamp_sub -> Some () | _ -> None) + (fun () -> Timestamp_sub) let of_seconds s = try Some (of_seconds (Int64.of_string s)) @@ -49,6 +60,9 @@ let to_seconds_string s = Int64.to_string (to_seconds s) let pp = pp_hum let (+?) x y = - (* TODO check overflow *) try ok (add x (Period_repr.to_seconds y)) - with _exn -> Error [ Timestamp_add ] + with _exn -> error Timestamp_add + +let (-?) x y = + record_trace Timestamp_sub + (Period_repr.of_seconds (diff x y)) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli index 4269fe68c..3cb96922f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli @@ -31,4 +31,5 @@ val of_seconds: string -> time option val to_seconds_string: time -> string val (+?) : time -> Period_repr.t -> time tzresult +val (-?) : time -> time -> Period_repr.t tzresult diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml index 3a2a7b452..d5e901321 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml @@ -124,15 +124,24 @@ let clear_listings ctxt = let get_current_period_kind = Storage.Vote.Current_period_kind.get let set_current_period_kind = Storage.Vote.Current_period_kind.set -let get_current_quorum = Storage.Vote.Current_quorum.get -let set_current_quorum = Storage.Vote.Current_quorum.set +let get_current_quorum ctxt = + Storage.Vote.Participation_ema.get ctxt >>=? fun participation_ema -> + let quorum_min = Constants_storage.quorum_min ctxt in + let quorum_max = Constants_storage.quorum_max ctxt in + let quorum_diff = Int32.sub quorum_max quorum_min in + return Int32.(add quorum_min + (div (mul participation_ema quorum_diff) 100_00l)) + +let get_participation_ema = Storage.Vote.Participation_ema.get +let set_participation_ema = Storage.Vote.Participation_ema.set let get_current_proposal = Storage.Vote.Current_proposal.get let init_current_proposal = Storage.Vote.Current_proposal.init let clear_current_proposal = Storage.Vote.Current_proposal.delete let init ctxt = - (* quorum is in centile of a percentage *) - Storage.Vote.Current_quorum.init ctxt 80_00l >>=? fun ctxt -> + (* participation EMA is in centile of a percentage *) + let participation_ema = Constants_storage.quorum_max ctxt in + Storage.Vote.Participation_ema.init ctxt participation_ema >>=? fun ctxt -> Storage.Vote.Current_period_kind.init ctxt Proposal >>=? fun ctxt -> return ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli index 3853f5e8f..6606bbb83 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli @@ -79,7 +79,9 @@ val in_listings: val get_listings : Raw_context.t -> (Signature.Public_key_hash.t * int32) list Lwt.t val get_current_quorum: Raw_context.t -> int32 tzresult Lwt.t -val set_current_quorum: Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t + +val get_participation_ema: Raw_context.t -> int32 tzresult Lwt.t +val set_participation_ema: Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t val get_current_period_kind: Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml index 80a42a4cd..37220bdc8 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml @@ -112,8 +112,8 @@ let register () = (* this would be better implemented using get_option in get_current_proposal *) Vote.get_current_proposal ctxt >>= function | Ok p -> return_some p - | Error [Raw_context.Storage_error (Missing_key _)] -> return_none - | (Error _ as e) -> Lwt.return e + | Error (Raw_context.Storage_error (Missing_key _) :: _) -> return_none + | Error _ as e -> Lwt.return e end let ballots ctxt block = diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 8f8527f30..8f20e8c30 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -1,7 +1,8 @@ open Tezos_micheline open Micheline -include Memory_proto_alpha.Protocol.Michelson_v1_primitives +open Memory_proto_alpha.Protocol +include Michelson_v1_primitives type michelson = (int, prim) node type t = michelson @@ -45,6 +46,8 @@ let i_push ty code = prim ~children:[ty;code] I_PUSH let i_push_unit = i_push t_unit d_unit let i_push_string str = i_push t_string (string str) +let i_apply = prim I_APPLY + let i_comment s : michelson = seq [ i_push_string s ; prim I_DROP ] let i_none ty = prim ~children:[ty] I_NONE @@ -56,6 +59,7 @@ let i_some = prim I_SOME let i_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA let i_empty_map src dst = prim ~children:[src;dst] I_EMPTY_MAP let i_drop = prim I_DROP +let i_dropn n = prim I_DROP ~children:[int (Z.of_int n)] let i_exec = prim I_EXEC let i_if a b = prim ~children:[seq [a] ; seq[b]] I_IF @@ -67,6 +71,9 @@ let i_assert_some = i_if_none (seq [i_push_string "ASSERT_SOME" ; i_failwith]) ( let i_assert_some_msg msg = i_if_none (seq [msg ; i_failwith]) (seq []) let dip code : michelson = prim ~children:[seq [code]] I_DIP +let dipn n code = prim ~children:[Int (0 , Z.of_int n) ; seq [code]] I_DIP +let i_dig n : michelson = prim ~children:[Int (0 , Z.of_int n)] I_DIG +let i_dug n : michelson = prim ~children:[Int (0 , Z.of_int n)] I_DUG let i_unpair = seq [i_dup ; i_car ; dip i_cdr] let i_unpiar = seq [i_dup ; i_cdr ; dip i_car] @@ -92,3 +99,10 @@ let pp_json ppf (michelson : michelson) = ) in Format.fprintf ppf "%a" Tezos_data_encoding.Json.pp json + +let pp_hex ppf (michelson : michelson) = + let canonical = strip_locations michelson in + let bytes = Tezos_data_encoding.Binary_writer.to_bytes_exn Script_repr.expr_encoding canonical in + let bytes = Tezos_stdlib.MBytes.to_bytes bytes in + let hex = Hex.of_bytes bytes in + Format.fprintf ppf "%a" Hex.pp hex