diff --git a/.gitignore b/.gitignore index 9596d6ad..2833604f 100644 --- a/.gitignore +++ b/.gitignore @@ -6,5 +6,7 @@ _opam* *-orig /liquidity /liquidity-mini +/liquidity-client /docs/sphinx/src/_extensions/__pycache__/ +/docs/sphinx/src/man/liquidity* /DEVEL \ No newline at end of file diff --git a/.gitmodules b/.gitmodules index bb2a0d37..2e45e90a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -2,3 +2,6 @@ path = dune-network url = https://gitlab.com/dune-network/dune-network.git branch = mainnet +[submodule "libs/ezcmd"] + path = libs/ezcmd + url = https://github.com/OCamlPro/ezcmd.git diff --git a/CHANGES b/CHANGES index b9b32f89..3fb3c640 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,110 @@ +2.0 2020/06/23 + NEW FEATURES + * Support for Babylon+ + - Only write entry points' type parameter in signatures [BREAKING CHANGE] + - Multiple entry points (compiler/client) + - Lifting of restictions on big maps + - New instruction `Big_map.create` + - Big map constants + - Use new Michelson instructions `DIP n`, `DROP n` + - Compile DUP n with DIP+DIG instead of DU.UP macro to avoid bubbling + expansion to `DIP { DUP; SWAP }` + - Deprecate `Current.gas` + - Type `chain_id` and instruction `Chain.id : unit -> chain_id` + * Remove contract instances, and use contract handles instead [BREAKING CHANGE] + * Allow polymorphic variants (so as to not have to declare type) + * Allow capitalized entry point names with syntax + `let%entry `Entry = fun param -> fun storage -> body` + * New instruction `Contract.address` returns address without entry point + handle [BREAKING CHANGE] + * Previous behaviour can be accessed with `Contract.untype` + * Addresses can have an entry point handle with syntax + `KT1LLcCCB9Fr1hrkGzfdiJ9u3ZajbdckBFrF%entry_name` + + IMPROVEMENTS + * Better simplifications (for sequences) and inlining + * Decompilation of Michelson entry points with arbitrary names + * Modular client in separate executable `liquidity-client` + * Documenation + +1.057 2020/01/14 + BUG FIXES + * Fix scoping bug in inlining + * Don't use _ as a variable name when decompiling + +1.056 2020/01/08 + BUG FIXES + * Fix conflicts in internal names with multiple contracts + +1.055 2019/11/28 + NEW FEATURES + * Estimate fees and storage (burn) in Client + + IMPROVEMENTS + * Updated documentation + +1.053 2019/10/08 + NEW FEATURES + * Fee code (only Dune Network) + * Decompilation of Michelson fee code + + IMPROVEMENTS + * Switch to Dune Network backend + * Remove unecessary type annotation in decompiled Liquidity + +1.044 2019/09/02 + IMPROVEMENTS + * Generate contracts whose parameter is compatible with upcoming version of + Michelson + +1.042 2019/07/19 + IMPROVEMENTS + * Client update wrt. Tezos protocol + + BUG FIXES + * Decompilation of failing branches + * Restriction on timestamp operations + +1.041 2019/07/09 + NEW FEATURES + * Allow lambdas in constants + +1.04 2019/05/24 + NEW FEATURES + * GPL license + + IMPROVEMENTS + * Client update wrt. Tezos protocol + + BUG FIXES + * Occur check with physiscal equality (in inlining phase) + +1.03 2019/04/03 + NEW FEATURES + * Uncurrying of totally applied functions + + IMPROVEMENTS + * Bytes.pack is polymorphic + * Better simplifications + * Better error reporting + * Inlining of closures and constants + * Better name/strucuture recovery when decompiling + + BUG FIXES + * Monomorphisation global values/variables + * Dependencies when using sub-contract as main (#201) + * Fix issue in decompilation of sub-contracts + * Fix namespace for first class contract types (#202) + +1.02 2019/04/02 + IMPROVEMENTS + * Debug information with --verbose + + BUG FIXES + * Fix issue in monomophisation + * Normalize types wrt current namesapce (#197) + * Fix issue with module and contract aliases + 1.0 2019-03-08 NEW FEATURES * Revamped module system for function exports diff --git a/Makefile b/Makefile index 33b661d2..90cca8d9 100644 --- a/Makefile +++ b/Makefile @@ -32,14 +32,21 @@ _obuild/liquidity/liquidity.asm: _obuild _obuild/liquidity-mini/liquidity-mini.asm: _obuild ocp-build build liquidity-mini +_obuild/liquidity-client/liquidity-client.asm: _obuild + ocp-build build liquidity-client + +liquidity-client: _obuild/liquidity-client/liquidity-client.asm + cp -f _obuild/liquidity-client/liquidity-client.asm liquidity-client + liquidity-mini: _obuild/liquidity-mini/liquidity-mini.asm cp -f _obuild/liquidity-mini/liquidity-mini.asm liquidity-mini liquidity: _obuild/liquidity/liquidity.asm cp -f _obuild/liquidity/liquidity.asm liquidity +client: liquidity-mini mini: liquidity-mini -build: liquidity liquidity-mini +build: liquidity liquidity-mini liquidity-client install: _obuild ocp-build install liquidity @@ -93,16 +100,20 @@ MORE_TESTS=test_ifcons test_if test_loop test_option test_transfer test_call tes test_mapmap_closure test_setreduce_closure test_left_match test_loop_left \ test_fold test_iter test_big_map test_map_fold_closure test_inline test_rec_fun \ bug_annot0 inline_fail bug_annot1 test_infer_unpack test_infer_param test_record \ - bug187 test_modules lambda_const votes bug_197 curry bug_210 bug_213 bug_213_0 \ + bug187 test_modules lambda_const votes bug_197 curry bug_210 bug_213 \ bug_214 bug_216 bug_steven1 bug_steven2 bug_inline2 RE_TESTS=bug202 -OTHER_TESTS=others/broker others/demo others/auction others/multisig others/alias others/game others/mist_wallet_current others/token others/token_vote others/token_no_fee +OTHER_TESTS=others/broker others/demo others/auction others/multisig others/alias others/game others/mist_wallet_current others/token others/token_vote others/token_no_fee others/new_token DOC_TESTS=`cd tests; find doc -regex "[^\.]+.liq" | sort -V` REV_TESTS=`find tests/reverse -regex "[^\.]+.tz" | sort -V` NEW_DUNE_TESTS= fail weather_insurance FAILING_DUNE_TESTS= originator -DUNE_TESTS=`find dune-network/src/bin_client/test/contracts -regex "[^\.]+.tz" ! -path "*concat_hello.tz"| sort -V` +DUNE_TESTS=`find dune-network/src/bin_client/test/contracts -regex "[^\.]+.tz" \ + ! -path "*concat_hello.tz" \ + ! -path "*/deprecated/*" \ + ! -path "*pexec*.tz" \ + | sort -V` TESTS=$(DOC_TESTS) $(SIMPLE_TESTS) $(MORE_TESTS:=.liq) $(RE_TESTS:=.reliq) $(OTHER_TESTS:=.liq) diff --git a/README.md b/README.md index 8a68dc71..285cf65f 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,7 @@ next | master ------------ | ------------- [![Travis-CI Build Status](https://travis-ci.org/OCamlPro/liquidity.svg?branch=next)](https://travis-ci.org/OCamlPro/liquidity) | [![Travis-CI Build Status](https://travis-ci.org/OCamlPro/liquidity.svg?branch=master)](https://travis-ci.org/OCamlPro/liquidity) +![Liquidity Logo](docs/sphinx/src/liquidity-dark.svg) Liquidity: a Smart Contract Language for Dune Network ============================================== diff --git a/docs/sphinx/Makefile b/docs/sphinx/Makefile index b9d36f3e..fb5b3a13 100644 --- a/docs/sphinx/Makefile +++ b/docs/sphinx/Makefile @@ -1,6 +1,8 @@ SPHINXBUILD = sphinx-build SPHINXOPTS = -aE -n SOURCEDIR = src +LIQUIDITY = ../../liquidity +LIQUIDITYCLIENT = ../../liquidity-client sources := $(shell find $(SOURCEDIR) -type f) Makefile ../../.git/logs/HEAD $(SOURCEDIR)/reference/michelson.rst @@ -10,20 +12,34 @@ html: _site pdf: Liquidity.pdf epub: Liquidity.epub -_site: $(sources) +manpages: + ./mk_man.sh liquidity + ./mk_man.sh liquidity-client + ./mk_man.sh liquidity-client call + ./mk_man.sh liquidity-client call-arg + ./mk_man.sh liquidity-client deploy + ./mk_man.sh liquidity-client forge-call + ./mk_man.sh liquidity-client forge-deploy + ./mk_man.sh liquidity-client get-storage + ./mk_man.sh liquidity-client init-storage + ./mk_man.sh liquidity-client inject + ./mk_man.sh liquidity-client pack + ./mk_man.sh liquidity-client run + +_site: $(sources) manpages $(SPHINXBUILD) -b html "$(SOURCEDIR)" _site $(SPHINXOPTS) -Liquidity.epub: $(sources) +Liquidity.epub: $(sources) manpages $(SPHINXBUILD) -b epub "$(SOURCEDIR)" _epub $(SPHINXOPTS) mv _epub/Liquidity.epub Liquidity.epub -Liquidity.pdf: $(sources) +Liquidity.pdf: $(sources) manpages $(SPHINXBUILD) -b latex "$(SOURCEDIR)" _pdf $(SPHINXOPTS) cd _pdf && xelatex Liquidity && xelatex Liquidity mv _pdf/Liquidity.pdf Liquidity.pdf clean: - rm -rf _site _epub _pdf *~ Liquidity.pdf Liquidity.epub + rm -rf _site _epub _pdf *~ Liquidity.pdf Liquidity.epub src/man/liquidity* find . -name '*~' -exec rm -f {} \; web: _site diff --git a/docs/sphinx/mk_man.sh b/docs/sphinx/mk_man.sh new file mode 100755 index 00000000..8d46837f --- /dev/null +++ b/docs/sphinx/mk_man.sh @@ -0,0 +1,14 @@ +#! /usr/bin/env sh + +cmd=$@ +file=$(echo $cmd | tr ' ' '-') +dsthtml=src/man/$file.html +dst=src/man/$file.rst + +../../$cmd --help=groff | groff -Thtml > $dsthtml +echo "\`\`$cmd\`\`" > $dst +echo "============" >> $dst +echo >> $dst +echo ".. _$file:" >> $dst +echo ".. raw:: html" >> $dst +echo " :file: $file.html" >> $dst diff --git a/docs/sphinx/src/_static/css/fixes.css b/docs/sphinx/src/_static/css/fixes.css index 4a1ae78b..73960115 100644 --- a/docs/sphinx/src/_static/css/fixes.css +++ b/docs/sphinx/src/_static/css/fixes.css @@ -1,19 +1,85 @@ @media screen and (min-width: 1400px) { - .wy-nav-content-wrap { - background: #fcfcfc; - } - .wy-nav-content { - margin: auto; - background: #fcfcfc; - } + .wy-nav-content-wrap { + background: #fcfcfc; + } + .wy-nav-content { + margin: auto; + background: #fcfcfc; + max-width: unset; + } } @media screen and (min-width: 1100px) { - .wy-nav-content-wrap { - background: #fcfcfc; - } - .wy-nav-content { - margin: auto; - background: #fcfcfc; - } + .wy-nav-content-wrap { + background: #fcfcfc; + } + .wy-nav-content { + margin: auto; + background: #fcfcfc; + max-width: unset; + } +} + +.document { + max-width: 800px; + margin: auto; +} + +.wy-side-nav-search, .wy-nav-top { + background-color: #0f093d; +} + +a, a:visited { + color: #553bff +} + +a, a:hover { + color: #3e22f8; +} + +rst-content tt.literal, .rst-content tt.literal, .rst-content code.literal { + color: #e84fff; +} + +.wy-nav-side { + background: #292640; +} + +.wy-menu-vertical a { + color: #D7D6E7; +} + +.wy-menu-vertical li.on a, .wy-menu-vertical li.current>a { + color: #404040; +} + +.wy-menu-vertical header, .wy-menu-vertical p.caption { + color: hsla(247, 84%, 77%, 1) +} + +.wy-menu-vertical li.current { + background: #eae9f2; +} + + +.wy-menu-vertical li.current a:hover { + background: #d6d6d6; +} + +.wy-menu-vertical li.current a:hover { + background: hsla(247, 32%, 87%, 1); +} + +.wy-menu-vertical a:hover { + background-color: hsla(292, 29%, 46%, 1); +} + +.wy-menu-vertical li.toctree-l2.current>a, +.wy-menu-vertical li.toctree-l2.current li.toctree-l3>a { + background: hsla(247, 26%, 88%, 1); +} + +.wy-menu-vertical li.on a, .wy-menu-vertical li.current>a { + border-top:none; + border-bottom:none; } diff --git a/docs/sphinx/src/conf.py b/docs/sphinx/src/conf.py index 7cb90acc..443cb418 100644 --- a/docs/sphinx/src/conf.py +++ b/docs/sphinx/src/conf.py @@ -51,7 +51,7 @@ # General information about the project. project = 'Liquidity' -copyright = '2018, OCamlPro SAS. ' +copyright = '2020, OCamlPro SAS. ' author = 'OCamlPro SAS. ' # The version info for the project you're documenting, acts as replacement for @@ -60,7 +60,7 @@ # # The short X.Y version. -version = subprocess.check_output("../../../_obuild/liquidity-mini/liquidity-mini.asm -v --version", shell=True).decode("utf-8") +version = subprocess.check_output("grep 'version = \"' ../../../tools/liquidity/build.ocp2 | cut -d'\"' -f 2", shell=True).decode("utf-8") # version = os.environ.get('CI_COMMIT_REF_NAME', 'v1.0') # The full version, including alpha/beta/rc tags. release = version + datetime.datetime.now().strftime(" (%Y/%m/%d %H:%M)") @@ -103,7 +103,7 @@ # documentation. # html_theme_options = {'logo_only': True} -html_logo = "logo.svg" +html_logo = "liquidity.svg" # Add any paths that contain custom static files (such as style sheets) here, # relative to this directory. They are copied after the builtin static files, # so a file named "default.css" will overwrite the builtin "default.css". diff --git a/docs/sphinx/src/index.rst b/docs/sphinx/src/index.rst index aaca70d8..d31d5fb9 100644 --- a/docs/sphinx/src/index.rst +++ b/docs/sphinx/src/index.rst @@ -13,8 +13,9 @@ decompiler that can translate Michelson contracts to Liquidity, for auditing purposes. .. toctree:: - :maxdepth: 2 + :maxdepth: 3 :caption: Liquidity Documentation + :glob: introduction installation/index @@ -22,6 +23,7 @@ auditing purposes. tutorial/tutorial tutorial/examples reference/liquidity + man/index .. toctree:: .. :maxdepth: 2 diff --git a/docs/sphinx/src/introduction.rst b/docs/sphinx/src/introduction.rst index 80ecee82..82c31e90 100644 --- a/docs/sphinx/src/introduction.rst +++ b/docs/sphinx/src/introduction.rst @@ -28,6 +28,7 @@ The Liquidity project contains: * A compiler from Liquidity files (.liq extension) to Michelson * A decompiler from Michelson files (.tz extension) to Liquidity +* A client for Dune Network See `Examples `__ in the `Github `__ project. diff --git a/docs/sphinx/src/liquidity-dark.svg b/docs/sphinx/src/liquidity-dark.svg new file mode 100644 index 00000000..3887855e --- /dev/null +++ b/docs/sphinx/src/liquidity-dark.svg @@ -0,0 +1,238 @@ + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/docs/sphinx/src/logo.svg b/docs/sphinx/src/liquidity.svg similarity index 90% rename from docs/sphinx/src/logo.svg rename to docs/sphinx/src/liquidity.svg index c145f273..fc15f386 100644 --- a/docs/sphinx/src/logo.svg +++ b/docs/sphinx/src/liquidity.svg @@ -7,6 +7,7 @@ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:svg="http://www.w3.org/2000/svg" xmlns="http://www.w3.org/2000/svg" + xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" width="155mm" @@ -14,13 +15,56 @@ viewBox="0 0 155 101.79833" version="1.1" id="svg8" - inkscape:version="0.92.2 (5c3e80d, 2017-08-06)" - sodipodi:docname="liquidity3_1.svg" + inkscape:version="0.92.3 (2405546, 2018-03-11)" + sodipodi:docname="liquidity.svg" inkscape:export-filename="/home/alain/Images/liquidity2.svg.png" inkscape:export-xdpi="140.07001" inkscape:export-ydpi="140.07001"> + id="defs2"> + + + + + + + + + + + image/svg+xml - + @@ -65,7 +109,7 @@ id="layer1" transform="translate(0.89997404,-196.1016)"> + sodipodi:nodetypes="ccssc" + transform="translate(0.89997404,-196.1016)" /> diff --git a/docs/sphinx/src/man/index.rst b/docs/sphinx/src/man/index.rst new file mode 100644 index 00000000..0421d923 --- /dev/null +++ b/docs/sphinx/src/man/index.rst @@ -0,0 +1,15 @@ +.. _manual-pages: + +Manual Pages +============ + +These manual pages for the binaries ``liquidity`` and +``liquidity-client`` are regenerated automatically. You will find all +command line options and example usages for each command. + +.. toctree:: + :maxdepth: 1 + :caption: Manual pages for binaries + :glob: + + * diff --git a/docs/sphinx/src/reference/liquidity.rst b/docs/sphinx/src/reference/liquidity.rst index a7e569e2..79dd318e 100644 --- a/docs/sphinx/src/reference/liquidity.rst +++ b/docs/sphinx/src/reference/liquidity.rst @@ -6,7 +6,7 @@ Contract Format All the contracts have the following form:: - [%%version 0.4] + [%%version 2.0] <... local declarations ...> @@ -28,7 +28,7 @@ All the contracts have the following form:: (s2 : TYPE) = BODY - let%entry main + let%entry default (parameter : TYPE) (storage : TYPE) = BODY @@ -51,9 +51,13 @@ is the storage (type annotation optional). The return type of the function can be specified but is not necessary. Each entry point must be given a unique name within the same contract. -If there is an entry point named ``main``, it will be the default +If there is an entry point named ``default``, it will be the default entry point for the contract, *i.e.* the one that is called when the -entry point is not specified in ``Contract.call``. +entry point is not specified in ``Contract.call``. It is generally a +goof idea to make this entry point take a parameter of type unit, so +that the code will be executed by any transfer made to it without +arguments. (This can code to prevent accidental token transfers for +instance.) An entry point always returns a pair ``(operations, storage)``, where ``operations`` is a list of internal operations to perform after @@ -96,6 +100,7 @@ The built-in base types are: - ``signature``: cryptographic signatures - ``operation``: type of operations, can only be constructed - ``address``: abstract type of contract addresses +- ``chain_id``: abstract type for chain ids Composite Types ~~~~~~~~~~~~~~~ @@ -204,9 +209,10 @@ type and another compatible type, using the notation ``address``, ``_ contract``, ``key_hash`` and ``signature``. * A ``bytes`` can be coerced to ``address``, ``_.instance``, ``key``, ``key_hash`` and ``signature``. -* An ``address`` can be coerced to ``_.instance``. -* A ``_.instance`` can be coerced to ``address``. -* A ``key_hash`` can be coerced to ``UnitContract.instance`` and ``address``. +* An constant ``address`` can be coerced to a contract handle. +* A constant contract handle can be coerced to ``address``. +* A ``key_hash`` can be coerced to an ``address`` and a contract + handle (to entry point ``default`` of parameter type ``unit``). Starting with version ``0.5``, constant values such as ``[]``, ``Map``, ``Set``, ``None`` do not need to be annotated with their type @@ -349,13 +355,6 @@ The ``Current`` module .. tryliquidity:: ../../../../tests/doc/doc3.liq .. literalinclude:: ../../../../tests/doc/doc3.liq -* ``Current.gas: unit -> nat``: returns the amount of gas available to - execute the rest of the transaction. It is translated to - ``STEPS_TO_QUOTA`` in Michelson. - - .. tryliquidity:: ../../../../tests/doc/doc4.liq - .. literalinclude:: ../../../../tests/doc/doc4.liq - * ``Current.source: unit -> address``: returns the address that initiated the current top-level transaction in the blockchain. It is the same one for all the transactions resulting from the top-level @@ -525,11 +524,13 @@ Operations on numeric values Operations on contracts ~~~~~~~~~~~~~~~~~~~~~~~ -* ``Contract.call: dest:'S.instance -> amount:dun -> - ?entry: parameter:'a -> operation``. Forge an internal +* ``Contract.call: dest:(address | [%handle 'a]) -> amount:dun -> + ?entry: -> parameter:'a -> operation``. Forge an internal contract call. It is translated to ``TRANSFER_TOKENS`` in Michelson. Arguments can be labeled, in which case they can be given - in any order. The entry point name is optional (``main`` by default). + in any order. The entry point name is optional (``default`` by + default). The destination is either a contract handle or an address + (in which case, an entry point must be specified). .. tryliquidity:: ../../../../tests/doc/doc13.liq .. literalinclude:: ../../../../tests/doc/doc13.liq @@ -537,7 +538,8 @@ Operations on contracts * ``: 'parameter -> amount:dun -> operation``. Forge an internal contract call. It is translated to ``TRANSFER_TOKENS`` in Michelson. The amount argument can be labeled, in which case it can - appear before the parameter. + appear before the parameter. ``c`` is either a contract handle (of + type ``[%handle 'parameter]``) or an address. .. tryliquidity:: ../../../../tests/doc/doc14.liq .. literalinclude:: ../../../../tests/doc/doc14.liq @@ -552,21 +554,10 @@ Operations on contracts .. tryliquidity:: ../../../../tests/doc/doc15.liq .. literalinclude:: ../../../../tests/doc/doc15.liq -* ``Account.create: manager:key_hash -> delegate:key_hash option -> - delegatable:bool -> amount:dun -> operation * address``. Forge an - operation to create a new (originated) account and returns its - address. It is translated to ``CREATE_ACCOUNT`` in - Michelson. Arguments can be labeled, in which case they can be given - in any order. - - .. tryliquidity:: ../../../../tests/doc/doc16.liq - .. literalinclude:: ../../../../tests/doc/doc16.liq - -* ``Account.default: key_hash -> UnitContract.instance``. Returns - the contract associated to the given ``key_hash``. Since this - contract is not originated, it cannot contains code, so transfers to - it cannot fail. It is translated to ``IMPLICIT_ACCOUNT`` in - Michelson. +* ``Account.default: key_hash -> [%handle unit]``. Returns a contract + handle to the ``default`` entry point of the implicit account + associated to the given ``key_hash``. Transfers to it cannot + fail. It is translated to ``IMPLICIT_ACCOUNT`` in Michelson. .. tryliquidity:: ../../../../tests/doc/doc17.liq .. literalinclude:: ../../../../tests/doc/doc17.liq @@ -575,61 +566,69 @@ Operations on contracts delegation operation for the current contract. A ``None`` argument means that the contract should have no delegate (it falls back to its manager). The delegation operation will only be executed in an - internal operation if it is returned at the end of the ``%entry`` - function. It is translated to ``SET_DELEGATE`` in Michelson. + internal operation if it is returned at the end of the entry point + definition. It is translated to ``SET_DELEGATE`` in Michelson. .. tryliquidity:: ../../../../tests/doc/doc18.liq .. literalinclude:: ../../../../tests/doc/doc18.liq -* ``Contract.address: _.instance -> address`` . Returns the address of - a contract. It is translated to ``ADDRESS`` in Michelson. +* ``Contract.address: [%handle 'a] -> address`` . Returns the address of + a contract. The returned address can be converted to any entry point + handle of the contract (contrary to ``Contract.untype``). .. tryliquidity:: ../../../../tests/doc/doc19.liq .. literalinclude:: ../../../../tests/doc/doc19.liq -* ``Contract.at: address -> _.instance option``. Returns the contract - associated with the address and type annotation, if any. Must be - annotated with the type of the contract. It is translated to - ``CREATE_CONTRACT`` in Michelson. For any contract or contract type - ``C``, you can also use the syntactic sugar ``C.at`` without any - type annotation. +* ``Contract.untype: [%handle 'a] -> address``. Returns the address + corresponding to an untype version of the contract handle. + + .. tryliquidity:: ../../../../tests/doc/doc16.liq + .. literalinclude:: ../../../../tests/doc/doc16.liq + +* ``[%handle: val%entry : 'a ] : address -> [%handle 'a] + option``. Returns a contract handle to the entry point + ```` if the contract at the specified address has an + entry point named ```` of parameter type ``'a``. If no + such entry point exists or the parameter type is different then this + function returns ``None``. It is translated to ``CONTRACT`` in + Michelson. For any contract or contract type ``C``, you can also use + the syntactic sugar ``[%handle C.]`` instead. .. tryliquidity:: ../../../../tests/doc/doc20.liq .. literalinclude:: ../../../../tests/doc/doc20.liq - -* ``Contract.get_balance: address -> dun``. Returns the balance of the - contract associated with the address (0 if it does not exist). +* ``Contract.get_balance: [%handle 'a] -> dun``. Returns the balance + of the contract. .. tryliquidity:: ../../../../tests/doc/doc77.liq .. literalinclude:: ../../../../tests/doc/doc77.liq -* ``Contract.is_implicit: UnitContract.instance -> key_hash - option``. Returns the key hash of a contract if it is an implicit - one, otherwise, returns ``None``. +* ``Contract.is_implicit: [%handle unit] -> key_hash option``. Returns + the key hash of a contract handle if it is an implicit one, + otherwise, returns ``None``. .. tryliquidity:: ../../../../tests/doc/doc74.liq .. literalinclude:: ../../../../tests/doc/doc74.liq -* ``Contract.self: unit -> _.instance``. Returns the current - executing contract. It is translated to ``SELF`` in Michelson. +* ``[%handle Self.] -> [%handle 'a]``. Returns a handle + to the entry point ```` of the currently executing + contract. It is translated to ``SELF`` in Michelson. You can use the + syntactic sugar ``Contract.self ()`` for ``[%handle Self.default]``. .. tryliquidity:: ../../../../tests/doc/doc21.liq .. literalinclude:: ../../../../tests/doc/doc21.liq -* ``Contract.create: manager:key_hash -> delegate:key_hash option -> - spendable:bool -> delegatable:bool -> amount:dun -> storage:'storage +* ``Contract.create: delegate:key_hash option -> amount:dun -> storage:'storage -> code:(contract _) -> (operation, address)``. Forge an operation to originate a contract with code. The contract is only created when the operation is executed, so it must be returned by the transaction. Note that the code must be specified as a contract structure (inlined or not). It is translated to ``CREATE_CONTRACT`` - in Michelson. ``Contract.create manager delegate_opt spendable - delegatable initial_amount initial_storage (contract C)`` forges an - an origination operation for contract `C` with manager ``manager``, - optional delegate ``delegate``, Boolean spendable flag - ``spendable``, Boolean delegatable flag ``delegatable``, initial + in Michelson. ``Contract.create delegate_opt initial_amount + initial_storage (contract C)`` forges an + an origination operation for contract ``C`` with + optional delegate ``delegate``, initial balance ``initial_amount`` and initial storage ``initial_storage``. Arguments can be named and put in any order. @@ -693,7 +692,7 @@ Operations on bytes .. literalinclude:: ../../../../tests/doc/doc29.liq * ``Bytes.unpack: bytes -> 'a option``. Deserialize a sequence of - bytes to a value from which it was serialized. The expression should + bytes to a value from which it was serialized. The expression must be annotated with the (option) type that it should return. It is translated to ``UNPACK`` in Michelson. @@ -776,6 +775,8 @@ Operations on lambdas -> ('a,'b) closure -> 'b``. Applies a function or closure to its argument. +* ``( @@ ) : ('a -> 'b) -> 'a -> 'b`` is also function application. + .. tryliquidity:: ../../../../tests/doc/doc39.liq .. literalinclude:: ../../../../tests/doc/doc39.liq @@ -979,9 +980,8 @@ Operations on Big maps Big maps are a specific kind of maps, optimized for storing. They can be updated incrementally and scale to a high number of associations, whereas standard maps will have an expensive serialization and -deserialization cost. You are limited by Michelson to one big map per -smart contract, that should appear as the first element of the -storage. Big maps cannot be iterated. +deserialization cost. Big maps cannot be iterated and cannot have big +maps as their keys or as their elements. * ``Map.find: 'key -> ('key,'val) big_map -> 'val option``. Return the value associated with a key in the map. It is translated to ``GET`` @@ -1075,7 +1075,7 @@ use it elsewhere). The toplevel contract can use elements from either structures. Here we use types and functions from both ``M`` and ``C`` and call the entry -point ``main`` of a contract instance of type ``C``. +point ``default`` of a contract instance of type ``C``. .. tryliquidity:: ../../../../tests/doc/doc73.liq .. literalinclude:: ../../../../tests/doc/doc73.liq @@ -1100,13 +1100,14 @@ instances* here) can also be used as first class values: .. tryliquidity:: ../../../../tests/doc/doc23.liq .. literalinclude:: ../../../../tests/doc/doc23.liq -**Instances** of contracts can be called with three different syntaxes: +**Handles** to contracts can be called with three different syntaxes: - ``Contract.call ~dest:c ~amount:1DUN ~parameter:"hello"`` -- ``Contract.call ~dest:c ~amount:1DUN ~entry:main ~parameter:"hello"`` -- ``c.main "hello" ~amount:1DUN`` +- ``Contract.call ~dest:c ~amount:1DUN ~entry:default ~parameter:"hello"`` +- ``c.default "hello" ~amount:1DUN`` -These calls are all equivalent. +These calls are all equivalent when c is an address or a handle to the +default entry point. Toplevel Contracts ~~~~~~~~~~~~~~~~~~ @@ -1120,47 +1121,29 @@ Contract Types and Signatures ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A contract is a first class object in Liquidity only for the -instruction ``Contract.create``, while contract *instances* can be +instruction ``Contract.create``, while contract *handles* can be used like any other values. Contract signatures are introduced with the keyword ``sig`` and defined with the keyword ``contract type``:: contract type S = sig - type storage = int - val%entry entry1 : p1:TYPE -> s1:TYPE -> operation list * storage - val%entry entry2 : p2:TYPE -> s2:TYPE -> operation list * storage - val%entry main : TYPE -> TYPE -> operation list * storage + type t1 = ... + type t2 = ... + val%entry entry1 : TYPE + val%entry entry2 : TYPE + val%entry default : TYPE ... end -A contract signature contains a declaration for the type ``storage`` -(this type can be abstract from the outside of the contract), and +A contract signature can contain type declarations, and declarations for the entry point signatures with the special keyword -``val%entry`` (names of argument can be specified). - -| You can use the following syntactic sugar if you don't want to write -| storage and return types (as they are identical for all entries of a -| smart contract.) : ``val%entry entry_name : p2:TYPE -> _`` -| - -The type of a contract (instance) whose signature is `S` is written -``S.instance``. Note that ``S`` must be declared as a contract signature -beforehand if we want to declare values of type ``S.instance``. - -For example:: - - type t = { - counter : int; - dest : S.instance; - } - -is a record type with a contract field ``dest`` of signature ``S``. +``val%entry`` in which only the type parameter must be specified. Predefined Contract Signatures ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The contract signature ``UnitContract`` is built-in, in Liquidity, and -stands for contracts with a single entry point ``main`` whose +stands for contracts with a single entry point ``default`` whose parameter is of type ``unit``: .. tryliquidity:: ../../../../tests/doc/doc70.liq @@ -1250,84 +1233,76 @@ You can also convert a file from one syntax to another, using the be converted to ReasonML syntax:: $ liquidity --convert test19.liq - %version - 0.5; - - type storage = { - key, - hash: bytes, - c: address, - }; - - let%init storage: storage = { - key: 0x0085b1e4560f47f089d7b97aabcf46937a4c137a9c3f96f73f20c83621694e36d5, - hash: 0xabcdef, - c: KT1LLcCCB9Fr1hrkGzfdiJ9u3ZajbdckBFrF, - }; - - contract PlusOne = { - type storage = int; - - type t = - | A - | B; - - let%init init_storage = (x: bool, y: int) => - if (x == false) { - 0; - } else { - y; - }; - - let%entry main = (_: unit, s) => ([], s + 1); - }; - - let%entry main = (sign: signature, storage) => { - let x = PlusOne.A; - switch (x) { - | PlusOne.B => failwith() - | _ => () + + type storage = { + key, + hash: bytes, + c: address, }; - - let key_hash = Crypto.hash_key(storage.key); - if (key_hash == dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb) { - Current.failwith(); + + let%init storage: storage = { + key: 0x0085b1e4560f47f089d7b97aabcf46937a4c137a9c3f96f73f20c83621694e36d5, + hash: 0xabcdef, + c: KT1LLcCCB9Fr1hrkGzfdiJ9u3ZajbdckBFrF, }; - if (key_hash - == Crypto.hash_key( - edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV, - )) { - Current.failwith(); + + contract PlusOne = { + type storage = int; + + type t = + | A + | B; + + let%init init_storage = (x: bool, y: int) => + if (x == false) { + 0; + } else { + y; + }; + + let%entry default = (_: unit, s) => ([], s + 1); }; - let delegate = Some(key_hash); - let spendable = Crypto.check(storage.key, sign, storage.hash); - let amount = Current.amount(); - let amount = - switch (amount / 2p) { - | None => Current.failwith() - | Some(qr) => qr + + let%entry default = (sign: signature, storage) => { + let x = PlusOne.A; + switch (x) { + | PlusOne.B => failwith() + | _ => () }; - - let delegatable = false; - let _cocococ: option(PlusOne.instance) = Contract.at(storage.c); - let _cocococ2 = PlusOne.at(storage.c); - let _op1 = Contract.self().main(sign, ~amount=0DUN); - let (account_op, _account) = - Account.create(key_hash, delegate, delegatable, amount[0] + amount[1]); - let (c_op, c_addr) = - Contract.create( - ~manager=key_hash, - ~delegate, - ~spendable, - ~delegatable=true, - ~amount=amount[0], - ~storage=9, - (contract PlusOne), - ); - - let storage = storage.c = c_addr; - ([account_op, c_op], storage); - }; + let c = Contract.self(); + let key_hash = Crypto.hash_key(storage.key); + if (key_hash == tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx) { + Current.failwith(); + }; + if (key_hash + == Crypto.hash_key( + edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV, + )) { + Current.failwith(); + }; + let delegate = Some(key_hash); + let spendable = Crypto.check(storage.key, sign, storage.hash); + let amount = Current.amount(); + let amount = + switch (amount / 2p) { + | None => Current.failwith() /* not possible */ + | Some(qr) => qr + }; + + let delegatable = false; + let _cocococ = [%handle PlusOne.default](storage.c); + let _op1 = Self.default(sign, ~amount=0DUN); + let (c_op, c_addr) = + Contract.create( + ~delegate, + ~amount=amount[0], + ~storage=9, + (contract PlusOne), + ); + + let storage = storage.c = c_addr; + ([c_op], storage); + }; The same file can be converted back and forth:: @@ -1359,7 +1334,7 @@ From Michelson to Liquidity Here is a table of how Michelson instructions translate to Liquidity: -* ``ADDRESS``: ``Contract.address addr`` +* ``ADDRESS``: ``Contract.untype c`` * ``AMOUNT``: ``Current.amount()`` * ``ABS``: ``match%nat x with Plus n -> | Minus n -> n`` * ``ADD``: ``x + y`` @@ -1380,10 +1355,11 @@ Here is a table of how Michelson instructions translate to Liquidity: * ``DROP``: automatic stack management * ``DUP``: automatic stack management * ``EDIV``: ``x / y`` -* ``EMPTY_MAP``: ``(Map : (int, string) map)`` -* ``EMPTY_SET``: ``(Set : int set)`` +* ``EMPTY_BIG_MAP``: ``BigMap []`` +* ``EMPTY_MAP``: ``Map []`` +* ``EMPTY_SET``: ``Set []`` * ``EQ``: ``x = y`` -* ``EXEC``: ``x |> f`` or ``f x`` +* ``EXEC``: ``x |> f`` or ``f x`` or ``f @@ x`` * ``FAILWITH``: ``Current.failwith`` * ``GE``: ``x >= y`` * ``GET``: ``Map.find key map`` @@ -1393,7 +1369,7 @@ Here is a table of how Michelson instructions translate to Liquidity: * ``IF_CONS``: ``match list with [] -> EXPR | head :: tail -> EXPR`` * ``IF_LEFT``: ``match variant with Left x -> EXPR | Right x -> EXPR`` * ``IF_NONE``: ``match option with None -> EXPR | Some x -> EXPR`` -* ``IMPLICIT_ACCOUNT``: ``Account.default keyhash`` +* ``IMPLICIT_ACCOUNT``: ``Account.default`` * ``INT``: ``int x`` * ``ISNAT``:``is_nat x`` or ``match%int x with Plus x -> ... | Minus y -> ...`` * ``ITER``: ``List.iter``, ``Set.iter``, ``Map.iter``, @@ -1419,21 +1395,21 @@ Here is a table of how Michelson instructions translate to Liquidity: * ``OR``: ``x lor y``, or ``x || y``, or ``x or y`` * ``PACK``: ``Bytes.pack x`` * ``PAIR``: ``( x, y )`` -* ``PUSH``: automatic stack management +* ``PUSH``, ``DIP``, ``DROP``, ``DIG``, ``DUG``, ``SWAP``: automatic stack management * ``RENAME``: automatic annotations management * ``RIGHT``: ``Right x`` * ``SENDER``: ``Current.sender()`` * ``SIZE``: ``List.size list``, ``String.size``, ``Bytes.size``, ``Set.size`` -* ``SELF``: ``Contract.self ()`` +* ``SELF %e``: ``[%handle Self.e]`` * ``SET_DELEGATE``: ``Contract.set_delegate (Some keyhash)`` * ``SHA256``: ``Crypto.sha256 bytes`` * ``SHA512``: ``Crypto.sha512 bytes`` * ``SLICE``: ``String.sub pos len string`` or ``Bytes.sub`` * ``SOME``: ``Some x`` * ``SOURCE``: ``Current.source()`` -* ``STEPS_TO_QUOTA``: ``Current.gas()`` +* ``STEPS_TO_QUOTA``: ``Current.gas()`` (deprecated, works for + decompilation only) * ``SUB``: ``x - y`` -* ``SWAP``: automatic stack management * ``TRANSFER_TOKENS``: ``Contract.call contract amount param`` * ``UNIT``: ``()`` * ``UNPACK``: ``(unpack bytes : int list option)`` @@ -1539,6 +1515,7 @@ Type: * ``signature`` * ``operation`` * ``address`` +* ``chain_id`` * Type ``option`` * Type ``list`` * Type ``set`` diff --git a/docs/sphinx/src/tutorial/examples.rst b/docs/sphinx/src/tutorial/examples.rst index 3050436e..01107b63 100644 --- a/docs/sphinx/src/tutorial/examples.rst +++ b/docs/sphinx/src/tutorial/examples.rst @@ -2,5 +2,6 @@ Examples ======== .. toctree:: + :maxdepth: 3 game diff --git a/docs/sphinx/src/tutorial/game.rst b/docs/sphinx/src/tutorial/game.rst index 71a88f58..c05a3009 100644 --- a/docs/sphinx/src/tutorial/game.rst +++ b/docs/sphinx/src/tutorial/game.rst @@ -261,8 +261,8 @@ current game is erased. The list of generated operations and the reset storage is returned. -A safety entry point: ``fund`` -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A safety entry point: ``default`` +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At anytime we authorize anyone (most likely the manager of the contract) to add funds to the contract's balance. This allows new diff --git a/docs/sphinx/src/usage/index.rst b/docs/sphinx/src/usage/index.rst index 35484630..9895c796 100644 --- a/docs/sphinx/src/usage/index.rst +++ b/docs/sphinx/src/usage/index.rst @@ -1,77 +1,22 @@ Usage ===== -There is only one tool, called ``liquidity``, provided by Liquidity. -It can be used to: - -* compile Liquidity files (.liq) to Michelson -* decompile Michelson files (.tz) to Liquidity -* interact with a dune-node to simulate or deploy a contract - -Basic Usage ------------ - -Let's run ``liquidity`` with no options:: - - ─➤ liquidity - liquidity [OPTIONS] FILES [COMMAND] - - The liquidity compiler can translate files from Liquidity to Michelson - and from Michelson to Liquidity. Liquidity files must end with the .liq - extension. Michelson files must end with the .tz extension. - - Available options: - --verbose Increment verbosity - --version Show version and exit - -o Output code in - --main Produce code for contract named - --no-peephole Disable peephole optimizations - --type-only Stop after type checking - --parse-only Stop after parsing - --compact Produce compact Michelson - --json Output Michelson in JSON representation - --amount <1.99tz> Set amount for deploying or running a contract (default: 0tz) - --fee <0.05tz> Set fee for deploying a contract (default: 0.05tz) - --source Set the source for deploying or running a contract (default: none) - --private-key Set the private key for deploying a contract (default: none) - --counter N Set the counter for the operation instead of retrieving it - ---node Set the address and port of a Dune node to run or deploy contracts (default: 127.0.0.1:8733) - - Available commands: - --protocol Specify protocol (mainnet, zeronet, alphanet) (detect if not specified) - --run ENTRY PARAMETER STORAGE Run Liquidity contract on Dune node - --delegatable With --[forge-]deploy, deploy a delegatable contract - --spendable With --[forge-]deploy, deploy a spendable contract - --init-storage [INPUT1 INPUT2 ...] Generate initial storage - --forge-deploy [INPUT1 INPUT2 ...] Forge deployment operation for contract - --deploy [INPUT1 INPUT2 ...] Deploy contract - --get-storage Get deployed contract storage - --call ENTRY PARAMETER Call deployed contract - --data ENTRY PARAMETER [STORAGE] Translate to Michelson - --signature SIGNATURE Set the signature for an operation - --inject OPERATION.bytes Inject a sign operation - - Misc: - -help Display this list of options - --help Display this list of options - - -Note that this is equivalent to running ``liquidity`` with the ``-help`` or -``--help`` arguments. - -We can ask the current version of the compiler:: - - ─➤ liquidity --version - 0.4 +There are two tools provided by Liquidity. +1. ``liquidity``, the compiler. It can be used to: + * compile Liquidity files (.liq) to Michelson + * decompile Michelson files (.tz) to Liquidity +2. ``liquidity-client``, a client to interact with Liquidity contracts + on Dune Network. +We recommend to read the :ref:`Manual Pages ` if you want to see all +options and examples for each command. The rest of this section shows +some typical command usage if you want to get started immediately. Compiling a Liquidity file -------------------------- Let's take a very simple Liquidity contract, stored in a file ``simple.liq``:: - [%%version 0.4] - type storage = int let%entry main (parameter : int) storage = @@ -85,7 +30,8 @@ To compile the file, we can use:: Main contract Simple File "simple.tz" generated -The ``liquidity`` compiler will try to compile any file with a ``.liq`` extension provided on the command line. +The ``liquidity`` compiler will try to compile any file with a +``.liq`` extension provided on the command line. Let's have a look at the generated ``simple.tz`` file:: @@ -109,7 +55,10 @@ Note that we can use a more compact version, on a single line:: parameter int; storage int; code { DUP ; DIP { CDR } ; CAR ; DUP ; SWAP ; DROP ; SWAP ; ADD ; NIL operation ; PAIR }; -In case of error, for example if we set the storage to type ``nat`` instead of ``int``, the compiler will provide the location of the error in a standard format:: +In case of an error, for example if we set the storage to type ``nat`` +instead of ``int``, the compiler will provide the location of the +error in a standard format (most editors can parse it so you can jump +with a single keystroke to the error location):: ─➤ liquidity simple.liq simple.liq:4.2-4.48: Error: Type error: Unexpected type for return value. @@ -120,15 +69,7 @@ In case of error, for example if we set the storage to type ``nat`` instead of ` (exit 1) -Relevant options: - --verbose Increment verbosity - --no-peephole Disable peephole optimizations - --type-only Stop after type checking - --parse-only Stop after parsing - --single-line Output Michelson on a single line - --compact Produce compact Michelson - --json Output Michelson in JSON representation - +:ref:`-> More details on the compiler `. Decompiling a Michelson file ---------------------------- @@ -150,61 +91,55 @@ We can now check the result of the decompilation:: The ``liquidity`` tool will decompile in the same way any file with the ``.tz`` extension provided on the command line. - -Relevant options: - --verbose Increment verbosity Interacting with a Dune node ----------------------------- -Liquidity comes with a Dune client which allows interactions with a -node using Liquidity smart contracts and Liquidity syntax. +Liquidity comes with a Dune Network client (also usable on the Tezos +network) which allows interactions with a node using Liquidity smart +contracts and Liquidity syntax. Running a simulation of the contract ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you have access to a Dune node (for instance locally on port -8732), you can run contract call simulations of a contract by +If you have access to a node (for instance locally on port +8733), you can run contract call simulations of a contract by specifying its current storage value, the entry point and the transaction parameter:: - > liquidity \ + > liquidity-client run \ --node http://127.0.0.1:8733 \ - --amount 2tz \ - tests/others/demo.liq \ - --run main '"candidate 1"' 'Map ["candidate 1", 0; "candidate 2", 0]' + --amount 2DUN \ + --files tests/others/demo.liq \ + default '"candidate 1"' 'Map ["candidate 1", 0; "candidate 2", 0]' Main contract Demo tests/others/demo.liq:13.4-13.61: Failed at runtime: in /chains/main/blocks/head/helpers/scripts/run_code - Failed with "Not enough money, at least 5tz to vote" + Failed with "Not enough money, at least 5DUN to vote" :: - > liquidity \ + > liquidity-client run \ --node http://127.0.0.1:8733 \ - --amount 5tz \ - tests/others/demo.liq \ - --run main '"candidate 1"' 'Map ["candidate 1", 0; "candidate 2", 0]' + --amount 5DUN \ + --files tests/others/demo.liq \ + default '"candidate 1"' 'Map ["candidate 1", 0; "candidate 2", 0]' Main contract Demo Map [("candidate 2", 0); ("candidate 1", 1)] # Internal operations: 0 -Relevant options: - --amount <1.99tz> Set amount for deploying or running a contract (default: 0tz) - --source Set the source for deploying or running a contract (default: none) - --node Set the address and port of a Dune node to run or deploy contracts (default: 127.0.0.1:8733) - --run Run Liquidity contract on Dune node +:ref:`-> More details on run `. Deploying a contract ~~~~~~~~~~~~~~~~~~~~ To deploy a contract you need to forge a deployment operation, sign -this operation and inject it to a Dune node. This can be performed -separately or all at once with the command ``--deploy``. +this operation and inject it to a node. This can be performed +separately or all at once with the command ``deploy``. Deploying a contract directly (unsafe) @@ -215,15 +150,12 @@ Liquidity source code is contained in file ``contract.liq``, whose initializer takes one string parameter as argument, and with initial balance 2tz:: - liquidity \ + liquidity-client deploy \ --node http://127.0.0.1:8733 \ - --amount 2tz \ - --fee 0tz \ - --delegatable \ + --amount 2DUN \ --private-key edsk2gL9deG8idefWJJWNNtKXeszWR4FrEdNFM5622t1PkzH66oH3r \ - --source tz1WWXeGFgtARRLPPzT2qcpeiQZ8oQb6rBZd \ - contract.liq \ - --deploy '"first"' + --files contract.liq \ + '"first"' Because we give the private key as an argument (notice that this process is unsafe, and should only be used with private keys not @@ -231,6 +163,8 @@ associated with real accounts on the mainnet) to sign the transaction, we don't need to specify the source which will be inferred as being the corresponding public key hash. +:ref:`-> More details on deploy `. + Deploying a contract with an offline signature ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -240,14 +174,11 @@ phase, the second one being the offline signature. First we need to produce (forge) an unsigned serialized deployment operation:: - > liquidity \ - --node http://127.0.0.1:8733 \ - --amount 2tz \ - --fee 0tz \ - --delegatable \ - --source tz1WWXeGFgtARRLPPzT2qcpeiQZ8oQb6rBZd \ - contract.liq \ - --forge-deploy '"first"' > my_op.bytes + > liquidity-client forge-deploy \ + --files tests/others/multisig.liq \ + --node http://127.0.0.1:8733 \ + --source dn1GLMm5dMXRxCwqmkV22keRCcoWwrrani9F \ + 'Set [dn1GLMm5dMXRxCwqmkV22keRCcoWwrrani9F]' 1p > op.bytes Using the default client we can then sign this operation with an account ``my_account`` on an offline machine. If this accounts @@ -256,32 +187,60 @@ client, you will be required to confirm the signature. If this accounts in an encrypted private key you will be asked to input your password:: - > dune-client sign bytes 0x03$(cat ./my_op.bytes) for my_account - - Signature: edsigtzxo2Q7wFiEjausSp7pKUXLK9PnPqf8rHEKdc18HtNVbZSg5WJyFJwk14w7mykCsq3nV5iB6Eo4gTX3y8Dv8tkn1EadRj7 - -Save this signature. You can now inject the signed operation on the -Tezos newtork by simply issuing:: - - > liquidity \ - --node http://127.0.0.1:8733 \ - --signature edsigtzxo2Q7wFiEjausSp7pKUXLK9PnPqf8rHEKdc18HtNVbZSg5WJyFJwk14w7mykCsq3nV5iB6Eo4gTX3y8Dv8tkn1EadRj7 \ - --inject my_op.bytes - -Relevant options: - --amount <1.99tz> Set amount for deploying or running a contract (default: 0tz) - --fee <0.05tz> Set fee for deploying a contract (default: 0.05tz) - --source Set the source for deploying or running a contract (default: none) - --private-key Set the private key for deploying a contract (default: none) - --counter N Set the counter for the operation instead of retrieving it - --node Set the address and port of a Dune node to run or deploy contracts (default: 127.0.0.1:8733) - --protocol Specify protocol (mainnet, zeronet, alphanet) (detect if not specified) - --delegatable With --[forge-]deploy, deploy a delegatable contract - --spendable With --[forge-]deploy, deploy a spendable contract - --forge-deploy Forge deployment operation for contract - --deploy Deploy contract - --signature Set the signature for an operation - --inject Inject a sign operation + > dune-client sign operation op.bytes for my_account --out op.signed + + Node: http://localhost:18735 + Parsed operation: + Manager signed operations: + From: dn1GLMm5dMXRxCwqmkV22keRCcoWwrrani9F + Fee to the baker: đ0.009661 + Expected counter: 1 + Gas limit: 70221 + Storage limit: 2874 bytes + Balance updates: + dn1GLMm5dMXRxCwqmkV22keRCcoWwrrani9F ........... -đ0.009661 + fees(dn1G8vdxwTcD7Nqf5ewF8FAj6bRG8iqtTgba,0) ... +đ0.009661 + Origination: + From: dn1GLMm5dMXRxCwqmkV22keRCcoWwrrani9F + Credit: đ0 + Script: + ... + Initial storage: + (Pair { "dn1GLMm5dMXRxCwqmkV22keRCcoWwrrani9F" } (Pair {} (Pair 1 1))) + No delegate for this contract + This origination was successfully applied + Originated contracts: + KT1JS5QEB64SvLGRPBYxpmDG8obHoeGJZG5D + Storage size: 2617 bytes + Paid storage size diff: 2617 bytes + Consumed gas: 70221 + Balance updates: + dn1GLMm5dMXRxCwqmkV22keRCcoWwrrani9F ... -đ2.617 + dn1GLMm5dMXRxCwqmkV22keRCcoWwrrani9F ... -đ0.257 + + Would you like to sign this operation? [y/N]: y + Yes + Signature: edsigtxAkTRs3xqdKmTfSitdHc4o7Msjsg5bfSPCoMUS6mE3t89sAQWz6V8MJsfY3G4pTShBSEV5pXM66QZSCKpewxU5WCK345X + Serialized signed operation written to op.signed + +You can now inject the signed operation on the +newtork by simply issuing:: + + > dune-client inject operation op.signed + + Parsed operation: + ... + Would you like to inject this operation? [y/N]: y + Yes + Operation successfully injected in the node. + Operation hash is 'op47tCnmZkn6LToM4Yp8pTydesjJ3GWXhDrE2hFryvb9SAufRwm' + Waiting for the operation to be included... + This sequence of operations was run: + ... + New contract KT1Q69vbqSQmWDGZMoMde2BT7nBv5uj3sFG7 originated. + + +:ref:`-> More details on forge deploy `. Calling a contract ~~~~~~~~~~~~~~~~~~ @@ -289,28 +248,29 @@ Calling a contract To call an already deployed smart contract you need to forge a transfer operation, sign this operation ans inject it to a Dune node. This can be performed separately or all at once with the command -``--call``. +``call``. Calling a contract directly (unsafe) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ The following command will call the ``demo.liq`` contract deployed at -address ``KT1Ukta5wAt5R87U2awCoYHJAVA38FeptagD`` on the zeronet:: +address ``KT1Ukta5wAt5R87U2awCoYHJAVA38FeptagD`` on the testnet:: - liquidity \ - --node http://testnet-node.dunscan.io \ - --amount 5tz \ - --fee 0tz \ - --private-key edsk2gL9deG8idefWJJWNNtKXeszWR4FrEdNFM5622t1PkzH66oH3r \ - --source tz1WWXeGFgtARRLPPzT2qcpeiQZ8oQb6rBZd \ - tests/others/demo.liq \ - --call KT1Ukta5wAt5R87U2awCoYHJAVA38FeptagD main '"ocaml"' + > liquidity-client call \ + --node http://testnet-node.dunscan.io \ + --amount 5DUN \ + --private-key edsk2gL9deG8idefWJJWNNtKXeszWR4FrEdNFM5622t1PkzH66oH3r \ + --files tests/others/demo.liq \ + KT1Ukta5wAt5R87U2awCoYHJAVA38FeptagD main '"ocaml"' Main contract Demo Successful call to contract KT1Ukta5wAt5R87U2awCoYHJAVA38FeptagD in operation oosA6qjVjtFbE9tGsrzHtjB6zk27R3yRH61wKD55WJ1WWiVjhy2 +:ref:`-> More details on call `. + + Calling a contract with an offline signature ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -320,55 +280,35 @@ phase, the second one being the offline signature. First we need to produce (forge) an unsigned serialized deployment operation:: - > liquidity \ + > liquidity-client forge-call \ --node http://testnet-node.dunscan.io \ - --amount 5tz \ - --fee 0tz \ - --source tz1WWXeGFgtARRLPPzT2qcpeiQZ8oQb6rBZd \ - tests/others/demo.liq \ - --forge-call KT1Ukta5wAt5R87U2awCoYHJAVA38FeptagD main '"ocaml"' > my_op.bytes + --amount 5DUN \ + --source dn1GLMm5dMXRxCwqmkV22keRCcoWwrrani9F \ + --files tests/others/demo.liq \ + KT1Ukta5wAt5R87U2awCoYHJAVA38FeptagD main '"ocaml"' > op.bytes :: - > dune-client sign bytes 0x03$(cat ./my_op.bytes) for my_account + > dune-client sign operation op.bytes for my_account --out op.signed - Signature:edsigu1xkB6tC2Sm39QaGtAzPbjdfWF7V9ctNVwGVH52zrmus921eVmdga2nZowGkF9HSagMNsw6ZaZ8xoKvvhyFgfgirR9Wuow + ... Save this signature. You can now inject the signed operation on the -Tezos newtork by simply issuing:: +network with the same command as above. - > liquidity \ - --node http://testnet-node.dunscan.io \ - --signature edsigu1xkB6tC2Sm39QaGtAzPbjdfWF7V9ctNVwGVH52zrmus921eVmdga2nZowGkF9HSagMNsw6ZaZ8xoKvvhyFgfgirR9Wuow \ - --inject my_op.bytes - - Operation injected: ooDm5JPw5fgaMyM6eAWJA1vW49jjPDC3KrxTU4UZkuPx952D59o - -Relevant options: - --amount <1.99tz> Set amount for deploying or running a contract (default: 0tz) - --fee <0.05tz> Set fee for deploying a contract (default: 0.05tz) - --source Set the source for deploying or running a contract (default: none) - --private-key Set the private key for deploying a contract (default: none) - --counter N Set the counter for the operation instead of retrieving it - --node Set the address and port of a Dune node to run or deploy contracts (default: 127.0.0.1:8733) - --protocol Specify protocol (mainnet, zeronet, alphanet) (detect if not specified) - --call Call deployed contract - --forge-call Forge call transaction operation - --signature Set the signature for an operation - --inject Inject a sign operation +:ref:`-> More details on forge call `. Generating initial storage ~~~~~~~~~~~~~~~~~~~~~~~~~~ :: - > liquidity \ + > liquidity-client init-storage \ --node http://testnet-node.dunscan.io \ - tests/others/demo.liq - --init-storage '"this"' + --files tests/others/demo.liq \ + '"this"' Main contract Demo - Evaluated initial storage: Map [("this", 0); ("pro", 0); ("ocaml", 0)] Constant initial storage generated in "tests/others/demo.liq.init.tz" :: @@ -377,9 +317,5 @@ Generating initial storage { Elt "ocaml" 0 ; Elt "pro" 0 ; Elt "this" 0} -Relevant options: - --amount <1.99tz> Set amount for deploying or running a contract (default: 0tz) - --node Set the address and port of a Dune node to run or deploy contracts (default: 127.0.0.1:8733) - --init-storage Generate initial storage - --json Output Michelson in JSON representation - -o Output code in + +:ref:`-> More details on init-storage `. diff --git a/dune-network b/dune-network index 1423cbf6..3c6e59ae 160000 --- a/dune-network +++ b/dune-network @@ -1 +1 @@ -Subproject commit 1423cbf6ba4fb55c15e455fe61679fa76b073f74 +Subproject commit 3c6e59ae1eb4f57d2f688643854a8300793f958b diff --git a/libs/deps-dune-network/build.ocp2 b/libs/deps-dune-network/build.ocp2 index b9a8caa4..6dd7c794 100644 --- a/libs/deps-dune-network/build.ocp2 +++ b/libs/deps-dune-network/build.ocp2 @@ -62,7 +62,6 @@ OCaml.library("ezjsonm", ocaml + { OCaml.library("dune-network-deps", ocaml + { files = [ - "nocrypto.ml"; pp_js("js/blake2.ml"); "hacl.ml"; ]; diff --git a/libs/deps-dune-network/js/blake2.ml b/libs/deps-dune-network/js/blake2.ml index b16cf56b..d51d2b26 100644 --- a/libs/deps-dune-network/js/blake2.ml +++ b/libs/deps-dune-network/js/blake2.ml @@ -23,6 +23,28 @@ (* Bindings to https://github.com/dcposch/blakejs *) +open Js_of_ocaml + +(* Ensure required libraries are available *) +let () = + let is_node_js = + Js.Optdef.test Js.Unsafe.global##module_ && + Js.Optdef.test Js.Unsafe.global##module_##exports + in + let js_failwith fmt = + Format.kasprintf + (fun s -> + Js.raise_js_error (jsnew Js.error_constr (Js.string s))) + fmt + in + if not (Js.Optdef.test Js.Unsafe.global##blakejs) then + js_failwith "Library blakejs is required but not available, \ + load it before liquidity-js %s" + (if is_node_js then + "with:\n\ + const blakejs = require('blakejs');" + else "") + (* Same interface as Tezos' Blake2 *) module Blake2b : sig type t diff --git a/libs/deps-dune-network/z.ml b/libs/deps-dune-network/z.ml index 59f4d331..e03e1bbc 100644 --- a/libs/deps-dune-network/z.ml +++ b/libs/deps-dune-network/z.ml @@ -27,8 +27,11 @@ let zero = Num.num_of_int 0 let of_int = Num.num_of_int let to_int = Num.int_of_num +let of_int64 x = Num.num_of_big_int (Big_int.big_int_of_int64 x) +let to_int64 x = Big_int.int64_of_big_int (Num.big_int_of_num x) let add = Num.add_num let mul = Num.mult_num +let pred = Num.pred_num let div_rem a b = Num.quo_num a b, Num.mod_num a b diff --git a/libs/dune-network-lib/build.ocp2 b/libs/dune-network-lib/build.ocp2 index 5a5c0571..a20e5d3a 100644 --- a/libs/dune-network-lib/build.ocp2 +++ b/libs/dune-network-lib/build.ocp2 @@ -38,10 +38,6 @@ function pp_dune_network(file){ return file, { more_deps = [ dune_network_dir + file ] }; } -function pp_proto_client(file){ - return file, { more_deps = [ dune_network_dir + "proto_004_Pt24m4xi/lib_client/" + file ] }; -} - function pp_stdlib(file){ return file, { more_deps = [ dune_network_dir + "lib_stdlib/" + file ] }; } @@ -71,6 +67,7 @@ OCaml.library("dune-network-lib", from_dune_network("lib_stdlib/tzString.ml"); from_dune_network("lib_stdlib/utils.ml"); from_dune_network("lib_stdlib/binary_stream.ml"); + "ocplib_ironmin.ml"; from_dune_network("lib_data_encoding/binary_size.ml"); from_dune_network("lib_data_encoding/encoding.ml"); from_dune_network("lib_data_encoding/binary_error.ml"); @@ -90,6 +87,7 @@ OCaml.library("dune-network-lib", from_dune_network("lib_stdlib/weakRingTable.ml"); from_dune_network("lib_error_monad/error_monad_sig.ml"); from_dune_network("lib_error_monad/error_monad.ml"); + from_dune_network("lib_error_monad/error_table.ml"); from_dune_network("lib_micheline/micheline.ml"); from_dune_network("lib_micheline/micheline_parser.ml"); from_dune_network("lib_micheline/micheline_printer.ml"); @@ -98,12 +96,12 @@ OCaml.library("dune-network-lib", "RPC_arg.ml"; "clic.ml"; from_dune_network("lib_crypto/base58.ml"); + from_dune_network("lib_crypto/s.ml"); from_dune_network("lib_crypto/helpers.ml"); from_dune_network("lib_crypto/blake2B.ml"); "ed25519.ml"; - from_dune_network("lib_crypto/s.ml"); from_dune_network("lib_crypto/operation_hash.ml"); - pp_proto_client("michelson_v1_macros.ml"); + "michelson_v1_macros.ml"; ]); requires = [ "dune-network-deps"; diff --git a/libs/dune-network-lib/michelson_v1_macros.ml b/libs/dune-network-lib/michelson_v1_macros.ml index f696a60e..8890913b 100644 --- a/libs/dune-network-lib/michelson_v1_macros.ml +++ b/libs/dune-network-lib/michelson_v1_macros.ml @@ -27,5 +27,6 @@ open Error_monad (* open Tezos_data *) module Proto_alpha = struct end module Tezos_micheline = struct end +module Protocol_client_context = struct end -#include "../../dune-network/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml" +#include "../../dune-network/src/proto_005_PsBabyM1/lib_client/michelson_v1_macros.ml" diff --git a/libs/dune-network-lib/ocplib_ironmin.ml b/libs/dune-network-lib/ocplib_ironmin.ml new file mode 100644 index 00000000..56fdfc6f --- /dev/null +++ b/libs/dune-network-lib/ocplib_ironmin.ml @@ -0,0 +1,3 @@ +module Uintvar = struct +#include "../../dune-network/vendors/ocplib-ironmin/uintvar.ml" +end diff --git a/libs/ezcmd b/libs/ezcmd new file mode 160000 index 00000000..df5c01e7 --- /dev/null +++ b/libs/ezcmd @@ -0,0 +1 @@ +Subproject commit df5c01e77c279814f1f36c0d48dad7ef1dcd0737 diff --git a/opam b/opam index d2f34adc..adf97caa 100644 --- a/opam +++ b/opam @@ -19,6 +19,7 @@ remove: [ depends: [ "bigstring" "calendar" + "cmdliner" "digestif" {>= "0.7" } "ezjsonm" "easy-format" diff --git a/tests/bug187.liq b/tests/bug187.liq index 07466acb..cdaac21d 100644 --- a/tests/bug187.liq +++ b/tests/bug187.liq @@ -13,7 +13,7 @@ let[@noinline] list_mem k l = else acc ) l None -let%entry main (i, a) s = +let%entry default (i, a) s = let s = match list_mem i s.mile_id with | Some _ -> { mile_id = []; owner_addr = [] } | None -> s in diff --git a/tests/bug202.reliq b/tests/bug202.reliq index 45cfe9c8..a7778cbf 100644 --- a/tests/bug202.reliq +++ b/tests/bug202.reliq @@ -9,7 +9,7 @@ contract Appstore = { let%entry main = (name: string, store) => { let amount = Current.amount(); - if (amount < 5.00tz) { + if (amount < 5.00DUN) { Current.failwith("Not enough money, at least 5tz to vote"); }; @@ -26,23 +26,11 @@ let init_storage = (name: string) => Map([("name", { Appstore.name : "test" , Appstore.owner : tz1XEKgRQtqV2XamF9CR7avwNq1V2hPDgNbL })]); -let deploy_account_op = (amount: tez): (operation, address) => { - let delegate: option(key_hash) = None; - Account.create( - ~manager=tz1YLtLqD1fWHthSVHPD116oYvsd4PTAHUoc, - ~delegate, - ~delegatable=true, - ~amount, - ); -}; let deploy_contract_op = (storage: Appstore.storage): (operation, address) => { let delegate: option(key_hash) = None; Contract.create( - ~manager=tz1YLtLqD1fWHthSVHPD116oYvsd4PTAHUoc, ~delegate, - ~delegatable=true, - ~spendable=false, ~amount=0tz, ~storage, ~code=(contract Appstore), @@ -52,7 +40,6 @@ let deploy_contract_op = (storage: Appstore.storage): (operation, address) => { type storage = unit; let%entry test = (_param: unit, _storage: unit) => { - let (fund_op, address) = deploy_account_op(10tz); let (main_op, main) = deploy_contract_op(init_storage("eple")); - ([fund_op, main_op], ()) + ([main_op], ()) }; diff --git a/tests/bug_210.liq b/tests/bug_210.liq index e7af980c..34814ee1 100644 --- a/tests/bug_210.liq +++ b/tests/bug_210.liq @@ -8,20 +8,19 @@ end contract C = struct type storage = unit - let%entry main () s = + let%entry default () s = Lib.sender_check (Current.source ()); (* Cannot access Lib here *) [], () end type storage = unit -let%entry main manager s = +let%entry default manager s = Lib.sender_check (Current.source ()); (* this line has no failure *) - let op, _ = Contract.create ~storage:() ~manager ~spendable:false - ~delegatable:false ~delegate:None ~amount:0tz + let op, _ = Contract.create ~storage:() ~delegate:(Some manager) ~amount:0tz (contract struct type storage = unit - let%entry main () s = + let%entry default () s = Lib.sender_check (Current.source ()); (* Cannot access Lib here *) [], () end) in diff --git a/tests/bug_213.liq b/tests/bug_213.liq index 46577917..26d5d33c 100644 --- a/tests/bug_213.liq +++ b/tests/bug_213.liq @@ -1,42 +1,34 @@ module FA12 = struct contract type ContractType = sig - type storage [%%entry - :val main : parameter:address -> storage -> (operation list * storage)] + :val main : address] end - type ct = ContractType.instance contract type ContractType3 = sig - type storage [%%entry - :val main : parameter:nat -> storage -> (operation list * storage)] + :val main : nat] end - type ct3 = ContractType3.instance contract type ContractType4 = sig - type storage [%%entry - :val main : parameter:nat -> storage -> (operation list * storage)] + :val main : nat] end - type ct4 = ContractType4.instance contract type ContractType5 = sig - type storage [%%entry - :val main : parameter:nat -> storage -> (operation list * storage)] + :val main : nat] end - type ct5 = ContractType5.instance contract type Fa12 = sig val%entry main: ((address * (address * nat)), ((address * nat), - (((address * address) * ct5), - ((address * ct4), - ((unit * ct3), + (((address * address) * address), + ((address * address), + ((unit * address), (bool, (address, - ((unit * ct), + ((unit * address), ((address * nat), (address * nat)) variant) variant) variant) variant) @@ -45,17 +37,17 @@ module FA12 = struct variant) variant) variant - -> _ + end end type storage = unit let%entry test_token (addr: address) storage = - begin match (Contract.at addr : FA12.Fa12.instance option) with + begin match [%handle FA12.Fa12.main] addr with | None -> failwith ("Cannot recover bool contract from:", addr) | Some token_contract -> let op = - Contract.call ~dest:token_contract (Left (addr, (addr, 2p))) ~amount:0tz + token_contract.main (Left (addr, (addr, 2p))) ~amount:0tz in [op], storage end diff --git a/tests/bug_213_0.liq b/tests/bug_213_0.liq deleted file mode 100644 index 8d2941c7..00000000 --- a/tests/bug_213_0.liq +++ /dev/null @@ -1,57 +0,0 @@ -module FA12 = struct - contract type ContractType = - sig - type storage - [%%entry - :val main : parameter:address -> storage -> (operation list * storage)] - end - contract type ContractType3 = - sig - type storage - [%%entry - :val main : parameter:nat -> storage -> (operation list * storage)] - end - contract type ContractType4 = - sig - type storage - [%%entry - :val main : parameter:nat -> storage -> (operation list * storage)] - end - contract type ContractType5 = - sig - type storage - [%%entry - :val main : parameter:nat -> storage -> (operation list * storage)] - end - contract type Fa12 = sig - val%entry main: - ((address * (address * nat)), - ((address * nat), - (((address * address) * ContractType5.instance), - ((address * ContractType4.instance), - ((unit * ContractType3.instance), - (bool, - (address, - ((unit * ContractType.instance), - ((address * nat), (address * nat)) variant) variant) - variant) - variant) - variant) - variant) - variant) - variant) - variant - -> _ - end -end - -type storage = unit -let%entry test_token (addr: address) storage = - begin match (Contract.at addr : FA12.Fa12.instance option) with - | None -> failwith ("Cannot recover contract from:", addr) - | Some token_contract -> - let op = - Contract.call ~dest:token_contract (Left (addr, (addr, 2p))) ~amount:0tz - in - [op], storage - end diff --git a/tests/bug_214.liq b/tests/bug_214.liq index e358ea43..9d4b06cc 100644 --- a/tests/bug_214.liq +++ b/tests/bug_214.liq @@ -4,7 +4,7 @@ let f () = if true then Current.failwith () let g f = f (); () let h () = f (); () -let%entry main () () = +let%entry default () () = g f; h (); [], () diff --git a/tests/bug_216.liq b/tests/bug_216.liq index a8e88c81..43fcdeb4 100644 --- a/tests/bug_216.liq +++ b/tests/bug_216.liq @@ -3,7 +3,7 @@ type storage = address contract A = struct type storage = { a : nat; b : nat } - let%entry main () s = + let%entry default () s = if s.a = s.b then failwith (); [], s end @@ -12,22 +12,22 @@ contract S = struct type x = {w : int; r : bool } type storage = { some_tez : tez; some_string : string ; x : x} - let%entry main ((delegate : key_hash), (manager : key_hash)) s = + let%entry default ((delegate : key_hash), (manager : key_hash)) s = if s.some_tez < 10tz then failwith "less-than-ten" ; let delegatable = true in let spendable = false in let (initial : A.storage) = { A.a = 0p; A.b = 1p } in let (op, _addr) = - Contract.create ~storage:initial ~manager ~spendable - ~delegatable ~delegate:(Some delegate) ~amount:10tz (contract A) in + Contract.create ~storage:initial + ~delegate:(Some delegate) ~amount:10tz (contract A) in [op], s end -let%entry main ((delegate : key_hash), (manager : key_hash)) _ = +let%entry default ((delegate : key_hash), (manager : key_hash)) _ = let delegatable = true in let spendable = false in let initial_storage = { S.some_tez = 10tz; S.some_string = "Hello" ; S.x = { S.w = 0; S.r = true }} in let (op, addr) = - Contract.create ~storage:initial_storage ~manager ~spendable - ~delegatable ~delegate:(Some delegate) ~amount:10tz (contract S) in + Contract.create ~storage:initial_storage + ~delegate:(Some delegate) ~amount:10tz (contract S) in [op], addr diff --git a/tests/bug_annot0.liq b/tests/bug_annot0.liq index 011147f1..332c6363 100644 --- a/tests/bug_annot0.liq +++ b/tests/bug_annot0.liq @@ -8,5 +8,5 @@ let%init storage = { b = (); } -let%entry main (_parameter : unit) storage = +let%entry default (_parameter : unit) storage = Current.failwith storage.b diff --git a/tests/bug_annot1.liq b/tests/bug_annot1.liq index 73cec714..63b79b5f 100644 --- a/tests/bug_annot1.liq +++ b/tests/bug_annot1.liq @@ -7,14 +7,14 @@ module C1 = struct contract C3 = struct type storage = unit - let%entry main (_x:int) _ = ([] : operation list), () + let%entry default (_x:int) _ = ([] : operation list), () end contract C = struct type storage = unit - let%entry main (_x:t) _ = ([] : operation list), () - (* val%entry main : t -> _ *) + let%entry default (_x:t) _ = ([] : operation list), () + (* val%entry default : t *) let mc = 1tz end @@ -29,16 +29,16 @@ contract type C = sig type t = { x : timestamp; y : address } type storage = unit - val%entry main : t -> _ + val%entry default : t end module Y = C1.C2 module R = Y contract X = R.C -type storage = X.instance * C.instance +type storage = address * address -let%entry main (_k : key_hash) storage = +let%entry default (_k : key_hash) storage = let x = { Y.x = 1tz + Y.C.mc + Y.my ; R.y = true } in - let op = storage.(0).main x ~amount:0tz in + let op = storage.(0).default x ~amount:0tz in [op], storage diff --git a/tests/bug_mohamed1.liq b/tests/bug_mohamed1.liq new file mode 100644 index 00000000..47d22d63 --- /dev/null +++ b/tests/bug_mohamed1.liq @@ -0,0 +1,187 @@ +[%%version 1.056] + +(* A player's choice is either hidden: hashed value obtained from his/her choice +and an arbitrary (secret) nonce, or a revealed choice that may have value 0 +(Rock), 1 (Paper), or 2 (Scissors) +*) +type move = + | Hashed of bytes (* sha256 (move : bytes, nonce : bytes) *) + | Revealed of int (* 0 = Rock | 1 = Paper | 2 = Scisors*) + +(* A player's state, made of the address and the choice made *) +type player = { + addr : address ; + move : move +} + +(* The storage of the contract is made of players' states, if they already +played, a timestamp indicating the date of the latest storage, and the value +of the current bet. *) +type storage = { + player1 : player option ; + player2 : player option ; + last_update : timestamp ; + bet : dun; +} + +(* --- auxiliary functions --- *) + + (* People should reveal their choices within this time frame after both players +made their moves. Otherwise, they may be disqualified, and the person who +revealed wins. If there is no second player, the first one can also withdraw +his/her bet once this TTL expires. *) +let[@inline] time_to_live = 300 (*1200 (* 20 minutes *)*) + +(* initial storage *) +let%init storage = { + player1 = None; + player2 = None; + last_update = Current.time (); + bet = 0DUN; (* correct bet will be fixed by the first player *) +} + +(* initial storage as a function *) +let[@inline] empty_storage () = { + player1 = None; + player2 = None; + last_update = Current.time (); + bet = 0DUN; +} + +(* Transfer the given amount to the given destination. Assumes a Unit contract +for the destination *) +let[@inline] make_transfer (dest : address) amount = + Contract.call ~dest ~amount () + +(* Check that sha256 (0x (move ^ nonce) = commit. Fails otherwise *) +let[@inline] check_commitment move nonce commit = + let s = Bytes.concat [move; nonce] in + let h = Crypto.sha256 s in + if h <> commit then + failwith ("revelation does not match commitment. (move, nonce, s, hash(s), com) =", + move, nonce, s, h, commit) + +(* Decode the given choice. Returns 0 (Rock), 1 (Paper), or 2 (Scissors) +depending on the value of the move. Fails if input is different from 0x01, 0x02 +and 0x03 *) +let[@inline] decode_move move = + if move = 0x00 then 0 + else if move = 0x01 then 1 + else if move = 0x02 then 2 + else failwith "invalid move" + +(* Check that Current.amount () is equal to the given amount. Fail otherwise *) +let[@inline] check_amount amnt = + if (Current.amount ()) <> amnt then + failwith ("Invalid amount. (expected, provided) = ", amnt, (Current.amount ())) + +(* Check if given timestamp plus time_to_live is smaller Current timestamp +(timeout expired). Fail otherwise *) +let[@inline] check_timeouted (last_update : timestamp) = + let diff = (Current.time()) - last_update in + let timeout = time_to_live - diff in + if timeout > 0 then + failwith ("Cannot ask for refund yet. You should wait", timeout) + + +(* --- entry points --- *) + +(* play: reveal a commitment of some choice. The second player should bet the +same amount of DUN than the first one (can be 0 DUN) *) +let%entry play commit storage = + let play = Some { addr = Current.sender () ; move = Hashed commit } in + let storage = match storage.player1 with + | None -> (storage.player1 <- play).bet <- Current.amount (); + | Some p -> + if p.addr = Current.sender () then + failwith "Cannot play twice with the same address"; + check_amount storage.bet; + match storage.player2 with + | None -> storage.player2 <- play + | Some _ -> failwith "Two players already made their moves" + in + [], storage.last_update <- Current.time () + +(* Once the two players provided their commitments. They should reveal their +choices + nonces. The revelations are checked against commitment and saved in +the storage *) +let%entry reveal (move, nonce) storage = + check_amount 0DUN; + let is_player1, player = + match storage.player1 with + | None -> failwith "Not in a reveal phase" + | Some p -> + if p.addr = Current.sender () then true, p + else + match storage.player2 with + | None -> failwith "Not in a reveal phase" + | Some p -> + if p.addr = Current.sender () then false, p + else + failwith "Only players can reveal" + in + match player.move with + | Revealed _ -> failwith "Revelation already made" + | Hashed commit -> + check_commitment move nonce commit; + let player = player.move <- Revealed (decode_move move) in + let storage = + if is_player1 then storage.player1 <- Some player + else storage.player2 <- Some player + in + [], storage.last_update <- Current.time () + +(* finalize the game: refund the winner, or the player who played honestly +(ie. revealed). Indeed, players who do not reveal after "time_to_live" are +disqualified. *) + +let%entry finalize () storage = + check_amount 0DUN; + let bet = storage.bet in + let ops = + match storage.player1 with + | None -> failwith "Nothing to refund" + | Some p1 -> + match storage.player2 with + | None -> + check_timeouted storage.last_update; + if Current.sender () <> p1.addr then failwith "Unauthorized caller"; + (* no other player after TTL, withdraw bet *) + [ make_transfer p1.addr bet ] + | Some p2 -> + let p_caller, p_other = + if Current.sender () = p1.addr then p1, p2 + else if Current.sender () = p2.addr then p2, p1 + else failwith "Unauthorized caller" + in + match p_caller.move with + | Hashed _ -> failwith "You should reveal before asking for refund" + | Revealed m1 -> + match p_other.move with + | Hashed _ -> + check_timeouted storage.last_update; + (* the player who didn't reveal after TTL will loose everything *) + [ make_transfer p_caller.addr (2p * bet) ] + | Revealed m2 -> + (* Both revealed *) + let diff = m1 - m2 in + if diff = 0 then (* The two players made the same choice *) + [ make_transfer p_caller.addr bet; + make_transfer p_other.addr bet ] + + else + (* Here the person who loses will get back "bet / 2", and + the winner will get "bet / 2". The goal is to incentivize + players to reveal their choices *) + let low, high = match bet / 2p with + | None -> failwith "invariant: unreachable" + | Some (res, rem) -> res, res + rem + in + if diff = 1 || diff = -2 then + [ make_transfer p_caller.addr (bet + high); + make_transfer p_other.addr low ] + else if diff = -1 || diff = 2 then + [ make_transfer p_other.addr (bet + high); + make_transfer p_caller.addr low ] + else failwith "invariant : unreachable" + in ops, empty_storage () diff --git a/tests/bug_steven1.liq b/tests/bug_steven1.liq index 09e8ef56..6d866c03 100644 --- a/tests/bug_steven1.liq +++ b/tests/bug_steven1.liq @@ -1,15 +1,12 @@ type storage = address contract C = struct type storage = A | B - let%entry main (_delegate : key_hash) _ = [], A + let%entry default (_delegate : key_hash) _ = [], A end -let%entry main ((delegate : key_hash), (manager : key_hash)) (s : storage) = - let delegatable = true in - let spendable = false in +let%entry default (delegate : key_hash) (s : storage) = let initial_storage = C.A in let (op, addr) = - Contract.create ~storage:initial_storage ~manager ~spendable - ~delegatable ~delegate:(Some delegate) ~amount:10tz + Contract.create ~storage:initial_storage ~delegate:(Some delegate) ~amount:10tz (contract C) in [], addr diff --git a/tests/bug_steven2.liq b/tests/bug_steven2.liq index 4deef61f..bbaf200b 100644 --- a/tests/bug_steven2.liq +++ b/tests/bug_steven2.liq @@ -2,15 +2,13 @@ type storage = address contract C = struct type storage = A | B let init () = A - let%entry main (_delegate : key_hash) _ = [], A + let%entry default (_delegate : key_hash) _ = [], A end -let%entry main ((delegate : key_hash), (manager : key_hash)) (s : storage) = - let delegatable = true in - let spendable = false in +let%entry default (delegate : key_hash) (s : storage) = let initial_storage : C.storage = C.init () in let (op, addr) = - Contract.create ~storage:initial_storage ~manager ~spendable - ~delegatable ~delegate:(Some delegate) ~amount:10tz + Contract.create ~storage:initial_storage + ~delegate:(Some delegate) ~amount:10tz (contract C) in [], addr diff --git a/tests/build.ocp2 b/tests/build.ocp2 index bfd9344e..cdeb7f50 100644 --- a/tests/build.ocp2 +++ b/tests/build.ocp2 @@ -86,6 +86,7 @@ OCaml.library("ocplib-liquidity-examples", "others/mist_wallet_light.liq"; "others/token.liq"; "others/token_no_fee.liq"; + "others/new_token.liq"; ]; }; @@ -116,138 +117,154 @@ if( with_dune_network ) { file2string = List.map (function (file){ return test_dir + file; }, [ - "attic/accounts.tz"; - "attic/add1.tz"; - "attic/add1_list.tz"; - "attic/after_strategy.tz"; - "attic/always.tz"; - "attic/append.tz"; - "attic/at_least.tz"; - "attic/auction.tz"; - "attic/bad_lockup.tz"; - "attic/big_map_union.tz"; - "attic/cadr_annotation.tz"; - "attic/concat.tz"; - "attic/conditionals.tz"; - "attic/cons_twice.tz"; - "attic/cps_fact.tz"; - "attic/create_add1_lists.tz"; - "attic/data_publisher.tz"; - "attic/dispatch.tz"; - "attic/empty.tz"; - "attic/fail_amount.tz"; - "attic/faucet.tz"; - "attic/forward.tz"; - "attic/id.tz"; - "attic/infinite_loop.tz"; - "attic/insertion_sort.tz"; - "attic/int_publisher.tz"; - "attic/king_of_tez.tz"; - "attic/list_of_transactions.tz"; - "attic/queue.tz"; - "attic/reduce_map.tz"; - "attic/reentrancy.tz"; - "attic/spawn_identities.tz"; - "macros/assert.tz"; - "macros/assert_cmpeq.tz"; - "macros/assert_cmpge.tz"; - "macros/assert_cmpgt.tz"; - "macros/assert_cmple.tz"; - "macros/assert_cmplt.tz"; - "macros/assert_cmpneq.tz"; - "macros/assert_eq.tz"; - "macros/assert_ge.tz"; - "macros/assert_gt.tz"; - "macros/assert_le.tz"; - "macros/assert_lt.tz"; - "macros/assert_neq.tz"; - "macros/big_map_get_add.tz"; - "macros/big_map_mem.tz"; - "macros/build_list.tz"; - "macros/compare.tz"; - "macros/compare_bytes.tz"; - "macros/fail.tz"; - "macros/guestbook.tz"; - "macros/macro_annotations.tz"; - "macros/map_caddaadr.tz"; - "macros/max_in_list.tz"; - "macros/min.tz"; - "macros/pair_macro.tz"; - "macros/set_caddaadr.tz"; - "macros/take_my_money.tz"; - "macros/unpair_macro.tz"; - "mini_scenarios/create_account.tz"; - "mini_scenarios/create_contract.tz"; - "mini_scenarios/default_account.tz"; - "mini_scenarios/hardlimit.tz"; - "mini_scenarios/lockup.tz"; - "mini_scenarios/originator.tz"; - "mini_scenarios/parameterized_multisig.tz"; - "mini_scenarios/replay.tz"; - "mini_scenarios/reservoir.tz"; - "mini_scenarios/reveal_signed_preimage.tz"; - "mini_scenarios/scrutable_reservoir.tz"; - "mini_scenarios/vote_for_delegate.tz"; - "mini_scenarios/weather_insurance.tz"; - "mini_scenarios/xcat.tz"; - "mini_scenarios/xcat_dapp.tz"; - "opcodes/add_delta_timestamp.tz"; - "opcodes/add_timestamp_delta.tz"; - "opcodes/and.tz"; - "opcodes/balance.tz"; - "opcodes/check_signature.tz"; - "opcodes/concat_list.tz"; - "opcodes/contains_all.tz"; - "opcodes/diff_timestamps.tz"; - "opcodes/empty_map.tz"; - "opcodes/exec_concat.tz"; - "opcodes/first.tz"; - "opcodes/get_map_value.tz"; - "opcodes/hash_consistency_checker.tz"; - "opcodes/hash_key.tz"; - "opcodes/hash_string.tz"; - "opcodes/if.tz"; - "opcodes/if_some.tz"; - "opcodes/left_right.tz"; - "opcodes/list_concat.tz"; - "opcodes/list_concat_bytes.tz"; - "opcodes/list_id.tz"; - "opcodes/list_id_map.tz"; - "opcodes/list_iter.tz"; - "opcodes/list_map_block.tz"; - "opcodes/loop_left.tz"; - "opcodes/map_car.tz"; - "opcodes/map_id.tz"; - "opcodes/map_iter.tz"; - "opcodes/map_size.tz"; - "opcodes/noop.tz"; - "opcodes/not.tz"; - "opcodes/or.tz"; - "opcodes/packunpack.tz"; - "opcodes/pair_id.tz"; - "opcodes/ret_int.tz"; - "opcodes/reverse.tz"; - "opcodes/reverse_loop.tz"; - "opcodes/self.tz"; - "opcodes/set_car.tz"; - "opcodes/set_cdr.tz"; - "opcodes/set_id.tz"; - "opcodes/set_iter.tz"; - "opcodes/set_member.tz"; - "opcodes/set_size.tz"; - "opcodes/slices.tz"; - "opcodes/split_bytes.tz"; - "opcodes/split_string.tz"; - "opcodes/steps_to_quota.tz"; - "opcodes/store_input.tz"; - "opcodes/store_now.tz"; - "opcodes/str_id.tz"; - "opcodes/subset.tz"; - "opcodes/sub_timestamp_delta.tz"; - "opcodes/tez_add_sub.tz"; - "opcodes/transfer_amount.tz"; - "opcodes/transfer_tokens.tz"; - "opcodes/xor.tz"; +"attic/accounts.tz"; +"attic/add1.tz"; +"attic/add1_list.tz"; +"attic/after_strategy.tz"; +"attic/always.tz"; +"attic/append.tz"; +"attic/at_least.tz"; +"attic/auction.tz"; +"attic/bad_lockup.tz"; +"attic/big_map_union.tz"; +"attic/cadr_annotation.tz"; +"attic/concat.tz"; +"attic/conditionals.tz"; +"attic/cons_twice.tz"; +"attic/cps_fact.tz"; +"attic/create_add1_lists.tz"; +"attic/data_publisher.tz"; +"attic/dispatch.tz"; +"attic/empty.tz"; +"attic/fail_amount.tz"; +"attic/faucet.tz"; +"attic/forward.tz"; +"attic/id.tz"; +"attic/infinite_loop.tz"; +"attic/insertion_sort.tz"; +"attic/int_publisher.tz"; +"attic/king_of_tez.tz"; +"attic/list_of_transactions.tz"; +"attic/queue.tz"; +"attic/reduce_map.tz"; +"attic/reentrancy.tz"; +"attic/reservoir.tz"; +"attic/scrutable_reservoir.tz"; +"attic/spawn_identities.tz"; +"entrypoints/big_map_entrypoints.tz"; +"entrypoints/manager.tz"; +"entrypoints/no_default_target.tz"; +"entrypoints/no_entrypoint_target.tz"; +"entrypoints/rooted_target.tz"; +"macros/assert.tz"; +"macros/assert_cmpeq.tz"; +"macros/assert_cmpge.tz"; +"macros/assert_cmpgt.tz"; +"macros/assert_cmple.tz"; +"macros/assert_cmplt.tz"; +"macros/assert_cmpneq.tz"; +"macros/assert_eq.tz"; +"macros/assert_ge.tz"; +"macros/assert_gt.tz"; +"macros/assert_le.tz"; +"macros/assert_lt.tz"; +"macros/assert_neq.tz"; +"macros/big_map_get_add.tz"; +"macros/big_map_mem.tz"; +"macros/build_list.tz"; +"macros/compare.tz"; +"macros/compare_bytes.tz"; +"macros/fail.tz"; +"macros/guestbook.tz"; +"macros/macro_annotations.tz"; +"macros/map_caddaadr.tz"; +"macros/max_in_list.tz"; +"macros/min.tz"; +"macros/pair_macro.tz"; +"macros/set_caddaadr.tz"; +"macros/take_my_money.tz"; +"macros/unpair_macro.tz"; +"mini_scenarios/big_map_entrypoints.tz"; +"mini_scenarios/big_map_magic.tz"; +"mini_scenarios/create_contract.tz"; +"mini_scenarios/default_account.tz"; +"mini_scenarios/hardlimit.tz"; +"mini_scenarios/lockup.tz"; +"mini_scenarios/multiple_entrypoints_counter.tz"; +"mini_scenarios/parameterized_multisig.tz"; +"mini_scenarios/replay.tz"; +"mini_scenarios/reveal_signed_preimage.tz"; +"mini_scenarios/votes.tz"; +"mini_scenarios/votes2.tz"; +"mini_scenarios/vote_for_delegate.tz"; +"mini_scenarios/weather_insurance.tz"; +"mini_scenarios/xcat.tz"; +"mini_scenarios/xcat_dapp.tz"; +"opcodes/add_delta_timestamp.tz"; +"opcodes/add_timestamp_delta.tz"; +"opcodes/and.tz"; +"opcodes/balance.tz"; +"opcodes/big_map_to_self.tz"; +"opcodes/chain_id.tz"; +"opcodes/check_signature.tz"; +"opcodes/collect_check.tz"; +"opcodes/concat_list.tz"; +"opcodes/contains_all.tz"; +"opcodes/diff_timestamps.tz"; +"opcodes/dign.tz"; +"opcodes/dipn.tz"; +"opcodes/dropn.tz"; +"opcodes/dugn.tz"; +"opcodes/empty_map.tz"; +"opcodes/exec_concat.tz"; +"opcodes/first.tz"; +"opcodes/get_map_value.tz"; +"opcodes/hash_consistency_checker.tz"; +"opcodes/hash_key.tz"; +"opcodes/hash_string.tz"; +"opcodes/if.tz"; +"opcodes/if_some.tz"; +"opcodes/implicit.tz"; +"opcodes/left_right.tz"; +"opcodes/level.tz"; +"opcodes/list_concat.tz"; +"opcodes/list_concat_bytes.tz"; +"opcodes/list_id.tz"; +"opcodes/list_id_map.tz"; +"opcodes/list_iter.tz"; +"opcodes/list_map_block.tz"; +"opcodes/loop_left.tz"; +"opcodes/map_car.tz"; +"opcodes/map_id.tz"; +"opcodes/map_iter.tz"; +"opcodes/map_size.tz"; +"opcodes/noop.tz"; +"opcodes/not.tz"; +"opcodes/or.tz"; +"opcodes/packunpack.tz"; +"opcodes/pair_id.tz"; +"opcodes/ret_int.tz"; +"opcodes/reverse.tz"; +"opcodes/reverse_loop.tz"; +"opcodes/self.tz"; +"opcodes/set_car.tz"; +"opcodes/set_cdr.tz"; +"opcodes/set_id.tz"; +"opcodes/set_iter.tz"; +"opcodes/set_member.tz"; +"opcodes/set_size.tz"; +"opcodes/slices.tz"; +"opcodes/split_bytes.tz"; +"opcodes/split_string.tz"; +"opcodes/store_input.tz"; +"opcodes/store_now.tz"; +"opcodes/str_id.tz"; +"opcodes/subset.tz"; +"opcodes/sub_timestamp_delta.tz"; +"opcodes/tez_add_sub.tz"; +"opcodes/transfer_amount.tz"; +"opcodes/transfer_tokens.tz"; +"opcodes/xor.tz"; ]); }; diff --git a/tests/curry.liq b/tests/curry.liq index 0f75156e..de2a5ad8 100644 --- a/tests/curry.liq +++ b/tests/curry.liq @@ -2,7 +2,7 @@ type storage = (bool -> unit -> int) * bytes let g (x:unit) (x:unit) (x:unit) (x:unit) (x:unit) = 0 -let%entry main (f : tez -> bool -> int) (s, b) = +let%entry default (f : tez -> bool -> int) (s, b) = (* let g (x:unit) (x:unit) (x:unit) (x:unit) (x:unit) = 0 in *) (* let a = 9tz in *) let l = [] in diff --git a/tests/doc/doc1.liq b/tests/doc/doc1.liq index 650bd474..6e8bbc41 100644 --- a/tests/doc/doc1.liq +++ b/tests/doc/doc1.liq @@ -1,5 +1,5 @@ type storage = dun -let%entry main () s = +let%entry default () s = let bal = Current.balance() in [], bal diff --git a/tests/doc/doc10.liq b/tests/doc/doc10.liq index e0f1d3d6..63e6e4aa 100644 --- a/tests/doc/doc10.liq +++ b/tests/doc/doc10.liq @@ -1,6 +1,6 @@ type storage = dun -let%entry main ( v : nat ) _ = +let%entry default ( v : nat ) _ = (* conversion from nat to dun *) let amount = v * 1DUN in [], amount diff --git a/tests/doc/doc11.liq b/tests/doc/doc11.liq index 6f450136..e355ba30 100644 --- a/tests/doc/doc11.liq +++ b/tests/doc/doc11.liq @@ -1,6 +1,6 @@ type storage = nat -let%entry main ( v : dun ) _ = +let%entry default ( v : dun ) _ = (* conversion from dun to nat *) let (nat, rem_dun) = match v / 1DUN with | Some qr -> qr diff --git a/tests/doc/doc12.liq b/tests/doc/doc12.liq index 4a97129c..1a81b531 100644 --- a/tests/doc/doc12.liq +++ b/tests/doc/doc12.liq @@ -1,6 +1,6 @@ type storage = nat -let%entry main ( x : int ) _ = +let%entry default ( x : int ) _ = (* conversion from int to nat *) let n = match%nat x with | Plus n -> n diff --git a/tests/doc/doc13.liq b/tests/doc/doc13.liq index dd8e5b45..d4f1b418 100644 --- a/tests/doc/doc13.liq +++ b/tests/doc/doc13.liq @@ -1,6 +1,9 @@ type storage = unit -let%entry main ( to_forward : dun ) _ = - let dest = (dn1UqnHgHFe8ezEgsoow4hERctPssuWiw9h8 : UnitContract.instance) in - let op = Contract.call ~dest ~amount:to_forward () in +let%entry default ( to_forward : dun ) _ = + let op = + Contract.call + ~dest:(dn1UqnHgHFe8ezEgsoow4hERctPssuWiw9h8 : address) + ~entry:default + ~amount:to_forward () in [op], () diff --git a/tests/doc/doc14.liq b/tests/doc/doc14.liq index 7abcac66..0002c3c1 100644 --- a/tests/doc/doc14.liq +++ b/tests/doc/doc14.liq @@ -1,11 +1,10 @@ contract type My = sig - type storage - val%entry my_entry : int -> _ + val%entry my_entry : int end type storage = unit -let%entry main ((amount : dun ), (p : int), (c : My.instance)) _ = +let%entry default ((amount : dun ), (p : int), (c : address)) _ = let op1 = c.my_entry p ~amount in (* this is syntactic sugar for: *) let op2 = Contract.call ~dest:c ~entry:my_entry ~parameter:p ~amount in diff --git a/tests/doc/doc15.liq b/tests/doc/doc15.liq index a9c8d05e..ec08f35f 100644 --- a/tests/doc/doc15.liq +++ b/tests/doc/doc15.liq @@ -1,6 +1,6 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let op = Account.transfer ~dest:dn1UqnHgHFe8ezEgsoow4hERctPssuWiw9h8 ~amount:1DUN in [op], () diff --git a/tests/doc/doc16.liq b/tests/doc/doc16.liq index 10884c54..83606fef 100644 --- a/tests/doc/doc16.liq +++ b/tests/doc/doc16.liq @@ -1,8 +1,9 @@ -type storage = address option +type storage = { + x : int; + c : address; +} -let%entry main (k : key_hash) _ = - let not_delegatable = false in - let (op, addr) = - Account.create - ~manager:k ~delegate:(Some k) ~delegatable:false ~amount:100DUN in - ([op], Some addr) +let%entry default () storage = + let addr = Contract.untype (Contract.self ()) in + let storage = storage.c <- addr in + [], storage diff --git a/tests/doc/doc17.liq b/tests/doc/doc17.liq index a6593cf3..2b189b04 100644 --- a/tests/doc/doc17.liq +++ b/tests/doc/doc17.liq @@ -1,6 +1,6 @@ -type storage = UnitContract.instance option +type storage = address option -let%entry main (k : key_hash) _ = +let%entry default (k : key_hash) _ = let my_contract = Account.default k in - let op = my_contract.main () ~amount:0DUN in - [op], Some my_contract + let op = my_contract.default () ~amount:0DUN in + [op], Some (Contract.address my_contract) diff --git a/tests/doc/doc18.liq b/tests/doc/doc18.liq index 82029e62..7c884603 100644 --- a/tests/doc/doc18.liq +++ b/tests/doc/doc18.liq @@ -1,6 +1,6 @@ type storage = unit -let%entry main () () = (* accept funds *) +let%entry default () () = (* accept funds *) [], () let%entry change_delegate (new_del : key_hash) () = diff --git a/tests/doc/doc19.liq b/tests/doc/doc19.liq index 6b2112a0..e1bd6b9e 100644 --- a/tests/doc/doc19.liq +++ b/tests/doc/doc19.liq @@ -3,7 +3,7 @@ type storage = { my_address : address; } -let%entry main () storage = +let%entry default () storage = let addr = Contract.address (Contract.self ()) in let storage = storage.my_address <- addr in [], storage diff --git a/tests/doc/doc2.liq b/tests/doc/doc2.liq index 03be61a8..fb7f9cad 100644 --- a/tests/doc/doc2.liq +++ b/tests/doc/doc2.liq @@ -1,5 +1,5 @@ type storage = timestamp -let%entry main () _ = +let%entry default () _ = let now = Current.time() in [], now diff --git a/tests/doc/doc20.liq b/tests/doc/doc20.liq index 0a8e28f9..424528c0 100644 --- a/tests/doc/doc20.liq +++ b/tests/doc/doc20.liq @@ -1,12 +1,11 @@ type storage = unit contract type BoolContract = sig - type storage - val%entry main : bool -> _ + val%entry default : bool end -let%entry main (addr : address) _ = - begin match (Contract.at addr : BoolContract.instance option) with +let%entry default (addr : address) _ = + begin match [%handle BoolContract.default] addr with | None -> failwith ("Cannot recover bool contract from:", addr) - | Some _my_contract -> () + | Some _my_handle -> () end; [], () diff --git a/tests/doc/doc21.liq b/tests/doc/doc21.liq index 9edba91c..331cf2d8 100644 --- a/tests/doc/doc21.liq +++ b/tests/doc/doc21.liq @@ -1,7 +1,7 @@ type storage = unit -let%entry main () _ = - let me = Contract.self () in +let%entry default () _ = + let me = [%handle Self.other] in let op = me.other 10 ~amount:0DUN in [op], () diff --git a/tests/doc/doc22.liq b/tests/doc/doc22.liq index 58914228..7d4d71da 100644 --- a/tests/doc/doc22.liq +++ b/tests/doc/doc22.liq @@ -1,15 +1,13 @@ type storage = address -let%entry main ((delegate : key_hash), (manager : key_hash)) _ = - let delegatable = true in - let spendable = false in - let initial_storage = (10DUN,"Hello") in +let%entry default (delegate : key_hash) _ = + let initial_storage = (10DUN, "Hello") in let (op, addr) = - Contract.create ~storage:initial_storage ~manager ~spendable - ~delegatable ~delegate:(Some delegate) ~amount:10DUN + Contract.create + ~storage:initial_storage ~delegate:(Some delegate) ~amount:10DUN (contract struct type storage = dun * string - let%entry main () s = [], s + let%entry default () s = [], s end) in [op], addr diff --git a/tests/doc/doc23.liq b/tests/doc/doc23.liq index 72ae2e45..d9c49f41 100644 --- a/tests/doc/doc23.liq +++ b/tests/doc/doc23.liq @@ -2,14 +2,13 @@ type storage = address contract S = struct type storage = dun * string - let%entry main () s = [], s + let%entry default () s = [], s end -let%entry main ((delegate : key_hash), (manager : key_hash)) _ = - let delegatable = true in - let spendable = false in +let%entry default (delegate : key_hash) _ = let initial_storage = (10DUN,"Hello") in let (op, addr) = - Contract.create ~storage:initial_storage ~manager ~spendable - ~delegatable ~delegate:(Some delegate) ~amount:10DUN (contract S) in + Contract.create + ~storage:initial_storage ~delegate:(Some delegate) ~amount:10DUN + (contract S) in [op], addr diff --git a/tests/doc/doc24.liq b/tests/doc/doc24.liq index f47ecea2..3bbbf27f 100644 --- a/tests/doc/doc24.liq +++ b/tests/doc/doc24.liq @@ -1,5 +1,5 @@ type storage = bytes -let%entry main () _ = +let%entry default () _ = let b = 0xdeadbeef in let h = Crypto.blake2b b in if Bytes.length h <> 32p then failwith "incorrect size"; diff --git a/tests/doc/doc25.liq b/tests/doc/doc25.liq index 5fc976c2..55957fcb 100644 --- a/tests/doc/doc25.liq +++ b/tests/doc/doc25.liq @@ -1,5 +1,5 @@ type storage = bytes -let%entry main () _ = +let%entry default () _ = let b = Bytes.pack "This is a message" in let h = Crypto.sha512 b in if Bytes.length h <> 32p then failwith "incorrect size"; diff --git a/tests/doc/doc26.liq b/tests/doc/doc26.liq index c4de5fdc..f35cc511 100644 --- a/tests/doc/doc26.liq +++ b/tests/doc/doc26.liq @@ -1,5 +1,5 @@ type storage = bytes -let%entry main () _ = +let%entry default () _ = let b = Bytes.pack [1; 2; 3] in let h = Crypto.sha512 b in if Bytes.length h <> 64p then failwith "incorrect size"; diff --git a/tests/doc/doc27.liq b/tests/doc/doc27.liq index eab7e9e7..722da78c 100644 --- a/tests/doc/doc27.liq +++ b/tests/doc/doc27.liq @@ -1,5 +1,5 @@ type storage = key_hash -let%entry main (k : key) _ = +let%entry default (k : key) _ = let h = Crypto.hash_key k in [], h diff --git a/tests/doc/doc28.liq b/tests/doc/doc28.liq index 2b311716..3a00f6d0 100644 --- a/tests/doc/doc28.liq +++ b/tests/doc/doc28.liq @@ -1,6 +1,6 @@ type storage = key -let%entry main ((message : string), (signature : signature)) key = +let%entry default ((message : string), (signature : signature)) key = let bytes = Bytes.pack message in if not (Crypto.check key signature bytes) then failwith "Wrong signature"; diff --git a/tests/doc/doc29.liq b/tests/doc/doc29.liq index 1d1a1e21..055b8930 100644 --- a/tests/doc/doc29.liq +++ b/tests/doc/doc29.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let b = Bytes.pack [1; 2; 3; 4; 5] in let hash = Crypto.sha256 b in if hash = 0x then failwith "?"; diff --git a/tests/doc/doc3.liq b/tests/doc/doc3.liq index 2bce8ee1..087b0833 100644 --- a/tests/doc/doc3.liq +++ b/tests/doc/doc3.liq @@ -1,5 +1,5 @@ type storage = dun -let%entry main () _ = +let%entry default () _ = let received = Current.amount () in [], received diff --git a/tests/doc/doc30.liq b/tests/doc/doc30.liq index 1bfc3dad..4776990c 100644 --- a/tests/doc/doc30.liq +++ b/tests/doc/doc30.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let s = Bytes.pack (1, 2, 3, 4) in let t = (Bytes.unpack s : (int * int * int * int) option) in begin match t with diff --git a/tests/doc/doc31.liq b/tests/doc/doc31.liq index 13934f1d..a1423b6c 100644 --- a/tests/doc/doc31.liq +++ b/tests/doc/doc31.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let s = Bytes.pack (1, 2, 3, 4) in let n = Bytes.length s in if n > 16p then failwith "serialization too long"; diff --git a/tests/doc/doc32.liq b/tests/doc/doc32.liq index e512c72a..4cfac0a7 100644 --- a/tests/doc/doc32.liq +++ b/tests/doc/doc32.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let s = Bytes.concat [ 0x616161; 0x616161 ] in if Bytes.length s <> 6p then failwith "bad concat !"; [], () diff --git a/tests/doc/doc33.liq b/tests/doc/doc33.liq index 99eb5e14..49c5335e 100644 --- a/tests/doc/doc33.liq +++ b/tests/doc/doc33.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let b = 0x616161 in let s = Bytes.concat [ b; b ] in let b' = Bytes.sub 3p 3p s in diff --git a/tests/doc/doc34.liq b/tests/doc/doc34.liq index 19604d6d..ad8dba06 100644 --- a/tests/doc/doc34.liq +++ b/tests/doc/doc34.liq @@ -1,5 +1,5 @@ type storage = bytes -let%entry main () _ = +let%entry default () _ = let b = 0x616161 in let s = b @ b in let b' = match Bytes.sub 3p 3p s with diff --git a/tests/doc/doc35.liq b/tests/doc/doc35.liq index 87119ee9..e14ea2d6 100644 --- a/tests/doc/doc35.liq +++ b/tests/doc/doc35.liq @@ -1,5 +1,5 @@ type storage = nat -let%entry main () _ = +let%entry default () _ = let s = "Hello world" in let len = String.length s in [], len diff --git a/tests/doc/doc36.liq b/tests/doc/doc36.liq index 895058f0..46dd470d 100644 --- a/tests/doc/doc36.liq +++ b/tests/doc/doc36.liq @@ -1,5 +1,5 @@ type storage = string -let%entry main () _ = +let%entry default () _ = let s = "Hello world" in let world = match String.sub 6p 5p s with | Some s -> s diff --git a/tests/doc/doc37.liq b/tests/doc/doc37.liq index d94031f2..cf0cf144 100644 --- a/tests/doc/doc37.liq +++ b/tests/doc/doc37.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let s1 = "Hello world" in let s2 = String.concat [ "Hello"; " "; "world" ] in if s1 <> s2 then failwith (s1, s2); diff --git a/tests/doc/doc38.liq b/tests/doc/doc38.liq index 6e9fd235..17640618 100644 --- a/tests/doc/doc38.liq +++ b/tests/doc/doc38.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let s1 = "Hello world" in let s2 = "Hello " @ "world" in if s1 <> s2 then failwith (s1, s2); diff --git a/tests/doc/doc39.liq b/tests/doc/doc39.liq index e9ab4e3f..5283a765 100644 --- a/tests/doc/doc39.liq +++ b/tests/doc/doc39.liq @@ -1,7 +1,8 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let square x = x * x in let x = 23 |> square in let y = square 23 in (* this is the same as x *) - if x <> y then failwith (x, y); + let z = square @@ 23 in (* this is also the same as x *) + if x <> y || x <> z then failwith (x, y, z); [], () diff --git a/tests/doc/doc4.liq b/tests/doc/doc4.liq deleted file mode 100644 index 88494def..00000000 --- a/tests/doc/doc4.liq +++ /dev/null @@ -1,7 +0,0 @@ -type storage = unit - -let%entry main () _ = - let remaining_gas = Current.gas () in - if remaining_gas < 1000p then - Current.failwith ("Not enough gas", remaining_gas); - [], () diff --git a/tests/doc/doc40.liq b/tests/doc/doc40.liq index e8a7cf88..cfca8ad8 100644 --- a/tests/doc/doc40.liq +++ b/tests/doc/doc40.liq @@ -1,4 +1,4 @@ type storage = string list -let%entry main () old_list = +let%entry default () old_list = let new_list = "Hello" :: old_list in [], new_list diff --git a/tests/doc/doc41.liq b/tests/doc/doc41.liq index 527f8f1f..1b58bb10 100644 --- a/tests/doc/doc41.liq +++ b/tests/doc/doc41.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let list = List.rev [7; 5; 10] in (* list = [10; 5; 7] *) begin match list with diff --git a/tests/doc/doc42.liq b/tests/doc/doc42.liq index 85cccd1a..141b3ce0 100644 --- a/tests/doc/doc42.liq +++ b/tests/doc/doc42.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let size = List.length [10; 20; 30; 40] in if size <> 4p then failwith size; [], () diff --git a/tests/doc/doc43.liq b/tests/doc/doc43.liq index b9e5aed4..78199817 100644 --- a/tests/doc/doc43.liq +++ b/tests/doc/doc43.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main (list : nat list) _ = +let%entry default (list : nat list) _ = List.iter (fun x -> if x < 10p then failwith "error, element two small" ) list; diff --git a/tests/doc/doc44.liq b/tests/doc/doc44.liq index ee5cffbe..3487a923 100644 --- a/tests/doc/doc44.liq +++ b/tests/doc/doc44.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let sum = List.fold (fun (elt, acc) -> elt + acc ) [1; 2; 3; 4; 5] 0 diff --git a/tests/doc/doc45.liq b/tests/doc/doc45.liq index 48709548..22b8691f 100644 --- a/tests/doc/doc45.liq +++ b/tests/doc/doc45.liq @@ -1,4 +1,4 @@ type storage = int list -let%entry main () list = +let%entry default () list = let list = List.map (fun x -> x + 1) list in [], list diff --git a/tests/doc/doc46.liq b/tests/doc/doc46.liq index 09314341..5862e2da 100644 --- a/tests/doc/doc46.liq +++ b/tests/doc/doc46.liq @@ -1,5 +1,5 @@ type storage = int -let%entry main () _ = +let%entry default () _ = let (list, acc) = List.map_fold (fun (elt, acc) -> ( elt + 1, elt + acc ) ) [1; 2; 3; 4; 5] 0 in diff --git a/tests/doc/doc47.liq b/tests/doc/doc47.liq index f126a422..799a23f6 100644 --- a/tests/doc/doc47.liq +++ b/tests/doc/doc47.liq @@ -1,5 +1,5 @@ type storage = int set -let%entry main () my_set = +let%entry default () my_set = let my_set = Set.update 3 true my_set in (* add 3 *) let my_set = Set.update 10 false my_set in (* remove 10 *) [], my_set diff --git a/tests/doc/doc48.liq b/tests/doc/doc48.liq index b72fed4b..bfc54e9c 100644 --- a/tests/doc/doc48.liq +++ b/tests/doc/doc48.liq @@ -1,4 +1,4 @@ type storage = int set -let%entry main () my_set = +let%entry default () my_set = let my_set = Set.add 3 my_set in [], my_set diff --git a/tests/doc/doc49.liq b/tests/doc/doc49.liq index d90f3ce0..eec4cb00 100644 --- a/tests/doc/doc49.liq +++ b/tests/doc/doc49.liq @@ -1,4 +1,4 @@ type storage = int set -let%entry main () my_set = +let%entry default () my_set = let my_set = Set.remove 10 my_set in [], my_set diff --git a/tests/doc/doc5.liq b/tests/doc/doc5.liq index f9e77846..9e9b0004 100644 --- a/tests/doc/doc5.liq +++ b/tests/doc/doc5.liq @@ -1,6 +1,6 @@ type storage = address -let%entry main () owner = +let%entry default () owner = let addr = Current.source () in if addr <> owner then Current.failwith ("Not allowed"); diff --git a/tests/doc/doc50.liq b/tests/doc/doc50.liq index 94620e6e..d0977067 100644 --- a/tests/doc/doc50.liq +++ b/tests/doc/doc50.liq @@ -1,5 +1,5 @@ type storage = int set -let%entry main () my_set = +let%entry default () my_set = let my_set = Set.add 3 my_set in if not ( Set.mem 3 my_set ) then failwith "Missing integer 3 in int set"; diff --git a/tests/doc/doc51.liq b/tests/doc/doc51.liq index 7964ba92..0942bed8 100644 --- a/tests/doc/doc51.liq +++ b/tests/doc/doc51.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main (my_set : int set) _ = +let%entry default (my_set : int set) _ = let cardinal = Set.size my_set in if cardinal < 10p then failwith "too few elements"; [], () diff --git a/tests/doc/doc52.liq b/tests/doc/doc52.liq index 6ef80dfd..3ee91228 100644 --- a/tests/doc/doc52.liq +++ b/tests/doc/doc52.liq @@ -1,4 +1,4 @@ type storage = unit -let%entry main (my_set : int set) _ = +let%entry default (my_set : int set) _ = Set.iter (fun ele -> if ele < 0 then failwith "negative integer") my_set; [], () diff --git a/tests/doc/doc56.liq b/tests/doc/doc56.liq index 2cec020b..3e09fbeb 100644 --- a/tests/doc/doc56.liq +++ b/tests/doc/doc56.liq @@ -1,5 +1,5 @@ type storage = (int, string) map -let%entry main () map = +let%entry default () map = let map = Map.add 1 "Hello" map in let map = Map.add 2 "World" map in [], map diff --git a/tests/doc/doc57.liq b/tests/doc/doc57.liq index f7ef2bd9..22f431e1 100644 --- a/tests/doc/doc57.liq +++ b/tests/doc/doc57.liq @@ -1,4 +1,4 @@ type storage = (int, string) map -let%entry main (id : int) map = +let%entry default (id : int) map = let map = Map.remove id map in [], map diff --git a/tests/doc/doc58.liq b/tests/doc/doc58.liq index 59766580..2bafea4b 100644 --- a/tests/doc/doc58.liq +++ b/tests/doc/doc58.liq @@ -1,5 +1,5 @@ type storage = (int, string) map -let%entry main (id : int) map = +let%entry default (id : int) map = let _v = match Map.find id map with | None -> failwith ("id is not in the map", id) | Some v -> v diff --git a/tests/doc/doc59.liq b/tests/doc/doc59.liq index 13f093ee..a7ecc51f 100644 --- a/tests/doc/doc59.liq +++ b/tests/doc/doc59.liq @@ -1,5 +1,5 @@ type storage = (int, string) map -let%entry main ((id : int), (v : string)) map = +let%entry default ((id : int), (v : string)) map = let new_map = Map.update id None map in (* removed *) let new_map = Map.update id (Some v) new_map in (* added *) [], new_map diff --git a/tests/doc/doc6.liq b/tests/doc/doc6.liq index 0181f733..ff33e17e 100644 --- a/tests/doc/doc6.liq +++ b/tests/doc/doc6.liq @@ -1,6 +1,6 @@ type storage = address -let%entry main () owner = +let%entry default () owner = let addr = Current.sender () in if addr <> owner then Current.failwith ("Sender cannot call"); diff --git a/tests/doc/doc60.liq b/tests/doc/doc60.liq index 5ce4540f..c996a7ce 100644 --- a/tests/doc/doc60.liq +++ b/tests/doc/doc60.liq @@ -1,5 +1,5 @@ type storage = (address, string) map -let%entry main () owners_map = +let%entry default () owners_map = let sender = Current.sender () in if not ( Map.mem sender owners_map ) then failwith ("not allowed", sender); diff --git a/tests/doc/doc61.liq b/tests/doc/doc61.liq index e9d22531..358a07e2 100644 --- a/tests/doc/doc61.liq +++ b/tests/doc/doc61.liq @@ -1,4 +1,4 @@ type storage = (address, string) map -let%entry main () owners_map = +let%entry default () owners_map = if Map.size owners_map = 0p then failwith "no owners"; [], owners_map diff --git a/tests/doc/doc62.liq b/tests/doc/doc62.liq index 4e6d8a7f..9f19d2db 100644 --- a/tests/doc/doc62.liq +++ b/tests/doc/doc62.liq @@ -1,5 +1,5 @@ type storage = (string, int) map -let%entry main () map = +let%entry default () map = Map.iter (fun (_, v) -> if v < 0 then failwith "No option should be negative" diff --git a/tests/doc/doc63.liq b/tests/doc/doc63.liq index 1e22db9e..505cf379 100644 --- a/tests/doc/doc63.liq +++ b/tests/doc/doc63.liq @@ -1,5 +1,5 @@ type storage = (string, int) map -let%entry main () map = +let%entry default () map = let sum_vals = Map.fold (fun ((_, v), acc) -> acc + v) map 0 in if sum_vals <= 0 then failwith "Need at least one positive"; diff --git a/tests/doc/doc64.liq b/tests/doc/doc64.liq index 525dcc80..d25366a4 100644 --- a/tests/doc/doc64.liq +++ b/tests/doc/doc64.liq @@ -1,4 +1,4 @@ type storage = (string, int) map -let%entry main () map = +let%entry default () map = let negated_map = Map.map (fun (_key, v) -> - v) map in [], negated_map diff --git a/tests/doc/doc65.liq b/tests/doc/doc65.liq index 3c8af13a..c66bcc0f 100644 --- a/tests/doc/doc65.liq +++ b/tests/doc/doc65.liq @@ -1,5 +1,5 @@ type storage = (string, int) map -let%entry main () map = +let%entry default () map = let negated_values, min_key = Map.map_fold (fun ((key, v) , min_key) -> let min_key = match min_key with | None -> Some key diff --git a/tests/doc/doc66.liq b/tests/doc/doc66.liq index d4b7353b..cc62a2a4 100644 --- a/tests/doc/doc66.liq +++ b/tests/doc/doc66.liq @@ -3,7 +3,7 @@ type storage = { nothing : unit } -let%entry main (param : int) storage = +let%entry default (param : int) storage = let _v = match Map.find param storage.big with | None -> failwith ("param is not in the map", param) | Some v -> v diff --git a/tests/doc/doc67.liq b/tests/doc/doc67.liq index 9f68c0cd..a2e53df1 100644 --- a/tests/doc/doc67.liq +++ b/tests/doc/doc67.liq @@ -3,7 +3,7 @@ type storage = { nothing : unit } -let%entry main (param : int) storage = +let%entry default (param : int) storage = if not (Map.mem param storage.big) then failwith ("param is not in the map", param); [], storage diff --git a/tests/doc/doc68.liq b/tests/doc/doc68.liq index 4fd628f9..353f716b 100644 --- a/tests/doc/doc68.liq +++ b/tests/doc/doc68.liq @@ -3,7 +3,7 @@ type storage = { nothing : unit } -let%entry main () storage = +let%entry default () storage = let big = Map.add 10 "ten" storage.big in let big = Map.remove 0 big in let big = Map.update 0 (Some "zero") big in diff --git a/tests/doc/doc69.liq b/tests/doc/doc69.liq index 6b7fb172..00b9b888 100644 --- a/tests/doc/doc69.liq +++ b/tests/doc/doc69.liq @@ -6,12 +6,12 @@ contract C = struct let%init storage = 0 - let%entry main (u : unit) storage = + let%entry default (u : unit) storage = [], succ storage end type storage = C.storage -let%entry main (x : int) s = +let%entry default (x : int) s = [], x + s diff --git a/tests/doc/doc7.liq b/tests/doc/doc7.liq index 26cf7161..1ee0a94c 100644 --- a/tests/doc/doc7.liq +++ b/tests/doc/doc7.liq @@ -1,6 +1,6 @@ type storage = unit -let%entry main (param : string) _ = +let%entry default (param : string) _ = if String.length param > 256p then Current.failwith ("Parameter too long", param); [], () diff --git a/tests/doc/doc70.liq b/tests/doc/doc70.liq index 49f2e188..82dedde3 100644 --- a/tests/doc/doc70.liq +++ b/tests/doc/doc70.liq @@ -1,9 +1,11 @@ contract type UnitContract = sig type storage - val%entry main : unit -> storage -> operation list * storage + val%entry default : unit end type storage = unit -let%entry main (c : UnitContract.instance) _ = - [c.main ~amount:0DUN ()], () +let%entry default (c : address) _ = + match [%handle UnitContract.default] c with + | None -> failwith () + | Some c -> [c.default ~amount:0DUN ()], () diff --git a/tests/doc/doc71.liq b/tests/doc/doc71.liq index d8fd767d..5387f6aa 100644 --- a/tests/doc/doc71.liq +++ b/tests/doc/doc71.liq @@ -9,7 +9,7 @@ let bool_to_int c = (* type of pos is inferred to: int -> bool *) let pos i = i > 0 -let%entry main param _ = +let%entry default param _ = (* type of l is inferred to: (dun, int) variant *) let l = Left 1DUN in diff --git a/tests/doc/doc72.liq b/tests/doc/doc72.liq index 7a9153fe..1056d079 100644 --- a/tests/doc/doc72.liq +++ b/tests/doc/doc72.liq @@ -6,7 +6,7 @@ type ('a, 'b) t = let[@noinline] mk_t (x, y) = { x; y } -let%entry main parameter _ = +let%entry default parameter _ = let w = mk_t (parameter, 99) in if not w.x then failwith (); let v = mk_t (false, Some 0) in diff --git a/tests/doc/doc73.liq b/tests/doc/doc73.liq index 8b0d865a..2aa10f18 100644 --- a/tests/doc/doc73.liq +++ b/tests/doc/doc73.liq @@ -11,7 +11,7 @@ contract C = struct let succ x = M.f x [@@inline] let[@private] prev x = x + 1 [@@inline] - let%entry main () storage = + let%entry default () storage = [], prev (succ storage) end @@ -29,5 +29,5 @@ contract C_alias = C type storage = M.t -let%entry main (c : C.instance) s = +let%entry default (c : address) s = [c.main () ~amount:0DUN], C.succ (M.f (2 * s)) diff --git a/tests/doc/doc74.liq b/tests/doc/doc74.liq index 3c4f2df2..61ccba20 100644 --- a/tests/doc/doc74.liq +++ b/tests/doc/doc74.liq @@ -1,6 +1,6 @@ type storage = key_hash -let%entry main () _ = - match UnitContract.at (Current.sender ()) with +let%entry default () _ = + match [%handle: val%entry default : unit] (Current.sender ()) with | None -> failwith "can only be called by implicit contract" | Some c -> match Contract.is_implicit c with diff --git a/tests/doc/doc75.liq b/tests/doc/doc75.liq index d43beb83..d9bbb767 100644 --- a/tests/doc/doc75.liq +++ b/tests/doc/doc75.liq @@ -1,5 +1,5 @@ type storage = nat -let%entry main () start_level = +let%entry default () start_level = if Current.block_level () < start_level then failwith "not started"; [], start_level diff --git a/tests/doc/doc76.liq b/tests/doc/doc76.liq index 0a0aef5e..a1c45ec0 100644 --- a/tests/doc/doc76.liq +++ b/tests/doc/doc76.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () () = +let%entry default () () = if Current.collect_call () then failwith "Cannot be called in a collect call"; [], () diff --git a/tests/doc/doc77.liq b/tests/doc/doc77.liq index 20bc3597..1c400a41 100644 --- a/tests/doc/doc77.liq +++ b/tests/doc/doc77.liq @@ -1,5 +1,8 @@ type storage = unit -let%entry main addr () = - if Current.balance () < Contract.get_balance addr then - failwith "balance too big"; - [], () +let%entry default addr () = + match [%handle: val%entry default : unit] addr with + | None -> failwith () + | Some c -> + if Current.balance () < Contract.get_balance c then + failwith "balance too big"; + [], () diff --git a/tests/doc/doc8.liq b/tests/doc/doc8.liq index 2e7092ad..1809ad94 100644 --- a/tests/doc/doc8.liq +++ b/tests/doc/doc8.liq @@ -1,6 +1,6 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let x = (1, 2, 3, 4) in let car = x.(0) in let cdr = x.(1) in diff --git a/tests/doc/doc9.liq b/tests/doc/doc9.liq index d909b947..19b39dd7 100644 --- a/tests/doc/doc9.liq +++ b/tests/doc/doc9.liq @@ -1,6 +1,6 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let x = (1,2,3,4) in let x0 = x.(0) <- 10 in let x1 = x0.(1) <- 11 in diff --git a/tests/extra/extra.liq b/tests/extra/extra.liq index 553a34a7..866dd189 100644 --- a/tests/extra/extra.liq +++ b/tests/extra/extra.liq @@ -1,7 +1,7 @@ -external get_balance : [%stack: UnitContract.instance] -> [%stack: tez] = "GET_BALANCE" +external get_balance : [%stack: address] -> [%stack: tez] = "GET_BALANCE" external block_level : unit -> [%stack: nat] = "BLOCK_LEVEL" -external is_implicit : [%stack: UnitContract.instance] -> [%stack: key_hash option] = "IS_IMPLICIT" -external get_storage : [%type: 'a] -> [%stack: UnitContract.instance] -> [%stack: 'a option] = "GET_STORAGE" +external is_implicit : [%stack: address] -> [%stack: key_hash option] = "IS_IMPLICIT" +external get_storage : [%type: 'a] -> [%stack: address] -> [%stack: 'a option] = "GET_STORAGE" external reveal : [%stack: address] -> [%stack: key] -> [%stack: operation] = "REVEAL" external increase_balance : [%stack: tez] -> unit = "INCREASE_BALANCE" [@@effect] external test_fail : [%stack: 'a] -> unit = "FAILWITH" [@@effect] diff --git a/tests/extra/test.liq b/tests/extra/test.liq index bfe9bd82..e92e2300 100644 --- a/tests/extra/test.liq +++ b/tests/extra/test.liq @@ -5,7 +5,7 @@ end type storage = tez -let%entry main (c, k, a) (* ((c : UnitContract.instance), (k:key), (a:address)) *) s = +let%entry default (c, k, a) s = let s = Extra.get_balance c in let op = Extra.reveal a k in Extra.increase_balance 1_000_000tz; diff --git a/tests/inline_fail.liq b/tests/inline_fail.liq index b1d9a1b8..f4561cf2 100644 --- a/tests/inline_fail.liq +++ b/tests/inline_fail.liq @@ -2,7 +2,7 @@ type storage = unit let[@inline] f x = failwith x -let%entry main () s = +let%entry default () s = f 1; let _x = f 0 in [], s diff --git a/tests/lambda_const.liq b/tests/lambda_const.liq index 3e3dd922..d73f3778 100644 --- a/tests/lambda_const.liq +++ b/tests/lambda_const.liq @@ -5,5 +5,5 @@ let%init storage = * Some (f) *) Some (fun x -> if x > 0 then 1tz else 2tz) -let%entry main new_f _ = +let%entry default new_f _ = [], Some new_f diff --git a/tests/others/auction.liq b/tests/others/auction.liq index a9a710c9..93642f57 100644 --- a/tests/others/auction.liq +++ b/tests/others/auction.liq @@ -7,7 +7,7 @@ type storage = { bidder : key_hash; } -let%entry main +let%entry submit_auction (parameter : key_hash) (storage : storage) = diff --git a/tests/others/broker.liq b/tests/others/broker.liq index b8cab7a1..5ec7f626 100644 --- a/tests/others/broker.liq +++ b/tests/others/broker.liq @@ -4,12 +4,12 @@ type storage = { state : string; timeout : timestamp; pn : tez * tez; - x : UnitContract.instance; - a : UnitContract.instance; - b : UnitContract.instance; + x : address; + a : address; + b : address; } -let%entry main +let%entry default (parameter : timestamp) (storage : storage) = @@ -29,9 +29,9 @@ let%entry main # We update the global*) let storage = storage.state <- "success" in let (pn0, _) = storage.pn in - let op1 = Contract.call storage.x pn0 () in + let op1 = Contract.call storage.x pn0 default () in let (_, pn1) = storage.pn in - let op2 = Contract.call storage.a pn1 () in + let op2 = Contract.call storage.a pn1 default () in ( [op1; op2], storage ) else (* # After timeout, we refund @@ -45,9 +45,9 @@ let%entry main if available < p then available else p in - let op1 = Contract.call storage.x transfer () in + let op1 = Contract.call storage.x transfer default () in (* # We transfer the rest to B *) let transfer = Current.balance () - 1.00tz in - let op2 = Contract.call storage.b transfer () in + let op2 = Contract.call storage.b transfer default () in ( [op1; op2], storage ) diff --git a/tests/others/demo.liq b/tests/others/demo.liq index f6424413..75c9b032 100644 --- a/tests/others/demo.liq +++ b/tests/others/demo.liq @@ -4,7 +4,7 @@ type storage = (string, int) map let%init initial_votes (myname : string) = Map.add myname 0 (Map ["ocaml", 0; "pro", 0]) -let%entry main (choice : string) votes = +let%entry default (choice : string) votes = let amount = Current.amount() in diff --git a/tests/others/game.liq b/tests/others/game.liq index 83fcde4a..b69a762b 100644 --- a/tests/others/game.liq +++ b/tests/others/game.liq @@ -54,5 +54,5 @@ let%entry finish (random_number : nat) storage = (ops, storage) (* accept funds *) -let%entry fund () storage = +let%entry default () storage = [], storage diff --git a/tests/others/mist_wallet_current.liq b/tests/others/mist_wallet_current.liq index 921dc2fd..48619ac1 100644 --- a/tests/others/mist_wallet_current.liq +++ b/tests/others/mist_wallet_current.liq @@ -13,7 +13,7 @@ type pending_state = { } type transaction = { - destination : UnitContract.instance; + destination : address; amount : tez; } @@ -25,7 +25,7 @@ type wallet_operation = | ChangeRequirement of nat | SetDailyLimit of tez | ResetSpentToday - | Kill of UnitContract.instance + | Kill of address type operation_bytes = bytes @@ -220,11 +220,11 @@ let%entry deposit () (s : storage) = if Current.amount () = 0tz then Current.failwith () else no_op, s -let%entry kill (dest: UnitContract.instance) storage = +let%entry kill (dest: address) storage = match confirmAndCheck (Kill dest, storage) with | Confirmations_Needed storage -> no_op, storage | Execute storage -> - let trans_all = Contract.call dest (Current.balance ()) () in + let trans_all = dest.default () ~amount:(Current.balance ()) in [trans_all], storage let%entry withdraw (t: transaction) storage = @@ -232,11 +232,11 @@ let%entry withdraw (t: transaction) storage = (* execute directly if under limit *) let under, storage = underLimit (t.amount, storage) in if under then - let op = Contract.call t.destination t.amount () in + let op = t.destination.default () ~amount:t.amount in [op], storage else match confirmAndCheck (Withdraw t, storage) with | Confirmations_Needed storage -> no_op, storage | Execute storage -> - let op = Contract.call t.destination t.amount () in + let op = t.destination.default ~amount:t.amount () in [op], storage diff --git a/tests/others/mist_wallet_light.liq b/tests/others/mist_wallet_light.liq index 21939283..29f8a594 100644 --- a/tests/others/mist_wallet_light.liq +++ b/tests/others/mist_wallet_light.liq @@ -13,7 +13,7 @@ type pending_state = { } type transaction = { - destination : UnitContract.instance; + destination : address; amount : tez; } @@ -168,5 +168,5 @@ let%entry withdraw (t: transaction) storage = match confirmAndCheck (Withdraw t, storage) with | Confirmations_Needed storage -> no_op, storage | Execute storage -> - let op = Contract.call t.destination t.amount () in + let op = t.destination.default ~amount:t.amount () in [op], storage diff --git a/tests/others/multisig.liq b/tests/others/multisig.liq index df2a26ca..fdc6a2fa 100644 --- a/tests/others/multisig.liq +++ b/tests/others/multisig.liq @@ -50,7 +50,7 @@ let should_execute (p, storage) = in nb_agree >= storage.min_agree -let%entry pay (parameter : unit) storage = +let%entry pay () storage = begin[@fee failwith "I don't pay fees for the entry point pay" ] diff --git a/tests/others/new_token.liq b/tests/others/new_token.liq new file mode 100644 index 00000000..49fdc08c --- /dev/null +++ b/tests/others/new_token.liq @@ -0,0 +1,152 @@ +[%%version 2.0] + +type accounts = (address, nat) big_map + +type metadata = { + version : nat * nat; (* version of token standard *) + decimals : nat; + name : string; + symbol : string; +} + +(* Implementation dependent: can be any type *) +type internal_storage = { + owner : address; + rest : unit; +} + +type storage = { + accounts : accounts; + totalSupply : nat; + metadata : metadata; + internal : internal_storage; +} + +contract type TokenReceiver = sig + val%entry receiveTokens : address * nat * bytes option +end + +let%init storage owner decimals name symbol = + { + accounts = BigMap; + totalSupply = 0p; + metadata = { + version = 1p, 2p; (* Version of standard : 1.2 *) + decimals; + name; + symbol; + }; + internal = { + owner; + rest = (); + } + } + +(* Helper functions *) + +let[@inline] no_base_currency () = + if Current.amount () <> 0DUN then failwith "Don't send DUN" + +let perform_transfer (dest, tokens, (accounts : accounts)) = + (* Helper functions *) + let[@inline] get_balance (a, (accounts : accounts)) = + match Map.find a accounts with + | None -> 0p + | Some balance -> balance + in + let[@inline] set_balance (a, balance, (accounts : accounts)) = + let v = if balance = 0p then None else Some balance in + Map.update a v accounts + in + (* Decrease balance of sender *) + let sender_balance = get_balance (Current.sender (), accounts) in + let new_sender_balance = match is_nat (sender_balance - tokens) with + | None -> failwith ("Not enough tokens for transfer", sender_balance) + | Some b -> b in + let accounts = + set_balance (Current.sender (), new_sender_balance, accounts) in + (* Increase balance of destination *) + let dest_balance = get_balance (dest, accounts) in + let new_dest_balance = dest_balance + tokens in + let accounts = set_balance (dest, new_dest_balance, accounts) in + accounts + +let[@inline] get_balance (a, (accounts : accounts)) = + match Map.find a accounts with + | None -> 0p + | Some balance -> balance + +let[@inline] set_balance (a, balance, (accounts : accounts)) = + let v = if balance = 0p then None else Some balance in + Map.update a v accounts + +(*------------------ Transfer tokens --------------------*) + +let%entry transfer (dest, tokens, data) storage = + no_base_currency (); + let accounts = perform_transfer (dest, tokens, storage.accounts) in + let ops = + match [%handle TokenReceiver.receiveTokens] dest + (* Alternative syntax: *) + (* [%handle: val%entry receiveTokens : address * nat * bytes option] dest *) + with + | Some dest -> + let dest = Contract.address dest in + let dest = match [%handle TokenReceiver.receiveTokens] dest with + | None -> failwith () + | Some dest -> dest in + [dest.receiveTokens (Current.sender (), tokens, data) ~amount:0DUN] + | None -> match data with + | None -> [] + | Some _ -> failwith "Cannot send data to a non TokenReceiver contract" + in + ops, storage.accounts <- accounts + + +(* --------------- Storage access from outside ---------------- *) + +let%entry balanceOf (addr, (balanceOf_handler : [%handle: address * nat])) storage = + no_base_currency (); + let balance = get_balance (addr, storage.accounts) in + [ Contract.call balanceOf_handler (addr, balance) ~amount:0DUN ], storage + +let%entry totalSupply (totalSupply_handler : [%handle: nat]) storage = + no_base_currency (); + [ Contract.call totalSupply_handler storage.totalSupply ~amount:0DUN ], storage + +(* ------------------ Burning tokens ------------------------ *) + +let%entry burn (tokens : nat) storage = + no_base_currency (); + let accounts = storage.accounts in + (* Decrease balance of sender *) + let sender_balance = get_balance (Current.sender (), accounts) in + let new_sender_balance = match is_nat (sender_balance - tokens) with + | None -> + failwith ("Not enough tokens for transfer", sender_balance) + | Some b -> b in + let accounts = + set_balance (Current.sender (), new_sender_balance, accounts) in + let totalSupply = match is_nat (storage.totalSupply - tokens) with + | None -> failwith () + | Some t -> t in + [], (storage.accounts <- accounts).totalSupply <- totalSupply + + +(* ------------------ Minting tokens ------------------------ *) +(* Not part of standard *) + +let%entry mint new_accounts storage = + no_base_currency (); + if Current.sender () <> storage.internal.owner then + failwith "Only owner can create accounts"; + let accounts, totalSupply = + List.fold (fun ((dest, tokens), acc) -> + let accounts, totalSupply = acc in + if tokens = 0p then acc + else + let balance = get_balance (dest, accounts) in + (Map.add dest (balance + tokens) accounts, + totalSupply + tokens) + ) new_accounts (storage.accounts, storage.totalSupply) in + [], (storage.accounts <- accounts).totalSupply <- totalSupply diff --git a/tests/others/new_token_sig.liq b/tests/others/new_token_sig.liq new file mode 100644 index 00000000..d3712d47 --- /dev/null +++ b/tests/others/new_token_sig.liq @@ -0,0 +1,27 @@ +[%%version 2.0] + +contract type TOKEN = sig + + type accounts = (address, nat) big_map + + type metadata = { + version : nat * nat; + decimals : nat; + name : string; + symbol : string; + } + + type internal_storage + + type storage = { + accounts : accounts; + totalSupply : nat; + metadata : metadata; + internal : internal_storage; + } + + val%entry transfer : address * nat * bytes option + val%entry balanceOf : address * [%handle: address * nat] + val%entry totalSupply : [%handle: nat] + val%entry burn : nat +end diff --git a/tests/others/token.liq b/tests/others/token.liq index 975a8f81..57f8a3f8 100644 --- a/tests/others/token.liq +++ b/tests/others/token.liq @@ -90,12 +90,12 @@ let%entry transferFrom (from, dest, tokens) storage = contract type NatContract = sig type storage - val%entry main : nat -> _ + val%entry default : nat end contract type NatNatContract = sig type storage - val%entry main : nat * nat -> _ + val%entry default : nat * nat end let%entry balanceOf (spender, forward) storage = diff --git a/tests/others/token_no_fee.liq b/tests/others/token_no_fee.liq index 756d2df4..109eb370 100644 --- a/tests/others/token_no_fee.liq +++ b/tests/others/token_no_fee.liq @@ -145,12 +145,12 @@ end contract type NatContract = sig type storage - val%entry main : nat -> _ + val%entry default : nat end contract type NatNatContract = sig type storage - val%entry main : nat * nat -> _ + val%entry default : nat * nat end let%entry balanceOf (spender, forward) storage = begin[@fee diff --git a/tests/others/token_signature.liq b/tests/others/token_signature.liq index b5a1bada..27705fad 100644 --- a/tests/others/token_signature.liq +++ b/tests/others/token_signature.liq @@ -1,15 +1,3 @@ - -contract type NatContract = sig - type storage - val%entry main : nat -> _ -end - -contract type NatNatContract = sig - type storage - val%entry main : nat * nat -> _ -end - - contract type Token = sig type account = { @@ -27,12 +15,10 @@ contract type Token = sig owner : address; } - val%entry transfer : (address * nat) -> _ - val%entry approve : (address * nat) -> _ - val%entry transferFrom : (address * address * nat) -> _ - val%entry balanceOf : (address * NatContract.instance) -> _ - val%entry allowance : (address * address * NatNatContract.instance) -> _ - val%entry createAccount : (address * nat) -> _ - val%entry createAccounts : (address * nat) list -> _ + val%entry transfer : (address * nat) + val%entry approve : (address * nat) + val%entry transferFrom : (address * address * nat) + val%entry balanceOf : (address * address) + val%entry allowance : (address * address * address) end diff --git a/tests/others/token_vote.liq b/tests/others/token_vote.liq index c2d068e0..5670e652 100644 --- a/tests/others/token_vote.liq +++ b/tests/others/token_vote.liq @@ -119,12 +119,12 @@ let%entry transferFrom (from, dest, tokens) storage = contract type NatContract = sig type storage - val%entry main : nat -> _ + val%entry default : nat end contract type NatNatContract = sig type storage - val%entry main : nat * nat -> _ + val%entry default : nat * nat end let%entry balanceOf (spender, forward) storage = diff --git a/tests/others/tokenreceiver.liq b/tests/others/tokenreceiver.liq new file mode 100644 index 00000000..6449ebdb --- /dev/null +++ b/tests/others/tokenreceiver.liq @@ -0,0 +1,18 @@ +type storage = address + +let%init storage = KT1SbCLVnkPAZHZysSnYTYrtVoJZ8anP54iB (* token manager *) + +contract type TOKEN = sig + val%entry transfer : address * nat * bytes option +end + +let%entry receiveTokens ((_from : address), amount, (data : bytes option)) token_manager = + match data with + | Some _ -> failwith "I don't accept data" + | None -> + match [%handle TOKEN.transfer] (Current.sender ()) with + | None -> failwith "Receiving tokens from a non token contract" + | Some token_contract -> + (* forward tokens to manager *) + [ token_contract.transfer (token_manager, amount, None) ~amount:0DUN ], + token_manager diff --git a/tests/reports/issue39.liq b/tests/reports/issue39.liq index 6391a932..4d932b2a 100644 --- a/tests/reports/issue39.liq +++ b/tests/reports/issue39.liq @@ -66,7 +66,7 @@ type return_t = type parameter_t = (token * odd_index * odd_decimal) * (mod_parameter_t, return_t) contract * (bet_parameter_t, bet_return_t) contract -let%entry main (parameter : parameter_t) (storage : parameter_t): return_t * parameter_t = +let%entry default (parameter : parameter_t) (storage : parameter_t): return_t * parameter_t = (* let bet_contract = parameter.(2) in let (result, parameter) = Contract.call bet_contract 0tz parameter Check in *) diff --git a/tests/reverse/bug_217.tz b/tests/reverse/bug_217.tz index 8850302d..3d80f251 100644 --- a/tests/reverse/bug_217.tz +++ b/tests/reverse/bug_217.tz @@ -4,6 +4,6 @@ code { DUP ; DIP { CDR @__slash_1 ; } ; CAR @b_slash_2 ; DUP @b ; - UNPACK (contract nat) ; + UNPACK address ; IF_NONE { PUSH int 1 ; FAILWITH ; } { DUP @s ; FAILWITH ; } } diff --git a/tests/test0.liq b/tests/test0.liq index 382d11c0..14cdda4f 100644 --- a/tests/test0.liq +++ b/tests/test0.liq @@ -3,10 +3,10 @@ type storage = string * (* 0: S *) timestamp * (* 1: T *) (tez * tez) * (* 2: P N *) - UnitContract.instance * (* 3: X *) - UnitContract.instance * (* 4: A *) - UnitContract.instance (* 5: B *) -let%entry main + address * (* 3: X *) + address * (* 4: A *) + address (* 5: B *) +let%entry default (_parameter : timestamp) (storage : storage) = ( [], storage ) diff --git a/tests/test1.liq b/tests/test1.liq index 5cf55fcc..e609dbf2 100644 --- a/tests/test1.liq +++ b/tests/test1.liq @@ -3,11 +3,11 @@ type storage = string * (* 0: S *) timestamp * (* 1: T *) (tez * tez) * (* 2: P N *) - UnitContract.instance * (* 3: X *) - UnitContract.instance * (* 4: A *) - UnitContract.instance * (* 5: B *) + address * (* 3: X *) + address * (* 4: A *) + address * (* 5: B *) (timestamp * tez) * (tez * timestamp) -let%entry main +let%entry default (parameter : timestamp) (storage : storage) = let amount = Current.amount () in diff --git a/tests/test10.liq b/tests/test10.liq index 955d8329..0baab399 100644 --- a/tests/test10.liq +++ b/tests/test10.liq @@ -9,7 +9,7 @@ type storage = let x = if true then 3 else 4 -let%entry main +let%entry default (p : bool) (storage : storage) = diff --git a/tests/test11.liq b/tests/test11.liq index 4b07fdea..1b1fd678 100644 --- a/tests/test11.liq +++ b/tests/test11.liq @@ -4,7 +4,7 @@ type storage = string -let%entry main +let%entry default (parameter : string) (storage : string) = diff --git a/tests/test12.liq b/tests/test12.liq index 2020791b..1ac4edbb 100644 --- a/tests/test12.liq +++ b/tests/test12.liq @@ -4,7 +4,7 @@ type storage = string set -let%entry main +let%entry default (parameter : string) (storage : string set) = diff --git a/tests/test13.liq b/tests/test13.liq index e024e2b0..7e643c5d 100644 --- a/tests/test13.liq +++ b/tests/test13.liq @@ -4,7 +4,7 @@ type storage = string list -let%entry main +let%entry default (_parameter : string) (storage : string list) = diff --git a/tests/test14.liq b/tests/test14.liq index 95ce4e74..c45c3678 100644 --- a/tests/test14.liq +++ b/tests/test14.liq @@ -4,7 +4,7 @@ type storage = int set -let%entry main +let%entry default (parameter : int) (storage : int set) = diff --git a/tests/test15.liq b/tests/test15.liq index 87110ea5..c550b072 100644 --- a/tests/test15.liq +++ b/tests/test15.liq @@ -8,7 +8,7 @@ type storage = { whatever : unit; } -let%entry main +let%entry default (parameter : int) (storage : storage) = diff --git a/tests/test16.liq b/tests/test16.liq index 33beba9e..0ba76b17 100644 --- a/tests/test16.liq +++ b/tests/test16.liq @@ -1,7 +1,7 @@ type storage = unit -let%entry main +let%entry default (parameter : int) (storage : unit) = let f = fun arg -> diff --git a/tests/test17.liq b/tests/test17.liq index 185b6ed2..3929e38c 100644 --- a/tests/test17.liq +++ b/tests/test17.liq @@ -4,7 +4,7 @@ type storage = | Int of int | String of string * int -let%entry main +let%entry default (_parameter : int) storage = let _a = Nothing in diff --git a/tests/test18.liq b/tests/test18.liq index c5b38d9b..2cfed118 100644 --- a/tests/test18.liq +++ b/tests/test18.liq @@ -1,6 +1,6 @@ type storage = int * nat -let%entry main +let%entry default (parameter : int) (storage : (int * nat)) = diff --git a/tests/test19.liq b/tests/test19.liq index 3196eb9d..6353d277 100644 --- a/tests/test19.liq +++ b/tests/test19.liq @@ -8,13 +8,9 @@ type storage = { let%init storage : storage = { key = 0x0085b1e4560f47f089d7b97aabcf46937a4c137a9c3f96f73f20c83621694e36d5; hash = 0xabcdef; - c = KT1LLcCCB9Fr1hrkGzfdiJ9u3ZajbdckBFrF + c = KT1LLcCCB9Fr1hrkGzfdiJ9u3ZajbdckBFrF%default; } -(* -edsigtc766ouxRKCy6dfYMTanSB9NkaqnBk2eit2i1vNAcKAuMtQRZZUFWWcZ7NdhQgLkgXp9kYNKiXfKsBvpk6ebWwQkMbNvgk -*) - contract PlusOne = struct type storage = int @@ -22,24 +18,18 @@ contract PlusOne = struct let%init init_storage (x : bool) (y : int) = if x = false then 0 else y - let%entry main (_ : unit) s = + let%entry default (_ : unit) s = [], s + 1 end -(* contract type PS = sig - * type storage - * - * val%entry main : unit -> storage -> operation list * storage - * end *) - -let%entry main +let%entry default (sign : signature) storage = let x = PlusOne.A in begin match x with | PlusOne.B -> failwith () | _ -> () end; - (* let c = Contract.self () in *) + let c = Contract.self () in let key_hash = Crypto.hash_key storage.key in if key_hash = tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx then Current.failwith (); @@ -54,27 +44,14 @@ let%entry main | Some qr -> qr in let delegatable = false in - let _cocococ = (Contract.at storage.c : PlusOne.instance option) in - let _cocococ2 = PlusOne.at storage.c in - let _op1 = (Contract.self ()).main sign ~amount:0tz in - let account_op, _account = - Account.create - key_hash delegate delegatable - (amount.(0) + amount.(1)) in + let _cocococ = [%handle PlusOne.default] storage.c in + let _op1 = Self.default sign ~amount:0tz in let c_op, c_addr = Contract.create - ~manager:key_hash ~delegate - ~spendable - ~delegatable:true ~amount:amount.(0) ~storage:9 (contract PlusOne) - (* (contract struct - * type storage = int - * let%entry main (parameter : unit) (storage : storage) = - * ([] : operation list), storage + 1 - * end) *) in let storage = storage.c <- c_addr in - ( [account_op; c_op], storage ) + ( [c_op], storage ) diff --git a/tests/test2.liq b/tests/test2.liq index 27ca12b8..d331ec36 100644 --- a/tests/test2.liq +++ b/tests/test2.liq @@ -3,11 +3,11 @@ type storage = string * (* 0: S *) timestamp * (* 1: T *) (tez * tez) * (* 2: P N *) - UnitContract.instance * (* 3: X *) - UnitContract.instance * (* 4: A *) - UnitContract.instance (* 5: B *) + address * (* 3: X *) + address * (* 4: A *) + address (* 5: B *) -let%entry main +let%entry default (_parameter : timestamp) storage = let pn = storage.(2) in diff --git a/tests/test20.liq b/tests/test20.liq index cea8480f..8c37342d 100644 --- a/tests/test20.liq +++ b/tests/test20.liq @@ -1,6 +1,6 @@ type storage = tez * int * ((nat * unit) * bool) -let%entry main +let%entry default (_parameter : unit) storage = diff --git a/tests/test21.liq b/tests/test21.liq index 6f223395..b8b22f6b 100644 --- a/tests/test21.liq +++ b/tests/test21.liq @@ -1,6 +1,6 @@ type storage = nat -let%entry main +let%entry default (parameter : int) storage = diff --git a/tests/test22.liq b/tests/test22.liq index dad02b7f..5fe1ac6a 100644 --- a/tests/test22.liq +++ b/tests/test22.liq @@ -2,8 +2,8 @@ type t = A of int | B | C of (int * nat) type storage = int -let%entry main - (parameter : UnitContract.instance * t) +let%entry default + (parameter : address * t) storage = let (c, m) = parameter in @@ -11,8 +11,8 @@ let%entry main | A i -> [], i | B -> - let _op = Contract.call c 0tz () in + let _op = c.default () 0DUN in [], 0 | C (i, _) -> - let _op = Contract.call c 1tz () in + let _op = c.default () 1DUN in [], i diff --git a/tests/test23.liq b/tests/test23.liq index 584b0fea..1eb689ef 100644 --- a/tests/test23.liq +++ b/tests/test23.liq @@ -1,19 +1,14 @@ type storage = int -contract type N = sig - type storage - val%entry main : nat -> storage -> (operation list * storage) -end - -let%entry main - (parameter : N.instance) +let%entry default + (parameter : address) storage = let r, ops = match%nat (storage + 1) with | Plus x -> x + 2p, [] | Minus y -> - let op = Contract.call parameter 0tz y in + let op = Contract.call parameter ~entry:default 0tz y in 0p, [op] in let x = r + 10p in diff --git a/tests/test24.liq b/tests/test24.liq index b26638dd..8e6bf130 100644 --- a/tests/test24.liq +++ b/tests/test24.liq @@ -4,28 +4,29 @@ type t = A of int | B | C of (int * nat) type storage = int contract type UnitContract = sig - type storage contract type U = sig - type storage - val%entry main : parameter:unit -> storage -> (operation list * storage) + val%entry default : unit end - val%entry main : parameter:unit -> storage -> (operation list * storage) + val%entry default : unit end -let%entry main - (parameter : UnitContract.U.instance * t) +let%entry default + (parameter : address * t) storage = let (c, m) = parameter in + let c = match [%handle UnitContract.U.default] c with + | None -> failwith () + | Some c -> c in match m with | A _ -> let amount = 0tz in - let op = Contract.call ~dest:c ~entry:main ~amount () in + let op = Contract.call ~dest:c ~entry:default ~amount () in [op], storage | B -> - let op = Contract.call c 0tz main ~parameter:() in + let op = Contract.call c 0tz default ~parameter:() in [op], 0 | C _ -> - let op = c.main () ~amount:1tz in + let op = c.default () ~amount:1tz in [op], 1 diff --git a/tests/test25.liq b/tests/test25.liq index ddb82c5d..176e9ce6 100644 --- a/tests/test25.liq +++ b/tests/test25.liq @@ -1,21 +1,19 @@ type storage = int -contract type N = sig - type storage - val%entry main : nat -> storage -> (operation list * storage) -end - -let%entry main - (parameter : N.instance) +let%entry default + (parameter : address) storage = + let handle = match [%handle: val%entry default : nat] parameter with + | None -> failwith () + | Some h -> h in let r, op = match%nat (storage + 1) with | Plus x -> - let op = Contract.call parameter 0tz x in + let op = Contract.call handle 0tz x in (x + 2p, op) | Minus y -> - let op = Contract.call parameter 0tz y in + let op = Contract.call handle 0tz y in (y, op) in let x = r + 10p in diff --git a/tests/test26.liq b/tests/test26.liq index 29cd2701..a26f8895 100644 --- a/tests/test26.liq +++ b/tests/test26.liq @@ -1,18 +1,13 @@ type storage = bool -contract type N = sig - type storage - val%entry main : nat -> storage -> (operation list * storage) -end - -let%entry main - (parameter : N.instance) +let%entry default + (parameter : address) _storage = let b = if - let _op = Contract.call parameter 0tz 1p in + let _op = Contract.call ~entry:default parameter 0tz 1p in true then false diff --git a/tests/test27.liq b/tests/test27.liq index 7c905a84..4c62a381 100644 --- a/tests/test27.liq +++ b/tests/test27.liq @@ -1,12 +1,6 @@ +type storage = bool * address -contract type NatContract = sig - type storage - val%entry thisisit : nat -> storage -> (operation list * storage) -end - -type storage = bool * NatContract.instance - -let%entry main (_parameter : NatContract.instance) storage = +let%entry default () storage = let (b, c) = storage in if b then diff --git a/tests/test28.liq b/tests/test28.liq index efa489bb..cfcc174a 100644 --- a/tests/test28.liq +++ b/tests/test28.liq @@ -1,16 +1,11 @@ -contract type NatContract = sig - type storage - val%entry main : nat -> storage -> (operation list * storage) -end +type storage = bool * address -type storage = bool * NatContract.instance - -let%entry main (_parameter : NatContract.instance) storage = +let%entry default (_parameter : address) storage = let (b, c) = storage in if b then - let op = Contract.call c 0tz 0p in + let op = c.default 0p 0DUN in [op], set storage 0 true else [], set storage 0 false diff --git a/tests/test29.liq b/tests/test29.liq index 3943de18..f0dfa926 100644 --- a/tests/test29.liq +++ b/tests/test29.liq @@ -1,14 +1,8 @@ type storage = int -contract type I = sig - type storage - val%entry main : int -> storage -> (operation list * storage) -end - - -let%entry main - (parameter : I.instance * int list) +let%entry default + (parameter : address * int list) storage = let (c, l) = parameter in @@ -16,5 +10,5 @@ let%entry main | [] -> ([], storage) | x :: _ -> - let op = Contract.call c 0tz x in + let op = Contract.call c ~entry:default 0tz x in [op], storage diff --git a/tests/test3.liq b/tests/test3.liq index 6984724b..e2f65ac5 100644 --- a/tests/test3.liq +++ b/tests/test3.liq @@ -3,11 +3,11 @@ type storage = string * (* 0: S *) timestamp * (* 1: T *) (tez * tez) * (* 2: P N *) - UnitContract.instance * (* 3: X *) - UnitContract.instance * (* 4: A *) - UnitContract.instance (* 5: B *) + address * (* 3: X *) + address * (* 4: A *) + address (* 5: B *) -let%entry main +let%entry default (_parameter : timestamp) storage = let s = get storage 0 in diff --git a/tests/test30.liq b/tests/test30.liq index 4a229756..c2de1931 100644 --- a/tests/test30.liq +++ b/tests/test30.liq @@ -1,20 +1,14 @@ type storage = int -contract type I = sig - type storage - val%entry main : int -> storage -> (operation list * storage) -end - - -let%entry main - (parameter : I.instance * int list) +let%entry default + (parameter : address * int list) storage = let (c, l) = parameter in match l with | [] -> - let op = Contract.call c 0tz (-1) in + let op = c.default (-1) 0DUN in ([op], storage) | _ :: _ -> ([], storage) diff --git a/tests/test31.liq b/tests/test31.liq index 8bbd2428..07d7c320 100644 --- a/tests/test31.liq +++ b/tests/test31.liq @@ -2,13 +2,12 @@ type storage = int contract type I = sig - type storage - val%entry main : int -> storage -> (operation list * storage) + val%entry default : int end -let%entry main - (parameter : I.instance * int option) +let%entry default + (parameter : address * int option) storage = let (c, l) = parameter in @@ -16,5 +15,5 @@ let%entry main | None -> ([], storage) | Some x -> - let op = Contract.call c 0tz x in + let op = Contract.call c ~entry:default 0tz x in ([op], storage) diff --git a/tests/test32.liq b/tests/test32.liq index 6c92c220..94bcf452 100644 --- a/tests/test32.liq +++ b/tests/test32.liq @@ -3,7 +3,7 @@ type t = A of int | B of (int * ((bool * unit) * nat)) type storage = int -let%entry main +let%entry default (parameter : t) storage = diff --git a/tests/test33.liq b/tests/test33.liq index 7d8bace2..7d196a4c 100644 --- a/tests/test33.liq +++ b/tests/test33.liq @@ -1,7 +1,7 @@ type storage = { q : nat; res : (tez * tez) option * (nat * tez) option } -let%entry main +let%entry default (parameter : tez) storage = diff --git a/tests/test34.liq b/tests/test34.liq index 5f67062c..abdfb48e 100644 --- a/tests/test34.liq +++ b/tests/test34.liq @@ -1,7 +1,7 @@ type storage = bool -let%entry main +let%entry default (parameter : bool) storage = diff --git a/tests/test35.liq b/tests/test35.liq index 77ee5dd5..ef26e5e7 100644 --- a/tests/test35.liq +++ b/tests/test35.liq @@ -2,7 +2,7 @@ type t = A | B | C type storage = int -let%entry main +let%entry default (parameter : t) _storage = let r = match parameter with diff --git a/tests/test36.liq b/tests/test36.liq index 540d3564..e52dfe6e 100644 --- a/tests/test36.liq +++ b/tests/test36.liq @@ -1,11 +1,11 @@ -type storage = ((int, tez) map * UnitContract.instance) +type storage = ((int, tez) map * address) -let%entry main (_parameter : unit) storage = +let%entry default (_parameter : unit) storage = let foo = storage.(0) in let acc = Map.fold (fun ((_i, j), acc) -> - let op = Contract.call storage.(1) j () in + let op = Contract.call storage.(1) j default () in op :: acc ) foo [] in diff --git a/tests/test37.liq b/tests/test37.liq index dbcc2b0a..9a96b6e5 100644 --- a/tests/test37.liq +++ b/tests/test37.liq @@ -1,11 +1,11 @@ -type storage = (int, tez) map * UnitContract.instance +type storage = (int, tez) map * address -let%entry main (_parameter : UnitContract.instance) storage = +let%entry default (_parameter : address) storage = let _foo = storage.(0) in let acc = Loop.loop (fun acc -> - let op = Contract.call storage.(1) 1tz () in + let op = Contract.call storage.(1) 1tz default () in ( false, op :: acc ) ) [] in diff --git a/tests/test38.liq b/tests/test38.liq index 6a9e5b08..d2be74bb 100644 --- a/tests/test38.liq +++ b/tests/test38.liq @@ -1,7 +1,7 @@ type storage = { i: int; t: tez; } -let%entry main (parameter : int) storage = +let%entry default (parameter : int) storage = let s = storage.i <- (- parameter) in let s = s.t <- (2p * storage.t) in [], s diff --git a/tests/test39.liq b/tests/test39.liq index 57e16d4b..3319c081 100644 --- a/tests/test39.liq +++ b/tests/test39.liq @@ -3,6 +3,6 @@ type storage = bool let%init storage (i: int) (j: int) = i <= j -let%entry main (parameter : bool) storage = +let%entry default (parameter : bool) storage = let sto = ((11p && 10p) = 0p) || ((not parameter xor storage) && storage) in [], sto diff --git a/tests/test4.liq b/tests/test4.liq index 9108a5fa..6744cd60 100644 --- a/tests/test4.liq +++ b/tests/test4.liq @@ -2,11 +2,11 @@ type storage = string * (* 0: S *) timestamp * (* 1: T *) (tez * tez) * (* 2: P N *) - UnitContract.instance * (* 3: X *) - UnitContract.instance * (* 4: A *) - UnitContract.instance (* 5: B *) + address * (* 3: X *) + address * (* 4: A *) + address (* 5: B *) -let%entry main +let%entry default (parameter : timestamp) storage = let storage = set storage 1 parameter in diff --git a/tests/test40.liq b/tests/test40.liq index 5ed58ae0..b5368a8e 100644 --- a/tests/test40.liq +++ b/tests/test40.liq @@ -1,4 +1,4 @@ type storage = key_hash -let%entry main (parameter : key) _storage = +let%entry default (parameter : key) _storage = [], Crypto.hash_key parameter diff --git a/tests/test41.liq b/tests/test41.liq index b01bebfa..c8c70111 100644 --- a/tests/test41.liq +++ b/tests/test41.liq @@ -1,6 +1,6 @@ type storage = string -let%entry main (parameter : string) storage = +let%entry default (parameter : string) storage = let size = String.size parameter in let size_minus_one = match%nat size-1 with | Minus _ -> failwith "Wrong size" diff --git a/tests/test42.liq b/tests/test42.liq index ca9f5aa3..ac7c80f4 100644 --- a/tests/test42.liq +++ b/tests/test42.liq @@ -2,8 +2,8 @@ type t = A of int | B | C of (int * nat) type storage = int -let%entry main - (parameter : UnitContract.instance * t) +let%entry default + (parameter : [%handle: unit] * t) _storage = let (c, m) = parameter in diff --git a/tests/test43.liq b/tests/test43.liq index 75f86cf9..65d0df6d 100644 --- a/tests/test43.liq +++ b/tests/test43.liq @@ -3,17 +3,16 @@ contract C = struct type storage = nat contract type NatContract = sig - type storage - val%entry main : nat -> _ + val%entry default : nat end let%entry c_entry1 forward storage = - [ forward.main storage ~amount:0tz ], storage + [ forward.default storage ~amount:0tz ], storage let%entry c_entry2 forward storage = - [ forward.main storage ~amount:1tz ], storage + [ forward.default storage ~amount:1tz ], storage - let%entry main (_: int) storage = + let%entry default (_: int) storage = [], storage end diff --git a/tests/test5.liq b/tests/test5.liq index 1c6a0d0c..ad8bede0 100644 --- a/tests/test5.liq +++ b/tests/test5.liq @@ -3,11 +3,11 @@ type storage = string * (* 0: S *) timestamp * (* 1: T *) (tez * tez) * (* 2: P N *) - UnitContract.instance * (* 3: X *) - UnitContract.instance * (* 4: A *) - UnitContract.instance (* 5: B *) + address * (* 3: X *) + address * (* 4: A *) + address (* 5: B *) -let%entry main +let%entry default (_parameter : timestamp) storage = let pn = get storage 2 in diff --git a/tests/test6.liq b/tests/test6.liq index 4374453c..c25dbb86 100644 --- a/tests/test6.liq +++ b/tests/test6.liq @@ -3,11 +3,11 @@ type storage = string * (* 0: S *) timestamp * (* 1: T *) (tez * tez) * (* 2: P N *) - UnitContract.instance * (* 3: X *) - UnitContract.instance * (* 4: A *) - UnitContract.instance (* 5: B *) + address * (* 3: X *) + address * (* 4: A *) + address (* 5: B *) -let%entry main +let%entry default (_parameter : timestamp) storage = let pn = get storage 2 in diff --git a/tests/test7.liq b/tests/test7.liq index 369871c0..19afc247 100644 --- a/tests/test7.liq +++ b/tests/test7.liq @@ -3,7 +3,7 @@ type t = tez type storage = (t * tez) -let%entry main +let%entry default (_parameter : timestamp) storage = diff --git a/tests/test8.liq b/tests/test8.liq index 37ade20a..2e3015f0 100644 --- a/tests/test8.liq +++ b/tests/test8.liq @@ -2,7 +2,7 @@ type storage = tez * tez -let%entry main +let%entry default (parameter : timestamp) storage = (* 2: P N *) let p = diff --git a/tests/test9.liq b/tests/test9.liq index 294fa376..3ed3d6ef 100644 --- a/tests/test9.liq +++ b/tests/test9.liq @@ -8,7 +8,7 @@ type storage = bool * int set * int list -let%entry main +let%entry default (parameter : bool) storage = diff --git a/tests/test_big_map.liq b/tests/test_big_map.liq index 741f54bb..7317ec59 100644 --- a/tests/test_big_map.liq +++ b/tests/test_big_map.liq @@ -9,7 +9,7 @@ type storage = { let%init storage : storage = { bm = BigMap []; r = None } -let%entry main +let%entry default (parameter : string) storage = let storage = diff --git a/tests/test_call.liq b/tests/test_call.liq index b1bdbda2..b98aaf8c 100644 --- a/tests/test_call.liq +++ b/tests/test_call.liq @@ -4,8 +4,8 @@ type storage = tez -let%entry main - (parameter : UnitContract.instance) +let%entry default + (parameter : [%handle: unit] ) storage = let amount = Current.amount () in diff --git a/tests/test_closure.liq b/tests/test_closure.liq index bf080902..9ce94798 100644 --- a/tests/test_closure.liq +++ b/tests/test_closure.liq @@ -2,7 +2,7 @@ type storage = int -let%entry main +let%entry default (parameter : int) storage = let x = parameter + 10 in diff --git a/tests/test_closure2.liq b/tests/test_closure2.liq index 27c66fa9..b3f22f72 100644 --- a/tests/test_closure2.liq +++ b/tests/test_closure2.liq @@ -2,7 +2,7 @@ type storage = int -let%entry main +let%entry default (parameter : bool) storage = let x = if parameter then 10 else 0 in diff --git a/tests/test_closure3.liq b/tests/test_closure3.liq index 7244b187..06739ed6 100644 --- a/tests/test_closure3.liq +++ b/tests/test_closure3.liq @@ -2,7 +2,7 @@ type storage = int -let%entry main +let%entry default (parameter : int) storage = let _x = parameter + 10 in diff --git a/tests/test_external.liq b/tests/test_external.liq index d73943fd..47ef3dea 100644 --- a/tests/test_external.liq +++ b/tests/test_external.liq @@ -12,7 +12,7 @@ external many : unit -> [%stack: int] * [%stack: nat] type storage = (nat * int) * (int * nat * int * nat) -let%entry main (parameter : nat) _storage = +let%entry default (parameter : nat) _storage = let _ = ignore 42 in let x = random () in diff --git a/tests/test_extfun.liq b/tests/test_extfun.liq index 71d7f0f9..ab172538 100644 --- a/tests/test_extfun.liq +++ b/tests/test_extfun.liq @@ -4,7 +4,7 @@ let f (x, _) = x type storage = unit -let%entry main +let%entry default (parameter : int) storage = let storage = f (storage, parameter) in diff --git a/tests/test_fold.liq b/tests/test_fold.liq index 0d2be7a0..5a9bb414 100644 --- a/tests/test_fold.liq +++ b/tests/test_fold.liq @@ -3,7 +3,7 @@ type storage = int -let%entry main +let%entry default (_parameter : int list) _storage = diff --git a/tests/test_if.liq b/tests/test_if.liq index b49b5e6f..f09edc74 100644 --- a/tests/test_if.liq +++ b/tests/test_if.liq @@ -9,7 +9,7 @@ type storage = int set * int list -let%entry main +let%entry default (parameter : bool) storage = diff --git a/tests/test_ifcons.liq b/tests/test_ifcons.liq index d863fb30..220a03e9 100644 --- a/tests/test_ifcons.liq +++ b/tests/test_ifcons.liq @@ -4,7 +4,7 @@ type storage = string list -let%entry main +let%entry default (_parameter : string) storage = diff --git a/tests/test_infer_param.liq b/tests/test_infer_param.liq index cc05093f..736102ee 100644 --- a/tests/test_infer_param.liq +++ b/tests/test_infer_param.liq @@ -1,5 +1,5 @@ type storage = tez * string -let%entry main () s = [], s +let%entry default () s = [], s (* type storage = int * diff --git a/tests/test_infer_unpack.liq b/tests/test_infer_unpack.liq index 823d0fc4..409eb1ab 100644 --- a/tests/test_infer_unpack.liq +++ b/tests/test_infer_unpack.liq @@ -1,5 +1,5 @@ type storage = unit -let%entry main () _ = +let%entry default () _ = let s = Bytes.pack (1, 2, 3, 4) in let t = Bytes.unpack s in begin match t with diff --git a/tests/test_inline.liq b/tests/test_inline.liq index 5259091d..30292fb4 100644 --- a/tests/test_inline.liq +++ b/tests/test_inline.liq @@ -9,11 +9,11 @@ let g x = x + 2 let h x = x + 3 [@@inline] (* Will not be inlined, even with attribute *) -let op = Contract.call (Contract.self ()) 0tz () [@@inline] +let op = Contract.call (Contract.self ()) 0DUN default () [@@inline] type storage = int -let%entry main (_parameter : unit) storage = +let%entry default (_parameter : unit) storage = let a = f storage in let b = g storage in let c = g storage in diff --git a/tests/test_iter.liq b/tests/test_iter.liq index 6e75e0f5..e66040c1 100644 --- a/tests/test_iter.liq +++ b/tests/test_iter.liq @@ -3,7 +3,7 @@ type storage = unit -let%entry main +let%entry default (parameter : int list) storage = diff --git a/tests/test_left.liq b/tests/test_left.liq index eff5e5d7..b52db9a4 100644 --- a/tests/test_left.liq +++ b/tests/test_left.liq @@ -16,7 +16,7 @@ let[@noinline] mk_t (x, y) = (* let mk_somet (x, y) = * { x = Some x ; y = Some y } *) -let%entry main +let%entry default parameter storage = diff --git a/tests/test_left_constr.liq b/tests/test_left_constr.liq index 0bd7636d..9d754d3f 100644 --- a/tests/test_left_constr.liq +++ b/tests/test_left_constr.liq @@ -1,7 +1,7 @@ type storage = (int, string) variant -let%entry main +let%entry default (parameter : int) _storage = let a = Left parameter in diff --git a/tests/test_left_match.liq b/tests/test_left_match.liq index 0b61d120..70d93c85 100644 --- a/tests/test_left_match.liq +++ b/tests/test_left_match.liq @@ -1,6 +1,6 @@ type storage = (string, int) variant -let%entry main +let%entry default (parameter : (int, string) variant) _storage = diff --git a/tests/test_loop.liq b/tests/test_loop.liq index df3f7f03..0d2f455e 100644 --- a/tests/test_loop.liq +++ b/tests/test_loop.liq @@ -4,7 +4,7 @@ type storage = int -let%entry main +let%entry default (parameter : int) storage = diff --git a/tests/test_loop_left.liq b/tests/test_loop_left.liq index cd3aef8a..ec994298 100644 --- a/tests/test_loop_left.liq +++ b/tests/test_loop_left.liq @@ -1,7 +1,7 @@ type storage = int -let%entry main +let%entry default (parameter : int) storage = diff --git a/tests/test_map.liq b/tests/test_map.liq index 6cb6bff7..68d8b569 100644 --- a/tests/test_map.liq +++ b/tests/test_map.liq @@ -5,7 +5,7 @@ let succ x = x + 1 type storage = int list -let%entry main +let%entry default (_parameter : int) storage = let l = List.map succ storage in diff --git a/tests/test_map_closure.liq b/tests/test_map_closure.liq index f64c1a5f..a2346070 100644 --- a/tests/test_map_closure.liq +++ b/tests/test_map_closure.liq @@ -3,7 +3,7 @@ type storage = int list -let%entry main +let%entry default (parameter : int) storage = let add_param x = x + parameter in diff --git a/tests/test_map_fold_closure.liq b/tests/test_map_fold_closure.liq index 6c0d721a..a63a29ce 100644 --- a/tests/test_map_fold_closure.liq +++ b/tests/test_map_fold_closure.liq @@ -1,7 +1,7 @@ type storage = (bool * (string, bool) map) -let%entry main +let%entry default (parameter : (string, tez) map) _storage = diff --git a/tests/test_mapmap_closure.liq b/tests/test_mapmap_closure.liq index 3ec57677..bbbede36 100644 --- a/tests/test_mapmap_closure.liq +++ b/tests/test_mapmap_closure.liq @@ -1,6 +1,6 @@ type storage = (string, bool) map -let%entry main +let%entry default (parameter : (string, tez) map) _storage = diff --git a/tests/test_mapreduce_closure.liq b/tests/test_mapreduce_closure.liq index 6162790b..c939afde 100644 --- a/tests/test_mapreduce_closure.liq +++ b/tests/test_mapreduce_closure.liq @@ -1,7 +1,7 @@ type storage = bool -let%entry main +let%entry default (parameter : (string, tez) map) _storage = diff --git a/tests/test_modules.liq b/tests/test_modules.liq index 250cacd2..5bf30d71 100644 --- a/tests/test_modules.liq +++ b/tests/test_modules.liq @@ -34,5 +34,5 @@ type storage = B.t let cf (y : int) = A.af (B.bf (y + A.x)) + B.W.r -let%entry main p s = +let%entry default p s = [], B.A (cf p) diff --git a/tests/test_option.liq b/tests/test_option.liq index 0ca829db..49f60e47 100644 --- a/tests/test_option.liq +++ b/tests/test_option.liq @@ -1,7 +1,7 @@ type storage = int -let%entry main +let%entry default (parameter : int option) _storage = diff --git a/tests/test_reduce_closure.liq b/tests/test_reduce_closure.liq index 21166985..fdeb4500 100644 --- a/tests/test_reduce_closure.liq +++ b/tests/test_reduce_closure.liq @@ -3,7 +3,7 @@ type storage = int -let%entry main +let%entry default (parameter : int list) storage = diff --git a/tests/test_rev.liq b/tests/test_rev.liq index 8479f520..11e4b2b9 100644 --- a/tests/test_rev.liq +++ b/tests/test_rev.liq @@ -3,7 +3,7 @@ type storage = int list -let%entry main +let%entry default (_parameter : int) storage = let l = List.rev storage in diff --git a/tests/test_right_constr.liq b/tests/test_right_constr.liq index b06c1d4e..a01d7089 100644 --- a/tests/test_right_constr.liq +++ b/tests/test_right_constr.liq @@ -1,7 +1,7 @@ type storage = (int, string) variant -let%entry main +let%entry default (parameter : string) _storage = let a = Right parameter in diff --git a/tests/test_setreduce_closure.liq b/tests/test_setreduce_closure.liq index d2443a89..26763d5e 100644 --- a/tests/test_setreduce_closure.liq +++ b/tests/test_setreduce_closure.liq @@ -1,7 +1,7 @@ type storage = bool -let%entry main +let%entry default (parameter : tez set) _storage = diff --git a/tests/test_transfer.liq b/tests/test_transfer.liq index 51f69e57..6a4f61ed 100644 --- a/tests/test_transfer.liq +++ b/tests/test_transfer.liq @@ -4,7 +4,7 @@ type storage = tez -let%entry main +let%entry default (dest : key_hash) storage = diff --git a/tests/tst.liq b/tests/tst.liq index ebd1c764..10b54401 100644 --- a/tests/tst.liq +++ b/tests/tst.liq @@ -17,18 +17,17 @@ type storage = int (* contract type NatContract = sig * type storage - * val%entry main : nat -> _ + * val%entry default : nat * end * * contract type NatNatContract = sig * type storage - * val%entry main : nat * nat -> _ + * val%entry default : nat * nat * end *) -(* let%entry main (parameter : UnitContract.instance) storage = *) -let%entry main (_parameter : int) storage = +let%entry default (_parameter : int) storage = let g x = if x < 10p then failwith "error, element two small" in let f l = List.iter g l in diff --git a/tests/tstmod/c.liq b/tests/tstmod/c.liq index 53ad72de..410ecf57 100644 --- a/tests/tstmod/c.liq +++ b/tests/tstmod/c.liq @@ -3,5 +3,5 @@ type storage = B.t let cf (y : int) = A.af (B.bf (y + A.x)) + B.W.r -let%entry main p s = +let%entry default p s = [], B.A (cf p) diff --git a/tools/liquidity/.merlin b/tools/.merlin similarity index 72% rename from tools/liquidity/.merlin rename to tools/.merlin index 14700827..1b554f20 100644 --- a/tools/liquidity/.merlin +++ b/tools/.merlin @@ -1,6 +1,8 @@ S ./** -S ../../libs/** -B ../../_obuild/** +S ../libs/** +S ../dune-network/src/** +S ../dune-network/vendors/** +B ../_obuild/** FLG -rectypes @@ -21,4 +23,5 @@ PKG bigstring PKG easy-format PKG ocaml-migrate-parsetree PKG menhirLib -PKG zarith \ No newline at end of file +PKG zarith +PKG ezcmd \ No newline at end of file diff --git a/tools/client/build.ocp2 b/tools/client/build.ocp2 new file mode 100644 index 00000000..9364b244 --- /dev/null +++ b/tools/client/build.ocp2 @@ -0,0 +1,56 @@ + +OCaml.library("ocplib-liquidity-client-functor", + ocaml + { + files = [ + "liquidClientSigs.ml"; + "liquidClientUtils.ml"; + "liquidClientRequest.ml"; + "liquidClientTypes.ml"; + "liquidClientErrors.ml"; + "liquidClientRPCs.ml"; + "liquidClient.ml"; + ]; + requires = [ + "ocplib-liquidity-options"; + "ocplib-json-typed"; + "dune-network-lib"; + "ezjsonm"; + "curl"; + "curl.lwt"; + ]; + }); + +if ( with_dune_network ) { + +OCaml.library("ocplib-liquidity-to-michelson-client", + ocaml + { + files = [ + "lazy_superposed.ml"; + "liquidityToMichelson.ml"; + "liquidityToMichelsonClient.ml"; + ]; + requires = [ + "ocplib-liquidity-client-functor"; + "ocplib-liquidity-base"; + "ocplib-liquidity-init"; + "ocplib-liquidity-with-dune-network"; + ]; + }); + +OCaml.program("liquidity-client", + ocaml + { + bytelink = ["-cclib"; "-lsodium_stubs -lsodium"]; + files = [ + "../liquidity/liquidCommonArgs.ml"; + "liquidClientMain.ml"; + ]; + requires = [ + "ocplib-liquidity-to-michelson-client"; + "ocplib-file"; + "ocplib-liquidity-base"; + "ocplib-liquidity-init"; + "ezcmd"; + ]; + }); + +} diff --git a/tools/client/lazy_superposed.ml b/tools/client/lazy_superposed.ml new file mode 100644 index 00000000..efabe87a --- /dev/null +++ b/tools/client/lazy_superposed.ml @@ -0,0 +1,73 @@ +type 'a superposed = + | AST of 'a + | String of string + | Json of Ezjsonm.value + | ASTString of { ast : 'a; string : string } + | ASTJson of { ast : 'a; json : Ezjsonm.value } + | JsonString of { json : Ezjsonm.value; string : string } + | All of { ast : 'a; json : Ezjsonm.value; string : string } + +type 'a t = 'a superposed ref + +let ast x = ref (AST x) +let json x = ref (Json x) +let string x = ref (String x) + +module Make (C : sig + type t + val parse : string -> t + val print : t -> string + val encoding : t Json_encoding.encoding + end) = struct + + let force_ast x = + match !x with + | AST ast | ASTString { ast } | ASTJson { ast } | All { ast } -> ast + | String string -> + let ast = C.parse string in + x := ASTString { ast; string }; + ast + | Json json -> + let ast = Json_encoding.destruct C.encoding json in + x := ASTJson { ast; json }; + ast + | JsonString { json; string } -> + let ast = Json_encoding.destruct C.encoding json in + x := All { ast; json; string }; + ast + + let force_string x = + match !x with + | String string | ASTString { string } | JsonString { string } | All { string } -> string + | AST ast -> + let string = C.print ast in + x := ASTString { ast; string }; + string + | Json json -> + let ast = Json_encoding.destruct C.encoding json in + let string = C.print ast in + x := All { ast; json; string }; + string + | ASTJson { ast; json } -> + let string = C.print ast in + x := All { ast; json; string }; + string + + let force_json x = + match !x with + | Json json | ASTJson { json } | JsonString { json } | All { json } -> json + | AST ast -> + let json = Json_encoding.construct C.encoding ast in + x := ASTJson { ast; json }; + json + | String string -> + let ast = C.parse string in + let json = Json_encoding.construct C.encoding ast in + x := All { ast; json; string }; + json + | ASTString { ast; string } -> + let json = Json_encoding.construct C.encoding ast in + x := All { ast; json; string }; + json + +end diff --git a/tools/client/lazy_superposed.mli b/tools/client/lazy_superposed.mli new file mode 100644 index 00000000..b0103b8b --- /dev/null +++ b/tools/client/lazy_superposed.mli @@ -0,0 +1,18 @@ +type 'a t + +val ast : 'a -> 'a t +val json : Ezjsonm.value -> 'a t +val string : string -> 'a t + +module Make : functor + (C : sig + type t + val parse : string -> t + val print : t -> string + val encoding : t Json_encoding.encoding + end) -> +sig + val force_ast : C.t t -> C.t + val force_string : C.t t -> string + val force_json : C.t t -> Ezjsonm.value +end diff --git a/tools/client/liquidClient.ml b/tools/client/liquidClient.ml new file mode 100644 index 00000000..fb77236c --- /dev/null +++ b/tools/client/liquidClient.ml @@ -0,0 +1,839 @@ +open LiquidClientUtils +open LiquidClientRequest +open LiquidClientSigs +open Lwt.Infix +open Dune_Network_Lib (* for crypto *) + +module Make + (L : LANG) + (SourceFrom : TT) + (TargetFrom : TT) + (C : CONVERTER with type source_from_datatype := SourceFrom.datatype + and type source_from_const := SourceFrom.const + and type source_from_contract := SourceFrom.contract + and type source_dest_datatype := L.Source.datatype + and type source_dest_const := L.Source.const + and type source_dest_contract := L.Source.contract + and type target_from_datatype := TargetFrom.datatype + and type target_from_const := TargetFrom.const + and type target_from_contract := TargetFrom.contract + and type target_dest_datatype := L.Target.datatype + and type target_dest_const := L.Target.const + and type target_dest_contract := L.Target.contract) = struct + + module C = C + module L = L + module RPC = LiquidClientRPCs.Make(L) + module E = RPC.E + module T = RPC.E.T + + open L + open E + open T + open RPC + + + type liq_big_map_diff = (bm_id, Source.const) Big_map_diff.t + + let get_private_key ?private_key () = + match private_key, !LiquidOptions.private_key with + | None, None -> failwith "Missing private key" + | Some sk, _ | _, Some sk -> + match Ed25519.Secret_key.of_b58check sk with + | Ok sk -> sk + | Error _ -> + failwith "Bad private key: must be an Ed25519, \ + base58-check encoded private key of the form edsk..." + + let get_public_key ?public_key () = + match public_key, !LiquidOptions.public_key with + | Some pk, _ | _, Some pk -> pk + | None, None -> + try get_private_key () |> get_public_key_from_secret_key + with _ -> failwith "Missing public key" + + let get_source ?source () = + match source, !LiquidOptions.source with + | Some source, _ | _, Some source -> source + | None, None -> + try + let pk = match Ed25519.Public_key.of_b58check (get_public_key ()) with + | Ok pk -> pk + | Error _ -> raise Exit in + get_public_key_hash_from_public_key pk + with _ -> + try get_private_key () |> get_public_key_from_secret_key + with _ -> failwith "Missing source" + + let get_next_counter source = + match !LiquidOptions.counter with + | None -> + get_counter source >>= fun counter -> + Lwt.return (counter+1) + | Some counter -> Lwt.return counter + + let big_map_info storage storage_ty id = + Source.list_big_maps storage storage_ty + |> List.find_opt (fun ((Bm_id i | Bm_name (i, _)), _, _) -> i = id) + + let id_of_info id info = match info with + | None -> Bm_id id + | Some (id, _, _) -> id + + let convert_big_map_diff_item storage storage_ty = + let open Big_map_diff in + function + | Big_map_add { id; key_hash; key; value } -> + let info = big_map_info storage storage_ty id in + let id = id_of_info id info in + let key, value = match info with + | None -> + decompile_const key, + decompile_const value + | Some (_, tk, tv) -> + decompile_const key ~ty:tk, + decompile_const value ~ty:tv in + Big_map_add { id; key_hash; key; value } + | Big_map_remove { id; key_hash; key } -> + let info = big_map_info storage storage_ty id in + let id = id_of_info id info in + let key = match info with + | None -> decompile_const key + | Some (_, tk, _) -> decompile_const key ~ty:tk in + Big_map_remove { id; key_hash; key } + | Big_map_delete { id } -> + let info = big_map_info storage storage_ty id in + let id = id_of_info id info in + Big_map_delete { id } + | Big_map_alloc { id } -> + let info = big_map_info storage storage_ty id in + let id = id_of_info id info in + Big_map_alloc { id } + | Big_map_copy { source_id; destination_id } -> + let source_info = big_map_info storage storage_ty source_id in + let source_id = id_of_info source_id source_info in + let destination_info = big_map_info storage storage_ty destination_id in + let destination_id = id_of_info destination_id destination_info in + Big_map_copy { source_id; destination_id } + + let convert_big_map_diff storage storage_ty l = + List.map (convert_big_map_diff_item storage storage_ty) l + + (* let decode_convert_big_map_diff storage storage_ty json_opt = + * match json_opt with + * | None -> [] + * | Some json -> + * decode_big_map json + * |> convert_big_map_diff storage storage_ty *) + + let convert_manager_operation = + function + | Operation.Reveal s -> SourceOperation.Reveal s + | Delegation s -> SourceOperation.Delegation s + | Transaction {amount; destination; entrypoint; parameters = None} -> + SourceOperation.Transaction {amount; destination; entrypoint; parameters = None} + | Transaction {amount; destination; entrypoint; parameters = Some p} -> + SourceOperation.Transaction {amount; destination; entrypoint; + parameters = Some (decompile_const p)} + | Origination {delegate; script= None; balance} -> + SourceOperation.Origination {delegate; script= None; balance} + | Origination {delegate; script= Some (c, s); balance} -> + SourceOperation.Origination {delegate; balance; + script= Some (decompile_contract c, decompile_const s); } + + let convert_operation = function + | Operation.Manager m -> + SourceOperation.Manager (convert_manager_operation m) + | Activate_account { pkh; secret } -> + SourceOperation.Activate_account { pkh; secret } + + let convert_internal_operation op = + { SourceOperation.op = convert_operation op.Operation.op; + source = op.Operation.source; + nonce = op.Operation.nonce } + + let get_head ?head () = + match head with + | Some head -> Lwt.return head + | None -> get_head () + + let run_pre ?(debug=false) ?(amount = !LiquidOptions.amount) + source_contract target_contract loc_table ?source entry_name input storage = + let rpc = if debug then RPC.trace else RPC.run in + let storage_ty = Source.storage source_contract in + let input_ty = + match List.assoc_opt entry_name (Source.entries source_contract) with + | Some ty -> ty + | None -> failwith ("Contract has no entry point " ^ entry_name) in + let input = compile_const ~ty:input_ty input in + let storage = compile_const ~ty:storage_ty storage in + get_head () >>= fun head -> + let operation = Run_code.Input.{ + script = target_contract; + entrypoint = entry_name; + input; + storage; + amount; + chain_id = head.chain_id; + source; + } in + rpc ~loc_table operation + >>= fun Run_code.Result.{ storage ; operations; big_map_diff; trace } -> + let storage = decompile_const ~ty:storage_ty storage in + let big_map_diff = convert_big_map_diff storage storage_ty big_map_diff in + let operations = List.map convert_internal_operation operations in + let trace = match trace with + | None -> None + | Some trace -> Some (E.convert_trace ~loc_table trace) in + Lwt.return (operations, storage, big_map_diff, trace) + + let run ~debug ?source ?amount contract entry_name parameter storage = + let source = get_source ?source () in + let target_contract, _, loc_table = compile_contract contract in + run_pre ~debug contract + target_contract loc_table ~source entry_name parameter storage + + let run_debug ?source ?amount liquid entry_name input storage = + run ~debug:true ?source liquid entry_name input storage + >>= function + | (nbops, sto, big_diff, Some trace) -> + Lwt.return (nbops, sto, big_diff, trace) + | _ -> assert false + + let run ?source ?amount liquid entry_name input storage = + run ~debug:false ?source liquid entry_name input storage + >>= fun (nbops, sto, big_diff, _) -> + Lwt.return (nbops, sto, big_diff) + + let get_storage contract address = + let _ = compile_contract contract in + RPC.get_storage address >|= fun storage -> + try decompile_const storage ~ty:(Source.storage contract) + with _ -> + Format.eprintf "Could not convert constant to contract storage type.@."; + decompile_const storage + + let get_big_map_value big_map_info key = + let ((Bm_id id | Bm_name (id, _)), key_ty, val_ty) = big_map_info in + let key_t = compile_const ~ty:key_ty key in + let ty = compile_datatype key_ty in + RPC.pack ~data:key_t ~ty >>= fun packed_key -> + let hash_key_b58 = + ExprHash.hash_bytes [Bigstring.of_bytes packed_key] + |> ExprHash.to_b58check in + RPC.get_big_map_hash_value id hash_key_b58 >|= function + | None -> None + | Some expr -> + try Some (decompile_const expr ~ty:val_ty) + with _ -> + Format.eprintf "Could not convert constant to value type.@."; + Some (decompile_const expr) + + + let is_revealed source = + RPC.get_manager_key source >|= function + | None -> false + | Some _ -> true + + + let big_map_elements id big_map_diff = + let open Big_map_diff in + List.fold_left (fun acc -> function + | Big_map_add { id = (Bm_id i | Bm_name (i, _)); key; value } when id = i -> + (key, value) :: acc + | _ -> acc + ) [] big_map_diff |> List.rev + + let build_big_map_subst const const_ty big_map_diff = + let open Big_map_diff in + Source.list_big_maps const const_ty |> + List.map (fun ((Bm_id i | Bm_name (i, _)), _, _) -> + i, big_map_elements i big_map_diff + ) + + let replace_init_big_maps big_map_diff storage storage_ty = + Source.apply_big_map_subst + (build_big_map_subst storage storage_ty big_map_diff) + storage + + + let init_storage ?source contract comp_init init_params = + let source = + try Some (get_source ?source ()) + with _ -> None in + match comp_init, init_params with + | No_init, [c] + | Init_constant c, [] -> Lwt.return c + + | No_init, [] -> + raise (ResponseError "init_storage: Missing init") + | No_init, _ -> + raise (ResponseError "init_storage: No initializer, cannot take arguments") + | Init_constant _, _ -> + raise (ResponseError "init_storage: Constant initializer, cannot take arguments") + + | Init_code (c, args_tys), _ -> + let l_req, l_giv = List.length args_tys, List.length init_params in + if l_req <> l_giv then + raise + (ResponseError + (Printf.sprintf + "init_storage: init storage needs %d arguments, but was given %d" + l_req l_giv + )); + let eval_input_storage = + try + Source.default_empty_const (Source.storage contract) + with Not_found -> failwith "could not construct dummy storage for eval" + in + let eval_input_parameter = match init_params with + | [] -> Source.unit + | [x] -> x + | _ -> Source.tuple init_params + in + + let ct, _, loc_table = compile_contract c in + run_pre c ct loc_table ?source "default" + eval_input_parameter eval_input_storage + >>= fun (_, eval_init_storage, big_map_diff, _) -> + (* Add elements of big map *) + let eval_init_storage = + replace_init_big_maps big_map_diff eval_init_storage (Source.storage contract) in + Lwt.return eval_init_storage + + + let estimate_gas_storage ~loc_table ?head operation = + get_head ?head () >>= fun head -> + let open Run_operation in + RPC.run_operation ~loc_table ~chain_id:head.Header.chain_id operation + >>= fun { Result.contents } -> + let (_, metadata) as res = match contents with + | [ (Operation.Manager { op = Reveal _ }, _) ; y ] -> y + | [ y ] -> y + | _ -> invalid_arg "estimate_gas_storage" in + let extract_consumed = function + | Result.Failed errors -> Lwt.return_error ("failed", errors) + | Backtracked (errors, _) -> Lwt.return_error ("backtracked", errors) + | Skipped -> Lwt.return_error ("skipped", []) + | Other json -> + Lwt.return_error + ("unexpected node response metadata for run_operation", [json]) + | Applied res -> + let allocated = List.length res.originated_contracts + + if res.allocated_destination_contract then 1 else 0 in + let consumed_storage = allocated * 257 + res.paid_storage_size_diff in + Lwt.return_ok (res.consumed_gas, consumed_storage) + in + extract_consumed metadata.Result.operation_result + >>= fun res -> + Lwt_list.fold_left_s (fun acc (_, internal_result) -> + extract_consumed internal_result + >>= function + | Error (int_st, internal_errs) -> (match acc with + | Error (st, errs) -> Lwt.return_error (String.concat "/" [st; int_st], + errs @ internal_errs) + | Ok _ -> Lwt.return_error (int_st, internal_errs) + ) + | Ok (internal_gas, internal_storage) -> match acc with + | Error errs -> Lwt.return_error errs + | Ok (gas, storage) -> + Lwt.return_ok (gas + internal_gas, storage + internal_storage) + ) + res + metadata.Result.internal_operation_results + >>= function + | Error (st, errs) -> + raise_response_error ~loc_table st + (`A (List.map Json_repr.from_any errs)) + | Ok (consumed_gas, consumed_storage) -> + Format.eprintf "Estimated gas limit:\t %d\nEstimated storage limit: %d@." + consumed_gas consumed_storage; + Lwt.return (consumed_gas, consumed_storage) + + let rec forge_op ?head ?source ?public_key + ?fee ?gas_limit ?storage_limit ?real_op_size + ~loc_table op = + let source = get_source ?source () in + get_head ?head () >>= fun head -> + RPC.get_constants () + >>= fun Constants.{ hard_gas_limit_per_operation; hard_storage_limit_per_operation } -> + get_next_counter source >>= fun counter -> + is_revealed source >>= fun source_revealed -> + let storage_limit = match storage_limit with + | Some l -> l + | None -> hard_storage_limit_per_operation in + let gas_limit = match gas_limit with + | Some l -> l + | None -> hard_gas_limit_per_operation in + let computed_fee = match real_op_size with + | None -> Z.zero + | Some size -> + let gas_limit = + if source_revealed then gas_limit else gas_limit + 10000 in + compute_fees ~gas_limit ~size + in + let computed_fee = match fee with + | None -> LiquidNumber.tez_of_mic_mutez computed_fee + | Some fee when Z.compare (LiquidNumber.mic_mutez_of_tez fee) computed_fee < 0 -> + Format.kasprintf failwith + "Fee too low, operation would never be included: given %s, but required \ + at least %s in fee." + LiquidNumber.(liq_of_tez fee) + LiquidNumber.(liq_of_tez @@ tez_of_mic_mutez computed_fee) + | Some fee -> fee in + let operation counter = Operation.(Manager { + source; + fee = computed_fee; + counter; gas_limit; storage_limit; + op; + }) in + let operations = + if source_revealed then + [operation counter] + else + let edpk = get_public_key ?public_key () in + let reveal = Operation.(Manager { + source; + fee = {tezzies = "0"; mutez = None}; + counter; + gas_limit = 1_0000; + storage_limit = 0; + op = Reveal edpk; + }) in + [reveal; operation (counter + 1)] + in + let data = Operation.{ + branch = head.Header.hash; + contents = operations; + signature = if real_op_size = None then Some dummy_sign else None + } in + match real_op_size with + | None -> + Lwt.return (data, None, loc_table) + | Some size -> + RPC.forge_operation ~loc_table data >>= fun op_bytes -> + let actual_size = Bytes.length op_bytes + 64 in + if actual_size <= size then begin + Format.eprintf "Computed fee:\t\t %s%s@." + (LiquidNumber.liq_of_tez computed_fee) + (LiquidOptions.curreny ()); + Lwt.return (data, Some op_bytes, loc_table) + end else + (* Fix point to estimate size of operation which depends on fees + which depends on size of operation *rolleyes* *) + forge_op ~head ~source ?public_key ~real_op_size:actual_size + ?fee ~gas_limit ~storage_limit + ~loc_table op + + let forge_deploy_op ?head ?source ?public_key ?(balance = !LiquidOptions.amount) + ?fee ?gas_limit ?storage_limit ?real_op_size + contract init_params = + let target_contract, comp_init, loc_table = compile_contract contract in + init_storage ?source contract comp_init init_params >>= fun init_storage -> + let init_storage = + compile_const ~ty:(Source.storage contract) init_storage in + let op = Operation.(Origination { + delegate = None; + balance ; + script = Some (target_contract, init_storage); + }) in + forge_op ?head ?source ?public_key + ?fee ?gas_limit ?storage_limit ?real_op_size + ~loc_table op + + let forge_deploy ?head ?source ?public_key ?balance + contract init_params = + forge_deploy_op ?head ?source ?public_key ?balance + contract init_params >>= fun (operation, _, loc_table) -> + estimate_gas_storage ~loc_table ?head operation >>= fun (est_gas_limit, est_storage_limit) -> + let gas_limit = match !LiquidOptions.gas_limit with + | None -> est_gas_limit + | Some l when l < est_gas_limit -> + failwith (Printf.sprintf "Gas limit below estimated (%d)" est_gas_limit) + | Some l -> l in + let storage_limit = match !LiquidOptions.storage_limit with + | None -> est_storage_limit + | Some l when l < est_storage_limit -> + failwith (Printf.sprintf "Storage limit below estimated (%d)" + est_storage_limit) + | Some l -> l in + forge_deploy_op ?head ?source ?public_key ?balance ~real_op_size:0 + ?fee:!LiquidOptions.fee ~gas_limit ~storage_limit + contract init_params + >|= function + | _, None, _ -> assert false + | (operation, Some op, loc_table) -> + (operation, op, loc_table) + + let inject_operation ?(force=false) ?loc_table ?sk ?head operations op_b = + get_head ?head () >>= fun head -> + let signed_op, op_hash, operation = match sk with + | None -> + let op_hash = + Operation_hash.to_b58check @@ + Operation_hash.hash_bytes [ MBytes.of_bytes op_b ] in + op_b, op_hash, + Operation.{ + branch = head.Header.hash; + contents = operations; + signature = None; + } + | Some sk -> + let op_b = MBytes.of_bytes op_b in + let signature_b = sign sk op_b in + let signature = Ed25519.Signature.to_b58check signature_b in + let signed_op_b = MBytes.concat "" [op_b; signature_b] in + let op_hash = + Operation_hash.to_b58check @@ + Operation_hash.hash_bytes [ signed_op_b ] in + MBytes.to_bytes signed_op_b, op_hash, + Operation.{ + branch = head.Header.hash; + contents = operations; + signature = Some signature; + } + in + RPC.preapply_operations ?loc_table ~protocol:head.Header.protocol [operation] + >>= function + | [] | _ :: _ :: _ -> assert false + | [{ Run_operation.Result.contents }] -> + Lwt_list.map_p (fun (content, metadata) -> + match content with + | Operation.Activate_account _ -> + Lwt.return [] + | _ -> match metadata.Run_operation.Result.operation_result with + | Run_operation.Result.Failed _ | Backtracked _ | Skipped + when force -> + (* Allow injection even if there is an error *) + Format.eprintf "Warning: injecting failing operation@."; + Lwt.return [] + | Run_operation.Result.Failed errors + | Backtracked (errors, _) -> + raise_response_error ?loc_table "failed" + (`A (List.map Json_repr.from_any errors)) + | Skipped -> raise_response_error ?loc_table "skipped" (`A []) + | Applied { originated_contracts } -> + Lwt.return originated_contracts + | Other json -> + raise_response_error ?loc_table + "unexpected node response for preapply_operations" + (`A [Json_repr.from_any json]) + ) contents + >>= fun originated_contracts -> + let originated_contracts = List.flatten originated_contracts in + RPC.injection ?loc_table signed_op >>= fun injected_op_hash -> + assert (injected_op_hash = op_hash); + Lwt.return (injected_op_hash, originated_contracts) + + + let deploy ?balance contract init_params = + let sk = get_private_key () in + let source = get_source () in + let public_key = get_public_key_from_secret_key sk in + get_head () >>= fun head -> + forge_deploy ~head ~source ~public_key ?balance + contract init_params + >>= fun (op, op_bytes, loc_table) -> + inject_operation ~loc_table ~sk ~head op.Operation.contents op_bytes >>= function + | op_h, [c] -> Lwt.return (op_h, c) + | op_h, [_; c] -> Lwt.return (op_h, c) (* with revelation *) + | _ -> raise (ResponseError "deploy (inject)") + + let rec forge_call_op ?head ?source ?public_key ?(amount = !LiquidOptions.amount) + ?fee ?gas_limit ?storage_limit ?real_op_size + ~loc_table address ?contract entry_name input = + let input_ty = match contract with + | None -> None + | Some c -> match List.assoc_opt entry_name (Source.entries c) with + | None -> failwith ("Contract has no entry point " ^ entry_name) + | ty -> ty in + let input_t = compile_const ?ty:input_ty input in + let op = Operation.(Transaction { + amount; + destination = address; + entrypoint = entry_name; + parameters = Some input_t; + }) in + forge_op ?head ?source ?public_key + ?fee ?gas_limit ?storage_limit ?real_op_size + ~loc_table op + + let forge_call ?head ?source ?public_key ?amount + ?contract ~address ~entry input = + let loc_table = match contract with + | None -> [] + | Some contract -> + let _, _, l = compile_contract contract in l + in + forge_call_op ?head ?source ?public_key ?amount ~loc_table ?contract + address entry input >>= fun (operation, _, loc_table) -> + estimate_gas_storage ~loc_table ?head operation >>= fun (est_gas_limit, est_storage_limit) -> + let gas_limit = match !LiquidOptions.gas_limit with + | None -> est_gas_limit + | Some l when l < est_gas_limit -> + failwith (Printf.sprintf "Gas limit below estimated (%d)" est_gas_limit) + | Some l -> l in + let storage_limit = match !LiquidOptions.storage_limit with + | None -> est_storage_limit + | Some l when l < est_storage_limit -> + failwith (Printf.sprintf "Storage limit below estimated (%d)" + est_storage_limit) + | Some l -> l in + forge_call_op ?head ?source ?public_key ?amount ~loc_table ?contract ~real_op_size:0 + ?fee:!LiquidOptions.fee ~gas_limit ~storage_limit + address entry input + >|= function + | _, None, _ -> assert false + | (operation, Some op, loc_table) -> + (operation, op, loc_table) + + let call ?contract ?amount ~address ~entry parameter = + let sk = get_private_key () in + let source = get_source () in + let public_key = get_public_key_from_secret_key sk in + get_head () >>= fun head -> + forge_call ~head ~source ~public_key ?amount + ?contract ~address ~entry parameter + >>= fun (op, op_bytes, loc_table) -> + inject_operation ~loc_table ~sk ~head op.Operation.contents op_bytes + >|= fun (op_h, _) -> op_h + + + let reveal () = + let sk = get_private_key () in + let source = get_source () in + let public_key = get_public_key_from_secret_key sk in + get_head () >>= fun head -> + get_next_counter source >>= fun counter -> + let reveal = Operation.(Manager { + source; + fee = {tezzies = "0"; mutez = None}; + counter; + gas_limit = 1_0000; + storage_limit = 0; + op = Reveal public_key; + }) + in + let data = Operation.{ + branch = head.Header.hash; + contents = [reveal]; + signature = None + } in + RPC.forge_operation data >>= fun op -> + inject_operation ~sk ~head data.contents op >>= fun _ -> + Lwt.return_unit + + let activate ~secret = + let sk = get_private_key () in + let source = get_source () in + get_head () >>= fun head -> + let activate = Operation.(Activate_account { pkh = source; secret }) in + let data = Operation.{ + branch = head.Header.hash; + contents = [activate]; + signature = None + } in + RPC.forge_operation data >>= fun op -> + inject_operation ~sk ~head data.contents op >|= fun (op_h, _) -> + op_h + + let inject ~operation ~signature = + let signature = + match Ed25519.Signature.of_b58check signature with + | Error _ -> failwith "Cannot decode signature (must be valid edsig...)" + | Ok s -> MBytes.to_bytes s in + RPC.injection (Bytes.cat operation signature) + + let init_storage ?source contract init_params = + let _, comp_init, _ = compile_contract contract in + init_storage ?source contract comp_init init_params + >|= compile_const ~ty:(Source.storage contract) + + let pack ~const ~ty = + let const = compile_const ~ty const in + let ty = compile_datatype ty in + RPC.pack ~data:const ~ty + + let print_big_map_diff_item = + let open Big_map_diff in + function + | Big_map_add { id; key_hash; key; value } -> + let key = C.SourceConv.print_const key in + let value = C.SourceConv.print_const value in + Big_map_add { id; key_hash; key; value } + | Big_map_remove { id; key_hash; key } -> + let key = C.SourceConv.print_const key in + Big_map_remove { id; key_hash; key } + | Big_map_delete { id } -> + Big_map_delete { id } + | Big_map_alloc { id } -> + Big_map_alloc { id } + | Big_map_copy { source_id; destination_id } -> + Big_map_copy { source_id; destination_id } + + let print_big_map_diff l = + List.map print_big_map_diff_item l + + let print_stack stack_expr = + List.map (fun (e, annot) -> + let name = name_of_var_annot annot in + C.SourceConv.print_const e, name + ) stack_expr + + let print_trace t = + List.map (fun T.Trace.{ loc; gas; stack } -> + let stack = print_stack stack in + T.Trace.{ loc; gas; stack } + ) t + + module type S = sig + type 'a t + val init_storage : + ?source:string -> + SourceFrom.contract -> + SourceFrom.const list -> TargetFrom.const t + val run : + ?amount : LiquidNumber.tez -> + SourceFrom.contract -> + string -> + SourceFrom.const -> + SourceFrom.const -> + (SourceOperation.internal list * SourceFrom.const * + (LiquidClientSigs.bm_id, SourceFrom.const) T.Big_map_diff.item + list) + t + val run_debug : + ?amount : LiquidNumber.tez -> + SourceFrom.contract -> + string -> + SourceFrom.const -> + SourceFrom.const -> + (SourceOperation.internal list * SourceFrom.const * + (LiquidClientSigs.bm_id, SourceFrom.const) Big_map_diff.item + list * + (L.Source.location, SourceFrom.const) Trace.trace_item list) + t + val deploy : + ?balance : LiquidNumber.tez -> + SourceFrom.contract -> + SourceFrom.const list -> (string * string) t + val get_storage : + SourceFrom.contract -> string -> SourceFrom.const t + val get_big_map_value : + LiquidClientSigs.bm_id * Source.datatype * Source.datatype -> + SourceFrom.const -> SourceFrom.const option t + val call : + ?contract:SourceFrom.contract -> + ?amount : LiquidNumber.tez -> + address:string -> entry:string -> SourceFrom.const -> string t + val activate : secret:string -> string t + val inject : operation:bytes -> signature:string -> string t + val pack : + const:SourceFrom.const -> ty:SourceFrom.datatype -> bytes t + val forge_deploy : + ?head:Header.t -> + ?source:string -> + ?public_key:string -> + ?balance : LiquidNumber.tez -> + SourceFrom.contract -> SourceFrom.const list -> bytes t + val forge_call : + ?head:Header.t -> + ?source:string -> + ?public_key:string -> + ?contract:SourceFrom.contract -> + ?amount : LiquidNumber.tez -> + address:string -> entry:string -> SourceFrom.const -> bytes t + end + + (* Withoud optional argument head *) + module Async : S with type 'a t := 'a Lwt.t = struct + + let init_storage ?source contract args = + let contract = C.SourceConv.parse_contract contract in + let args = List.map C.SourceConv.parse_const args in + init_storage ?source contract args + >|= fun storage -> + C.TargetConv.print_const storage + + let run ?amount contract entry_name input storage = + let contract = C.SourceConv.parse_contract contract in + let input = C.SourceConv.parse_const input in + let storage = C.SourceConv.parse_const storage in + run ?amount contract entry_name input storage + >|= fun (ops, storage, bm) -> + (ops, C.SourceConv.print_const storage, print_big_map_diff bm) + + let run_debug ?amount contract entry_name input storage = + let contract = C.SourceConv.parse_contract contract in + let input = C.SourceConv.parse_const input in + let storage = C.SourceConv.parse_const storage in + run_debug ?amount contract entry_name input storage + >|= fun (ops, storage, bm, trace) -> + (ops, C.SourceConv.print_const storage, print_big_map_diff bm, print_trace trace) + + let deploy ?balance contract args = + let contract = C.SourceConv.parse_contract contract in + let args = List.map C.SourceConv.parse_const args in + deploy ?balance contract args + + let get_storage contract address = + let contract = C.SourceConv.parse_contract contract in + get_storage contract address + >|= fun storage -> + C.SourceConv.print_const storage + + let get_big_map_value id key = + let key = C.SourceConv.parse_const key in + get_big_map_value id key + >|= function + | None -> None + | Some v -> Some (C.SourceConv.print_const v) + + let call ?contract ?amount ~address ~entry parameter = + let contract = match contract with + | None -> None + | Some c -> Some (C.SourceConv.parse_contract c) in + let parameter = C.SourceConv.parse_const parameter in + call ?contract ?amount ~address ~entry parameter + + let activate = activate + let inject = inject + let pack ~const ~ty = + let ty = C.SourceConv.parse_datatype ty in + let const = C.SourceConv.parse_const const in + pack ~const ~ty + + let forge_deploy ?head ?source ?public_key ?balance contract args = + let contract = C.SourceConv.parse_contract contract in + let args = List.map C.SourceConv.parse_const args in + forge_deploy ?head ?source ?public_key ?balance contract args + >>= fun (_, op, _) -> Lwt.return op + + let forge_call ?head ?source ?public_key ?contract ?amount ~address ~entry parameter = + let contract = match contract with + | None -> None + | Some c -> Some (C.SourceConv.parse_contract c) in + let parameter = C.SourceConv.parse_const parameter in + forge_call ?head ?source ?public_key ?contract ?amount ~address ~entry parameter + >>= fun (_, op, _) -> Lwt.return op + end + + module Sync : S with type 'a t := 'a = struct + let init_storage ?source a b = Lwt_main.run @@ Async.init_storage ?source a b + let forge_deploy ?head ?source ?public_key ?balance a b = + Lwt_main.run @@ Async.forge_deploy ?head ?source ?public_key ?balance a b + let forge_call ?head ?source ?public_key ?contract ?amount ~address ~entry d = + Lwt_main.run @@ Async.forge_call ?head ?source ?public_key ?contract ?amount ~address ~entry d + let run ?amount a b c d = Lwt_main.run @@ Async.run ?amount a b c d + let run_debug ?amount a b c d = Lwt_main.run @@ Async.run_debug ?amount a b c d + let deploy ?balance a b = Lwt_main.run @@ Async.deploy ?balance a b + let get_storage a b = Lwt_main.run @@ Async.get_storage a b + let get_big_map_value b c = Lwt_main.run @@ Async.get_big_map_value b c + let call ?contract ?amount ~address ~entry d = Lwt_main.run @@ Async.call ?contract ?amount ~address ~entry d + let activate ~secret = Lwt_main.run @@ Async.activate ~secret + let inject ~operation ~signature = + Lwt_main.run @@ Async.inject ~operation ~signature + let pack ~const ~ty = Lwt_main.run @@ Async.pack ~const ~ty + end + +end diff --git a/tools/client/liquidClientErrors.ml b/tools/client/liquidClientErrors.ml new file mode 100644 index 00000000..0e06190c --- /dev/null +++ b/tools/client/liquidClientErrors.ml @@ -0,0 +1,246 @@ +open LiquidClientUtils +open LiquidClientRequest +open LiquidClientSigs +open Lwt.Infix + +module Make (L : LANG) = struct + open L + module T = LiquidClientTypes.Make(L) + + type error = Source.location * string + type trace = (Source.location, Source.const) T.Trace.t + + exception RuntimeError of error * trace option + exception LocalizedError of error + exception RuntimeFailure of error * Source.const option * trace option + + let name_of_var_annot = function + | None -> None + | Some annot -> + try Scanf.sscanf annot "@%s" (function + | "" -> None + | s -> Some s + ) + with Scanf.Scan_failure _ | End_of_file -> None + + let convert_stack stack_expr = + List.(rev @@ rev_map (fun (e, annot) -> + let name = name_of_var_annot annot in + decompile_const e, name + ) stack_expr) + + let convert_trace ~loc_table t = + List.(rev @@ rev_map (fun T.Trace.{ loc; gas; stack } -> + let loc = match loc with + | None -> None + | Some loc -> match List.assoc_opt loc loc_table with + | Some (loc, _) -> Some loc + | None -> None + in + let stack = convert_stack stack in + T.Trace.{ loc; gas; stack } + ) t) + + let trace_of_json ~loc_table ?(error=false) trace_r = + let trace_expr = + Json_encoding.destruct + (T.Trace.encoding Target.loc_encoding Target.const_encoding) trace_r in + let trace_expr = match List.rev trace_expr with + | (T.Trace.{loc = Some l ; gas; _} :: _) as rtrace_expr when error -> + let extra = T.Trace.{loc = Some (Target.next_loc l); gas; stack = []} in + List.rev (extra :: rtrace_expr) + | _ -> trace_expr in + convert_trace ~loc_table trace_expr + + + let fail_of_err loc ~loc_table err = + let json = Ezjsonm.find err ["with"] in + let err_loc, _ (* failwith_ty *) = List.assoc loc loc_table in + let failed_with_expr = Json_encoding.destruct Target.const_encoding json in + let failed_with = decompile_const failed_with_expr in + err_loc, Some failed_with + + let error_trace_of_err loc ~loc_table err = + let err_loc, _ = List.assoc loc loc_table in + try + let json = Ezjsonm.find err ["trace"] in + let trace = trace_of_json ~loc_table ~error:true json in + err_loc, Some trace + with Not_found -> err_loc, None + + let raise_error_from_l ?loc_table err_msg l = + let default_error () = + let last_descr = match List.rev l with + | (_, _, _, _, Some descr, _) :: _ -> "\n " ^ descr + | _ -> "" + in + let err_l = + List.map (fun (kind, id, _, title, descr, _) -> + match title with + | Some t -> t + | None -> Printf.sprintf "%s: %s" kind id + ) l + |> String.concat "\n- " + in + Printf.sprintf "in %s\n- %s%s" err_msg err_l last_descr + in + match loc_table with + | None -> raise (ResponseError (default_error ())) + | Some loc_table -> + let err_msg = Printf.sprintf "in %s" err_msg in + try + List.iter (fun (kind, id, loc, title, descr, err) -> + let is_rejected = + match String.rindex_opt id '.' with + | None -> false + | Some i -> + match String.sub id i (String.length id - i) with + | ".script_rejected" | ".scriptRejectedRuntimeError" -> true + | _ -> false + in + match loc, kind, is_rejected with + | Some loc, "temporary", true -> + let err_loc, fail_v = fail_of_err loc ~loc_table err in + let _, trace = error_trace_of_err loc ~loc_table err in + raise (RuntimeFailure ((err_loc, err_msg), fail_v, trace)) + | Some loc, "temporary", _ -> + let title = match title with Some t -> t | None -> id in + let err_msg = String.concat "\n- " [err_msg; title] in + let err_loc, trace = error_trace_of_err loc ~loc_table err in + raise (RuntimeError ((err_loc, err_msg), trace)) + | Some loc, _, _ -> + let err_loc, _ = List.assoc loc loc_table in + let err_msg = default_error () in + raise (LocalizedError (err_loc, err_msg)) + | _ -> () + ) l; + raise (ResponseError (default_error ())) + with Not_found -> raise (ResponseError (default_error ())) + + let extract_errors_from_json r schema = + try + let schema_l = Ezjsonm.find schema ["oneOf"] in + try + Ezjsonm.find r ["error"], schema_l + with Not_found -> + match Ezjsonm.get_list (fun x -> x) r with + | err :: _ -> + begin try + let r = Ezjsonm.find err ["ecoproto"] in + let id = Ezjsonm.find err ["id"] |> Ezjsonm.get_string in + let schema_l = + schema_l + |> Ezjsonm.get_list (fun s -> + try + let s_id = + Ezjsonm.find s ["properties"; "id"; "enum"] + |> Ezjsonm.get_list Ezjsonm.get_string + |> function [s] -> s | _ -> assert false + in + if s_id <> id then + None + else + Some (Ezjsonm.find s + ["properties"; "ecoproto"; "items"; "oneOf"]) + with Not_found -> None + ) + |> List.find (function None -> false | Some _ -> true) + |> function None -> assert false | Some s -> s + in + r, schema_l + with Not_found -> r, schema_l + end + | [] -> r, schema_l + | exception Ezjsonm.Parse_error _ -> r, schema_l + with Not_found -> r, schema + + let rec descr_of_id id schema = + try + schema + |> Ezjsonm.get_list (fun s -> + try + let schema = Ezjsonm.find s ["oneOf"] in + descr_of_id id schema + with Not_found -> + try + let s_id = + Ezjsonm.find s ["properties"; "id"; "enum"] + |> Ezjsonm.get_list Ezjsonm.get_string + |> function [s] -> s | _ -> assert false + in + if s_id <> id then + None, None + else ( + let t = + try Some (Ezjsonm.find s ["title"] |> Ezjsonm.get_string) + with Not_found -> None + in + let d = + try Some (Ezjsonm.find s ["description"] |> Ezjsonm.get_string) + with Not_found -> None + in + (t, d) + ) + with Not_found -> + None, None + ) + |> List.find (function Some _, _ | _, Some _ -> true | _ -> false) + with Not_found | Ezjsonm.Parse_error _ -> + None, None + + (* + let error_encoding = + let open Json_encoding in + union [ + case_ignore_extra + (obj2 + (req "kind" (constant "generic")) + (req "error" string)) + (fun _ -> None) + (fun ((), err) -> raise (ResponseError err)); + + case_ignore_extra + (obj6 + (req "kind" string) + (req "id" string) + (opt "location" Target.loc_encoding) + (opt "loc" Target.loc_encoding) + (opt "with" any_value) + (opt "trace" any_value) + ) + (fun (kind, id, loc, fail_with_json, trace_json) -> + Some (kind, id, loc, None, fail_with_json, trace_json)) + (fun (kind, id, location, loc, fail_with_json, trace_json) -> + let loc = match location with None -> loc | Some _ as l -> l in + (kind, id, loc, fail_with_json, trace_json)); + ] + *) + + let raise_response_error ?loc_table msg r = + Lazy.force error_schema >>= fun error_schema -> + let err, schema = extract_errors_from_json r error_schema in + let l = + try + Ezjsonm.get_list (fun err -> + let kind = Ezjsonm.find err ["kind"] |> Ezjsonm.get_string in + if kind = "generic" then begin + let err = Ezjsonm.find err ["error"] |> Ezjsonm.get_string in + raise (ResponseError err) + end; + let id = Ezjsonm.find err ["id"] |> Ezjsonm.get_string in + let title, descr = descr_of_id id schema in + let loc = + try Some (Ezjsonm.find err ["location"] + |> Json_encoding.destruct Target.loc_encoding) + with Not_found -> + try Some (Ezjsonm.find err ["loc"] + |> Json_encoding.destruct Target.loc_encoding) + with Not_found -> None + in + kind, id, loc, title, descr, err + ) err + with Ezjsonm.Parse_error _ | Not_found -> [] + in + raise_error_from_l ?loc_table msg l + +end diff --git a/tools/client/liquidClientMain.ml b/tools/client/liquidClientMain.ml new file mode 100644 index 00000000..89d72ab0 --- /dev/null +++ b/tools/client/liquidClientMain.ml @@ -0,0 +1,714 @@ +(****************************************************************************) +(* Liquidity *) +(* *) +(* Copyright (C) 2017-2019 OCamlPro SAS *) +(* *) +(* Authors: Fabrice Le Fessant *) +(* Alain Mebsout *) +(* David Declerck *) +(* *) +(* This program is free software: you can redistribute it and/or modify *) +(* it under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 3 of the License, or *) +(* (at your option) any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU General Public License *) +(* along with this program. If not, see . *) +(****************************************************************************) + +open LiquidTypes +open LiquidClientSigs +module Client = LiquidityToMichelsonClient.String +module ClientJson = LiquidityToMichelsonClient.SJson +open Ezcmd.Modules + +exception Bad_arg + +let report_err ?(kind="Error") fmt (err_loc, err_msg) = + Format.fprintf fmt "%a: %s: @[%s@]\n%!" Client.L.Source.print_loc err_loc kind err_msg + +let report_error = function + | LiquidError error -> + report_err Format.err_formatter (error.err_loc, error.err_msg); + | LiquidNamespace.Unknown_namespace (p, err_loc) as exn -> + let backtrace = Printexc.get_backtrace () in + Format.eprintf "Error: %s\nBacktrace:\n%s@." + (Printexc.to_string exn) backtrace ; + report_err Format.err_formatter + (err_loc, + Printf.sprintf "Unknown module or contract %s" (String.concat "." p)); + | LiquidFromMicheline.Missing_program_field f -> + Format.eprintf "Missing script field %s@." f; + | LiquidClientRequest.RequestError (code, msg) -> + Format.eprintf "Request Error (code %d):\n%s@." code msg; + | LiquidClientRequest.ResponseError msg -> + Format.eprintf "Response Error:\n%s@." msg; + | Client.E.RuntimeError (error, _trace) -> + report_err ~kind:"Runtime error" Format.err_formatter error; + | Client.E.LocalizedError error -> + report_err ~kind:"Error" Format.err_formatter error; + | Client.E.RuntimeFailure (error, None, _trace) -> + report_err ~kind:"Failed at runtime" Format.err_formatter error; + | Client.E.RuntimeFailure (error, Some v, _trace) -> + report_err ~kind:"Failed at runtime" Format.err_formatter error; + Format.eprintf "Failed with %s@." (Client.C.SourceConv.print_const v); + | Failure f -> + Format.eprintf "Failure: %s@." f + | Syntaxerr.Error (Syntaxerr.Other loc) -> + report_err ~kind:"Syntax error" Format.err_formatter + (LiquidLoc.loc_of_location loc, "unknown"); + | exn -> + let backtrace = Printexc.get_backtrace () in + Format.eprintf "Error: %s\nBacktrace:\n%s@." + (Printexc.to_string exn) backtrace + + +module Data = struct + + let files = ref [] + let parameter = ref "" + let storage = ref "" + let entry_name = ref "default" + let ty = ref "" + let const = ref "" + + let contract_address = ref "" + let init_inputs = ref [] + + let get_files () = !files + + let get_inputs () = !init_inputs + + let validate_contract_addr s = + if String.length s <> 36 || + (String.sub s 0 3 <> "KT1" && + let pref = String.sub s 0 2 in + pref <> "tz" && pref <> "dn") + then + failwith (s ^ " is not a valid contract address") + + let validate_key_hash s = + if String.length s <> 36 || + let pref = String.sub s 0 2 in + pref <> "tz" && pref <> "dn" then + failwith (s ^ " is not a valid key hash") + + let validate_private_key s = + if ((String.length s <> 54 && String.length s <> 55) || + let p = String.sub s 0 4 in + p <> "edsk" && p <> "spsk" && p <> "p2sk") then + failwith (s ^ " is not a valid private key") + + let validate_public_key s = + if ((String.length s <> 54 && String.length s <> 55) || + let p = String.sub s 0 4 in + p <> "edpk" && p <> "sppk" && p <> "p2pk") then + failwith (s ^ " is not a valid public key") +end + + +let inject file = + let signature = match !LiquidOptions.signature with + | None -> + Printf.eprintf "Error: missing --signature option for --inject\n%!"; + exit 2 + | Some signature -> signature + in + (* an hexa encoded operation *) + let operation = FileString.read_file file in + let op_h = Client.Sync.inject + ~operation:(Hex.to_bytes (`Hex operation)) + ~signature in + Printf.printf "Operation injected: %s\n%!" op_h + +let run () = + let open Client in + let ops, r_storage, big_map_diff = + Sync.run (LiquidityToMichelson.From_files (Data.get_files ())) + !Data.entry_name !Data.parameter !Data.storage + in + Printf.printf "%s\n# Internal operations: %d\n%!" + r_storage + (List.length ops); + match big_map_diff with + | [] -> () + | diff -> + let open Client.T in + let open Client.T.Big_map_diff in + Printf.printf "\nBig map diff:\n"; + let pp_id fmt = function + | Bm_id id -> Format.fprintf fmt "[ID: %d]" id + | Bm_name (id, name) -> Format.fprintf fmt "[%s (%d)]" name id in + List.iter (fun item -> + match item with + | Big_map_add { id; key; value } -> + Format.printf "%a + %s --> %s\n" pp_id id key value + | Big_map_remove { id; key } -> + Format.printf "%a - %s\n" pp_id id key + | Big_map_delete { id } -> + Format.printf "%a DELETE\n" pp_id id + | Big_map_alloc { id } -> + Format.printf "%a ALLOC\n" pp_id id + | Big_map_copy { source_id; destination_id } -> + Format.printf "%a COPY to %a\n" pp_id source_id pp_id destination_id + ) diff; + Printf.printf "%!" + + +let forge_deploy () = + let op = + Client.Sync.forge_deploy + (LiquidityToMichelson.From_files (Data.get_files ())) (Data.get_inputs ()) + in + Printf.eprintf "Raw operation:\n--------------\n%!"; + Printf.printf "%s\n%!" Hex.(show @@ of_bytes op) + +let init_storage () = + let outname = + let c = match !LiquidOptions.main with + | Some c -> c + | None -> match List.rev (Data.get_files ()) with + | c :: _ -> c + | [] -> assert false in + String.uncapitalize_ascii c in + let from, inputs = + LiquidityToMichelson.From_files (Data.get_files ()), + Data.get_inputs () in + if !LiquidOptions.json then + let storage = ClientJson.Sync.init_storage from inputs in + let output = match !LiquidOptions.output with + | Some output -> output + | None -> outname ^ ".init.json" in + FileString.write_file output (Ezjsonm.value_to_string ~minify:false storage); + Printf.printf "Constant initial storage generated in %S\n%!" output + else + let storage = Client.Sync.init_storage from inputs in + let output = match !LiquidOptions.output with + | Some output -> output + | None -> outname ^ ".init.tz" in + FileString.write_file output storage; + Printf.printf "Constant initial storage generated in %S\n%!" output + +let deploy () = + let op_h, contract_id = + Client.Sync.deploy + (LiquidityToMichelson.From_files (Data.get_files ())) (Data.get_inputs ()) + in + Printf.printf "New contract %s deployed in operation %s\n%!" + contract_id op_h + +let get_storage () = + let r_storage = + Client.Sync.get_storage + (LiquidityToMichelson.From_files (Data.get_files ())) + !Data.contract_address + in + Printf.printf "%s\n%!" r_storage + +let call_arg () = + let s = + !Data.parameter + |> Client.C.SourceConv.parse_const + |> Client.L.compile_const + |> Client.C.TargetConv.print_const + in + match !LiquidOptions.output with + | None -> + Printf.printf "Use --arg '%s'\n%!" s + | Some "-" -> + Printf.printf "'%s'%!" s + | Some file -> + FileString.write_file file s + +let call () = + let contract = match Data.get_files () with + | [] -> None + | l -> Some (LiquidityToMichelson.From_files l) in + let op_h = + Client.Sync.call + ?contract + ~address:!Data.contract_address + ~entry:!Data.entry_name + !Data.parameter + in + Printf.printf "Successful call to contract %s in operation %s\n%!" + !Data.contract_address op_h + +let forge_call () = + let contract = match Data.get_files () with + | [] -> None + | l -> Some (LiquidityToMichelson.From_files l) in + let op = + Client.Sync.forge_call + ?contract + ~address:!Data.contract_address + ~entry:!Data.entry_name + !Data.parameter in + Printf.eprintf "Raw operation:\n--------------\n%!"; + Printf.printf "%s\n%!" Hex.(show @@ of_bytes op) + +let pack () = + (match Data.get_files () with + | [] -> () + | l -> + LiquidityToMichelson.From_files l + |> Client.C.SourceConv.parse_contract + |> Client.L.compile_contract + |> ignore); + let bytes = Client.Sync.pack ~const:!Data.const ~ty:!Data.ty in + Printf.printf "0x%s\n%!" Hex.(show @@ of_bytes bytes) + +let parse_tez expl amount = + match LiquidData.translate (LiquidFromParsetree.initial_env expl) + dummy_contract_sig amount Ttez + with + | CTez t -> t + | _ -> assert false + +let docs = Manpage.s_options + +let amount_arg = + ["amount"; "a"], + Arg.String (fun amount -> + LiquidOptions.amount := parse_tez "--amount" amount + ), + Ezcmd.info ~docs ~docv:"DUN" + "Set amount to $(docv) for deploying or running a contract (default: 0DUN)" + +let fee_arg = + ["fee"; "f"], + Arg.String (fun fee -> + LiquidOptions.fee := Some (parse_tez "--fee" fee) + ), + Ezcmd.info ~docs ~docv:"DUN" + "Set fee $(docv) for deploying a contract (default: computed automatically)" + +let gas_limit_arg = + ["gas-limit"; "G"], + Arg.Int (fun g -> LiquidOptions.gas_limit := Some g), + Ezcmd.info ~docs ~docv:"g" + "Set gas limit to $(docv) (default: automatic)" + +let storage_limit_arg = + ["storage-limit"; "S"], + Arg.Int (fun s -> LiquidOptions.storage_limit := Some s), + Ezcmd.info ~docs ~docv:"s" + "Set storage limit to $(docv) (default: automatic)" + +let source_arg = + ["source"; "s"], Arg.String (fun s -> + Data.validate_key_hash s; + LiquidOptions.source := Some s), + Ezcmd.info ~docs ~docv:"dn1..." + "Set the source to $(docv) for manager operations \ + (default: derived from public key)" + +let private_key_arg = + ["private-key"], Arg.String (fun s -> + Data.validate_private_key s; + LiquidOptions.private_key := Some s), + Ezcmd.info ~docs ~docv:"edsk..." + "Set the private key to $(docv) for signed operations (default: none)" + +let public_key_arg = + ["public-key"], Arg.String (fun s -> + Data.validate_public_key s; + LiquidOptions.public_key := Some s), + Ezcmd.info ~docs ~docv:"edpk..." + "Set the public key to $(docv) for revelations \ + (default: derived from private key)" + +let counter_arg = + ["counter"; "C"], Arg.Int (fun n -> LiquidOptions.counter := Some n), + Ezcmd.info ~docs ~docv:"N" + "Set the counter to $(docv) for the operation instead of retrieving it" + +let node_arg = + ["node"; "n"], Arg.Set_string LiquidOptions.node, + Ezcmd.info ~docs ~docv:"ADDR:PORT" + "Set the address and port to $(docv) of a node to run or deploy \ + contracts (default: 127.0.0.1:8733)" + +let common_args = LiquidCommonArgs.common @ [ + ["files"], + Arg.File (fun s -> let l = String.split_on_char ',' s in Data.files := l), + Ezcmd.info ~docs:Manpage.s_common_options ~docv:"FILE1,FILE2,..." + "Filenames to compile (comma separated)"; + ] + +let arg_entry i s = + [], + Arg.Anon (i, fun s -> Data.entry_name := s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"ENTRY" + ("Entry point name " ^ s) + +let arg_parameter i s = + [], + Arg.Anon (i, fun s -> Data.parameter := s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"PARAMETER" + ("Parameter value " ^ s) + +let arg_storage i s = + [], + Arg.Anon (i, fun s -> Data.storage := s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"STORAGE" + ("Storage value " ^ s) + +let arg_type i s = + [], + Arg.Anon (i, fun s -> Data.ty := s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"TYPE" + ("Type " ^ s) + +let arg_constant i s = + [], + Arg.Anon (i, fun s -> Data.const := s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"CONSTANT" + ("Constant value " ^ s) + +let arg_deploy_inputs = + [], + Arg.Anons (fun s -> Data.init_inputs := s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"INPUTS" + ("Inputs to initializtion function") + + +let arg_address i = + [], + Arg.Anon (i, fun s -> + Data.validate_contract_addr s; + Data.contract_address := s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"ADDRESS" + ("KT1... address of the contract") + + +let run_cmd = + { + Arg.cmd_name = "run"; + cmd_args = common_args @ [ + arg_entry 0 "for simulation"; + arg_parameter 1 "for simulation"; + arg_storage 2 "for simulation"; + source_arg; + public_key_arg; + node_arg; + amount_arg; + ]; + cmd_doc = "Run (simulate) a transation on a Liquidity contract"; + cmd_man = [ + `S Manpage.s_description; + `P "Run (simulate) a transation on a Liquidity contract"; + + `S Manpage.s_examples; + `Pre {| +liquidity-client run \\ + --files tests/others/multisig.liq \\ + --node http://testnet-node.dunscan.io \\ + --source dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb \\ + manage 'Some { destination = dn1UqnHgHFe8ezEgsoow4hERctPssuWiw9h8; amount = 10DUN }' '{owners = (Set [dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb]); actions = Map; owners_length = 1p; min_agree = 1p}' + + +{ + owners = (Set [dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb]); + actions = Map; + owners_length = 1p; + min_agree = 1p +} +# Internal operations: 1 +|}; + + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = run; + } + +let init_storage_cmd = + { + Arg.cmd_name = "init-storage"; + cmd_args = common_args @ [ + arg_deploy_inputs; + source_arg; + node_arg; + ]; + cmd_doc = "Generate input storage"; + cmd_man = [ + `S Manpage.s_description; + `P "Generate input storage with initialization function"; + `S Manpage.s_examples; + `P "Failing example:";`Noblank; + `Pre {| +liquidity-client init-storage --files tests/others/multisig.liq --node http://testnet-node.dunscan.io 'Set [dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb]' 2p + + +tests/others/multisig.liq:25.4-25.74: Failed at runtime: in /chains/main/blocks/head/helpers/scripts/run_code +Failed with "Number of owners must be greater or equal to quorum" +|}; + `P "Working example:";`Noblank; + `Pre {| +./liquidity-client init-storage --files tests/others/multisig.liq --node http://testnet-node.dunscan.io 'Set [dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb]' 1p + +Constant initial storage generated in "tests/others/multisig.liq.init.tz" +|}; + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = init_storage; + } + + +let forge_deploy_cmd = + { + Arg.cmd_name = "forge-deploy"; + cmd_args = common_args @ [ + arg_deploy_inputs; + source_arg; + public_key_arg; + node_arg; + counter_arg; + amount_arg; + fee_arg; gas_limit_arg; storage_limit_arg; + ]; + cmd_doc = "Forge deployment operation for contract"; + cmd_man = [ + `S Manpage.s_description; + `P "Forge unsigned deployment operation for contract"; + + `S Manpage.s_examples; + `Pre {| +liquidity-client forge-deploy --files tests/others/multisig.liq --node http://testnet-node.dunscan.io --source dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb 'Set [dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb]' 1p + + +Raw operation: +-------------- +9649d986044c498fc5e526a0c9608c79b73103ced669aed64d45445dd351b9946d0011589aef8... +|}; + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = forge_deploy; + } + +let deploy_cmd = + { + Arg.cmd_name = "deploy"; + cmd_args = common_args @ [ + arg_deploy_inputs; + source_arg; + node_arg; + counter_arg; + public_key_arg; + private_key_arg; + amount_arg; + fee_arg; gas_limit_arg; storage_limit_arg; + ]; + cmd_doc = "Deploy contract"; + cmd_man = [ + `S Manpage.s_description; + `P "Deploy contract on a network"; + `S Manpage.s_examples; + `Pre {| +liquidity-client deploy --files tests/others/multisig.liq --node http://testnet-node.dunscan.io --private-key edsk3impUREDjtAvDvz8MWQsY7JQyFHhBfVoU6CztBUCLw3ocuqqJ7 'Set [dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb]' 1p + + +New contract KT1Lb7UdXq88n2ahpjwXfbrQPkgjyKu6BoC2 deployed in operation oovkxqLCSk88RYgQ8e22aW4dy1ba7DXvHQTdFYPJg58JWun6qn3 +|}; + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = deploy; + } + +let get_storage_cmd = + { + Arg.cmd_name = "get-storage"; + cmd_args = common_args @ [ + arg_address 0; + node_arg; + ]; + cmd_doc = "Retrieve storage value for a contract"; + cmd_man = [ + `S Manpage.s_description; + `P "Retrieve storage value for a contract"; + `S Manpage.s_examples; + `Pre {| +liquidity-client get-storage --files tests/others/multisig.liq --node http://testnet-node.dunscan.io KT1Lb7UdXq88n2ahpjwXfbrQPkgjyKu6BoC2 + + +{ + owners = (Set [dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb]); + actions = Map; + owners_length = 1p; + min_agree = 1p +} +|}; + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = get_storage; + } + + +let call_cmd = + { + Arg.cmd_name = "call"; + cmd_args = common_args @ [ + arg_address 0; + arg_entry 1 "for call"; + arg_parameter 2 "for call"; + source_arg; + node_arg; + counter_arg; + public_key_arg; + private_key_arg; + amount_arg; + fee_arg; gas_limit_arg; storage_limit_arg; + ]; + cmd_doc = "Call a smart contract"; + cmd_man = [ + `S Manpage.s_description; + `P "Call a deployed smart contract"; + `S Manpage.s_examples; + `Pre {| +liquidity-client call --files tests/others/multisig.liq --node http://testnet-node.dunscan.io --private-key edsk3impUREDjtAvDvz8MWQsY7JQyFHhBfVoU6CztBUCLw3ocuqqJ7 KT1Lb7UdXq88n2ahpjwXfbrQPkgjyKu6BoC2 pay '()' + +Successful call to contract KT1Lb7UdXq88n2ahpjwXfbrQPkgjyKu6BoC2 in operation oozWUtgrnTNgfY5jG1NNdmHosYi3vKNMGKr2ZfzRZM8ReEkddNV +|}; + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = call; + } + +let forge_call_cmd = + { + Arg.cmd_name = "forge-call"; + cmd_args = [ + arg_address 0; + arg_entry 1 "for call"; + arg_parameter 2 "for call"; + source_arg; + public_key_arg; + node_arg; + counter_arg; + amount_arg; + fee_arg; gas_limit_arg; storage_limit_arg; + ] @ common_args; + cmd_doc = "Forge a call operation to a smart contract"; + cmd_man = [ + `S Manpage.s_description; + `P "Forge an unsigned call operation to a smart contract"; + `S Manpage.s_examples; + `Pre {| +liquidity-client forge-call --node http://testnet-node.dunscan.io --source dn1HieGdCFcT8Lg9jDANfEGbJyt6arqEuSJb KT1Lb7UdXq88n2ahpjwXfbrQPkgjyKu6BoC2 pay '()' --amount 10DUN + + +Raw operation: +-------------- +50d636cc2440f9042c4e79bb29c67ce6488aa1f5b419d4abbd22fc8ff8f4e1ab6c0011589aef8b9cd48925f6fedadcee774d51d14b85912e8b0bd3b8030080ade2040183b221732a1f1b05d442a81967ae8188ed44b6c300ffff0370617900000002030b|}; + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = forge_call; + } + +let call_arg_cmd = + { + Arg.cmd_name = "call-arg"; + cmd_args = common_args @ [ + arg_parameter 0 "for call"; + ]; + cmd_doc = "Compile a parameter for a contract call call"; + cmd_man = [ + `S Manpage.s_description; + `P "Compile a parameter for a contract call call"; + `S Manpage.s_examples; + `Pre {| +liquidity-client call-arg '()' + + +Use --arg 'Unit' +|}; + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = call_arg; + } + +let pack_cmd = + { + Arg.cmd_name = "pack"; + cmd_args = common_args @ [ + arg_constant 0 "for pack"; + arg_type 1 "of value to be packed (serialized)"; + node_arg; + ]; + cmd_doc = "Serialize (pack) a constant value"; + cmd_man = [ + `S Manpage.s_description; + `P "Serialize (pack) a constant value"; + `S Manpage.s_examples; + `Pre {| +liquidity-client pack --node http://testnet-node.dunscan.io '()' unit + +0x05030b +|}; + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = pack; + } + +let inject_cmd = + let opf = ref "" in + { + Arg.cmd_name = "inject"; + cmd_args = common_args @ [ + ["signature"], + Arg.String (fun s -> LiquidOptions.signature := Some s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"edsig..." + "Set the signature for an operation"; + + node_arg; + + [], + Arg.Anon (0, fun s -> opf := s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"OPERATION.bytes" + "File containing the unsigned operation"; + ]; + cmd_doc = "Inject a sign operation"; + cmd_man = [ + `S Manpage.s_description; + `P "Inject a sign operation"; + `Blocks LiquidCommonArgs.help_secs; + ]; + cmd_action = fun () -> inject !opf; + } + +let main () = + let name = "liquidity-client" in + let doc = "a client for Dune Network and Tezos to inteact with Liquidity \ + smart contracts" in + let man = LiquidCommonArgs.help_secs in + Ezcmd.main_with_subcommands + ~name + ~doc + ~man + (* ~default:compile_cmd *) + [ + run_cmd; + inject_cmd; + pack_cmd; + call_arg_cmd; + forge_call_cmd; + call_cmd; + get_storage_cmd; + deploy_cmd; + forge_deploy_cmd; + init_storage_cmd; + ] + + +let () = + Printexc.record_backtrace true; + try + main () + with exn -> + report_error exn; + exit 1 diff --git a/tools/client/liquidClientRPCs.ml b/tools/client/liquidClientRPCs.ml new file mode 100644 index 00000000..ec914899 --- /dev/null +++ b/tools/client/liquidClientRPCs.ml @@ -0,0 +1,185 @@ +open LiquidClientSigs +open LiquidClientRequest +open LiquidClientUtils +open Lwt.Infix + +module Make(L : LANG) = struct + + module E = LiquidClientErrors.Make(L) + module T = E.T + + open L + open E + open T + + let send_post ?loc_table ~data path = + Lwt.catch + (fun () -> !post ~data path) + (function + | RequestError (code, res) as exn -> + begin + try raise_response_error ?loc_table path (Ezjsonm.from_string res) + with Ezjsonm.Parse_error _ | Not_found -> Lwt.fail exn + end + | exn -> Lwt.fail exn + ) + + let send_get ?loc_table path = + Lwt.catch + (fun () -> !get path) + (function + | RequestError (code, res) as exn -> + begin + try raise_response_error ?loc_table path (Ezjsonm.from_string res) + with Ezjsonm.Parse_error _ | Not_found -> Lwt.fail exn + end + | exn -> Lwt.fail exn + ) + + + let post ?loc_table ~input ~output ~path data = + Format.kasprintf (fun path -> + let data = + Json_encoding.construct input data + |> Ezjsonm.value_to_string in + send_post ?loc_table ~data path >>= fun r -> + let r = Ezjsonm.value_from_string r in + try Json_encoding.destruct output r |> Lwt.return + with Json_encoding.Cannot_destruct _ -> + raise_response_error path r + ) path + + let get ?loc_table ~output ~path = + Format.kasprintf (fun path -> + send_get ?loc_table path >>= fun r -> + let r = Ezjsonm.value_from_string r in + try Json_encoding.destruct output r |> Lwt.return + with Json_encoding.Cannot_destruct _ -> + raise_response_error path r + ) path + + + let get_counter source = + get + ~output:int_string + ~path:"/chains/main/blocks/head/context/contracts/%s/counter" + source + + let get_head () = + get + ?loc_table:None + ~output:Header.encoding + ~path:"/chains/main/blocks/head/header" + + let get_manager_key source = + get + ~output:Json_encoding.(option string) + ~path:"/chains/main/blocks/head/context/contracts/%s/manager_key" + source + + let get_balance addr = + get + ~output:tez_encoding + ~path:"/chains/main/blocks/head/context/contracts/%s/balance" + addr + + let get_network () = + get + ?loc_table:None + ~output:Json_encoding.( + list + (conv_ignore_extra (fun x -> x) (fun x -> x) + (obj1 (req "chain_name" string))) + ) + ~path:"/network/versions" + + let get_constants () = + get + ?loc_table:None + ~output:Constants.encoding + ~path:"/chains/main/blocks/head/context/constants" + + let run ?loc_table data = + post + ?loc_table + ~input:Run_code.Input.encoding + ~output:Run_code.Result.encoding + ~path:"/chains/main/blocks/head/helpers/scripts/run_code" + data + + let trace ?loc_table data = + post + ?loc_table + ~input:Run_code.Input.encoding + ~output:Run_code.Result.encoding + ~path:"/chains/main/blocks/head/helpers/scripts/trace_code" + data + + let get_storage address = + get + ~output:Target.const_encoding + ~path:"/chains/main/blocks/head/context/contracts/%s/storage" + address + + let get_big_map_value id key = + post + ~input:Target.const_encoding + key + ~output:(Json_encoding.option Target.const_encoding) + ~path:"/chains/main/blocks/head/context/big_maps/%d" + id + + let get_big_map_hash_value id hash = + get + ~output:(Json_encoding.option Target.const_encoding) + ~path:"/chains/main/blocks/head/context/big_maps/%d/%s" + id hash + + let run_operation ?loc_table ~chain_id operation = + post + ?loc_table + ~input:Run_operation.Input.encoding + ~output:Run_operation.Result.encoding + ~path:"/chains/main/blocks/head/helpers/scripts/run_operation" + Run_operation.Input.{ operation; chain_id } + + let forge_operation ?loc_table data = + post + ?loc_table + ~input:Operation.encoding + ~output:bytes_hex + ~path:"/chains/main/blocks/head/helpers/forge/operations" + data + + let preapply_operations ?loc_table ~protocol operations = + post + ?loc_table + ~input:Json_encoding.( + list @@ merge_objs + (obj1 (req "protocol" string)) + Operation.encoding) + ~output:(Json_encoding.list Run_operation.Result.encoding) + ~path:"/chains/main/blocks/head/helpers/preapply/operations" + (List.map (fun op -> (protocol, op)) operations) + + let injection ?loc_table bytes = + post + ?loc_table + ~input:bytes_hex + ~output:Json_encoding.string (* operation hash *) + ~path:"/injection/operation" + bytes + + let pack ~data ~ty = + post + ~input:Json_encoding.( + obj2 + (req "data" Target.const_encoding) + (req "type" Target.datatype_encoding) + ) + ~output:Json_encoding.(conv_ignore_extra (fun x -> x) (fun x -> x) + (obj1 (req "packed" bytes_hex))) + ~path:"/chains/main/blocks/head/helpers/scripts/pack_data" + (data, ty) + +end diff --git a/tools/client/liquidClientRequest.ml b/tools/client/liquidClientRequest.ml new file mode 100644 index 00000000..b96793c5 --- /dev/null +++ b/tools/client/liquidClientRequest.ml @@ -0,0 +1,140 @@ + +exception RequestError of int * string +exception ResponseError of string + +open Lwt + +module Network_sync = struct + let writer_callback a d = + Buffer.add_string a d; + String.length d + + let initialize_connection host path = + let url = Printf.sprintf "%s%s" host path in + let r = Buffer.create 16384 + and c = Curl.init () in + Curl.set_timeout c 30; (* Timeout *) + Curl.set_sslverifypeer c false; + Curl.set_sslverifyhost c Curl.SSLVERIFYHOST_EXISTENCE; + Curl.set_writefunction c (writer_callback r); + Curl.set_tcpnodelay c true; + Curl.set_verbose c false; + Curl.set_post c false; + Curl.set_url c url; r,c + + let post ?(content_type = "application/json") host path data = + let r, c = initialize_connection host path in + Curl.set_post c true; + Curl.set_httpheader c [ "Content-Type: " ^ content_type ]; + Curl.set_postfields c data; + Curl.set_postfieldsize c (String.length data); + Curl.perform c; + let rc = Curl.get_responsecode c in + Curl.cleanup c; + rc, (Buffer.contents r) + + let get ?(content_type = "application/json") host path = + let r, c = initialize_connection host path in + Curl.set_post c false; + Curl.set_httpheader c [ "Content-Type: " ^ content_type ]; + Curl.perform c; + let rc = Curl.get_responsecode c in + Curl.cleanup c; + rc, (Buffer.contents r) +end + +module Network = struct + let writer_callback a d = + Buffer.add_string a d; + String.length d + + let initialize_connection host path = + let url = Printf.sprintf "%s%s" host path in + let r = Buffer.create 16384 + and c = Curl.init () in + Curl.set_timeout c 30; (* Timeout *) + Curl.set_sslverifypeer c false; + Curl.set_sslverifyhost c Curl.SSLVERIFYHOST_EXISTENCE; + Curl.set_writefunction c (writer_callback r); + Curl.set_tcpnodelay c true; + Curl.set_verbose c false; + Curl.set_post c false; + Curl.set_url c url; r,c + + let post ?(content_type = "application/json") host path data = + let r, c = initialize_connection host path in + Curl.set_post c true; + Curl.set_httpheader c [ "Content-Type: " ^ content_type ]; + Curl.set_postfields c data; + Curl.set_postfieldsize c (String.length data); + Curl_lwt.perform c >>= fun cc -> + (* if cc <> Curl.CURLE_OK then + * raise (RequestError + * (Printf.sprintf "[%d] [%s] Curl exception: %s\n%!" + * (Curl.errno cc) host path)) + * else *) + let rc = Curl.get_responsecode c in + Curl.cleanup c; + Lwt.return (rc, (Buffer.contents r)) + + let get ?(content_type = "application/json") host path = + let r, c = initialize_connection host path in + Curl.set_post c false; + Curl.set_httpheader c [ "Content-Type: " ^ content_type ]; + Curl_lwt.perform c >>= fun cc -> + (* if cc <> Curl.CURLE_OK then + * raise (RequestError + * (Printf.sprintf "[%d] [%s] Curl exception: %s\n%!" + * (Curl.errno cc) host path)) + * else *) + let rc = Curl.get_responsecode c in + Curl.cleanup c; + Lwt.return (rc, (Buffer.contents r)) +end + +(* (Ezjsonm.to_string ~minify:false (Ezjsonm.from_string data)); *) + +let curl_call meth f data path = + let host = !LiquidOptions.node in + if !LiquidOptions.verbosity > 0 then + Printf.eprintf "\n%s to %s%s:\n--------------\n<<<%s>>>\n%!" + meth host path data; + try + f host path data >>= fun (status, json) -> + if !LiquidOptions.verbosity > 0 then begin + Printf.eprintf "\nNode Response %d:\n------------------\n<<<%s>>>\n%!" + status json; + end; + if status <> 200 then raise (RequestError (status, json)); + return json + with Curl.CurlException (code, i, s) (* as exn *) -> + raise (RequestError (Curl.errno code, s)) + +let curl_post ~data path = + curl_call "POST" Network.post data path + +let curl_get path = + curl_call "GET" (fun host path data -> Network.get host path) "" path + + +let post = ref curl_post +let get = ref curl_get + +(* let error_string_of_michelson_error json = + * let errors = Ezjsonm.get_list Error_monad.error_of_json json in + * let fmt = Format.str_formatter in + * Michelson_v1_error_reporter.report_error + * ~details:false + * ~show_source:false + * fmt + * errors; + * Format.flush_str_formatter () *) + +let error_schema = + lazy ( + Lwt.catch + (fun () -> !get "/errors" >|= Ezjsonm.from_string) + (function + | RequestError _ | Not_found -> return @@ `O [] + | exn -> Lwt.fail exn) + ) diff --git a/tools/client/liquidClientSigs.ml b/tools/client/liquidClientSigs.ml new file mode 100644 index 00000000..560ece20 --- /dev/null +++ b/tools/client/liquidClientSigs.ml @@ -0,0 +1,124 @@ + +type bm_id = + | Bm_id of int + | Bm_name of int * string + +module type LANG = sig + + module Source : sig + type const + (* type expr *) + type contract + type datatype + type loc_info + type location + + val unit : const + val tuple : const list -> const + val list_big_maps : const -> datatype -> (bm_id * datatype * datatype) list + (* val string_of_const : const -> string *) + val storage : contract -> datatype + val entries : contract -> (string * datatype) list + val apply_big_map_subst : (int * (const * const) list) list -> const -> const + val default_empty_const : datatype -> const + + val print_loc : Format.formatter -> location -> unit + + (**/* unsused **) + val const_encoding : const Json_encoding.encoding + val contract_encoding : contract Json_encoding.encoding + + end + + module Target : sig + type const + (* type expr *) + type contract + type location + type datatype + + val unit : const + val compare_loc : location -> location -> int + val next_loc : location -> location + val loc_encoding : location Json_encoding.encoding + + val const_encoding : const Json_encoding.encoding + val contract_encoding : contract Json_encoding.encoding + val datatype_encoding : datatype Json_encoding.encoding + + end + + type compiled_init = + | No_init + | Init_constant of Source.const + | Init_code of Source.contract * (string * Source.datatype) list + + val compile_contract : + Source.contract -> + Target.contract * compiled_init * + (Target.location * (Source.location * Source.loc_info)) list + + val decompile_contract : Target.contract -> Source.contract + + val compile_const : ?ty:Source.datatype -> Source.const -> Target.const + + val decompile_const : ?ty:Source.datatype -> Target.const -> Source.const + + val compile_datatype : Source.datatype -> Target.datatype + +end + + +module type CONV = sig + type from_datatype + type from_const + type from_contract + type dest_datatype + type dest_const + type dest_contract + val parse_const : from_const -> dest_const + val parse_contract : from_contract -> dest_contract + val parse_datatype : from_datatype -> dest_datatype + val print_const : dest_const -> from_const + val print_contract : dest_contract -> from_contract + val print_datatype : dest_datatype -> from_datatype +end + +module type TT = sig + type datatype + type const + type contract +end + +module type CONVERTER = sig + (* module Source : TT + * module Target : TT + * module SourceFrom : TT + * module TargetFrom : TT *) + type source_from_datatype + type source_from_const + type source_from_contract + type source_dest_datatype + type source_dest_const + type source_dest_contract + type target_from_datatype + type target_from_const + type target_from_contract + type target_dest_datatype + type target_dest_const + type target_dest_contract + module SourceConv : + CONV with type dest_const := source_dest_const + and type dest_contract := source_dest_contract + and type dest_datatype := source_dest_datatype + and type from_const := source_from_const + and type from_contract := source_from_contract + and type from_datatype := source_from_datatype + module TargetConv : + CONV with type dest_const := target_dest_const + and type dest_contract := target_dest_contract + and type dest_datatype := target_dest_datatype + and type from_const := target_from_const + and type from_contract := target_from_contract + and type from_datatype := target_from_datatype +end diff --git a/tools/client/liquidClientTypes.ml b/tools/client/liquidClientTypes.ml new file mode 100644 index 00000000..6269dc96 --- /dev/null +++ b/tools/client/liquidClientTypes.ml @@ -0,0 +1,640 @@ +open LiquidClientUtils +open Dune_Network_Lib + +module Make (L : LiquidClientSigs.LANG) = struct + open L + + let int_string = Json_encoding.(conv string_of_int int_of_string string) + + let bytes_hex = + let open Json_encoding in + conv + (fun b -> Hex.show (Hex.of_bytes b)) + (fun h -> Hex.to_bytes (`Hex h)) + string + + type error = Json_repr.any + + let tez_encoding = + let open Json_encoding in + conv + (fun x -> LiquidNumber.mic_mutez_of_tez x |> Z.to_string) + (fun x -> Z.of_string x |> LiquidNumber.tez_of_mic_mutez) + string + + module Header = struct + type t = { + hash : string; + chain_id : string; + predecessor : string; + protocol : string; + } + + let encoding = + let open Json_encoding in + conv_ignore_extra + (fun {hash; chain_id; predecessor; protocol} -> + (hash, chain_id, predecessor, protocol)) + (fun (hash, chain_id, predecessor, protocol) -> + {hash; chain_id; predecessor; protocol}) + (obj4 + (req "hash" string) + (req "chain_id" string) + (req "predecessor" string) + (req "protocol" string)) + end + + module Constants = struct + + type t = { + hard_gas_limit_per_operation : int; + hard_storage_limit_per_operation : int; + } + + let encoding = + let open Json_encoding in + conv_ignore_extra + (fun {hard_gas_limit_per_operation; + hard_storage_limit_per_operation} -> + (hard_gas_limit_per_operation, + hard_storage_limit_per_operation)) + (fun (hard_gas_limit_per_operation, + hard_storage_limit_per_operation) -> + {hard_gas_limit_per_operation; + hard_storage_limit_per_operation}) + (obj2 + (req "hard_gas_limit_per_operation" int_string) + (req "hard_storage_limit_per_operation" int_string)) + end + + module Balance_update = struct + type category = + | Rewards + | Fees + | Deposits + type t = + | Contract of { + contract : string; + change : LiquidNumber.tez; + } + | Freezer of { + category : category; + delegate : string; + cycle : int; + change : LiquidNumber.tez + } + + let encoding = + let open Json_encoding in + union [ + case_ignore_extra + (obj3 + (req "kind" (constant "contract")) + (req "contract" string) + (req "change" tez_encoding)) + (function + | Contract { contract; change } -> Some ((), contract, change) + | _ -> None) + (fun ((), contract, change) -> + Contract { contract; change }); + + case_ignore_extra + (obj5 + (req "kind" (constant "freezer")) + (req "category" (string_enum [ + "rewards", Rewards; + "fees", Fees; + "deposits", Deposits; + ])) + (req "delegate" string) + (req "cycle" int) + (req "change" tez_encoding)) + (function + | Freezer { category; delegate; cycle; change } -> + Some ((), category, delegate, cycle, change) + | _ -> None) + (fun ((), category, delegate, cycle, change) -> + Freezer { category; delegate; cycle; change }); + ] + + end + + module Trace = struct + + type ('loc, 'const) trace_item = { + loc : 'loc option; + gas : int; + stack : ('const * string option) list; + } + + type ('loc, 'const) t = ('loc, 'const) trace_item list + + let encoding loc_enc const_enc = + let open Json_encoding in + list @@ conv_ignore_extra + (fun { loc; gas; stack } -> (loc, gas, stack)) + (fun (loc, gas, stack) -> { loc; gas; stack }) + (obj3 + (opt "location" loc_enc) + (req "gas" int_string) + (req "stack" (list (obj2 + (req "item" const_enc) + (opt "annot" string))))) + + end + + module Big_map_diff = struct + + type ('id, 'const) item = + | Big_map_add of { id : 'id; + key_hash : string; + key : 'const; + value : 'const } + | Big_map_remove of { id : 'id; + key_hash : string; + key : 'const } + | Big_map_delete of { id : 'id } + | Big_map_alloc of { id : 'id } + | Big_map_copy of { source_id : 'id; + destination_id : 'id } + + type ('id, 'const) t = ('id, 'const) item list + + let item_encoding id const = + let open Json_encoding in + union [ + case_ignore_extra + (obj5 + (req "action" (constant "update")) + (req "big_map" id) + (req "key_hash" string) + (req "key" const) + (req "value" const)) + (function + | Big_map_add { id; key_hash; key; value } -> + Some ((), id, key_hash, key, value) + | _ -> None) + (fun ((), id, key_hash, key, value) -> + Big_map_add { id; key_hash; key; value }); + + case_ignore_extra + (obj4 + (req "action" (constant "update")) + (req "big_map" id) + (req "key_hash" string) + (req "key" const)) + (function + | Big_map_remove { id; key_hash; key } -> + Some ((), id, key_hash, key) + | _ -> None) + (fun ((), id, key_hash, key) -> + Big_map_remove { id; key_hash; key }); + + case_ignore_extra + (obj2 + (req "action" (constant "remove")) + (req "big_map" id)) + (function + | Big_map_delete { id } -> Some ((), id) + | _ -> None) + (fun ((), id) -> Big_map_delete { id }); + + case_ignore_extra + (obj2 + (req "action" (constant "alloc")) + (req "big_map" id)) + (function + | Big_map_alloc { id } -> Some ((), id) + | _ -> None) + (fun ((), id) -> Big_map_alloc { id }); + + case_ignore_extra + (obj3 + (req "action" (constant "alloc")) + (req "source_big_map" id) + (req "destination_big_map" id)) + (function + | Big_map_copy { source_id; destination_id } -> + Some ((), source_id, destination_id) + | _ -> None) + (fun ((), source_id, destination_id) -> + Big_map_copy { source_id; destination_id }); + ] + + let encoding id const = Json_encoding.list @@ item_encoding id const + + end + + module OperationMake (T : sig + type const + type contract + val const_encoding : const Json_encoding.encoding + val contract_encoding : contract Json_encoding.encoding + end) = struct + open T + + type manager_operation_content = + | Reveal of string + | Transaction of { + amount : LiquidNumber.tez; + destination : string; + entrypoint : string; + parameters : const option; + } + | Origination of { + delegate: string option ; + script: (contract * const) option ; + balance: LiquidNumber.tez ; + } + | Delegation of string option + + + type 'manager operation_content = + | Manager of 'manager + | Activate_account of { + pkh : string; + secret : string; + } + + type manager_operation = { + op : manager_operation_content; + source : string; + fee : LiquidNumber.tez; + counter : int; + gas_limit : int; + storage_limit : int; + } + + type operation = manager_operation operation_content + + type internal = { + source : string; + nonce : int; + op : manager_operation_content operation_content; + } + + type t = { + branch : string; + contents : operation list; + signature : string option; + } + + let manager_operation_content_encoding = + let open Json_encoding in + union [ + case_ignore_extra + (obj2 + (req "kind" (constant "reveal")) + (req "public_key" string)) + (function + | Reveal pk -> + Some ((), pk) + | _ -> None) + (fun ((), pk) -> Reveal pk); + + case_ignore_extra + (obj4 + (req "kind" (constant "transaction")) + (req "amount" tez_encoding) + (req "destination" string) + (dft "parameters" + (obj2 + (dft "entrypoint" string "default") + (opt "value" const_encoding) + ) + ("default", None))) + (function + | Transaction { amount; destination; entrypoint; parameters } -> + Some ((), amount, destination, (entrypoint, parameters)) + | _ -> None) + (fun ((), amount, destination, (entrypoint, parameters)) -> + Transaction { amount; destination; entrypoint; parameters }); + + case_ignore_extra + (obj4 + (req "kind" (constant "origination")) + (req "balance" tez_encoding) + (opt "delegate" string) + (opt "script" + (obj2 + (req "code" contract_encoding) + (req "storage" const_encoding) + ))) + (function + | Origination { balance; delegate; script } -> + Some ((), balance, delegate, script) + | _ -> None) + (fun ((), balance, delegate, script) -> + Origination { balance; delegate; script }); + + case_ignore_extra + (obj2 + (req "kind" (constant "delegation")) + (opt "delegate" string)) + (function + | Delegation pk -> + Some ((), pk) + | _ -> None) + (fun ((), pk) -> Delegation pk); + ] + + let operation_content_encoding manager_encoding = + let open Json_encoding in + union [ + case + manager_encoding + (function Manager m -> Some m + | _ -> None) + (fun m -> Manager m); + + case_ignore_extra + (obj3 + (req "kind" (constant "activate_account")) + (req "pkh" string) + (req "secret" string)) + (function + | Activate_account { pkh ; secret } -> + Some ((), pkh, secret) + | _ -> None) + (fun ((), pkh, secret) -> Activate_account { pkh ; secret }); + ] + + let manager_operation_encoding = + let open Json_encoding in + conv_ignore_extra + (fun { op; source; fee; counter; gas_limit; storage_limit } -> + (op, (source, fee, counter, gas_limit, storage_limit))) + (fun (op, (source, fee, counter, gas_limit, storage_limit)) -> + { op; source; fee; counter; gas_limit; storage_limit }) + (merge_objs + manager_operation_content_encoding + (obj5 + (req "source" string) + (req "fee" tez_encoding) + (req "counter" int_string) + (req "gas_limit" int_string) + (req "storage_limit" int_string))) + + let operation_encoding = + operation_content_encoding manager_operation_encoding + + let internal_encoding = + let open Json_encoding in + conv_ignore_extra + (fun { source; nonce; op } -> ((source, nonce), op)) + (fun ((source, nonce), op) -> { source; nonce; op }) + (merge_objs + (obj2 + (req "source" string) + (req "nonce" int)) + (operation_content_encoding manager_operation_content_encoding)) + + let encoding = + let open Json_encoding in + conv_ignore_extra + (fun { branch; contents; signature } -> + (branch, contents, signature)) + (fun (branch, contents, signature) -> + { branch; contents; signature }) + (obj3 + (req "branch" string) + (req "contents" (list operation_encoding)) + (opt "signature" string)) + + end + + module Operation = OperationMake(Target) + module SourceOperation = OperationMake(Source) + + module Run_code = struct + + module Input = struct + + type t = { + script : Target.contract; + entrypoint : string; + input: Target.const; + storage: Target.const; + amount: LiquidNumber.tez; + chain_id: string; + source: string option; + } + + let encoding = + let open Json_encoding in + conv_ignore_extra + (fun { script; entrypoint; input; storage; amount; chain_id; source } -> + (script, entrypoint, input, storage, amount, chain_id, source)) + (fun (script, entrypoint, input, storage, amount, chain_id, source) -> + { script; entrypoint; input; storage; amount; chain_id; source }) + (obj7 + (req "script" Target.contract_encoding) + (req "entrypoint" string) + (req "input" Target.const_encoding) + (req "storage" Target.const_encoding) + (req "amount" tez_encoding) + (req "chain_id" string) + (opt "source" string)) + end + + + module Result = struct + + type t = { + storage: Target.const; + operations: Operation.internal list; + big_map_diff: (int, Target.const) Big_map_diff.t; + trace: (Target.location, Target.const) Trace.t option + } + + let encoding = + let open Json_encoding in + conv_ignore_extra + (fun { storage; operations; big_map_diff; trace } -> + (storage, operations, big_map_diff, trace)) + (fun (storage, operations, big_map_diff, trace) -> + { storage; operations; big_map_diff; trace }) + (obj4 + (req "storage" Target.const_encoding) + (dft "operations" (list Operation.internal_encoding) []) + (dft "big_map_diff" + (Big_map_diff.encoding int_string Target.const_encoding) + []) + (opt "trace" (Trace.encoding Target.loc_encoding Target.const_encoding))) + end + end + + module Run_operation = struct + + module Input = struct + type t = { + operation : Operation.t; + chain_id : string; + } + + let encoding = + let open Json_encoding in + conv_ignore_extra + (fun { operation; chain_id } -> + (operation, chain_id)) + (fun (operation, chain_id) -> + { operation; chain_id }) + (obj2 + (req "operation" Operation.encoding) + (req "chain_id" string)) + end + + module Result = struct + + type full_result_content = { + storage: Target.const option; + big_map_diff: (int, Target.const) Big_map_diff.t; + balance_updates: Balance_update.t list; + originated_contracts: string list; + consumed_gas: int; + storage_size: int; + paid_storage_size_diff: int; + allocated_destination_contract: bool; + } + type consumed_result_content = { + originated_contracts: string list; + consumed_gas: int; + paid_storage_size_diff: int; + allocated_destination_contract: bool; + } + type result = + | Applied of consumed_result_content + | Failed of error list + | Skipped + | Backtracked of error list * consumed_result_content + | Other of Json_repr.any + type metadata = { + balance_updates : Balance_update.t list; + operation_result : result; + internal_operation_results : (Operation.internal * result) list; + } + type t = { + contents : (Operation.operation * metadata) list; + signature : string option; + } + + let result_content_encoding = + let open Json_encoding in + conv + (fun { + originated_contracts; + consumed_gas; + paid_storage_size_diff; + allocated_destination_contract; + } -> ( + originated_contracts, + consumed_gas, + paid_storage_size_diff, + allocated_destination_contract + )) + (fun ( + originated_contracts, + consumed_gas, + paid_storage_size_diff, + allocated_destination_contract + ) -> { + originated_contracts; + consumed_gas; + paid_storage_size_diff; + allocated_destination_contract; + }) + (obj4 + (dft "originated_contracts" (list string) []) + (dft "consumed_gas" int_string 0) + (dft "paid_storage_size_diff" int_string 0) + (dft "allocated_destination_contract" bool false)) + + let result_encoding = + let open Json_encoding in + union [ + case_ignore_extra + (merge_objs + (obj1 (req "status" (constant "applied"))) + result_content_encoding) + (function + | Applied r -> Some ((), r) + | _ -> None) + (fun ((), r) -> Applied r); + + case_ignore_extra + (obj2 + (req "status" (constant "failed")) + (req "errors" (list any_value))) + (function + | Failed errs -> Some ((), errs) + | _ -> None) + (fun ((), errs) -> Failed errs); + + case_ignore_extra + (obj1 + (req "satus" (constant "skipped"))) + (function + | Skipped -> Some () + | _ -> None) + (fun () -> Skipped); + + case_ignore_extra + (merge_objs + (obj2 + (req "status" (constant "backtracked")) + (dft "errors" (list any_value) [])) + result_content_encoding) + (function + | Backtracked (errs, r) -> Some (((), errs), r) + | _ -> None) + (fun (((), errs), r) -> Backtracked (errs, r)); + + case + any_value + (function + | Other json -> Some json + | _ -> None) + (fun json -> Other json); + ] + + let metadata_encoding = + let open Json_encoding in + conv_ignore_extra + (fun { balance_updates; + operation_result; + internal_operation_results } -> + (balance_updates, operation_result, internal_operation_results)) + (fun + (balance_updates, operation_result, internal_operation_results) -> + { balance_updates; + operation_result; + internal_operation_results }) + (obj3 + (req "balance_updates" (list Balance_update.encoding)) + (dft "operation_result" result_encoding (Other (Json_repr.to_any (`O [])))) + (dft "internal_operation_results" + (list + (merge_objs + Operation.internal_encoding + (obj1 (req "result" result_encoding)) + )) [])) + + let encoding = + let open Json_encoding in + conv_ignore_extra + (fun { contents; signature } -> (contents, signature)) + (fun (contents, signature) -> { contents; signature }) + (obj2 + (req "contents" + (list + (merge_objs + Operation.operation_encoding + (obj1 (req "metadata" metadata_encoding))) + )) + (opt "signature" string)) + + end + + end + +end diff --git a/tools/client/liquidClientUtils.ml b/tools/client/liquidClientUtils.ml new file mode 100644 index 00000000..74dd284f --- /dev/null +++ b/tools/client/liquidClientUtils.ml @@ -0,0 +1,107 @@ +open Dune_Network_Lib (* for crypto *) + +let dummy_sign = "edsigtXomBKi5CTRf5cjATJWSyaRvhfYNHqSUGrn4SdbYRcGwQ\ + rUGjzEfQDTuqHhuA8b2d8NarZjz8TRf65WkpQmo423BtomS8Q" + +let minimal_fees = Z.of_int 100 +let nanotez_per_gas_unit = Z.of_int 100 +let nanotez_per_byte = Z.of_int 1000 +let to_nanotez m = Z.mul (Z.of_int 1000) m +let of_nanotez n = Z.div (Z.add (Z.of_int 999) n) (Z.of_int 1000) + +let compute_fees ~gas_limit ~size = + let minimal_fees_in_nanotez = to_nanotez minimal_fees in + let fees_for_gas_in_nanotez = + Z.mul nanotez_per_gas_unit (Z.of_int gas_limit) in + let fees_for_size_in_nanotez = Z.mul nanotez_per_byte (Z.of_int size) in + let fees_in_nanotez = + Z.add minimal_fees_in_nanotez @@ + Z.add fees_for_gas_in_nanotez fees_for_size_in_nanotez in + of_nanotez fees_in_nanotez + +let compute_gas_limit ~fee ~size = + let minimal_fees_in_nanotez = to_nanotez minimal_fees in + let fees_for_size_in_nanotez = Z.mul nanotez_per_byte (Z.of_int size) in + let fee_in_nanotez = to_nanotez fee in + let fees_for_gas_in_nanotez = + Z.sub fee_in_nanotez @@ + Z.add minimal_fees_in_nanotez fees_for_size_in_nanotez in + Z.div fees_for_gas_in_nanotez nanotez_per_gas_unit + |> Z.to_int + |> max 0 + + + +let mk_json_obj fields = + fields + |> List.map (fun (f,v) -> "\"" ^ f ^ "\":" ^ v) + |> String.concat "," + |> fun fs -> "{" ^ fs ^ "}" + +let mk_json_arr l = "[" ^ String.concat "," l ^ "]" + + +let get_json_string s = + try Scanf.sscanf s "%S" (fun x -> x) + with _ -> raise Not_found + +let get_json_int s = + try Scanf.sscanf s "%d" (fun x -> x) + with _ -> + try Scanf.sscanf s "\"%d\"" (fun x -> x) + with _ -> raise Not_found + +module ExprHash = struct + let prefix = "\013\044\064\027" (* expr(54) *) + include Blake2B.Make(Base58)(struct + let name = "script_expr" + let title = "A script expression hash" + let b58check_prefix = prefix + let size = None + end) +end + +let get_public_key_hash_from_public_key pk = + match !LiquidOptions.network with + | Tezos_network -> + pk + |> Ed25519.Public_key_hash_tezos.of_public_key + |> Ed25519.Public_key_hash_tezos.to_b58check + | Dune_network -> + pk + |> Ed25519.Public_key_hash_dune.of_public_key + |> Ed25519.Public_key_hash_dune.to_b58check + +let get_public_key_hash_from_secret_key sk = + let pk = Sodium.Sign.secret_key_to_public_key sk in + get_public_key_hash_from_public_key pk + +let get_public_key_from_secret_key sk = + sk + |> Sodium.Sign.secret_key_to_public_key + (* Replace by this when tezos is fixed *) + (* |> Ed25519.Secret_key.to_public_key *) + |> Ed25519.Public_key.to_b58check + +let hash msg = + Blake2B.(to_bytes (hash_bytes [MBytes.of_string "\x03"; msg])) + +let sign sk op_b = + Ed25519.sign sk (hash op_b) + + +let conv_ignore_extra ffrom fto enc = + let open Json_encoding in + conv + (fun x -> ffrom x, ()) + (fun (x, ()) -> fto x) + (merge_objs enc unit (* = ignore *)) + +let case_ignore_extra enc proj inj = + let open Json_encoding in + case + (merge_objs enc unit (* = ignore *)) + (fun x -> match proj x with + | None -> None + | Some x -> Some (x, ())) + (fun (x, ()) -> inj x) diff --git a/tools/client/liquidityToMichelson.ml b/tools/client/liquidityToMichelson.ml new file mode 100644 index 00000000..f0da27a9 --- /dev/null +++ b/tools/client/liquidityToMichelson.ml @@ -0,0 +1,574 @@ +open LiquidClientSigs +open LiquidTypes +open Dune_Network_Lib + +type from = + | From_strings of string list + | From_files of string list + +let global_ty_env = ref (LiquidFromParsetree.initial_env "") +let global_contract_sig = ref LiquidTypes.dummy_contract_sig +let global_type_annots = ref (Hashtbl.create 0) +let global_types = ref [] + +(* Liquidity *) + +module StringLiquidityConv : + (CONV + with type dest_const := LiquidTypes.syntax_const + and type dest_contract := LiquidTypes.syntax_contract + and type dest_datatype := LiquidTypes.datatype + and type from_const := string + and type from_contract := from + and type from_datatype := string) = struct + + let parse_const s = + let env = !global_ty_env in + s + |> LiquidFromParsetree.expression_of_string + |> LiquidFromParsetree.translate_expression env + (* |> LiquidCheck.typecheck_code tenv *) + |> LiquidData.translate_const_exp + (* |> LiquidCheck.typecheck_const tenv *) + + let parse_contract s = + let ocaml_asts = match s with + | From_strings ss -> + List.map (fun s -> + "liquidity_buffer", + LiquidFromParsetree.structure_of_string ~filename:"liquidity_buffer" + s) ss + | From_files files -> + List.map (fun f -> f, LiquidFromParsetree.read_file f) files + in + let syntax_ast = LiquidFromParsetree.translate_multi ocaml_asts in + syntax_ast + (* let typed_ast = LiquidCheck.typecheck_contract + * ~warnings:true ~decompiling:false syntax_ast in + * global_ty_env := typed_ast.ty_env; + * let contract_sig = LiquidTypes.full_sig_of_contract typed_ast in + * global_contract_sig := contract_sig; + * typed_ast *) + + let parse_datatype s = + LiquidFromParsetree.type_of_string s + |> LiquidFromParsetree.translate_type !global_ty_env + + let print_const c = + let env = !global_ty_env in + let tenv = empty_typecheck_env ~warnings:true + LiquidTypes.dummy_contract_sig env in + (* LiquidData.translate_const_exp const *) + c + |> LiquidCheck.typecheck_const tenv + (* |> LiquidSimplify.simplify_const *) + (* |> LiquidDecode.decode_const *) + (* |> LiquidUntype.untype_const *) + |> LiquidPrinter.Liquid.string_of_const + + let print_contract c = + let untyped_ast = + LiquidCheck.typecheck_contract + ~keep_tvars:true ~warnings:false ~decompiling:true c + in + From_strings [LiquidPrinter.Syntax.string_of_structure + (LiquidToParsetree.structure_of_contract + ~type_annots:!global_type_annots ~types:!global_types untyped_ast) [] + ] + + + let print_datatype ty = + LiquidPrinter.Liquid.string_of_type ty +end + +module Liquidity = struct + + type const = LiquidTypes.syntax_const + type contract = LiquidTypes.syntax_contract + type datatype = LiquidTypes.datatype + type location = LiquidTypes.location + type loc_info = string option + + let unit = CUnit + let tuple l = CTuple l + let print_loc = LiquidLoc.print_loc + + let rec list_big_maps name acc storage storage_ty = + match storage, storage_ty with + | CBigMap BMId i, Tbigmap (k, v) -> + let id = LiquidNumber.int_of_integer i in + let id = match name with + | Some name -> Bm_name (id, name) + | None -> Bm_id id in + (id, k, v) :: acc + | ( CUnit + | CBool _ + | CInt _ + | CNat _ + | CTez _ + | CTimestamp _ + | CString _ + | CBytes _ + | CKey _ + | CNone + | CSignature _ + | CKey_hash _ + | CContract _ + | CLambda _), _ -> acc + | CTuple l, Ttuple tys -> + List.fold_left2 (list_big_maps name) acc l tys + | CSome c, Toption ty + | CLeft c, Tor (ty, _) + | CRight c, Tor (_, ty) -> + list_big_maps name acc c ty + | CMap l, Tmap (tk, tv) -> + List.fold_left (fun acc (k, v) -> + let acc = list_big_maps name acc k tk in + list_big_maps name acc v tv + ) acc l + | CList l, Tlist ty + | CSet l, Tset ty -> + List.fold_left (fun acc c -> list_big_maps name acc c ty) acc l + | CRecord l, Trecord (_, tys) -> + List.fold_left2 (fun acc (field, c) (_, ty) -> + let name = match name with + | None -> Some field + | Some name -> Some (String.concat "." [name; field]) in + list_big_maps name acc c ty + ) acc l tys + | CConstr (n, c), Tsum (_, tys) -> + List.fold_left (fun acc (c_name, ty) -> + if c_name <> n then acc + else + let name = match name with + | None -> Some c_name + | Some name -> Some (String.concat "." [name; c_name]) in + list_big_maps name acc c ty + ) acc tys + | _, _ -> acc + + let list_big_maps storage storage_ty = + list_big_maps None [] storage storage_ty + + + let storage c = c.storage + let entries c = + List.map (fun e -> + e.entry_sig.entry_name, e.entry_sig.parameter + ) c.entries + + +let rec apply_big_map_subst subst storage = + let apply = apply_big_map_subst subst in + match storage with + | CBigMap BMId id -> + CBigMap (BMList (List.assoc (LiquidNumber.int_of_integer id) subst)) + | ( CBigMap BMList _ + | CUnit + | CBool _ + | CInt _ + | CNat _ + | CTez _ + | CTimestamp _ + | CString _ + | CBytes _ + | CKey _ + | CNone + | CSignature _ + | CKey_hash _ + | CContract _ + | CLambda _) as c -> c + | CTuple l -> CTuple (List.map apply l) + | CSome c -> CSome (apply c) + | CLeft c -> CLeft (apply c) + | CRight c -> CRight (apply c) + | CMap l -> CMap (List.map (fun (k, v) -> apply k, apply v) l) + | CList l -> CList (List.map apply l) + | CSet l -> CSet (List.map apply l) + | CRecord l -> CRecord (List.map (fun (f, v) -> f, apply v) l) + | CConstr (n, c) -> CConstr (n, apply c) + + let default_empty_const ty = LiquidData.default_empty_untyped_const ty + + let (const_encoding : const Json_encoding.encoding) = + Json_encoding.conv + StringLiquidityConv.print_const + StringLiquidityConv.parse_const + Json_encoding.string + + let (contract_encoding : contract Json_encoding.encoding) = + Json_encoding.conv + (fun c -> match StringLiquidityConv.print_contract c with + | From_strings [s] -> s + | _ -> assert false) + (fun s -> StringLiquidityConv.parse_contract (From_strings [s])) + Json_encoding.string + + let (datatype_encoding : datatype Json_encoding.encoding) = + Json_encoding.conv + StringLiquidityConv.print_datatype + StringLiquidityConv.parse_datatype + Json_encoding.string + +end + + +(* Michelson *) +module Michelson = struct + + open Dune_Network_Lib + + type const = LiquidMichelineTypes.expr + type contract = LiquidMichelineTypes.contract + type location = Micheline.canonical_location + type datatype = LiquidMichelineTypes.expr + + let unit = + let open Micheline in + strip_locations (Prim ((), "Unit", [], [])) + + + let compare_loc = Pervasives.compare + + let next_loc l = l + 1 + + let loc_encoding = Json_encoding.int + + let const_encoding = LiquidToMicheline.const_encoding + let contract_encoding = LiquidToMicheline.contract_encoding + let datatype_encoding = LiquidToMicheline.const_encoding + +end + +module Source = Liquidity +module Target = Michelson + +type compiled_init = + | No_init + | Init_constant of Source.const + | Init_code of Source.contract * (string * Source.datatype) list + +let compile_contract syntax_ast = + let typed_ast = LiquidCheck.typecheck_contract + ~warnings:true ~decompiling:false syntax_ast in + global_ty_env := typed_ast.ty_env; + let contract_sig = LiquidTypes.full_sig_of_contract typed_ast in + global_contract_sig := contract_sig; + let contract_sig = LiquidTypes.full_sig_of_contract typed_ast in + let encoded_ast, to_inline = + LiquidEncode.encode_contract ~annot:true typed_ast in + let live_ast = + if !LiquidOptions.simplify then + let to_inline = + if !LiquidOptions.inline then to_inline + else StringMap.empty, StringMap.empty in + LiquidSimplify.simplify_contract encoded_ast to_inline + else encoded_ast in + let pre_michelson = LiquidMichelson.translate live_ast in + let pre_michelson = + if !LiquidOptions.peephole then + LiquidPeephole.simplify pre_michelson + else + pre_michelson + in + let c, loc_table = + LiquidToMicheline.convert_contract ~expand:true pre_michelson in + let pre_init = match typed_ast.c_init with + | None -> None + | Some init -> + Some ( + LiquidInit.compile_liquid_init live_ast.ty_env contract_sig init, + init.init_args) in + let comp_init = match pre_init with + | None -> No_init + | Some (LiquidInit.Init_constant c, _) -> + Init_constant (LiquidUntype.untype_const c) + | Some (LiquidInit.Init_code c, args) -> + Init_code (LiquidUntype.untype_contract c, + List.map (fun (x,_,ty) -> x, ty) args) + in + (c, comp_init, loc_table) + +let decompile_contract code = + let env = LiquidMichelineTypes.empty_env "mic_code" in + let c = LiquidFromMicheline.convert_contract env code in + let c = LiquidClean.clean_contract c in + let c = LiquidInterp.interp c in + if !LiquidOptions.parseonly then exit 0; + let c = LiquidDecomp.decompile env c in + let annoted_tz, type_annots, types = LiquidFromMicheline.infos_env env in + global_types := types; + global_type_annots := type_annots; + let typed_ast = LiquidCheck.typecheck_contract + ~keep_tvars:true ~warnings:false ~decompiling:true c in + global_ty_env := typed_ast.ty_env; + global_contract_sig := LiquidTypes.full_sig_of_contract typed_ast; + let encode_ast, to_inline = + LiquidEncode.encode_contract ~decompiling:true typed_ast in + let live_ast = LiquidSimplify.simplify_contract + ~decompile_annoted:annoted_tz encode_ast to_inline in + let multi_ast = LiquidDecode.decode_contract live_ast in + let untyped_ast = LiquidUntype.untype_contract multi_ast in + untyped_ast + +let compile_const ?ty const = + let env = !global_ty_env in + let tenv = empty_typecheck_env ~warnings:true + LiquidTypes.dummy_contract_sig env in + (* LiquidData.translate_const_exp const *) + const + |> LiquidCheck.typecheck_const tenv ?expected_ty:ty + |> LiquidEncode.encode_const !global_ty_env !global_contract_sig + |> LiquidMichelson.compile_const + |> LiquidToMicheline.convert_const ~expand:true + +let decompile_const ?ty e = + let env = LiquidMichelineTypes.empty_env "decompile_const" in + let mic_e, loc = match ty with + | Some ty -> LiquidFromMicheline.convert_const_type env e ty + | None -> LiquidFromMicheline.convert_const_notype env e in + let nod_e = LiquidInterp.decompile_const loc mic_e in + let syn_e = LiquidDecomp.decompile_const nod_e in + let tenv = + LiquidTypes.empty_typecheck_env ~warnings:false + LiquidTypes.dummy_contract_sig + (LiquidFromParsetree.initial_env "") in + LiquidCheck.typecheck_const tenv ?expected_ty:ty ~loc syn_e + |> LiquidSimplify.simplify_const + |> LiquidUntype.untype_const + +let compile_datatype ty = + LiquidToMicheline.convert_type (LiquidEncode.encode_type ty) + + +module NoConverter : + (CONVERTER with type source_from_datatype := Liquidity.datatype + and type source_from_const := Liquidity.const + and type source_from_contract := Liquidity.contract + and type source_dest_datatype := Liquidity.datatype + and type source_dest_const := Liquidity.const + and type source_dest_contract := Liquidity.contract + and type target_from_datatype := Michelson.datatype + and type target_from_const := Michelson.const + and type target_from_contract := Michelson.contract + and type target_dest_datatype := Michelson.datatype + and type target_dest_const := Michelson.const + and type target_dest_contract := Michelson.contract) += struct + type source_from_datatype = Liquidity.datatype + type source_from_const = Liquidity.const + type source_from_contract = Liquidity.contract + type source_dest_datatype = Liquidity.datatype + type source_dest_const = Liquidity.const + type source_dest_contract = Liquidity.contract + type target_from_datatype = Michelson.datatype + type target_from_const = Michelson.const + type target_from_contract = Michelson.contract + type target_dest_datatype = Michelson.datatype + type target_dest_const = Michelson.const + type target_dest_contract = Michelson.contract + module SourceConv = struct + let parse_const x = x + let parse_contract x = x + let parse_datatype x = x + let print_const x = x + let print_contract x = x + let print_datatype x = x + end + module TargetConv = struct + let parse_const x = x + let parse_contract x = x + let parse_datatype x = x + let print_const x = x + let print_contract x = x + let print_datatype x = x + end +end + +module StringLiquidity = struct + type datatype = string + type const = string + type contract = from +end + +module StringMichelson = struct + type datatype = string + type const = string + type contract = string +end + +module JsonMichelson = struct + type datatype = Ezjsonm.value + type const = Ezjsonm.value + type contract = Ezjsonm.value +end + + +module StringMichelsonConv : + (CONV + with type dest_const := Michelson.const + and type dest_contract := Michelson.contract + and type dest_datatype := Michelson.datatype + and type from_const := string + and type from_contract := string + and type from_datatype := string) = struct + + let parse_const s = + match LiquidFromMicheline.const_of_string "michelson" s with + | None -> assert false + | Some (c, _) -> c + + let parse_datatype s = parse_const s + + let parse_contract s = + match LiquidFromMicheline.contract_of_string "michelson" s with + | None -> assert false + | Some (c, _) -> c + + let print_const c = + if !LiquidOptions.singleline + then LiquidToMicheline.line_of_const c + else LiquidToMicheline.string_of_const c + + let print_datatype c = + if !LiquidOptions.singleline + then LiquidToMicheline.line_of_const c + else LiquidToMicheline.string_of_const c + + let print_contract c = + if !LiquidOptions.singleline + then LiquidToMicheline.line_of_contract c + else LiquidToMicheline.string_of_contract c +end + +module StringStringConverter : + (CONVERTER with type source_from_datatype := string + and type source_from_const := string + and type source_from_contract := from + and type source_dest_datatype := Liquidity.datatype + and type source_dest_const := Liquidity.const + and type source_dest_contract := Liquidity.contract + and type target_from_datatype := string + and type target_from_const := string + and type target_from_contract := string + and type target_dest_datatype := Michelson.datatype + and type target_dest_const := Michelson.const + and type target_dest_contract := Michelson.contract) = struct + module SourceConv = StringLiquidityConv + module TargetConv = StringMichelsonConv +end + +module StringJsonConverter : + (CONVERTER with type source_from_datatype := string + and type source_from_const := string + and type source_from_contract := from + and type source_dest_datatype := Liquidity.datatype + and type source_dest_const := Liquidity.const + and type source_dest_contract := Liquidity.contract + and type target_from_datatype := Ezjsonm.value + and type target_from_const := Ezjsonm.value + and type target_from_contract := Ezjsonm.value + and type target_dest_datatype := Michelson.datatype + and type target_dest_const := Michelson.const + and type target_dest_contract := Michelson.contract) = struct + + module SourceConv = StringLiquidityConv + + module TargetConv = struct + let parse_const = Json_encoding.destruct Target.const_encoding + let parse_datatype = Json_encoding.destruct Target.datatype_encoding + let parse_contract = Json_encoding.destruct Target.contract_encoding + let print_const = Json_encoding.construct Target.const_encoding + let print_datatype = Json_encoding.construct Target.datatype_encoding + let print_contract = Json_encoding.construct Target.contract_encoding + end +end + +module MultiLiquidity = struct + type const = Source.const Lazy_superposed.t + type contract = Source.contract Lazy_superposed.t + type datatype = Source.datatype Lazy_superposed.t +end + +module MultiMichelson = struct + type const = Target.const Lazy_superposed.t + type contract = Target.contract Lazy_superposed.t + type datatype = Target.datatype Lazy_superposed.t +end + +module LiquidityConstMulti = Lazy_superposed.Make(struct + type t = Liquidity.const + let parse = StringLiquidityConv.parse_const + let print = StringLiquidityConv.print_const + let encoding = Liquidity.const_encoding + end) + +module LiquidityContractMulti = Lazy_superposed.Make(struct + type t = Liquidity.contract + let parse s = StringLiquidityConv.parse_contract (From_strings [s]) + let print c = match StringLiquidityConv.print_contract c with + | From_strings [s] -> s + | _ -> assert false + let encoding = Liquidity.contract_encoding + end) + +module LiquidityDatatypeMulti = Lazy_superposed.Make(struct + type t = Liquidity.datatype + let parse = StringLiquidityConv.parse_datatype + let print = StringLiquidityConv.print_datatype + let encoding = Liquidity.datatype_encoding + end) + +module MichelsonConstMulti = Lazy_superposed.Make(struct + type t = Michelson.const + let parse = StringMichelsonConv.parse_const + let print = StringMichelsonConv.print_const + let encoding = Michelson.const_encoding + end) + +module MichelsonContractMulti = Lazy_superposed.Make(struct + type t = Michelson.contract + let parse = StringMichelsonConv.parse_contract + let print = StringMichelsonConv.print_contract + let encoding = Michelson.contract_encoding + end) + +module MichelsonDatatypeMulti = Lazy_superposed.Make(struct + type t = Michelson.datatype + let parse = StringMichelsonConv.parse_datatype + let print = StringMichelsonConv.print_datatype + let encoding = Michelson.datatype_encoding + end) + +module MultiConverter : + (CONVERTER with type source_from_datatype := Liquidity.datatype Lazy_superposed.t + and type source_from_const := Liquidity.const Lazy_superposed.t + and type source_from_contract := Liquidity.contract Lazy_superposed.t + and type source_dest_datatype := Liquidity.datatype + and type source_dest_const := Liquidity.const + and type source_dest_contract := Liquidity.contract + and type target_from_datatype := Michelson.datatype Lazy_superposed.t + and type target_from_const := Michelson.const Lazy_superposed.t + and type target_from_contract := Michelson.contract Lazy_superposed.t + and type target_dest_datatype := Michelson.datatype + and type target_dest_const := Michelson.const + and type target_dest_contract := Michelson.contract) = struct + + module SourceConv = struct + let parse_const = LiquidityConstMulti.force_ast + let parse_datatype = LiquidityDatatypeMulti.force_ast + let parse_contract = LiquidityContractMulti.force_ast + let print_const x = Lazy_superposed.ast x + let print_datatype x = Lazy_superposed.ast x + let print_contract x = Lazy_superposed.ast x + end + + module TargetConv = struct + let parse_const = MichelsonConstMulti.force_ast + let parse_datatype = MichelsonDatatypeMulti.force_ast + let parse_contract = MichelsonContractMulti.force_ast + let print_const x = Lazy_superposed.ast x + let print_datatype x = Lazy_superposed.ast x + let print_contract x = Lazy_superposed.ast x + end +end diff --git a/tools/client/liquidityToMichelsonClient.ml b/tools/client/liquidityToMichelsonClient.ml new file mode 100644 index 00000000..115f3395 --- /dev/null +++ b/tools/client/liquidityToMichelsonClient.ml @@ -0,0 +1,29 @@ +open LiquidityToMichelson + +module AST = + LiquidClient.Make + (LiquidityToMichelson) + (Liquidity) + (Michelson) + (NoConverter) + +module String = + LiquidClient.Make + (LiquidityToMichelson) + (StringLiquidity) + (StringMichelson) + (StringStringConverter) + +module SJson = + LiquidClient.Make + (LiquidityToMichelson) + (StringLiquidity) + (JsonMichelson) + (StringJsonConverter) + +module Multi = + LiquidClient.Make + (LiquidityToMichelson) + (MultiLiquidity) + (MultiMichelson) + (MultiConverter) diff --git a/tools/liquidity/build.ocp2 b/tools/liquidity/build.ocp2 index 2c4068c1..faa2342f 100644 --- a/tools/liquidity/build.ocp2 +++ b/tools/liquidity/build.ocp2 @@ -41,30 +41,73 @@ *) +version = "2.0"; + if(with_version){ - version_info = { ocp2ml=true; - env_strings = [ - "ocp::commit"; - "ocp::dates"; - ]; }; -} else { + version_info = { ocp2ml=true; + env_strings = [ + "ocp::commit"; + "ocp::dates"; + ]; }; + } else { version_info = {}; } -OCaml.library("ocplib-liquidity-bare", +OCaml.library("ocplib-liquidity-version", ocaml + { + version=version; files = [ + "liquidVersion.ml", version_info; + ]; + }); +OCaml.library("ocplib-liquidity-options", + ocaml + { + files = [ "liquidOptions.ml"; - "liquidVersion.ml", version_info; + ]; + requires = [ + "ocplib-liquidity-number"; + ]; + }); + +OCaml.library("ocplib-liquidity-misc", + ocaml + { + files = [ "liquidMisc.ml"; + ]; + }); - "liquidTypes.ml"; +OCaml.library("ocplib-liquidity-number", + ocaml + { + files = [ "liquidNumber.ml"; ]; requires = [ "zarith"; ]; + }); + +OCaml.library("ocplib-liquidity-types", + ocaml + { + files = [ + "liquidTypes.ml"; + ]; + requires = [ + "ocplib-liquidity-number"; + "ocplib-liquidity-options"; + ]; + }); + +OCaml.library("ocplib-liquidity-bare", + ocaml + { + requires = [ + "ocplib-liquidity-version"; + "ocplib-liquidity-number"; + "ocplib-liquidity-types"; + "ocplib-liquidity-misc"; + "ocplib-liquidity-options"; + ]; }); @@ -113,6 +156,7 @@ OCaml.library("ocplib-liquidity-base", files = [ "iSO8601.ml"; + "liquidInfomark.ml"; "liquidBoundVariables.ml"; @@ -136,6 +180,8 @@ OCaml.library("ocplib-liquidity-base", ]; requires = [ "ocplib-liquidity-parser"; + "calendar"; + "hex"; ]; }); @@ -157,31 +203,32 @@ OCaml.library("ocplib-liquidity-with-dune-network", ]; }); -OCaml.library("ocplib-liquidity-deploy", +OCaml.library("ocplib-liquidity-init", ocaml + { files = [ "liquidInit.ml"; - "liquidDeploy.ml"; ]; requires = [ - "ocplib-liquidity-with-dune-network"; - "ocplib-liquidity-parser"; - "curl"; - "curl.lwt"; + "ocplib-liquidity-base"; ]; }); + if (for_javascript) { OCaml.program("liquidity", ocaml + { files = [ "liquidDot.ml"; + "liquidCommonArgs.ml"; "liquidMain.ml"; ]; requires = [ "ocplib-dot"; - "ocplib-liquidity-deploy"; "ocplib-file"; + "ocplib-liquidity-with-dune-network"; + "ocplib-liquidity-base"; + "ocplib-liquidity-init"; + "ezcmd"; ]; }); } else { @@ -190,12 +237,16 @@ OCaml.program("liquidity", bytelink = ["-cclib"; "-lsodium_stubs -lsodium"]; files = [ "liquidDot.ml"; + "liquidCommonArgs.ml"; "liquidMain.ml"; ]; requires = [ "ocplib-dot"; - "ocplib-liquidity-deploy"; "ocplib-file"; + "ocplib-liquidity-with-dune-network"; + "ocplib-liquidity-base"; + "ocplib-liquidity-init"; + "ezcmd"; ]; }); } @@ -215,31 +266,21 @@ OCaml.library("ocplib-liquidity-without-dune-network", ]; }); -OCaml.library("ocplib-liquidity-deploy-without-dune-network", - ocaml + { - files = [ - "without-dune-network/liquidDeploy.ml"; - ]; - requires = [ - "ocplib-liquidity-base"; - "ocplib-liquidity-without-dune-network"; - "ocplib-fake-lwt" - ]; - }); - OCaml.program("liquidity-mini", ocaml + { files = [ "liquidInit.ml"; "liquidDot.ml"; + "liquidCommonArgs.ml"; "liquidMain.ml"; ]; requires = [ "ocplib-dot"; - "ocplib-liquidity-deploy-without-dune-network"; "ocplib-liquidity-without-dune-network"; "ocplib-liquidity-base"; + "ocplib-liquidity-init"; "ocplib-file"; + "ezcmd"; ]; }); diff --git a/tools/liquidity/liquidBoundVariables.ml b/tools/liquidity/liquidBoundVariables.ml index 785ee088..be55298e 100644 --- a/tools/liquidity/liquidBoundVariables.ml +++ b/tools/liquidity/liquidBoundVariables.ml @@ -76,8 +76,12 @@ let rec bv code = (StringSet.remove tail_name.nname (bv ifcons)))) + | Self _ -> StringSet.empty + | Transfer { dest; amount } -> StringSet.union (bv dest) (bv amount) + | SelfCall { amount; arg } -> StringSet.union (bv arg) (bv amount) + | Call { contract; amount; entry; arg } -> List.fold_left (fun set exp -> StringSet.union set (bv exp) @@ -133,16 +137,17 @@ let rec bv code = and bv_const const = match const with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) -> StringSet.empty + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _ ) -> StringSet.empty | CSome x | CLeft x | CRight x | CConstr (_, x) -> bv_const x | CTuple xs | CList xs | CSet xs -> List.fold_left (fun acc x -> StringSet.union acc (bv_const x)) StringSet.empty xs - | CMap l | CBigMap l -> + | CMap l | CBigMap BMList l -> List.fold_left (fun acc (x, y) -> StringSet.union acc (StringSet.union (bv_const x) (bv_const y))) StringSet.empty l + | CBigMap BMId _ -> StringSet.empty | CRecord labels -> List.fold_left (fun acc (_, x) -> StringSet.union acc (bv_const x)) @@ -294,6 +299,10 @@ let rec bound code = let desc = MatchList { arg; head_name; tail_name; ifcons; ifnil } in mk desc code bv + | Self { entry } -> + let desc = Self { entry } in + mk desc code StringSet.empty + | Transfer { dest; amount } -> let dest = bound dest in let amount = bound amount in @@ -301,6 +310,13 @@ let rec bound code = let desc = Transfer { dest; amount } in mk desc code bv + | SelfCall { amount; entry; arg } -> + let amount = bound amount in + let arg = bound arg in + let bv = StringSet.union arg.bv amount.bv in + let desc = SelfCall { amount; entry; arg } in + mk desc code bv + | Call { contract; amount; entry; arg } -> let contract = bound contract in let amount = bound amount in @@ -403,9 +419,9 @@ let rec bound code = let desc = CreateContract { args; contract } in mk desc code bv - | ContractAt { arg; c_sig } -> + | ContractAt { arg; entry; entry_param } -> let arg = bound arg in - let desc = ContractAt { arg; c_sig } in + let desc = ContractAt { arg; entry; entry_param } in mk desc code arg.bv | Unpack { arg; ty } -> @@ -424,8 +440,8 @@ let rec bound code = and bound_const = function | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _) as c -> c | CSome x -> CSome (bound_const x) | CLeft x -> CLeft (bound_const x) | CRight x -> CRight (bound_const x) @@ -434,8 +450,9 @@ and bound_const = function | CSet xs -> CSet (List.map (bound_const) xs) | CMap l -> CMap (List.map (fun (x,y) -> bound_const x, bound_const y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> bound_const x, bound_const y) l) + | CBigMap BMList l -> + CBigMap (BMList (List.map (fun (x,y) -> bound_const x, bound_const y) l)) + | CBigMap BMId _ as c -> c | CRecord labels -> CRecord (List.map (fun (f, x) -> f, bound_const x) labels) | CConstr (constr, x) -> diff --git a/tools/liquidity/liquidCheck.ml b/tools/liquidity/liquidCheck.ml index 97151ff7..fef4a827 100644 --- a/tools/liquidity/liquidCheck.ml +++ b/tools/liquidity/liquidCheck.ml @@ -226,7 +226,8 @@ let rec type_of_const ~loc env = function | CBytes _ -> Tbytes | CKey _ -> Tkey | CSignature _ -> Tsignature - | CAddress _ -> Taddress + | CContract (_, None) -> Taddress + | CContract (_, entry) -> Tcontract (entry, fresh_tvar ()) | CTuple l -> Ttuple (List.map (type_of_const ~loc env) l) | CNone -> Toption (fresh_tvar ()) @@ -234,8 +235,8 @@ let rec type_of_const ~loc env = function | CMap [] -> Tmap (fresh_tvar (), fresh_tvar ()) | CMap ((k,e) :: _) -> Tmap (type_of_const ~loc env k, type_of_const ~loc env e) - | CBigMap [] -> Tbigmap (fresh_tvar (), fresh_tvar ()) - | CBigMap ((k,e) :: _) -> Tbigmap (type_of_const ~loc env k, type_of_const ~loc env e) + | CBigMap (BMList [] | BMId _)-> Tbigmap (fresh_tvar (), fresh_tvar ()) + | CBigMap BMList ((k,e) :: _) -> Tbigmap (type_of_const ~loc env k, type_of_const ~loc env e) | CList [] -> Tlist (fresh_tvar ()) | CList (e :: _) -> Tlist (type_of_const ~loc env e) @@ -247,11 +248,12 @@ let rec type_of_const ~loc env = function | CRight c -> Tor (fresh_tvar (), type_of_const ~loc env c) | CKey_hash _ -> Tkey_hash - | CContract _ -> Tcontract (contract_sig_of_param (fresh_tvar ())) | CRecord [] -> assert false | CRecord ((label, _) :: _ as fields) -> - let ty, _ = find_label ~loc label env.env in + let ty, _ = + try find_label ~loc label env.env + with Not_found -> error loc "unbound record field %S" label in begin match ty with | Trecord (n, l) -> let l = List.map2 (fun (lab_c, c) (lab_t, t) -> @@ -261,7 +263,10 @@ let rec type_of_const ~loc env = function | _ -> assert false end | CConstr (constr, c) -> - let ty, (constr, _, i) = find_constr ~loc constr env.env in + let ty, (constr, _, i) = + try find_constr ~loc constr env.env + with Not_found -> + error loc "unbound constructor %S" constr in begin match ty with | Tsum (n, l) -> let l = List.mapi (fun j ((constr, t) as ct) -> @@ -298,7 +303,7 @@ let rec set_uncurry exp = set_uncurry f | _ -> () -let rec typecheck_const ~loc env cst ty = +let rec typecheck_const ~loc env (cst : syntax_const) ty : datatype * typed_const = match ty, cst with (* No implicit conversions *) | ( Tunit, CUnit @@ -311,7 +316,6 @@ let rec typecheck_const ~loc env cst ty = | Tkey, CKey _ | Tkey_hash, CKey_hash _ | Tcontract _, CContract _ - | Taddress, CAddress _ | Ttimestamp, CTimestamp _ | Tsignature, CSignature _ | Toption _, CNone) as ty_cst @@ -322,24 +326,47 @@ let rec typecheck_const ~loc env cst ty = | Tnat, CInt s -> ty, CNat s | Tkey, CBytes s -> ty, CKey s | Tkey_hash, CBytes s -> ty, CKey_hash s - | Tcontract _, CAddress s -> ty, CAddress s - | Tcontract { entries_sig = [{ parameter = (Tunit | Tvar _ as p)}] }, - CKey_hash s -> - unify loc p Tunit; - ty, CKey_hash s - | Tcontract _, CBytes s -> ty, CContract s - | Taddress, CContract s -> ty, CContract s | Taddress, CKey_hash s -> ty, CKey_hash s - | Taddress, CBytes s -> ty, CContract s + | Taddress, CBytes s -> ty, CContract(s, None) | Tsignature, CBytes s -> ty, CSignature s + | Tcontract ((None | Some "default"), (Tunit | Tvar _ as p)), CKey_hash s -> + unify loc p Tunit; + ty, CKey_hash s + | Tcontract (entry,_), CBytes s -> + let len = String.length s in + if len < 46 then + error loc "constant %s is too short to be a contract" s; + let e = String.sub s 46 (len - 46) in + let e = Hex.to_string (`Hex e) in + begin if e = "" then + match entry with + | None | Some "default" -> () + | Some entry -> + error loc "constant contract is for entry point default \ + but should be for entry point %s" entry + else + match entry with + | None -> + error loc "constant contract is for entry point %s \ + but should be for entry point default" e + | Some entry when e <> entry -> + error loc "constant contract is for entry point %s \ + but should be for entry point %s" e entry + | _ -> () + end; + ty, CBytes s + | Taddress, CContract (s, e) -> ty, CContract (s, e) + | Ttimestamp, CString s -> ty, CTimestamp (ISO8601.of_string s) | Ttez, CString s -> ty, CTez (LiquidNumber.tez_of_liq s) | Tkey_hash, CString s -> ty, CKey_hash s - | Tcontract _, CString s -> ty, CContract s | Tkey, CString s -> ty, CKey s | Tsignature, CString s -> ty, CSignature s + | Tchainid, CString s -> ty, CString s + | Tchainid, CBytes s -> ty, CBytes s + (* Structures *) | Ttuple tys, CTuple csts -> begin @@ -375,7 +402,7 @@ let rec typecheck_const ~loc env cst ty = (string_of_type ty); Tmap (ty1, ty2), CMap csts - | Tbigmap (ty1, ty2), (CMap csts | CBigMap csts) -> (* allow map *) + | Tbigmap (ty1, ty2), (CMap csts | CBigMap BMList csts) -> (* allow map *) let (ty1, ty2), csts = List.fold_left (fun ((ty1, ty2), acc) (cst1, cst2) -> let ty1, cst1 = typecheck_const ~loc env cst1 ty1 in let ty2, cst2 = typecheck_const ~loc env cst2 ty2 in @@ -385,7 +412,12 @@ let rec typecheck_const ~loc env cst ty = if not @@ comparable_type ty1 then error loc "Keys of big map are of a non comparable type %s" (string_of_type ty); - Tbigmap (ty1, ty2), CBigMap csts + Tbigmap (ty1, ty2), CBigMap (BMList csts) + | Tbigmap (ty1, ty2), CBigMap BMId id -> (* allow map *) + if not @@ comparable_type ty1 then + error loc "Keys of big map are of a non comparable type %s" + (string_of_type ty); + Tbigmap (ty1, ty2), CBigMap (BMId id) | Tlist ty, CList csts -> let ty, csts = List.fold_left (fun (ty, acc) cst -> @@ -434,7 +466,24 @@ let rec typecheck_const ~loc env cst ty = let labels, fields = List.split (mk labels csts) in Trecord (rname, labels), CRecord fields - | Tsum (sname, constrs), CConstr (c, cst) -> + | Tsum (None, constrs), CConstr (c, cst) -> + let constrs, cst = try + let ty = List.assoc c constrs in + let ty, cst = typecheck_const ~loc env cst ty in + let constrs = + List.map (fun (c, t) -> if eq_types t ty then (c, ty) else (c, t)) constrs in + constrs, cst + with Not_found -> + let ty, cst = + typecheck_const ~loc env cst (type_of_const ~loc env cst) in + let constrs = constrs @ [c, ty] in + constrs, cst + in + let ty = Tsum (None, constrs) in + let c = CConstr (c, cst) in + (ty, c) + + | Tsum (Some sname, constrs), CConstr (c, cst) -> let ty = try List.assoc c constrs with Not_found -> @@ -442,7 +491,7 @@ let rec typecheck_const ~loc env cst ty = let ty, cst = typecheck_const ~loc env cst ty in let constrs = List.map (fun (c, t) -> if eq_types t ty then (c, ty) else (c, t)) constrs in - let ty = Tsum (sname, constrs) in + let ty = Tsum (Some sname, constrs) in let c = CConstr (c, cst) in (ty, c) @@ -454,7 +503,7 @@ let rec typecheck_const ~loc env cst ty = (c, ty, cst) | _ :: constrs, CRight cst -> seek constrs cst | _, _ -> - error loc "Constant cannot be converted to type %s" sname + error loc "Constant cannot be converted to type %s" (string_of_type ty) in let c, ty, cst = seek constrs cst in let constrs = @@ -466,9 +515,10 @@ let rec typecheck_const ~loc env cst ty = ty, CLambda lam | Tvar tv, c -> - unify loc ty (type_of_const ~loc env c); let ty = match (Ref.get tv).tyo with - | None -> ty + | None -> + unify loc ty (type_of_const ~loc env c); + ty | Some ty -> ty in typecheck_const ~loc env c ty @@ -578,57 +628,100 @@ and typecheck env ( exp : syntax_exp ) : typed_exp = let desc = If { cond; ifthen; ifelse } in mk ?name:exp.name ~loc desc ty + | Self { entry } -> + let self_entries = env.t_contract_sig.f_entries_sig in + let parameter = + match List.find_opt (fun e -> e.entry_name = entry) self_entries with + | Some e -> e.parameter + | None -> + error loc + "contract has no entry point %s (available entry points: %a)" + entry + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") + (fun fmt e -> Format.pp_print_string fmt e.entry_name)) + self_entries; + in + let ty = Tcontract (Some entry, parameter) in + let desc = Self { entry } in + mk ?name:exp.name ~loc desc ty + | Transfer { dest; amount } -> let amount = typecheck_expected "transfer amount" env Ttez amount in let dest = typecheck_expected "transfer destination" env Tkey_hash dest in let desc = Transfer { dest; amount } in mk ?name:exp.name ~loc desc Toperation + | SelfCall { amount; entry; arg } -> + let amount = typecheck_expected "call amount" env Ttez amount in + let self_entries = env.t_contract_sig.f_entries_sig in + let arg = match List.find_opt (fun e -> e.entry_name = entry) self_entries with + | Some e -> typecheck_expected "call argument" env e.parameter arg + | None -> + (* if env.decompiling then + * typecheck env arg + * else *) + error loc + "contract has no entry point %s (available entry points: %a)" + entry + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") + (fun fmt e -> Format.pp_print_string fmt e.entry_name)) + self_entries; + in + let desc = SelfCall { amount; entry; arg } in + mk ?name:exp.name ~loc desc Toperation + | Call { contract; amount; entry; arg } -> let amount = typecheck_expected "call amount" env Ttez amount in let contract = typecheck env contract in - let entry' = match entry with None -> "main" | Some e -> e in - begin - match expand contract.ty with - | Tcontract contract_sig -> - begin try - let { parameter = arg_ty } = - List.find (fun { entry_name } -> entry_name = entry') - contract_sig.entries_sig in - let arg = typecheck_expected "call argument" env arg_ty arg in - if amount.transfer || contract.transfer || arg.transfer then - error loc "transfer within transfer arguments"; - let desc = Call { contract; amount; entry; arg } in - mk ?name:exp.name ~loc desc Toperation - with Not_found -> - error loc - "contract has no entry point %s (available entry points: %a)" - entry' - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") - Format.pp_print_string) - (List.map (fun e -> e.entry_name) contract_sig.entries_sig); - end - | Tvar _ | Tpartial _ -> + let arg, entry = + match expand contract.ty, entry with + | Tcontract (Some c_entry, arg_ty), Some entry + when not env.decompiling && entry <> c_entry -> + error loc + "contract handle is for entry point %s, \ + but is called with entry point %s" + c_entry entry + | Tcontract (e, arg_ty), entry -> + let entry = match e, entry with + | None, None -> None + | Some e, _ | _, Some e -> Some e in + typecheck_expected "call argument" env arg_ty arg, entry + | Taddress, Some _ -> typecheck env arg, entry + | Tvar _, Some _ -> let arg = typecheck env arg in - if amount.transfer || contract.transfer || arg.transfer then - error loc "transfer within transfer arguments"; - unify contract.ty (Tpartial (Pcont [(entry', arg.ty)])); - let desc = Call { contract; amount; entry; arg } in - mk ?name:exp.name ~loc desc Toperation - | ty -> + unify contract.ty Taddress; + arg, entry + | (Taddress | Tvar _), None -> + error loc "contract call on address must specify an entry point" + | Tpartial (Pcont pe), _ -> + let entry = match pe, entry with + | None, None -> None + | _, Some e | Some (e, _), _ -> Some e in + let arg = typecheck env arg in + unify contract.ty (Tcontract (entry, arg.ty)); + arg, entry + | ty, _ -> error contract.loc - "Bad contract type.\nExpected type:\n .instance\n\ + "Bad contract type.\nAllowed types:\n \ + - Contract handle%s\n \ + - address\n\ Actual type:\n %s" + (match entry with + | None -> "" + | Some e -> " for entry point " ^ e) (string_of_type ty) - end + in + let desc = Call { contract; amount; entry; arg } in + mk ?name:exp.name ~loc desc Toperation - (* contract.main (param) amount *) + (* contract.entry_name (param) amount *) | Apply { prim = Prim_exec _; args = { desc = Project { field = entry; record = contract }} :: [param; amount] } when match (typecheck env contract).ty with - | Tcontract _ -> true + | Tcontract _ | Taddress -> true | _ -> false -> typecheck env @@ -1218,23 +1311,19 @@ and typecheck env ( exp : syntax_exp ) : typed_exp = let desc = Unpack { arg; ty } in mk ?name:exp.name ~loc desc (Toption ty) - | ContractAt { arg; c_sig } -> - let arg = typecheck_expected "Contract.at argument" env Taddress arg in - let desc = ContractAt { arg; c_sig } in - mk ?name:exp.name ~loc desc (Toption (Tcontract c_sig)) + | ContractAt { arg; entry; entry_param } -> + let arg = typecheck_expected "[%%handle ...] argument" env Taddress arg in + let desc = ContractAt { arg; entry; entry_param } in + mk ?name:exp.name ~loc desc (Toption (Tcontract (Some entry, entry_param))) | CreateContract { args; contract } -> let contract = typecheck_contract ~warnings:env.warnings ~others:env.visible_contracts ~decompiling:env.decompiling contract in begin match args with - | [manager; delegate; spendable; delegatable; init_balance; init_storage] -> - let manager = typecheck_expected "manager" env Tkey_hash manager in + | [delegate; init_balance; init_storage] -> let delegate = typecheck_expected "delegate" env (Toption Tkey_hash) delegate in - let spendable = typecheck_expected "spendable" env Tbool spendable in - let delegatable = - typecheck_expected "delegatable" env Tbool delegatable in let init_balance = typecheck_expected "initial balance" env Ttez init_balance in let contract_storage_type = @@ -1242,12 +1331,11 @@ and typecheck env ( exp : syntax_exp ) : typed_exp = let init_storage = typecheck_expected "initial storage" env contract_storage_type init_storage in let desc = CreateContract { - args = [manager; delegate; spendable; - delegatable; init_balance; init_storage]; + args = [delegate; init_balance; init_storage]; contract } in mk ?name:exp.name ~loc desc (Ttuple [Toperation; Taddress]) | _ -> - error loc "Contract.create expects 7 arguments, was given %d" + error loc "Contract.create expects 3 arguments, was given %d" (List.length args) end @@ -1514,15 +1602,17 @@ and typecheck_prim2i env prim loc args = | Prim_map_size, [ ty ] -> unify ty (Tmap (fresh_tvar (), fresh_tvar ())); Tnat - | Prim_Some, [ ty ] -> Toption ty + | Prim_big_map_create, [ ty ] -> + unify ty Tunit; + Tbigmap (fresh_tvar (), fresh_tvar ()) - | Prim_self, [ ty ] -> - unify ty Tunit; Tcontract (sig_of_full_sig env.t_contract_sig) + | Prim_Some, [ ty ] -> Toption ty | Prim_now, [ ty ] -> unify ty Tunit; Ttimestamp | ( Prim_balance | Prim_amount ), [ ty ] -> unify ty Tunit; Ttez | ( Prim_source | Prim_sender ), [ ty ] -> unify ty Tunit; Taddress | Prim_gas, [ ty ] -> unify ty Tunit; Tnat + | Prim_chain_id, [ ty ] -> unify ty Tunit; Tchainid | Prim_pack, [ ty ] -> Tbytes @@ -1535,17 +1625,12 @@ and typecheck_prim2i env prim loc args = | Prim_check, [ ty1; ty2; ty3 ] -> unify ty1 Tkey; unify ty2 Tsignature; unify ty3 Tbytes; Tbool - | Prim_address, [ ty ] -> - unify ty (Tpartial (Pcont [])); + | (Prim_address | Prim_address_untype), [ ty ] -> + unify ty (Tpartial (Pcont None)); Taddress - | Prim_create_account, [ ty1; ty2; ty3; ty4 ] -> - unify ty1 Tkey_hash; unify ty2 (Toption Tkey_hash); - unify ty3 Tbool; unify ty4 Ttez; - Ttuple [Toperation; Taddress] - | Prim_default_account, [ ty ] -> - unify ty Tkey_hash; Tcontract unit_contract_sig + unify ty Tkey_hash; unit_contract_ty | Prim_set_delegate, [ ty ] -> unify ty (Toption Tkey_hash); Toperation @@ -1582,7 +1667,7 @@ and typecheck_prim2i env prim loc args = unify ty1 Tnat; unify ty2 Tnat; unify ty3 Tbytes; Toption Tbytes | Prim_get_balance, [ ty ] -> - unify ty (Tpartial (Pcont [])); + unify ty (Tpartial (Pcont None)); Ttez | Prim_block_level, [ ty ] -> @@ -1594,7 +1679,7 @@ and typecheck_prim2i env prim loc args = Tbool | Prim_is_implicit, [ ty ] -> - unify ty (Tpartial (Pcont ["main", Tunit])); + unify ty (Tpartial (Pcont (Some ("default", Tunit)))); Toption Tkey_hash | _ -> failwith ("typecheck_prim2i " ^ @@ -1723,6 +1808,9 @@ and typecheck_prim2t env prim loc args = | Prim_set_size, [ Tset _] -> Tnat | Prim_map_size, [ Tmap _] -> Tnat + | Prim_big_map_create, [ Tunit ] -> + Tbigmap (fresh_tvar (), fresh_tvar ()) + | Prim_set_update, [ key_ty; Tbool; Tset expected_key_ty] -> fail_neq ~loc ~expected_ty:expected_key_ty key_ty @@ -1740,7 +1828,6 @@ and typecheck_prim2t env prim loc args = Tset key_ty | Prim_Some, [ ty ] -> Toption ty - | Prim_self, [ Tunit ] -> Tcontract (sig_of_full_sig env.t_contract_sig) | Prim_now, [ Tunit ] -> Ttimestamp | Prim_balance, [ Tunit ] -> Ttez | Prim_source, [ Tunit ] -> Taddress @@ -1752,23 +1839,17 @@ and typecheck_prim2t env prim loc args = | Prim_sha256, [ Tbytes ] -> Tbytes | Prim_sha512, [ Tbytes ] -> Tbytes | Prim_hash_key, [ Tkey ] -> Tkey_hash + | Prim_chain_id, [ Tunit ] -> Tchainid | Prim_check, [ Tkey; Tsignature; Tbytes ] -> Tbool | Prim_check, _ -> error_prim loc Prim_check args [Tkey; Tsignature; Tbytes] - | Prim_address, [ Tcontract _ ] -> + | (Prim_address | Prim_address_untype), [ Tcontract _ ] -> Taddress - | Prim_create_account, [ Tkey_hash; Toption Tkey_hash; Tbool; Ttez ] -> - Ttuple [Toperation; Taddress] - | Prim_create_account, _ -> - error_prim loc Prim_create_account args - [ Tkey_hash; Toption Tkey_hash; Tbool; Ttez ] - - | Prim_default_account, [ Tkey_hash ] -> - Tcontract unit_contract_sig + | Prim_default_account, [ Tkey_hash ] -> unit_contract_ty | Prim_set_delegate, [ Toption Tkey_hash ] -> Toperation @@ -1802,9 +1883,11 @@ and typecheck_prim2t env prim loc args = | Prim_bytes_sub, [ Tnat; Tnat; Tbytes ] -> Toption Tbytes | Prim_get_balance, [ Tcontract _ ] -> Ttez + (* XXX : should be address -> tez option *) + | Prim_block_level, [ Tunit ] -> Tnat | Prim_collect_call, [ Tunit ] -> Tbool - | Prim_is_implicit, [ Tcontract { entries_sig = [{ parameter = Tunit }] } ] -> + | Prim_is_implicit, [ Tcontract ((None | Some "default"), Tunit) ] -> Toption Tkey_hash | prim, args_tys -> @@ -1878,15 +1961,16 @@ and expected_prim_types = function | Prim_Some | Prim_pack -> 1, "'a" - | Prim_self | Prim_now | Prim_balance | Prim_source | Prim_sender | Prim_amount | Prim_gas + | Prim_chain_id | Prim_block_level - | Prim_collect_call -> + | Prim_collect_call + | Prim_big_map_create -> 1, "unit" | Prim_blake2b @@ -1900,14 +1984,8 @@ and expected_prim_types = function | Prim_check -> 3, "key, signature, bytes" - | Prim_address | Prim_get_balance -> - 1, ".instance" - - | Prim_create_account -> - 4, Printf.sprintf - "manager:key_hash, delegate:(key_hash option), \ - delegatable:bool, amount:%s" - (LiquidOptions.amount_type ()) + | Prim_address | Prim_get_balance | Prim_address_untype -> + 1, "" | Prim_default_account -> 1, "key_hash" @@ -2032,9 +2110,9 @@ and typecheck_contract ~others ~warnings ~decompiling contract = (* when decompiling recover signature of encoded Contract.self *) if not decompiling then t_contract_sig else match t_contract_sig.f_entries_sig with - | [{ entry_name = "main" } as e] -> + | [e] -> begin match expand e.parameter with - | Tsum ("_entries", l) -> + | Tsum (_, l) when List.for_all (fun (e,_) -> is_entry_case e) l -> let f_entries_sig = List.map (fun (c, parameter) -> { entry_name = entry_name_of_case c; parameter; @@ -2135,7 +2213,7 @@ let rec type_of_const = function | CBytes _ -> Tbytes | CKey _ -> Tkey | CSignature _ -> Tsignature - | CAddress _ -> Taddress + | CContract (_, e) -> Tcontract (e, Tunit) | CTuple l -> Ttuple (List.map type_of_const l) | CNone -> Toption Tunit @@ -2143,8 +2221,8 @@ let rec type_of_const = function | CMap [] -> Tmap (Tint, Tunit) | CMap ((k,e) :: _) -> Tmap (type_of_const k, type_of_const e) - | CBigMap [] -> Tbigmap (Tint, Tunit) - | CBigMap ((k,e) :: _) -> Tbigmap (type_of_const k, type_of_const e) + | CBigMap (BMList [] | BMId _) -> Tbigmap (Tint, Tunit) + | CBigMap BMList ((k,e) :: _) -> Tbigmap (type_of_const k, type_of_const e) | CList [] -> Tlist (Tunit) | CList (e :: _) -> Tlist (type_of_const e) @@ -2156,10 +2234,9 @@ let rec type_of_const = function | CRight c -> Tor (fresh_tvar (), type_of_const c) | CKey_hash _ -> Tkey_hash - | CContract _ -> Tcontract unit_contract_sig | CLambda { arg_ty; ret_ty } -> Tlambda (arg_ty, ret_ty, default_uncurry ()) (* XXX just for printing *) | CRecord _ -> Trecord ("", []) - | CConstr _ -> Tsum ("", []) + | CConstr _ -> Tsum (None, []) diff --git a/tools/liquidity/liquidCommonArgs.ml b/tools/liquidity/liquidCommonArgs.ml new file mode 100644 index 00000000..5b593ad7 --- /dev/null +++ b/tools/liquidity/liquidCommonArgs.ml @@ -0,0 +1,89 @@ +open Ezcmd.Modules + +let network_env = + let docs = Manpage.s_environment in + Ezcmd.env ~docs "LIQUID_NETWORK" + ~doc:"Network to use, possible values: $(i,Dune), $(i,Tezos)." + +let common = + let docs = Manpage.s_common_options in + [ + ["verbose"; "v"], + Arg.Unit (fun () -> incr LiquidOptions.verbosity), + Ezcmd.info ~docs "Increment verbosity"; + + ["V"], + Arg.Set_int LiquidOptions.verbosity, + Ezcmd.info ~docs ~docv:"level" "Verbosity level"; + + ["reason"; "re"], + Arg.Clear LiquidOptions.ocaml_syntax, + Ezcmd.info ~docs "Use ReasonML syntax"; + + ["version"], + Arg.Unit (fun () -> + Format.printf "%s" LiquidVersion.version; + if !LiquidOptions.verbosity > 0 then + Format.printf " (%s)" LiquidVersion.commit; + if !LiquidOptions.verbosity > 1 then + Format.printf "\nCompiled on %s" LiquidVersion.en_date; + Format.printf "@."; + exit 0 + ), + Ezcmd.info ~docs "Show version and exit"; + + ["network"; "N"], + Arg.Symbol (["dune"; "Dune"; "DUNE"; "tezos"; "Tezos"; "TEZOS"], + function + | "dune" | "Dune" | "DUNE" -> + LiquidOptions.network := Dune_network; + | "tezos" | "Tezos" | "TEZOS" -> + LiquidOptions.network := Tezos_network; + | s -> + Format.eprintf "%s not allowed for network@." s; + exit 1 + ), + Ezcmd.info ~docs ~docv:"NETWORK" ~env:network_env + "Set the network to use (possible values: $(i,Dune), $(i,Tezos))."; + + ["main"; "m"], + Arg.String (fun main -> LiquidOptions.main := Some main), + Ezcmd.info ~docs ~docv:"ContractName" + "Produce code for contract named $(docv)"; + + ["no-inline"], + Arg.Clear LiquidOptions.inline, + Ezcmd.info ~docs "Disable inlining"; + + ["no-simplify"], + Arg.Clear LiquidOptions.simplify, + Ezcmd.info ~docs "Disable simplifications"; + + ["no-peephole"], + Arg.Clear LiquidOptions.peephole, + Ezcmd.info ~docs "Disable peephole optimizations"; + + ["compact"; "c"], + Arg.Set LiquidOptions.singleline, + Ezcmd.info ~docs "Produce compact Michelson"; + + ["no-annot"], + Arg.Set LiquidOptions.no_annot, + Ezcmd.info ~docs "Don't produce any annotations when compiling"; + + ["no-ignore-annots"], + Arg.Clear LiquidOptions.retry_without_annots, + Ezcmd.info ~docs "Don't ignore annotations of failure when decompiling"; + + ["no-uncurry"], + Arg.Set LiquidOptions.no_uncurrying, + Ezcmd.info ~docs "Don't uncurry non partially applied lambdas"; + ] + + +let help_secs = [ + `S Manpage.s_common_options; + `P "These options are common to all commands."; + `S "MORE HELP"; + `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."; + `S Manpage.s_bugs; `P "Report bugs at https://github.com/OCamlPro/liquidity/issues.";] diff --git a/tools/liquidity/liquidData.ml b/tools/liquidity/liquidData.ml index a62b119c..3e761f8b 100644 --- a/tools/liquidity/liquidData.ml +++ b/tools/liquidity/liquidData.ml @@ -49,8 +49,11 @@ let rec default_const = function CSignature "edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk\ 68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7" - | Tcontract _ -> CContract "KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi" - | Taddress -> CAddress "KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi" + | Taddress | Tcontract ((None | Some "default"), _) -> + CContract ("KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi", None) + | Tcontract (e, _) -> + CContract ("KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi", e) + | Tchainid -> CString "NetXwhYbWGa82xo" | Ttuple l -> CTuple (List.map default_const l) | Toption ty -> CSome (default_const ty) @@ -58,8 +61,8 @@ let rec default_const = function | Tset ty -> CSet [default_const ty] | Tmap (ty1, ty2) -> CMap [default_const ty1, default_const ty2] - | Tbigmap (ty1, ty2) -> - CBigMap [default_const ty1, default_const ty2] + | Tbigmap (ty1, ty2) -> + CBigMap (BMList [default_const ty1, default_const ty2]) | Tor (ty, _) -> CLeft (default_const ty) | Trecord (_, fields) -> CRecord ( @@ -75,11 +78,16 @@ let rec default_const = function body = mk ~loc:noloc (Const { ty = ret_ty; const = default_const ret_ty }) ty } + | Tvar tv -> + (match (Ref.get tv).tyo with + | None -> raise Not_found + | Some ty -> default_const ty) + | Tsum (_, []) | Tfail | Tclosure _ | Toperation -> raise Not_found - | Tvar _ | Tpartial _ -> raise Not_found + | Tpartial _ -> raise Not_found let rec default_empty_const = function | Tunit -> CUnit @@ -96,15 +104,18 @@ let rec default_empty_const = function CSignature "edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk\ 68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7" - | Tcontract _ -> CContract "KT1GE2AZhazRxGsAjRVkQccHcB2pvANXQWd7" - | Taddress -> CAddress "KT1GE2AZhazRxGsAjRVkQccHcB2pvANXQWd7" + | Taddress | Tcontract ((None | Some "default"), _) -> + CContract ("KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi", None) + | Tcontract (e, _) -> + CContract ("KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi", e) + | Tchainid -> CString "NetXwhYbWGa82xo" | Ttuple l -> CTuple (List.map default_empty_const l) | Toption ty -> CNone | Tlist ty -> CList [] | Tset ty -> CSet [] | Tmap (ty1, ty2) -> CMap [] - | Tbigmap (ty1, ty2) -> CBigMap [] + | Tbigmap (ty1, ty2) -> CBigMap (BMList []) | Tor (ty, _) -> CLeft (default_empty_const ty) | Trecord (_, fields) -> CRecord ( @@ -124,13 +135,75 @@ let rec default_empty_const = function Tunit )) ty } + | Tvar tv -> + (match (Ref.get tv).tyo with + | None -> raise Not_found + | Some ty -> default_empty_const ty) + + | Tsum (_, []) + | Tfail + | Tclosure _ + | Toperation -> raise Not_found + | Tpartial _ -> raise Not_found + +let rec default_empty_untyped_const = function + | Tunit -> CUnit + | Tbool -> CBool false + | Tint -> CInt (LiquidNumber.integer_of_int 0) + | Tnat -> CNat (LiquidNumber.integer_of_int 0) + | Ttez -> CTez (LiquidNumber.tez_of_liq "0") + | Tstring -> CString "" + | Tbytes -> CBytes "0x" + | Ttimestamp -> CTimestamp "1970-01-01T00:00:00Z" + | Tkey -> CKey "edpkuit3FiCUhd6pmqf9ztUTdUs1isMTbF9RBGfwKk1ZrdTmeP9ypN" + | Tkey_hash -> CKey_hash (default_key_hash ()) + | Tsignature -> + CSignature + "edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk\ + 68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7" + | Taddress | Tcontract ((None | Some "default"), _) -> + CContract ("KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi", None) + | Tcontract (e, _) -> + CContract ("KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi", e) + | Tchainid -> CString "NetXwhYbWGa82xo" + | Ttuple l -> + CTuple (List.map default_empty_untyped_const l) + | Toption ty -> CNone + | Tlist ty -> CList [] + | Tset ty -> CSet [] + | Tmap (ty1, ty2) -> CMap [] + | Tbigmap (ty1, ty2) -> CBigMap (BMList []) + | Tor (ty, _) -> CLeft (default_empty_untyped_const ty) + | Trecord (_, fields) -> + CRecord ( + List.map (fun (name, ty) -> + name, default_empty_untyped_const ty) fields + ) + | Tsum (_, (c, ty) :: _) -> + CConstr (c, default_empty_untyped_const ty) + + + | Tlambda (arg_ty, ret_ty, _) -> + CLambda { arg_ty; ret_ty; recursive = None; + arg_name = { nname = "_"; nloc = noloc }; + body = mk ~loc:noloc + (Failwith + (mk ~loc:noloc (Const { ty = ret_ty; const = CUnit }) + () + )) () } + + | Tvar tv -> + (match (Ref.get tv).tyo with + | None -> raise Not_found + | Some ty -> default_empty_untyped_const ty) + | Tsum (_, []) | Tfail | Tclosure _ | Toperation -> raise Not_found - | Tvar _ | Tpartial _ -> raise Not_found + | Tpartial _ -> raise Not_found -let rec translate_const_exp (exp : encoded_exp) = +let rec translate_const_exp (exp : ('a, 'b) exp) = let loc = exp.loc in match exp.desc with | Let _ -> @@ -152,6 +225,8 @@ let rec translate_const_exp (exp : encoded_exp) = CList (List.map translate_const_exp args) | Apply { prim = Prim_tuple; args } -> CTuple (List.map translate_const_exp args) + | Apply { prim = Prim_big_map_create } -> + CBigMap (BMList []) | TypeAnnot { e } -> translate_const_exp e @@ -165,6 +240,8 @@ let rec translate_const_exp (exp : encoded_exp) = | Seq _ | Transfer _ | Call _ + | Self _ + | SelfCall _ | MatchOption _ | MatchNat _ | MatchList _ @@ -181,7 +258,8 @@ let rec translate_const_exp (exp : encoded_exp) = | Unpack _ | Type _ -> - LiquidLoc.raise_error ~loc "non-constant expression" + LiquidLoc.raise_error ~loc "non-constant expression: %s" + (LiquidPrinter.LiquidDebug.string_of_code exp) let translate env contract_sig s ty = @@ -193,6 +271,7 @@ let translate env contract_sig s ty = ~loc:(Location.in_file env.filename) ml_exp ml_ty in let sy_exp = LiquidFromParsetree.translate_expression env ml_exp in let tenv = empty_typecheck_env ~warnings:true contract_sig env in - let ty_exp = LiquidCheck.typecheck_code tenv ~expected_ty:ty sy_exp in - let enc_exp = LiquidEncode.encode_code tenv ty_exp in - translate_const_exp enc_exp + sy_exp + |> LiquidCheck.typecheck_code tenv ~expected_ty:ty + |> translate_const_exp + |> LiquidEncode.encode_const env contract_sig diff --git a/tools/liquidity/liquidData.mli b/tools/liquidity/liquidData.mli index 6522347c..2f39068f 100644 --- a/tools/liquidity/liquidData.mli +++ b/tools/liquidity/liquidData.mli @@ -27,7 +27,8 @@ val default_const : datatype -> (datatype, 'a) exp const (** same as [default_const] but with empty values for collections *) val default_empty_const : datatype -> (datatype, 'a) exp const +val default_empty_untyped_const : datatype -> syntax_const -val translate_const_exp : encoded_exp -> encoded_const +val translate_const_exp : ('a, 'b) exp -> ('a, 'b) exp const val translate : env -> full_contract_sig -> string -> datatype -> encoded_const diff --git a/tools/liquidity/liquidDecode.ml b/tools/liquidity/liquidDecode.ml index 1581ea4a..c026681a 100644 --- a/tools/liquidity/liquidDecode.ml +++ b/tools/liquidity/liquidDecode.ml @@ -34,8 +34,8 @@ let base_of_var arg = let rec decode_const (c : encoded_const) : typed_const = match c with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _) as c -> c | CSome x -> CSome (decode_const x) | CLeft x -> CLeft (decode_const x) | CRight x -> CRight (decode_const x) @@ -44,8 +44,9 @@ let rec decode_const (c : encoded_const) : typed_const = match c with | CSet xs -> CSet (List.map (decode_const) xs) | CMap l -> CMap (List.map (fun (x,y) -> decode_const x, decode_const y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> decode_const x, decode_const y) l) + | CBigMap BMList l -> + CBigMap (BMList (List.map (fun (x,y) -> decode_const x, decode_const y) l)) + | CBigMap BMId _ as c -> c | CRecord labels -> CRecord (List.map (fun (f, x) -> f, decode_const x) labels) | CConstr (constr, x) -> @@ -95,18 +96,36 @@ and decode ( exp : encoded_exp ) : typed_exp = let desc = Transfer { dest; amount } in mk ?name:exp.name ~loc desc exp.ty + | Call { amount; entry = _; arg; + contract = { desc = MatchOption { + arg = { desc = ContractAt { arg = addr; entry; entry_param }}; + ifnone = { desc = Failwith _ }; + ifsome = { desc = Var x }; some_name } } + } when some_name.nname = x -> + let amount = decode amount in + let contract = decode addr in + let arg = decode arg in + let desc = Call { contract; amount; entry = Some entry; arg } in + mk ?name:exp.name ~loc desc exp.ty + | Call { contract; amount; entry; arg } -> let amount = decode amount in let contract = decode contract in - let desc = match entry, arg.desc with - | None, Constructor { constr = Constr c; arg } when is_entry_case c -> - let entry = Some (entry_name_of_case c) in - let arg = decode arg in - Call { contract; amount; entry; arg } - | _, _ -> - let arg = decode arg in - Call { contract; amount; entry; arg } - in + let entry = match contract.ty, entry with + | Tcontract (Some e, _ ), _ | _, Some e -> Some e + | _, None -> None in + let arg = decode arg in + let desc = Call { contract; amount; entry; arg } in + mk ?name:exp.name ~loc desc exp.ty + + | Self { entry } -> + let desc = Self { entry } in + mk ?name:exp.name ~loc desc exp.ty + + | SelfCall { amount; entry; arg } -> + let amount = decode amount in + let arg = decode arg in + let desc = SelfCall { amount; entry; arg } in mk ?name:exp.name ~loc desc exp.ty | Failwith arg -> @@ -213,9 +232,9 @@ and decode ( exp : encoded_exp ) : typed_exp = let cases = List.map (fun (pat, e) -> pat, decode e) cases in mk ?name:exp.name ~loc (MatchVariant { arg; cases }) exp.ty - | ContractAt { arg; c_sig } -> + | ContractAt { arg; entry; entry_param } -> let arg = decode arg in - mk ?name:exp.name ~loc (ContractAt { arg; c_sig }) exp.ty + mk ?name:exp.name ~loc (ContractAt { arg; entry; entry_param }) exp.ty | Unpack { arg; ty } -> let arg = decode arg in @@ -244,9 +263,9 @@ and entry_of_case param_constrs top_storage (pat, body, fee_body) = | _ -> top_storage, body in match pat with - | PConstr (s, [parameter_name]) when is_entry_case s -> + | PConstr (s, [parameter_name]) when is_entry_case ~allow_capital:true s -> let storage_name, body = extract_storage_name body in - let entry_name = entry_name_of_case s in + let entry_name = entry_name_of_case ~allow_capital:true s in let parameter = List.assoc s param_constrs in let fee_code = match fee_body with | None -> None @@ -328,11 +347,41 @@ and decode_entries param_constrs top_parameter top_storage values exp fee_exp = List.map (entry_of_case param_constrs top_storage) cases | Let { bnd_var; inline; bnd_val; body } -> + let bv_val = LiquidBoundVariables.bv bnd_val in + if StringSet.mem top_parameter bv_val || + StringSet.mem top_storage bv_val then raise Exit; decode_entries param_constrs top_parameter top_storage ({ val_name = bnd_var.nname; val_private = false; inline; val_exp = decode bnd_val } :: values) body fee_exp + + | Apply { prim = Prim_tuple; args = [ { desc = Const { const = CList [] } } as le; + exp_sto ] } -> + let values, entries = + decode_entries param_constrs top_parameter top_storage values exp_sto fee_exp in + let le = decode le in + let entries = List.map (fun e -> + { e with + code = { e.code with + desc = Apply { prim = Prim_tuple; args = [le; e.code] } } + } + ) entries in + values, entries + + | Apply { prim = Prim_tuple; args = [ { desc = MatchVariant _ } as exp_ops ; + sto ] } -> + let values, entries = + decode_entries param_constrs top_parameter top_storage values exp_ops fee_exp in + let sto = decode sto in + let entries = List.map (fun e -> + { e with + code = { e.code with + desc = Apply { prim = Prim_tuple; args = [e.code; sto] } } + } + ) entries in + values, entries + | _ -> raise Exit and move_outer_lets parameter storage values exp = @@ -361,7 +410,7 @@ and decode_contract contract = | None -> None | Some i -> Some { i with init_body = decode i.init_body } in try match contract.entries with - | [{ entry_sig = { entry_name = "main"; + | [{ entry_sig = { entry_name = _; parameter = Tsum (_, param_constrs); parameter_name; storage_name; diff --git a/tools/liquidity/liquidDecomp.ml b/tools/liquidity/liquidDecomp.ml index 7ebc1952..45634a54 100644 --- a/tools/liquidity/liquidDecomp.ml +++ b/tools/liquidity/liquidDecomp.ml @@ -53,6 +53,7 @@ let const_name_of_datatype = function | Tfail -> "fail" | Toperation -> "op" | Taddress -> "addr" + | Tchainid -> "chain" | Tvar _ | Tpartial _ -> assert false @@ -365,9 +366,9 @@ let rec decompile_next (env : env) node = | "BALANCE", [] -> Prim_balance, [unit ~loc] | "AMOUNT",[] -> Prim_amount, [unit ~loc] | "STEPS_TO_QUOTA",[] -> Prim_gas, [unit ~loc] + | "CHAIN_ID",[] -> Prim_chain_id, [unit ~loc] | "SOURCE",[] -> Prim_source, [unit ~loc] | "SENDER",[] -> Prim_sender, [unit ~loc] - | "SELF",[] -> Prim_self, [unit ~loc] | "BLOCK_LEVEL", [] -> Prim_block_level, [unit ~loc] | "COLLECT_CALL", [] -> Prim_collect_call, [unit ~loc] | prim, args -> @@ -395,8 +396,7 @@ let rec decompile_next (env : env) node = | "SHA512" -> Prim_sha512 | "HASH_KEY" -> Prim_hash_key | "CHECK_SIGNATURE" -> Prim_check - | "CREATE_ACCOUNT" -> Prim_create_account - | "ADDRESS" -> Prim_address + | "ADDRESS" -> Prim_address_untype | "XOR" -> Prim_xor | "NOT" -> Prim_not | "OR" -> Prim_or @@ -448,9 +448,9 @@ let rec decompile_next (env : env) node = | N_CONSTR c, [arg] -> mklet env node (Constructor {constr = Constr c; arg = arg_of arg }) - | N_CONTRACT ty, [arg] -> - mklet env node (ContractAt { arg = arg_of arg; - c_sig = contract_sig_of_param ty }) + | N_CONTRACT (entry, entry_param), [arg] -> + let entry = match entry with None -> "default" | Some e -> e in + mklet env node (ContractAt { arg = arg_of arg; entry; entry_param }) | N_UNPACK ty, [arg] -> mklet env node (Unpack { arg = arg_of arg; ty }) @@ -626,22 +626,29 @@ let rec decompile_next (env : env) node = mklet env node desc | N_LAMBDA_END _, [arg] -> arg_of arg + | N_SELF entry, [] -> + let entry = match entry with None -> "default" | Some e -> e in + mklet env node (Self { entry }) + | N_TRANSFER, [dest; amount] -> mklet env node (Transfer { dest = arg_of dest; amount = arg_of amount }) + + | N_CALL, [ { kind = N_SELF entry }; amount; arg] -> + let entry = match entry with None -> "default" | Some e -> e in + mklet env node + (SelfCall { amount = arg_of amount; + entry; + arg = arg_of arg }) + | N_CALL, [contract; amount; arg] -> - let entry, arg = match arg.kind, arg.args with - | N_CONSTR c, [arg] when is_entry_case c -> - Some (entry_name_of_case c), arg - | _ -> None, arg in mklet env node (Call { contract = arg_of contract; amount = arg_of amount; - entry; + entry = None; arg = arg_of arg }) - (* TODO *) | N_CREATE_CONTRACT contract, args -> (* Hack: using annotation to represent contract name *) @@ -703,6 +710,7 @@ let rec decompile_next (env : env) node = | N_PROJ _ | N_CONSTR _ | N_SETFIELD _ + | N_SELF _ ), _-> LiquidLoc.raise_error "not implemented at node %s%!" @@ -710,8 +718,8 @@ let rec decompile_next (env : env) node = and decompile_const env c = match c with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _ ) as c -> c | CSome x -> CSome (decompile_const env x) | CLeft x -> CLeft (decompile_const env x) | CRight x -> CRight (decompile_const env x) @@ -720,8 +728,11 @@ and decompile_const env c = match c with | CSet xs -> CSet (List.map (decompile_const env) xs) | CMap l -> CMap (List.map (fun (x,y) -> decompile_const env x, decompile_const env y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> decompile_const env x, decompile_const env y) l) + | CBigMap BMList l -> + CBigMap + (BMList (List.map (fun (x,y) -> decompile_const env x, + decompile_const env y) l)) + | CBigMap BMId _ as c -> c | CRecord labels -> CRecord (List.map (fun (f, x) -> f, decompile_const env x) labels) | CConstr (constr, x) -> @@ -785,14 +796,26 @@ and decompile env contract = | None -> "parameter", "storage" | Some ps -> ps in + let rec get_type ty = match ty with + | Tvar { contents = { contents = { tyo = Some ty }}} -> get_type ty + | _ -> ty in + + let entry_name = match contract.mic_root with + | Some r -> r + | None -> + match get_type contract.mic_parameter with + | Tsum (_, l) when List.for_all (fun (e, _) -> is_entry_case e) l -> + "__root__" + | _ -> "default" in + { contract_name = "_dummy_"; storage = contract.mic_storage; values = []; - entries = [{ entry_sig = { entry_name = "main"; + entries = [{ entry_sig = { entry_name; parameter = contract.mic_parameter; - parameter_name ; - storage_name }; - code ; + parameter_name; + storage_name }; + code; fee_code }]; c_init = None; subs = []; diff --git a/tools/liquidity/liquidDeploy.ml b/tools/liquidity/liquidDeploy.ml deleted file mode 100644 index d6caf9a3..00000000 --- a/tools/liquidity/liquidDeploy.ml +++ /dev/null @@ -1,1851 +0,0 @@ -(****************************************************************************) -(* Liquidity *) -(* *) -(* Copyright (C) 2017-2019 OCamlPro SAS *) -(* *) -(* Authors: Fabrice Le Fessant *) -(* Alain Mebsout *) -(* David Declerck *) -(* *) -(* This program is free software: you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 3 of the License, or *) -(* (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program. If not, see . *) -(****************************************************************************) - -open LiquidTypes -open Dune_Network_Lib (* for crypto *) - -type from = - | From_strings of string list - | From_files of string list - -type key_diff = - | DiffKeyHash of string - | DiffKey of typed_const - -type big_map_diff_item = - | Big_map_add of key_diff * typed_const - | Big_map_remove of key_diff - -type big_map_diff = big_map_diff_item list - -type stack_item = - | StackConst of typed_const - | StackCode of int - -type trace_item = { - loc : location option; - gas : int; - stack : (stack_item * string option) list; -} - -type trace = trace_item array - -type internal_operation = - | Reveal of string - | Transaction of { - amount : string; - destination : string; - parameters : typed_const option; - } - | Origination of { - manager: string ; - delegate: string option ; - script: (typed_contract * typed_const) option ; - spendable: bool ; - delegatable: bool ; - balance: string ; - } - | Delegation of string option - -type operation = { - source : string; - nonce : int; - op : internal_operation; -} - -exception RequestError of int * string -exception ResponseError of string -exception RuntimeError of error * trace option -exception LocalizedError of error -exception RuntimeFailure of error * string option * trace option - -module type S = sig - type 'a t - val run : from -> string -> string -> string -> - (operation list * LiquidTypes.typed_const * big_map_diff option) t - val run_debug : from -> string -> string -> string -> - (operation list * LiquidTypes.typed_const * big_map_diff option * trace) t - val init_storage : from -> string list -> LiquidTypes.encoded_const t - val forge_deploy_script : - source:string -> from -> string list -> - (string * string * LiquidToMicheline.loc_table) t - val forge_deploy : ?delegatable:bool -> ?spendable:bool -> - from -> string list -> string t - val deploy : ?delegatable:bool -> ?spendable:bool -> - from -> string list -> (string * (string, exn) result) t - val get_storage : from -> string -> LiquidTypes.typed_const t - val get_big_map_value : - from -> string -> string -> LiquidTypes.typed_const option t - val forge_call_parameter : - from -> string -> string -> string * LiquidToMicheline.loc_table - val forge_call : from -> string -> string -> string -> string t - val call : from -> string -> string -> string -> - (string * (unit, exn) result) t - val activate : secret:string -> string t - val inject : operation:string -> signature:string -> string t - val pack : ?liquid:from -> const:string -> ty:string -> string t -end - -open Lwt - -module Network_sync = struct - let writer_callback a d = - Buffer.add_string a d; - String.length d - - let initialize_connection host path = - let url = Printf.sprintf "%s%s" host path in - let r = Buffer.create 16384 - and c = Curl.init () in - Curl.set_timeout c 30; (* Timeout *) - Curl.set_sslverifypeer c false; - Curl.set_sslverifyhost c Curl.SSLVERIFYHOST_EXISTENCE; - Curl.set_writefunction c (writer_callback r); - Curl.set_tcpnodelay c true; - Curl.set_verbose c false; - Curl.set_post c false; - Curl.set_url c url; r,c - - let post ?(content_type = "application/json") host path data = - let r, c = initialize_connection host path in - Curl.set_post c true; - Curl.set_httpheader c [ "Content-Type: " ^ content_type ]; - Curl.set_postfields c data; - Curl.set_postfieldsize c (String.length data); - Curl.perform c; - let rc = Curl.get_responsecode c in - Curl.cleanup c; - rc, (Buffer.contents r) - - let get ?(content_type = "application/json") host path = - let r, c = initialize_connection host path in - Curl.set_post c false; - Curl.set_httpheader c [ "Content-Type: " ^ content_type ]; - Curl.perform c; - let rc = Curl.get_responsecode c in - Curl.cleanup c; - rc, (Buffer.contents r) -end - -module Network = struct - let writer_callback a d = - Buffer.add_string a d; - String.length d - - let initialize_connection host path = - let url = Printf.sprintf "%s%s" host path in - let r = Buffer.create 16384 - and c = Curl.init () in - Curl.set_timeout c 30; (* Timeout *) - Curl.set_sslverifypeer c false; - Curl.set_sslverifyhost c Curl.SSLVERIFYHOST_EXISTENCE; - Curl.set_writefunction c (writer_callback r); - Curl.set_tcpnodelay c true; - Curl.set_verbose c false; - Curl.set_post c false; - Curl.set_url c url; r,c - - let post ?(content_type = "application/json") host path data = - let r, c = initialize_connection host path in - Curl.set_post c true; - Curl.set_httpheader c [ "Content-Type: " ^ content_type ]; - Curl.set_postfields c data; - Curl.set_postfieldsize c (String.length data); - Curl_lwt.perform c >>= fun cc -> - (* if cc <> Curl.CURLE_OK then - * raise (RequestError - * (Printf.sprintf "[%d] [%s] Curl exception: %s\n%!" - * (Curl.errno cc) host path)) - * else *) - let rc = Curl.get_responsecode c in - Curl.cleanup c; - Lwt.return (rc, (Buffer.contents r)) - - let get ?(content_type = "application/json") host path = - let r, c = initialize_connection host path in - Curl.set_post c false; - Curl.set_httpheader c [ "Content-Type: " ^ content_type ]; - Curl_lwt.perform c >>= fun cc -> - (* if cc <> Curl.CURLE_OK then - * raise (RequestError - * (Printf.sprintf "[%d] [%s] Curl exception: %s\n%!" - * (Curl.errno cc) host path)) - * else *) - let rc = Curl.get_responsecode c in - Curl.cleanup c; - Lwt.return (rc, (Buffer.contents r)) -end - -(* (Ezjsonm.to_string ~minify:false (Ezjsonm.from_string data)); *) - -let curl_call meth f data path = - let host = !LiquidOptions.node in - if !LiquidOptions.verbosity > 0 then - Printf.eprintf "\n%s to %s%s:\n--------------\n<<<%s>>>\n%!" - meth host path data; - try - f host path data >>= fun (status, json) -> - if !LiquidOptions.verbosity > 0 then begin - Printf.eprintf "\nNode Response %d:\n------------------\n<<<%s>>>\n%!" - status json; - end; - if status <> 200 then raise (RequestError (status, json)); - return json - with Curl.CurlException (code, i, s) (* as exn *) -> - raise (RequestError (Curl.errno code, s)) - -let curl_post ~data path = - curl_call "POST" Network.post data path - -let curl_get path = - curl_call "GET" (fun host path data -> Network.get host path) "" path - - -let post = ref curl_post -let get = ref curl_get - - -(* let error_string_of_michelson_error json = - * let errors = Ezjsonm.get_list Error_monad.error_of_json json in - * let fmt = Format.str_formatter in - * Michelson_v1_error_reporter.report_error - * ~details:false - * ~show_source:false - * fmt - * errors; - * Format.flush_str_formatter () *) - -let error_schema = - lazy ( - Lwt.catch - (fun () -> !get "/errors" >|= Ezjsonm.from_string) - (function - | RequestError _ | Not_found -> return @@ `O [] - | exn -> Lwt.fail exn) - ) - - -let memo_stack_code_cpt = ref 0 -let memo_stack_code_tbl = Hashtbl.create 19 -let reset_memo_stack_code () = - memo_stack_code_cpt := 0; - Hashtbl.clear memo_stack_code_tbl -let memo_stack_code e = - try Hashtbl.find memo_stack_code_tbl e - with Not_found -> - let cpt = !memo_stack_code_cpt in - incr memo_stack_code_cpt; - Hashtbl.add memo_stack_code_tbl e cpt; - cpt - -let name_of_var_annot = function - | None -> None - | Some annot -> - try Scanf.sscanf annot "@%s" (function - | "" -> None - | s -> Some s - ) - with Scanf.Scan_failure _ | End_of_file -> None - -let convert_const env ?ty e = - let mic_e, loc = match ty with - | Some ty -> LiquidFromMicheline.convert_const_type env e ty - | None -> LiquidFromMicheline.convert_const_notype env e in - let nod_e = LiquidInterp.decompile_const loc mic_e in - let syn_e = LiquidDecomp.decompile_const nod_e in - let tenv = - empty_typecheck_env ~warnings:false - LiquidTypes.dummy_contract_sig - (LiquidFromParsetree.initial_env "") in - LiquidCheck.typecheck_const tenv ?expected_ty:ty ~loc syn_e - (* |> LiquidEncode.encode_const tenv.env tenv.t_contract_sig *) - |> LiquidSimplify.simplify_const - (* |> LiquidDecode.decode_const *) - |> LiquidUntype.untype_const - -let convert_stack env stack_expr = - List.map (fun (e, annot) -> - let name = name_of_var_annot annot in - try StackConst (convert_const env e), name - with _ -> StackCode (memo_stack_code e), name - ) stack_expr - -let trace_of_json env ~loc_table ?(error=false) trace_r = - let trace_expr = - Ezjsonm.get_list (fun step -> - let loc = Ezjsonm.find step ["location"] |> Ezjsonm.get_int in - let gas = Ezjsonm.find step ["gas"] - |> Ezjsonm.get_string |> int_of_string in - let stack = - Ezjsonm.find step ["stack"] - |> Ezjsonm.get_list (fun s -> - Ezjsonm.find s ["item"] |> LiquidToMicheline.const_of_ezjson, - try Some (Ezjsonm.find s ["annot"] |> Ezjsonm.get_string) - with Not_found -> None - ) - in - (loc, gas, stack) - ) trace_r - in - (* Workaround bud in current betanet *) - let trace_expr = match trace_expr with - | (loc1, _, _) :: (loc2, _, _) :: _ when loc2 < loc1 -> List.rev trace_expr - | _ -> trace_expr in - let trace_expr = match List.rev trace_expr with - | ((loc, gas, _) :: _) as rtrace_expr when error -> - let extra = (loc + 1, gas, []) in - List.rev (extra :: rtrace_expr) - | _ -> trace_expr in - let l = - List.map (fun (loc, gas, stack) -> - let loc = match List.assoc_opt loc loc_table with - | Some (loc, _) -> Some loc - | None -> None - in - (* we don't know the liquidity type of elements in the stack *) - let stack = convert_stack env stack in - { loc; gas; stack } - ) trace_expr in - reset_memo_stack_code (); - Array.of_list l - -let loc_table_to_map loc_table = - List.fold_left (fun m (pos, (loc, _)) -> - IntMap.add pos loc m - ) IntMap.empty loc_table - -let fail_msg_of_err loc ~loc_table err = - let json = Ezjsonm.find err ["with"] in - let err_loc, _ (* failwith_ty *) = List.assoc loc loc_table in - let env = { (LiquidMichelineTypes.empty_env err_loc.loc_file) - with loc_table = loc_table_to_map loc_table } in - let failed_with_expr = LiquidToMicheline.const_of_ezjson json in - let failed_with = convert_const env failed_with_expr in - err_loc, Some (LiquidPrinter.Liquid.string_of_const failed_with) - -let error_trace_of_err loc ~loc_table err = - let err_loc, _ = List.assoc loc loc_table in - try - let json = Ezjsonm.find err ["trace"] in - let env = { (LiquidMichelineTypes.empty_env err_loc.loc_file) - with loc_table = loc_table_to_map loc_table } in - let trace = trace_of_json env ~loc_table ~error:true json in - err_loc, Some trace - with Not_found -> err_loc, None - -let raise_error_from_l ?loc_table err_msg l = - let default_error () = - let last_descr = match List.rev l with - | (_, _, _, _, Some descr, _) :: _ -> "\n " ^ descr - | _ -> "" - in - let err_l = - List.map (fun (kind, id, _, title, descr, _) -> - match title with - | Some t -> t - | None -> Printf.sprintf "%s: %s" kind id - ) l - |> String.concat "\n- " - in - Printf.sprintf "in %s\n- %s%s" err_msg err_l last_descr - in - match loc_table with - | None -> raise (ResponseError (default_error ())) - | Some loc_table -> - let err_msg = Printf.sprintf "in %s" err_msg in - try - List.iter (fun (kind, id, loc, title, descr, err) -> - let is_rejected = - match String.rindex_opt id '.' with - | None -> false - | Some i -> - match String.sub id i (String.length id - i) with - | ".script_rejected" | ".scriptRejectedRuntimeError" -> true - | _ -> false - in - match loc, kind, is_rejected with - | Some loc, "temporary", true -> - let err_loc, fail_str = fail_msg_of_err loc ~loc_table err in - let _, trace = error_trace_of_err loc ~loc_table err in - raise (RuntimeFailure ({err_msg; err_loc}, fail_str, trace)) - | Some loc, "temporary", _ -> - let title = match title with Some t -> t | None -> id in - let err_msg = String.concat "\n- " [err_msg; title] in - let err_loc, trace = error_trace_of_err loc ~loc_table err in - raise (RuntimeError ({err_msg; err_loc}, trace)) - | Some loc, _, _ -> - let err_loc, _ = List.assoc loc loc_table in - let err_msg = default_error () in - raise (LocalizedError {err_msg; err_loc}) - | _ -> () - ) l; - raise (ResponseError (default_error ())) - with Not_found -> raise (ResponseError (default_error ())) - -let extract_errors_from_json r schema = - try - let schema_l = Ezjsonm.find schema ["oneOf"] in - try - Ezjsonm.find r ["error"], schema_l - with Not_found -> - match Ezjsonm.get_list (fun x -> x) r with - | err :: _ -> - begin try - let r = Ezjsonm.find err ["ecoproto"] in - let id = Ezjsonm.find err ["id"] |> Ezjsonm.get_string in - let schema_l = - schema_l - |> Ezjsonm.get_list (fun s -> - try - let s_id = - Ezjsonm.find s ["properties"; "id"; "enum"] - |> Ezjsonm.get_list Ezjsonm.get_string - |> function [s] -> s | _ -> assert false - in - if s_id <> id then - None - else - Some (Ezjsonm.find s - ["properties"; "ecoproto"; "items"; "oneOf"]) - with Not_found -> None - ) - |> List.find (function None -> false | Some _ -> true) - |> function None -> assert false | Some s -> s - in - r, schema_l - with Not_found -> r, schema_l - end - | [] -> raise (ResponseError ("Could not parse error")) - | exception Ezjsonm.Parse_error _ -> r, schema_l - with Not_found -> r, schema - -let rec descr_of_id id schema = - try - schema - |> Ezjsonm.get_list (fun s -> - try - let schema = Ezjsonm.find s ["oneOf"] in - descr_of_id id schema - with Not_found -> - try - let s_id = - Ezjsonm.find s ["properties"; "id"; "enum"] - |> Ezjsonm.get_list Ezjsonm.get_string - |> function [s] -> s | _ -> assert false - in - if s_id <> id then - None, None - else ( - let t = - try Some (Ezjsonm.find s ["title"] |> Ezjsonm.get_string) - with Not_found -> None - in - let d = - try Some (Ezjsonm.find s ["description"] |> Ezjsonm.get_string) - with Not_found -> None - in - (t, d) - ) - with Not_found -> - None, None - ) - |> List.find (function Some _, _ | _, Some _ -> true | _ -> false) - with Not_found | Ezjsonm.Parse_error _ -> - None, None - -let raise_response_error ?loc_table msg r = - Lazy.force error_schema >>= fun error_schema -> - let err, schema = extract_errors_from_json r error_schema in - let l = - try - Ezjsonm.get_list (fun err -> - let kind = Ezjsonm.find err ["kind"] |> Ezjsonm.get_string in - if kind = "generic" then begin - let err = Ezjsonm.find err ["error"] |> Ezjsonm.get_string in - raise (ResponseError err) - end; - let id = Ezjsonm.find err ["id"] |> Ezjsonm.get_string in - let title, descr = descr_of_id id schema in - let loc = - try Some (Ezjsonm.find err ["location"] |> Ezjsonm.get_int) - with Not_found -> - try Some (Ezjsonm.find err ["loc"] |> Ezjsonm.get_int) - with Not_found -> None - in - kind, id, loc, title, descr, err - ) err - with Ezjsonm.Parse_error _ -> [] - in - raise_error_from_l ?loc_table msg l - - -let send_post ?loc_table ~data path = - Lwt.catch - (fun () -> !post ~data path) - (function - | RequestError (code, res) as exn -> - begin try raise_response_error ?loc_table path (Ezjsonm.from_string res) - with Ezjsonm.Parse_error _ | Not_found -> Lwt.fail exn - end - | exn -> Lwt.fail exn - ) - -let send_get ?loc_table path = - Lwt.catch - (fun () -> !get path) - (function - | RequestError (code, res) as exn -> - begin try raise_response_error ?loc_table path (Ezjsonm.from_string res) - with Ezjsonm.Parse_error _ | Not_found -> Lwt.fail exn - end - | exn -> Lwt.fail exn - ) - - -let mk_json_obj fields = - fields - |> List.map (fun (f,v) -> "\"" ^ f ^ "\":" ^ v) - |> String.concat "," - |> fun fs -> "{" ^ fs ^ "}" - -let mk_json_arr l = "[" ^ String.concat "," l ^ "]" - - -let compile_liquid liquid = - let ocaml_asts = match liquid with - | From_strings ss -> - List.map (fun s -> - "liquidity_buffer", - LiquidFromParsetree.structure_of_string ~filename:"liquidity_buffer" - s) ss - | From_files files -> - List.map (fun f -> f, LiquidFromParsetree.read_file f) files - in - let syntax_ast = LiquidFromParsetree.translate_multi ocaml_asts in - let contract_sig = full_sig_of_contract syntax_ast in - let typed_ast = LiquidCheck.typecheck_contract - ~warnings:true ~decompiling:false syntax_ast in - let encoded_ast, to_inline = - LiquidEncode.encode_contract ~annot:true typed_ast in - let live_ast = LiquidSimplify.simplify_contract encoded_ast to_inline in - let pre_michelson = LiquidMichelson.translate live_ast in - let pre_michelson = - if !LiquidOptions.peephole then - LiquidPeephole.simplify pre_michelson - else - pre_michelson - in - let pre_init = match live_ast.c_init with - | None -> None - | Some init -> - let inputs_infos = init.init_args in - Some ( - LiquidInit.compile_liquid_init live_ast.ty_env contract_sig init, - inputs_infos) - in - ( syntax_ast, pre_michelson, pre_init ) - -let decompile_michelson code = - let env = LiquidMichelineTypes.empty_env "mic_code" in - let c = LiquidFromMicheline.convert_contract env code in - let c = LiquidClean.clean_contract c in - let c = LiquidInterp.interp c in - let c = LiquidDecomp.decompile env c in - let annoted_tz, type_annots, types = LiquidFromMicheline.infos_env env in - let typed_ast = LiquidCheck.typecheck_contract ~warnings:false ~decompiling:true c in - let encode_ast, to_inline = - LiquidEncode.encode_contract ~decompiling:true typed_ast in - let live_ast = LiquidSimplify.simplify_contract - ~decompile_annoted:annoted_tz encode_ast to_inline in - let multi_ast = LiquidDecode.decode_contract live_ast in - let untyped_ast = LiquidUntype.untype_contract multi_ast in - untyped_ast - -let get_json_string s = - try Scanf.sscanf s "%S" (fun x -> x) - with _ -> raise Not_found - -let get_json_int s = - try Scanf.sscanf s "%d" (fun x -> x) - with _ -> - try Scanf.sscanf s "\"%d\"" (fun x -> x) - with _ -> raise Not_found - -let get_counter source = - send_get - (Printf.sprintf "/chains/main/blocks/head/context/contracts/%s/counter" - source) - >>= fun r -> - try - get_json_int r |> return - with Not_found -> - raise_response_error "get_counter" (Ezjsonm.from_string r) - -let get_next_counter source = - match !LiquidOptions.counter with - | None -> - get_counter source >>= fun counter -> - return (counter+1) - | Some counter -> return counter - -let get_head_hash () = - send_get "/chains/main/blocks/head/header" >>= fun r -> - let r = Ezjsonm.from_string r in - try - Ezjsonm.find r ["hash"] |> Ezjsonm.get_string |> return - with Not_found -> - raise_response_error "get_head_hash" r - -type head = { - head_hash : string; - head_chain_id : string; -} - -let get_head () = - send_get "/chains/main/blocks/head" >>= fun r -> - let r = Ezjsonm.from_string r in - try - let head_hash = Ezjsonm.find r ["hash"] |> Ezjsonm.get_string in - let head_chain_id = Ezjsonm.find r ["chain_id"] |> Ezjsonm.get_string in - return { head_hash; head_chain_id } - with Not_found -> - raise_response_error "get_head" r - -let get_manager_key source = - send_get - (Printf.sprintf "/chains/main/blocks/head/context/contracts/%s/manager_key" - source) - >>= fun r -> - try - try - let r = Ezjsonm.from_string r in - Ezjsonm.find r ["key"] - |> Ezjsonm.get_string - |> return - with _-> - get_json_string r |> return - with Not_found -> - raise_response_error "get_manager_key" (Ezjsonm.from_string r) - -let get_manager source = - send_get - (Printf.sprintf "/chains/main/blocks/head/context/contracts/%s/manager" - source) - >>= fun r -> - try - get_json_string r |> return - with Not_found -> - raise_response_error "get_manager" (Ezjsonm.from_string r) - -type constants = { - hard_gas_limit_per_operation : int; - hard_storage_limit_per_operation : int; -} - -let get_constants () = - send_get "/chains/main/blocks/head/context/constants" >>= fun r -> - let r = Ezjsonm.from_string r in - try - { - hard_gas_limit_per_operation = - Ezjsonm.find r ["hard_gas_limit_per_operation"] - |> Ezjsonm.get_string - |> int_of_string; - hard_storage_limit_per_operation = - Ezjsonm.find r ["hard_storage_limit_per_operation"] - |> Ezjsonm.get_string - |> int_of_string; - } - |> return - with Not_found -> - raise_response_error "get_constants" r - -let get_predecessor () = - send_get "/chains/main/blocks/head/header" >>= fun r -> - let r = Ezjsonm.from_string r in - try - Ezjsonm.find r ["predecessor"] |> Ezjsonm.get_string |> return - with Not_found -> - raise_response_error "get_predecessor" r - -let get_protocol () = - send_get "/chains/main/blocks/head/header" >>= fun r -> - let r = Ezjsonm.from_string r in - try - Ezjsonm.find r ["protocol"] |> Ezjsonm.get_string |> return - with Not_found -> - raise_response_error "get_protocol" r - -let operation_of_json ~head r = - let env = LiquidMichelineTypes.empty_env "operation" in - let source = Ezjsonm.(find r ["source"] |> get_string) in - let nonce = Ezjsonm.(find r ["nonce"] |> get_int) in - let kind = Ezjsonm.(find r ["kind"] |> get_string) in - let op = match kind with - | "reveal" -> Reveal Ezjsonm.(find r ["public_key"] |> get_string) - | "transaction" -> - let open Ezjsonm in - Transaction { - amount = find r ["amount"] |> get_string; - destination = find r ["destination"] |> get_string; - parameters = - try find r ["parameters"] - |> LiquidToMicheline.const_of_ezjson - |> convert_const env - |> Option.some - with Not_found -> None; - } - | "origination" -> - let open Ezjsonm in - let script = - try - let code = - find r ["script"; "code"] - |> LiquidToMicheline.contract_of_ezjson - |> decompile_michelson in - let storage = - find r ["script"; "storage"] - |> LiquidToMicheline.const_of_ezjson - |> (fun e -> convert_const env e ~ty:code.storage) - in - Some (code, storage) - with Not_found -> None in - Origination { - manager = find r ["manager_pubkey"] |> get_string; - script; - spendable = - (try find r ["spendable"] |> get_bool with Not_found -> true); - delegatable = - (try find r ["delegatable"] |> get_bool with Not_found -> true); - balance = find r ["balance"] |> get_string; - delegate = - Option.try_with (fun () -> find r ["delegate"] |> get_string); - } - | "delegation" -> - Delegation Ezjsonm.( - Option.try_with (fun () -> find r ["delegate"] |> get_string); - ) - | _ -> failwith kind in - { source; nonce; op } - - - -let get_big_map_type storage = - match storage with - | Ttuple (Tbigmap (k, v) :: _) - | Trecord (_, (_, Tbigmap (k, v)) :: _) -> Some (k, v) - | _ -> None - -let get_big_map_name storage = - match storage with - | Ttuple (Tbigmap (k, v) :: _) -> Some None - | Trecord (_, (name, Tbigmap _) :: _) -> Some (Some name) - | _ -> None - -let run_pre ?(debug=false) - contract pre_michelson source input storage = - let rpc = if debug then "trace_code" else "run_code" in - let env = contract.ty_env in - let storage_ty = contract.storage in - let c, loc_table = - LiquidToMicheline.convert_contract ~expand:true pre_michelson in - let input_m = LiquidMichelson.compile_const input in - let input_t = LiquidToMicheline.convert_const ~expand:true input_m in - let storage_m = LiquidMichelson.compile_const storage in - let storage_t = LiquidToMicheline.convert_const ~expand:true storage_m in - let contract_json = LiquidToMicheline.json_of_contract c in - let input_json = LiquidToMicheline.json_of_const input_t in - let storage_json = LiquidToMicheline.json_of_const storage_t in - let run_fields = [ - "script", contract_json; - "input", input_json; - "storage", storage_json; - "amount", Printf.sprintf "%S" !LiquidOptions.amount; - ] in - let run_json = mk_json_obj run_fields in - send_post ~loc_table ~data:run_json - (Printf.sprintf "/chains/main/blocks/head/helpers/scripts/%s" rpc) - >>= fun r -> - let r = Ezjsonm.from_string r in - try - let storage_r = Ezjsonm.find r ["storage"] in - let operations_r = Ezjsonm.find r ["operations"] in - get_head () >>= fun head -> - let operations = Ezjsonm.get_list (operation_of_json ~head) operations_r in - let big_map_diff_r = - try Some (Ezjsonm.find r ["big_map_diff"]) - with Not_found -> None - in - let trace_r = - if not debug then None - else Some (Ezjsonm.find r ["trace"]) - in - let storage_expr = LiquidToMicheline.const_of_ezjson storage_r in - let get_value v = match Ezjsonm.get_dict v with - | [] -> None - | _ :: _ -> - Some (LiquidToMicheline.const_of_ezjson v) - | exception Ezjsonm.Parse_error _ -> - Some (LiquidToMicheline.const_of_ezjson v) in - let big_map_diff_expr = match big_map_diff_r with - | None -> None - | Some json_diff -> - Some (Ezjsonm.get_list (fun diffi -> - try - Ok ( - Ezjsonm.find diffi ["key"] |> LiquidToMicheline.const_of_ezjson, - try Ezjsonm.find diffi ["value"] |> get_value - with Not_found -> None - ) - with Not_found -> - Error (Ezjsonm.get_pair - Ezjsonm.get_string - get_value - diffi) - ) json_diff) - in - let env = LiquidMichelineTypes.empty_env env.filename in - let storage = convert_const env storage_expr ~ty:storage_ty in - (* TODO parse returned operations *) - let big_map_diff = - match big_map_diff_expr, get_big_map_type storage_ty with - | None, _ -> None - | Some _, None -> assert false - | Some d, Some (tk, tv) -> - Some (List.map (function - | Ok (k, Some v) -> - let v = convert_const env v ~ty:tv in - let k = DiffKey (convert_const env k ~ty:tk) in - Big_map_add (k, v) - | Error (h, Some v) -> - let v = convert_const env v ~ty:tv in - let k = DiffKeyHash h in - Big_map_add (k, v) - | Ok (k, None) -> - let k = DiffKey (convert_const env k ~ty:tk) in - Big_map_remove k - | Error (h, None) -> - let k = DiffKeyHash h in - Big_map_remove k - ) d) - in - let trace = match trace_r with - | None -> None - | Some trace_r -> Some (trace_of_json env ~loc_table trace_r) - in - return (operations, storage, big_map_diff, trace) - with Not_found -> - raise_response_error ~loc_table "run" r - - -let run ~debug liquid entry_name input_string storage_string = - let contract , pre_michelson, _ = compile_liquid liquid in - let entry = - try - List.find (fun e -> e.entry_sig.entry_name = entry_name) contract.entries - with Not_found -> - invalid_arg @@ "Contract has no entry point " ^ entry_name - in - let contract_sig = full_sig_of_contract contract in - let input = - LiquidData.translate { contract.ty_env with filename = "run_input" } - contract_sig input_string entry.entry_sig.parameter - in - let parameter = match contract_sig.f_entries_sig with - | [_] -> input - | _ -> LiquidEncode.encode_const contract.ty_env contract_sig - (CConstr (entry_name, - (LiquidDecode.decode_const input))) in - let storage = - LiquidData.translate { contract.ty_env with filename = "run_storage" } - contract_sig storage_string contract.storage - in - run_pre ~debug contract - pre_michelson !LiquidOptions.source parameter storage - -let run_debug liquid entry_name input_string storage_string = - run ~debug:true liquid entry_name input_string storage_string - >>= function - | (nbops, sto, big_diff, Some trace) -> - Lwt.return (nbops, sto, big_diff, trace) - | _ -> assert false - -let run liquid entry_name input_string storage_string = - run ~debug:false liquid entry_name input_string storage_string - >>= fun (nbops, sto, big_diff, _) -> - Lwt.return (nbops, sto, big_diff) - -let get_storage liquid address = - let syntax_ast, _, _ = compile_liquid liquid in - send_get - (Printf.sprintf - "/chains/main/blocks/head/context/contracts/%s/storage" - address) - >>= fun r -> - let r = Ezjsonm.from_string r in - try - let storage_expr = LiquidToMicheline.const_of_ezjson r in - let env = LiquidMichelineTypes.empty_env syntax_ast.ty_env.filename in - return - (try convert_const env storage_expr ~ty:syntax_ast.storage - with LiquidTypes.LiquidError _ -> - Format.eprintf "Could not convert constant to contract storage type.@."; - convert_const env storage_expr) - with Not_found -> - raise_response_error "get_storage" r - -let get_big_map_value liquid address key = - let contract , pre_michelson, _ = compile_liquid liquid in - let contract_sig = full_sig_of_contract contract in - let (key_ty, val_ty) = match get_big_map_type contract.storage with - | None -> failwith "no big map" - | Some (k,v) -> k, v in - let key = - LiquidData.translate { contract.ty_env with filename = "big_map_key" } - contract_sig key key_ty - in - let key_m = LiquidMichelson.compile_const key in - let key_t = LiquidToMicheline.convert_const ~expand:true key_m in - let key_json = LiquidToMicheline.json_of_const key_t in - let key_ty_t = LiquidToMicheline.convert_type key_ty in - let key_ty_json = LiquidToMicheline.json_of_const key_ty_t in - let data_fields = [ - "key", key_json; - "type", key_ty_json; - ] in - let data = mk_json_obj data_fields in - send_post ~data - (Printf.sprintf - "/chains/main/blocks/head/context/contracts/%s/big_map_get" - address) - >>= function - | "null\n" | "null" -> return_none - | r -> - let r = Ezjsonm.from_string r in - try - let expr = LiquidToMicheline.const_of_ezjson r in - let env = LiquidMichelineTypes.empty_env "big_map_value" in - return_some - (try convert_const env expr ~ty:val_ty - with LiquidTypes.LiquidError _ -> - Format.eprintf "Could not convert constant to value type.@."; - convert_const env expr) - with Not_found -> - raise_response_error "get_big_map_value" r - -let is_revealed source = - send_get - (Printf.sprintf - "/chains/main/blocks/head/context/contracts/%s/manager_key" - source) - >>= function - | "null\n" | "null" -> return false - | r -> - try - let r = Ezjsonm.from_string r in - try - ignore (Ezjsonm.find r ["key"]); - return true - with Not_found -> - return false - with _ -> - ignore (get_json_string r); - return true - - -let get_public_key_hash_from_secret_key sk = - let pk = Sodium.Sign.secret_key_to_public_key sk in - match !LiquidOptions.network with - | Tezos_network -> - pk - |> Ed25519.Public_key_hash_tezos.of_public_key - |> Ed25519.Public_key_hash_tezos.to_b58check - | Dune_network -> - pk - |> Ed25519.Public_key_hash_dune.of_public_key - |> Ed25519.Public_key_hash_dune.to_b58check - -let get_public_key_from_secret_key sk = - sk - |> Sodium.Sign.secret_key_to_public_key - (* Replace by this when tezos is fixed *) - (* |> Ed25519.Secret_key.to_public_key *) - |> Ed25519.Public_key.to_b58check - -let init_storage ?source liquid init_params_strings = - let source = match source with - | Some _ -> source - | None -> !LiquidOptions.source - in - let syntax_ast, pre_michelson, pre_init_infos = compile_liquid liquid in - let contract_sig = full_sig_of_contract syntax_ast in - let pre_init, init_infos = match pre_init_infos with - | None -> raise (ResponseError "init_storage: Missing init") - | Some pre_init_infos -> pre_init_infos - in - match pre_init with - | LiquidInit.Init_constant c -> - if init_params_strings <> [] then - raise (ResponseError "init_storage: Constant storage, no inputs needed"); - return c - | LiquidInit.Init_code (syntax_c, c) -> - let init_params = - try - List.map2 (fun input_str (input_name,_, input_ty) -> - LiquidData.translate { syntax_ast.ty_env with filename = input_name } - contract_sig input_str input_ty - ) init_params_strings init_infos - with Invalid_argument _ -> - raise - (ResponseError - (Printf.sprintf - "init_storage: init storage needs %d arguments, but was given %d" - (List.length init_infos) (List.length init_params_strings) - )) - in - let eval_input_storage = - try - LiquidData.default_empty_const syntax_ast.storage - with Not_found -> failwith "could not construct dummy storage for eval" - in - let eval_input_parameter = match init_params with - | [] -> CUnit - | [x] -> x - | _ -> CTuple init_params - in - - run_pre syntax_ast c source - eval_input_parameter eval_input_storage - >>= fun (_, eval_init_storage, big_map_diff, _) -> - (* Add elements of big map *) - let eval_init_storage = match eval_init_storage, big_map_diff with - | CTuple (CBigMap m :: rtuple), Some l -> - let m = List.fold_left (fun m -> function - | Big_map_add (DiffKey k, v) -> (k, v) :: m - | Big_map_add (DiffKeyHash _, _) -> - failwith "Big map must be empty in initial storage with this version of Dune node" - | Big_map_remove _ -> m - ) m l - in - CTuple (CBigMap m :: rtuple) - | CRecord ((bname, CBigMap m) :: rrecord), Some l -> - let m = List.fold_left (fun m -> function - | Big_map_add (DiffKey k, v) -> (k, v) :: m - | Big_map_add (DiffKeyHash _, _) -> - failwith "Big map must be empty in initial storage with this version of Dune node" - | Big_map_remove _ -> m - ) m l - in - CRecord ((bname, CBigMap m) :: rrecord) - | _ -> eval_init_storage - in - if !LiquidOptions.verbosity > 0 then - Printf.eprintf "Evaluated initial storage: %s\n%!" - (LiquidPrinter.Liquid.string_of_const eval_init_storage); - return (LiquidEncode.encode_const - syntax_ast.ty_env contract_sig eval_init_storage) - -let dummy_sign = "edsigtXomBKi5CTRf5cjATJWSyaRvhfYNHqSUGrn4SdbYRcGwQ\ - rUGjzEfQDTuqHhuA8b2d8NarZjz8TRf65WkpQmo423BtomS8Q" - -let minimal_fees = Z.of_int 100 -let nanotez_per_gas_unit = Z.of_int 100 -let nanotez_per_byte = Z.of_int 1000 -let to_nanotez m = Z.mul (Z.of_int 1000) m -let of_nanotez n = Z.div (Z.add (Z.of_int 999) n) (Z.of_int 1000) - -let compute_fees ~gas_limit ~size = - let minimal_fees_in_nanotez = to_nanotez minimal_fees in - let fees_for_gas_in_nanotez = - Z.mul nanotez_per_gas_unit (Z.of_int gas_limit) in - let fees_for_size_in_nanotez = Z.mul nanotez_per_byte (Z.of_int size) in - let fees_in_nanotez = - Z.add minimal_fees_in_nanotez @@ - Z.add fees_for_gas_in_nanotez fees_for_size_in_nanotez in - of_nanotez fees_in_nanotez - -let compute_gas_limit ~fee ~size = - let minimal_fees_in_nanotez = to_nanotez minimal_fees in - let fees_for_size_in_nanotez = Z.mul nanotez_per_byte (Z.of_int size) in - let fee_in_nanotez = to_nanotez fee in - let fees_for_gas_in_nanotez = - Z.sub fee_in_nanotez @@ - Z.add minimal_fees_in_nanotez fees_for_size_in_nanotez in - Z.div fees_for_gas_in_nanotez nanotez_per_gas_unit - |> Z.to_int - |> max 0 - -let estimate_gas_storage ~loc_table data = - send_post ~loc_table ~data - "/chains/main/blocks/head/helpers/scripts/run_operation" - >>= fun r -> - let r = Ezjsonm.from_string r in - let contents = - Ezjsonm.find r ["contents"] |> Ezjsonm.get_list (fun o -> o) in - let res = match contents with - | [ x (* reveal *) ; y ] -> - assert (Ezjsonm.find x ["kind"] |> Ezjsonm.get_string = "reveal"); - y - | [ y ] -> y - | _ -> invalid_arg "estimate_gas_storage" in - let result = Ezjsonm.find res ["metadata"; "operation_result" ] in - let status = - Ezjsonm.find result ["status"] |> Ezjsonm.get_string in - match status with - | "failed" -> - let errors = - try Ezjsonm.find result ["errors"] - with Not_found -> `A [] in - raise_response_error ~loc_table status errors - | "applied" -> - let consumed_gas = - try Ezjsonm.find result ["consumed_gas"] - |> Ezjsonm.get_string |> int_of_string (* |> (+) 100 *) - with Not_found -> 0 in - let consumed_storage = - try Ezjsonm.find result ["paid_storage_size_diff"] - |> Ezjsonm.get_string |> int_of_string (* |> (+) 10 *) - with Not_found -> 0 in - let allocated_dest = - try Ezjsonm.find result ["allocated_destination_contract"] - |> Ezjsonm.get_bool - with Not_found -> false in - let nb_originated = - try Ezjsonm.find result ["originated_contracts"] - |> Ezjsonm.get_list (fun _ -> ()) |> List.length - with Not_found -> 0 in - let allocated = nb_originated + if allocated_dest then 1 else 0 in - let consumed_storage = allocated * 257 + consumed_storage in - let internal_ops = - try - Ezjsonm.find res ["metadata"; "internal_operation_results" ] - |> Ezjsonm.get_list (fun o -> o) - with Not_found -> [] in - let consumed_gas, consumed_storage = - List.fold_left (fun (gas, storage) op -> - let result = Ezjsonm.find op ["result"] in - let consumed_gas = - try Ezjsonm.find result ["consumed_gas"] - |> Ezjsonm.get_string |> int_of_string - with Not_found -> 0 in - let consumed_storage = - try Ezjsonm.find result ["paid_storage_size_diff"] - |> Ezjsonm.get_string |> int_of_string - with Not_found -> 0 in - (gas + consumed_gas, storage + consumed_storage) - ) (consumed_gas, consumed_storage) internal_ops in - Format.printf "gas limit: %d\nstorage limit: %d@." consumed_gas consumed_storage; - return (consumed_gas, consumed_storage) - | _ -> failwith status - -let forge_deploy_script ~source liquid init_params_strings = - let syntax_ast, pre_michelson, _ = compile_liquid liquid in - init_storage ~source liquid init_params_strings >>= fun init_storage -> - let c, loc_table = - LiquidToMicheline.convert_contract ~expand:true pre_michelson in - let init_storage_m = LiquidMichelson.compile_const init_storage in - let init_storage_t = - LiquidToMicheline.convert_const ~expand:true init_storage_m in - let contract_json = LiquidToMicheline.json_of_contract c in - let init_storage_json = LiquidToMicheline.json_of_const init_storage_t in - return (contract_json, init_storage_json, loc_table) - -let rec forge_deploy_json ?head ?source ?public_key - ?fee ?gas_limit ?storage_limit ?real_op_size - ?(delegatable=false) ?(spendable=false) - liquid init_params_strings = - let source = match source, !LiquidOptions.source with - | Some source, _ | _, Some source -> source - | None, None -> raise (ResponseError "forge_deploy: Missing source") - in - forge_deploy_script ~source liquid init_params_strings - >>= fun (contract_json, init_storage_json, loc_table) -> - let script_json = [ - "code", contract_json; - "storage", init_storage_json - ] |> mk_json_obj - in - begin match head with - | Some head -> return head - | None -> get_head () - end >>= fun head -> - get_constants () - >>= fun { hard_gas_limit_per_operation; hard_storage_limit_per_operation } -> - get_next_counter source >>= fun counter -> - is_revealed source >>= fun source_revealed -> - let storage_limit = match storage_limit with - | Some l -> l - | None -> hard_storage_limit_per_operation in - let gas_limit = match gas_limit with - | Some l -> l - | None -> hard_gas_limit_per_operation in - let computed_fee = match real_op_size with - | None -> Z.zero - | Some size -> - let gas_limit = - if source_revealed then gas_limit else gas_limit + 10000 in - compute_fees ~gas_limit ~size - in - let computed_fee = match fee with - | None -> Z.to_string computed_fee - | Some fee when Z.compare (Z.of_string fee) computed_fee < 0 -> - Format.kasprintf failwith - "Fee too low, operation would never be included: given %s, but required \ - at least %s in fee." - LiquidNumber.(liq_of_tez @@ tez_of_mic_mutez (Z.of_string fee)) - LiquidNumber.(liq_of_tez @@ tez_of_mic_mutez computed_fee) - | Some fee -> fee in - get_manager source >>= fun manager -> - let origination_json counter = [ - "kind", "\"origination\""; - "source", Printf.sprintf "%S" source; - "fee", Printf.sprintf "%S" computed_fee; - "counter", Printf.sprintf "\"%d\"" counter; - "gas_limit", Printf.sprintf "\"%d\"" gas_limit; - "storage_limit", Printf.sprintf "\"%d\"" storage_limit; - "manager_pubkey", Printf.sprintf "%S" manager; - "balance", Printf.sprintf "%S" !LiquidOptions.amount; - "spendable", string_of_bool spendable; - "delegatable", string_of_bool delegatable; - "script", script_json; - ] |> mk_json_obj - in - let operations = match source_revealed, public_key with - | true, _ -> [origination_json counter] - | false, None -> failwith "Missing public key for revelation" - | false, Some edpk -> - let reveal_json = [ - "kind", "\"reveal\""; - "source", Printf.sprintf "%S" source; - "fee", "\"0\""; - "counter", Printf.sprintf "\"%d\"" counter; - "gas_limit", "\"10000\""; - "storage_limit", "\"0\""; - "public_key", Printf.sprintf "%S" edpk; - ] |> mk_json_obj - in - [reveal_json; origination_json (counter + 1)] - in - let operations_json = mk_json_arr operations in - let data = ([ - "branch", Printf.sprintf "%S" head.head_hash; - "contents", operations_json; - ] @ if real_op_size = None then - ["signature", Printf.sprintf "%S" dummy_sign ] - else - [] - ) |> mk_json_obj - in - match real_op_size with - | None -> - return (data, operations_json, loc_table) - | Some size -> - send_post ~loc_table ~data - "/chains/main/blocks/head/helpers/forge/operations" - >>= fun r -> - let op = get_json_string r in - let actual_size = String.length op / 2 + 64 in - if actual_size <= size then begin - Format.printf "computed fee %s@." computed_fee; - return (data, operations_json, loc_table) - end else - (* Fix point to estimate size of operation which depends on fees - which depends on size of operation *rolleyes* *) - forge_deploy_json ~head ~source ?public_key ~real_op_size:actual_size - ?fee ~gas_limit ~storage_limit - ~delegatable ~spendable - liquid init_params_strings - - -let forge_deploy ?head ?source ?public_key - ?(delegatable=false) ?(spendable=false) - liquid init_params_strings = - forge_deploy_json ?head ?source ?public_key - ~delegatable ~spendable - liquid init_params_strings >>= fun (data, _, loc_table) -> - estimate_gas_storage ~loc_table data >>= fun (est_gas_limit, est_storage_limit) -> - let gas_limit = match !LiquidOptions.gas_limit with - | None -> est_gas_limit - | Some l -> l in - let storage_limit = match !LiquidOptions.storage_limit with - | None -> est_storage_limit - | Some l -> l in - forge_deploy_json ?head ?source ?public_key ~real_op_size:0 - ?fee:!LiquidOptions.fee ~gas_limit ~storage_limit - ~delegatable ~spendable - liquid init_params_strings - >>= fun (data, operations_json, loc_table) -> - send_post ~loc_table ~data - "/chains/main/blocks/head/helpers/forge/operations" - >>= fun r -> - try - let op = get_json_string r in - return (op, operations_json, loc_table) - with Not_found -> - raise_response_error ~loc_table "forge_deploy" (Ezjsonm.from_string r) - -let hash msg = - Blake2B.(to_bytes (hash_bytes [MBytes.of_string "\x03"; msg])) - -let sign sk op_b = - Ed25519.sign sk (hash op_b) - -let inject_operation ?(force=false) ?loc_table ?sk ~head json_op op = - let op_b = MBytes.of_string (Hex.to_string op) in - get_protocol () >>= fun protocol -> - let signed_op, op_hash, data = match sk with - | None -> - let op_hash = - Operation_hash.to_b58check @@ - Operation_hash.hash_bytes [ op_b ] in - op, op_hash, [[ - "protocol", Printf.sprintf "%S" protocol; - "branch", Printf.sprintf "%S" head.head_hash; - "contents", json_op; - ] |> mk_json_obj] |> mk_json_arr - - | Some sk -> - let signature_b = sign sk op_b in - let signature = Ed25519.Signature.to_b58check signature_b in - let signed_op_b = MBytes.concat "" [op_b; signature_b] in - let signed_op = Hex.of_string (MBytes.to_string signed_op_b) in - let op_hash = - Operation_hash.to_b58check @@ - Operation_hash.hash_bytes [ signed_op_b ] in - signed_op, op_hash, [[ - "protocol", Printf.sprintf "%S" protocol; - "branch", Printf.sprintf "%S" head.head_hash; - "contents", json_op; - "signature", Printf.sprintf "%S" signature; - ] |> mk_json_obj] |> mk_json_arr - in - send_post ?loc_table ~data - "/chains/main/blocks/head/helpers/preapply/operations" - >>= fun r -> - let r = Ezjsonm.from_string r in - (try - let r = - match Ezjsonm.get_list (fun x -> x) r with - | r :: _ -> r | [] -> assert false in - let contents = - Ezjsonm.find r ["contents"] |> Ezjsonm.get_list (fun o -> o) in - Lwt_list.map_p (fun o -> - try - match Ezjsonm.(find o ["kind"] |> get_string) with - | "activate_account" -> return_ok [] - | _ -> - let result = Ezjsonm.find o ["metadata"; "operation_result" ] in - let status = - Ezjsonm.find result ["status"] |> Ezjsonm.get_string in - match status with - | "failed" -> - let errors = - try Ezjsonm.find result ["errors"] - with Not_found -> `A [] in - begin try - raise_response_error ?loc_table status errors - with exn -> return_error exn - end - | "backtracked" | "skipped" -> - return_error (Failure status) - | "applied" -> - let contracts = - try - Ezjsonm.find result ["originated_contracts"] - |> Ezjsonm.get_list Ezjsonm.get_string - with Not_found -> [] in - return_ok contracts - | _ -> return_error (Failure status) - with Not_found -> return_error (Failure "operation_result") - ) contents - with Not_found -> - raise_response_error ?loc_table "inject (preapply/operations)" r - ) >>= fun result -> - if not force then - (* Don't inject if there is an error *) - List.iter (function - | Error exn -> raise exn - | Ok _ -> ()) result; - let data = Printf.sprintf "%S" (Hex.show signed_op) in - send_post ?loc_table ~data "/injection/operation" >>= fun r -> - (try - get_json_string r |> return - with Not_found -> - raise_response_error ?loc_table "inject (/injection/operation)" - (Ezjsonm.from_string r) - ) >>= fun injected_op_hash -> - assert (injected_op_hash = op_hash); - return (injected_op_hash, result) - - -let deploy ?(delegatable=false) ?(spendable=false) liquid init_params_strings = - let sk = match !LiquidOptions.private_key with - | None -> raise (ResponseError "deploy: Missing private key") - | Some sk -> match Ed25519.Secret_key.of_b58check sk with - | Ok sk -> sk - | Error _ -> raise (ResponseError "deploy: Bad private key") - in - let source = match !LiquidOptions.source with - | Some source -> source - | None -> get_public_key_hash_from_secret_key sk - in - let public_key = get_public_key_from_secret_key sk in - get_head () >>= fun head -> - forge_deploy ~head ~source ~public_key ~delegatable ~spendable - liquid init_params_strings - >>= fun (op, op_json, loc_table) -> - inject_operation ~loc_table ~sk ~head op_json (`Hex op) >>= function - | op_h, [Ok [c]] -> return (op_h, Ok c) - | op_h, [Ok _; Ok [c]] -> return (op_h, Ok c) (* with revelation *) - | op_h, (Error e :: _ | _ :: Error e :: _) -> return (op_h, Error e) - | _ -> raise (ResponseError "deploy (inject)") - -let forge_call_parameter liquid entry_name input_string = - let contract, pre_michelson, pre_init_infos = compile_liquid liquid in - let contract_sig = full_sig_of_contract contract in - let entry = - try - List.find (fun e -> e.entry_sig.entry_name = entry_name) contract.entries - with Not_found -> - invalid_arg @@ "Contract has no entry point " ^ entry_name - in - let input = - LiquidData.translate { contract.ty_env with filename = "call_parameter" } - contract_sig input_string entry.entry_sig.parameter - in - let parameter = match contract_sig.f_entries_sig with - | [_] -> input - | _ -> LiquidEncode.encode_const contract.ty_env contract_sig - (CConstr (entry_name, - (LiquidDecode.decode_const input))) in - let _, loc_table = - LiquidToMicheline.convert_contract ~expand:true pre_michelson in - let parameter_m = LiquidMichelson.compile_const parameter in - let parameter_t = LiquidToMicheline.convert_const ~expand:true parameter_m in - LiquidToMicheline.json_of_const parameter_t, loc_table - -let rec forge_call_json ?head ?source ?public_key - ?fee ?gas_limit ?storage_limit ?real_op_size - liquid address entry_name input_string = - let source = match source, !LiquidOptions.source with - | Some source, _ | _, Some source -> source - | None, None -> raise (ResponseError "forge_call: Missing source") - in - let parameter_json, loc_table = - forge_call_parameter liquid entry_name input_string in - begin match head with - | Some head -> return head - | None -> get_head () - end >>= fun head -> - get_constants () - >>= fun { hard_gas_limit_per_operation; hard_storage_limit_per_operation } -> - get_next_counter source >>= fun counter -> - is_revealed source >>= fun source_revealed -> - let storage_limit = match storage_limit with - | Some l -> l - | None -> hard_storage_limit_per_operation in - let gas_limit = match gas_limit with - | Some l -> l - | None -> hard_gas_limit_per_operation in - let computed_fee = match real_op_size with - | None -> Z.zero - | Some size -> - let gas_limit = - if source_revealed then gas_limit else gas_limit + 10000 in - compute_fees ~gas_limit ~size - in - let computed_fee = match fee with - | None -> Z.to_string computed_fee - | Some fee when Z.compare (Z.of_string fee) computed_fee < 0 -> - Format.kasprintf failwith - "Fee too low, operation would never be included: given %s, but required \ - at least %s in fee." - LiquidNumber.(liq_of_tez @@ tez_of_mic_mutez (Z.of_string fee)) - LiquidNumber.(liq_of_tez @@ tez_of_mic_mutez computed_fee) - | Some fee -> fee in - let transaction_json counter = [ - "kind", "\"transaction\""; - "source", Printf.sprintf "%S" source; - "fee", Printf.sprintf "%S" computed_fee; - "counter", Printf.sprintf "\"%d\"" counter; - "gas_limit", Printf.sprintf "\"%d\"" gas_limit; - "storage_limit", Printf.sprintf "\"%d\"" storage_limit; - "amount", Printf.sprintf "%S" !LiquidOptions.amount; - "destination", Printf.sprintf "%S" address; - "parameters", parameter_json; - ] |> mk_json_obj - in - let operations = match source_revealed, public_key with - | true, _ -> [transaction_json counter] - | false, None -> failwith "Missing public key for revelation" - | false, Some edpk -> - let reveal_json = [ - "kind", "\"reveal\""; - "source", Printf.sprintf "%S" source; - "fee", "\"0\""; - "counter", Printf.sprintf "\"%d\"" counter; - "gas_limit", "\"10000\""; - "storage_limit", "\"0\""; - "public_key", Printf.sprintf "%S" edpk; - ] |> mk_json_obj - in - [reveal_json; transaction_json (counter + 1)] - in - let operations_json = mk_json_arr operations in - let data = ([ - "branch", Printf.sprintf "%S" head.head_hash; - "contents", operations_json; - ] @ if real_op_size = None then - ["signature", Printf.sprintf "%S" dummy_sign ] - else - [] - ) |> mk_json_obj - in - match real_op_size with - | None -> - return (data, operations_json, loc_table) - | Some size -> - send_post ~loc_table ~data - "/chains/main/blocks/head/helpers/forge/operations" - >>= fun r -> - let op = get_json_string r in - let actual_size = String.length op / 2 + 64 in - if actual_size <= size then begin - Format.printf "computed fee %s@." computed_fee; - return (data, operations_json, loc_table) - end else - (* Fix point to estimate size of operation which depends on fees - which depends on size of operation *rolleyes* *) - forge_call_json ~head ~source ?public_key ~real_op_size:actual_size - ?fee ~gas_limit ~storage_limit - liquid address entry_name input_string - - -let forge_call ?head ?source ?public_key - liquid address entry_name input_string = - forge_call_json ?head ?source ?public_key - liquid address entry_name input_string >>= fun (data, _, loc_table) -> - estimate_gas_storage ~loc_table data >>= fun (est_gas_limit, est_storage_limit) -> - let gas_limit = match !LiquidOptions.gas_limit with - | None -> est_gas_limit - | Some l -> l in - let storage_limit = match !LiquidOptions.storage_limit with - | None -> est_storage_limit - | Some l -> l in - forge_call_json ?head ?source ?public_key ~real_op_size:0 - ?fee:!LiquidOptions.fee ~gas_limit ~storage_limit - liquid address entry_name input_string - >>= fun (data, operations_json, loc_table) -> - send_post ~loc_table ~data - "/chains/main/blocks/head/helpers/forge/operations" - >>= fun r -> - try - let op = get_json_string r in - return (op, operations_json, loc_table) - with Not_found -> - raise_response_error ~loc_table "forge_call" (Ezjsonm.from_string r) - -let call liquid address entry_name parameter_string = - let sk = match !LiquidOptions.private_key with - | None -> raise (ResponseError "call: Missing private key") - | Some sk -> match Ed25519.Secret_key.of_b58check sk with - | Ok sk -> sk - | Error _ -> raise (ResponseError "call: Bad private key") - in - let source = match !LiquidOptions.source with - | Some source -> source - | None -> get_public_key_hash_from_secret_key sk - in - let public_key = get_public_key_from_secret_key sk in - get_head () >>= fun head -> - forge_call ~head ~source ~public_key - liquid address entry_name parameter_string - >>= fun (op, op_json, loc_table) -> - inject_operation ~loc_table ~sk ~head op_json (`Hex op) >>= function - | op_h, [Ok []] -> return (op_h, Ok ()) - | op_h, [Ok _; Ok []] -> return (op_h, Ok ()) (* with revelation *) - | op_h, (Error e :: _ | _ :: Error e :: _) -> return (op_h, Error e) - | _ -> raise (ResponseError "call (inject)") - - -let reveal sk = - let source = get_public_key_hash_from_secret_key sk in - let public_key = get_public_key_from_secret_key sk in - get_head () >>= fun head -> - get_next_counter source >>= fun counter -> - let reveal_json = [ - "kind", "\"reveal\""; - "source", Printf.sprintf "%S" source; - "fee", "\"0\""; - "counter", Printf.sprintf "\"%d\"" counter; - "gas_limit", "\"10000\""; - "storage_limit", "\"0\""; - "public_key", Printf.sprintf "%S" public_key; - ] |> mk_json_obj - in - let operations_json = mk_json_arr [reveal_json] in - let data = [ - "branch", Printf.sprintf "%S" head.head_hash; - "contents", operations_json; - ] |> mk_json_obj - in - send_post ~data "/chains/main/blocks/head/helpers/forge/operations" - >>= fun r -> - (try - get_json_string r |> return_some - with Not_found -> - return_none - ) >>= function - | Some op -> - inject_operation ~sk ~head operations_json (`Hex op) >>= fun _ -> - return_unit - | None -> - return_unit - - -let activate ~secret = - let sk = match !LiquidOptions.private_key with - | None -> raise (ResponseError "activate: Missing private key") - | Some sk -> match Ed25519.Secret_key.of_b58check sk with - | Ok sk -> sk - | Error _ -> raise (ResponseError "activate: Bad private key") - in - let source = match !LiquidOptions.source with - | Some source -> source - | None -> get_public_key_hash_from_secret_key sk - in - get_head () >>= fun head -> - let activate_json = [ - "kind", "\"activate_account\""; - "pkh", Printf.sprintf "%S" source; - "secret", Printf.sprintf "%S" secret; - ] |> mk_json_obj - in - let operations_json = mk_json_arr [activate_json] in - let data = [ - "branch", Printf.sprintf "%S" head.head_hash; - "contents", operations_json; - ] |> mk_json_obj - in - send_post ~data "/chains/main/blocks/head/helpers/forge/operations" - >>= fun r -> - (try - get_json_string r |> return - with Not_found -> - raise_response_error "forge activation" (Ezjsonm.from_string r) - ) >>= fun op -> - inject_operation ~sk ~head operations_json (`Hex op) >>= function - | op_h, [Ok []] -> return op_h - | _, _ -> raise (ResponseError "activation (inject)") - - -(* operation is an hexa string, signature is "edsig..." of 0x03..., where - [...] is the hexa string of operation. *) -let inject ~operation ~signature = - let signature = - match Ed25519.Signature.of_b58check signature with - | Error _ -> failwith "cannot decode signature" - | Ok signature_b -> - Hex.show (Hex.of_string (MBytes.to_string signature_b)) - in - let b = Buffer.create 1000 in - Buffer.add_char b '"'; - for i = 0 to String.length operation -1 do - let c = operation.[i] in - match c with - | '0'..'9' | 'a' .. 'f' | 'A'..'F' -> Buffer.add_char b c - | ' ' | '\n' | '\t' -> () - | _ -> - Printf.eprintf "Error: illegal characher '%s' in operation hexa\n%!" - (Char.escaped c); - exit 2 - done; - Buffer.add_string b signature; - Buffer.add_char b '"'; - let data = Buffer.contents b in - send_post "/injection/operation" ~data >>= fun r -> - try - get_json_string r |> return - with Not_found -> - raise_response_error "inject (/injection/operation)" - (Ezjsonm.from_string r) - - -let pack ?liquid ~const ~ty = - let env, csig = match liquid with - | Some liquid -> - let syntax_ast, _, _ = compile_liquid liquid in - { syntax_ast.ty_env with filename = "input" }, - full_sig_of_contract syntax_ast - | None -> - LiquidFromParsetree.initial_env "input", - LiquidTypes.dummy_contract_sig - in - let ty = - LiquidFromParsetree.translate_type env (LiquidFromParsetree.type_of_string ty) in - let const = LiquidData.translate env csig const ty in - (* LiquidCheck.check_const_type ~to_tez:LiquidPrinter.tez_of_liq noloc - * ty const in *) - let const_m = LiquidMichelson.compile_const const in - let const_t = LiquidToMicheline.convert_const ~expand:true const_m in - let const_json = LiquidToMicheline.json_of_const const_t in - let ty_m = LiquidToMicheline.convert_type (LiquidEncode.encode_type ty) in - (* same syntax for const and types*) - let ty_json = LiquidToMicheline.json_of_const ty_m in - let pack_fields = [ - "data", const_json; - "type", ty_json; - "gas", "\"800000\""; - ] in - let pack_json = mk_json_obj pack_fields in - send_post ~data:pack_json "/chains/main/blocks/head/helpers/scripts/pack_data" - >>= fun r -> - try - let r = Ezjsonm.from_string r in - let bytes = Ezjsonm.find r ["packed"] |> Ezjsonm.get_string in - return ("0x" ^ bytes) - with Not_found -> - raise_response_error "pack" (Ezjsonm.from_string r) - - -(* Withoud optional argument head *) -module Async = struct - type 'a t = 'a Lwt.t - - let init_storage liquid init_params_strings = - init_storage liquid init_params_strings - - let forge_deploy_script ~source liquid init_params_strings = - forge_deploy_script ~source liquid init_params_strings - - let forge_deploy ?(delegatable=false) ?(spendable=false) - liquid init_params_strings = - forge_deploy ~delegatable ~spendable liquid init_params_strings - >>= fun (op, _, _) -> return op - - let forge_call_parameter = forge_call_parameter - - let forge_call liquid address entry_name parameter_string = - forge_call liquid address entry_name parameter_string - >>= fun (op, _, _) -> return op - - let run liquid entry_name input_string storage_string = - run liquid entry_name input_string storage_string - - let run_debug liquid entry_name input_string storage_string = - run_debug liquid entry_name input_string storage_string - - let deploy ?(delegatable=false) ?(spendable=false) - liquid init_params_strings = - deploy ~delegatable ~spendable liquid init_params_strings - - let get_storage liquid address = - get_storage liquid address - - let get_big_map_value liquid address key = - get_big_map_value liquid address key - - let call liquid address parameter_string = - call liquid address parameter_string - - let activate ~secret = - activate ~secret - - let inject ~operation ~signature = - inject ~operation ~signature - - let pack ?liquid ~const ~ty = - pack ?liquid ~const ~ty - -end - -module Sync = struct - type 'a t = 'a - - let init_storage liquid init_params_strings = - Lwt_main.run (init_storage liquid init_params_strings) - - let forge_deploy_script ~source liquid init_params_strings = - Lwt_main.run (forge_deploy_script ~source liquid init_params_strings) - - let forge_deploy ?(delegatable=false) ?(spendable=false) - liquid init_params_strings = - Lwt_main.run (forge_deploy liquid init_params_strings - >>= fun (op, _, _) -> return op) - - let forge_call_parameter = forge_call_parameter - - let forge_call liquid address entry_name parameter_string = - Lwt_main.run (forge_call liquid address entry_name parameter_string - >>= fun (op, _, _) -> return op) - - let run liquid entry_name input_string storage_string = - Lwt_main.run (run liquid entry_name input_string storage_string) - - let run_debug liquid entry_name input_string storage_string = - Lwt_main.run (run_debug liquid entry_name input_string storage_string) - - let deploy ?(delegatable=false) ?(spendable=false) - liquid init_params_strings = - Lwt_main.run (deploy ~delegatable ~spendable liquid init_params_strings) - - let get_storage liquid address = - Lwt_main.run (get_storage liquid address) - - let get_big_map_value liquid address key = - Lwt_main.run (get_big_map_value liquid address key) - - let call liquid address entry_name parameter_string = - Lwt_main.run (call liquid address entry_name parameter_string) - - let activate ~secret = - Lwt_main.run (activate ~secret) - - let inject ~operation ~signature = - Lwt_main.run (inject ~operation ~signature) - - let pack ?liquid ~const ~ty = - Lwt_main.run (pack ?liquid ~const ~ty) - -end - -let forge_call_arg ?(entry_name="main") liquid input_string = - let contract, pre_michelson, pre_init_infos = compile_liquid liquid in - let contract_sig = full_sig_of_contract contract in - let entry = - try - List.find (fun e -> e.entry_sig.entry_name = entry_name) contract.entries - with Not_found -> - invalid_arg @@ "Contract has no entry point " ^ entry_name - in - let input = - LiquidData.translate { contract.ty_env with filename = "call_parameter" } - contract_sig input_string entry.entry_sig.parameter - in - let parameter = match contract_sig.f_entries_sig with - | [_] -> input - | _ -> LiquidEncode.encode_const contract.ty_env contract_sig - (CConstr (entry_name, - (LiquidDecode.decode_const input))) in - let param_m = LiquidMichelson.compile_const parameter in - LiquidToMicheline.(string_of_const @@ convert_const ~expand:false param_m) diff --git a/tools/liquidity/liquidDeploy.mli b/tools/liquidity/liquidDeploy.mli deleted file mode 100644 index 2b56b82a..00000000 --- a/tools/liquidity/liquidDeploy.mli +++ /dev/null @@ -1,146 +0,0 @@ -(****************************************************************************) -(* Liquidity *) -(* *) -(* Copyright (C) 2017-2019 OCamlPro SAS *) -(* *) -(* Authors: Fabrice Le Fessant *) -(* Alain Mebsout *) -(* David Declerck *) -(* *) -(* This program is free software: you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 3 of the License, or *) -(* (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program. If not, see . *) -(****************************************************************************) - - -type from = - | From_strings of string list - | From_files of string list - -type key_diff = - | DiffKeyHash of string - | DiffKey of LiquidTypes.typed_const - -type big_map_diff_item = - | Big_map_add of key_diff * LiquidTypes.typed_const - | Big_map_remove of key_diff - -type big_map_diff = big_map_diff_item list - -type stack_item = - | StackConst of LiquidTypes.typed_const - | StackCode of int - -type trace_item = { - loc : LiquidTypes.location option; - gas : int; - stack : (stack_item * string option) list; -} - -type trace = trace_item array - -type internal_operation = - | Reveal of string - | Transaction of { - amount : string; - destination : string; - parameters : LiquidTypes.typed_const option; - } - | Origination of { - manager: string ; - delegate: string option ; - script: (LiquidTypes.typed_contract * LiquidTypes.typed_const) option ; - spendable: bool ; - delegatable: bool ; - balance: string ; - } - | Delegation of string option - -type operation = { - source : string; - nonce : int; - op : internal_operation; -} - -exception RequestError of int * string -exception ResponseError of string -exception RuntimeError of LiquidTypes.error * trace option -exception LocalizedError of LiquidTypes.error -exception RuntimeFailure of LiquidTypes.error * string option * trace option - -val post : (data:string -> string -> string Lwt.t) ref -val get : (string -> string Lwt.t) ref - -module type S = sig - type 'a t - - (** Run contract with given parameter and storage on the Dune node specified - in ![LiquidOptions], returns the return value, the storage and a diff of a - big map id the contract contains any *) - val run : - from -> string -> string -> string -> - (operation list * LiquidTypes.typed_const * big_map_diff option) t - - val run_debug : - from -> string -> string -> string -> - (operation list * LiquidTypes.typed_const * big_map_diff option * trace) t - - (** Compute the initial storage for a specific script, returns storage data *) - val init_storage : from -> string list -> LiquidTypes.encoded_const t - - val forge_deploy_script : - source:string -> from -> string list -> - (string * string * LiquidToMicheline.loc_table) t - - (** Forge a deployment operation contract on the Dune node specified in - ![LiquidOptions], returns the hex-encoded operation *) - val forge_deploy : - ?delegatable:bool -> ?spendable:bool -> from -> string list -> string t - - (** Deploy a Liquidity contract on the Dune node specified in - ![LiquidOptions], returns the operation hash and the contract address *) - val deploy : - ?delegatable:bool -> ?spendable:bool -> from -> string list -> - (string * (string, exn) result) t - - val get_storage : from -> string -> LiquidTypes.typed_const t - - val get_big_map_value : - from -> string -> string -> LiquidTypes.typed_const option t - - val forge_call_parameter : - from -> string -> string -> string * LiquidToMicheline.loc_table - - (** Forge an operation to call a deploy contract, returns the hex-encoded - operation *) - val forge_call : from -> string -> string -> string -> string t - - (** Calls a deployed Liquidity contract on the Dune node specified in - ![LiquidOptions], returns the operation hash *) - val call : from -> string -> string -> string -> - (string * (unit, exn) result) t - - val activate : secret:string -> string t - - (** Inject an operation in hexa with its signature, and returns an - operation hash *) - val inject : operation:string -> signature:string -> string t - - (** Packs data as bytes *) - val pack : ?liquid:from -> const:string -> ty:string -> string t -end - -module Async : S with type 'a t = 'a Lwt.t - -module Sync : S with type 'a t = 'a - -val forge_call_arg : ?entry_name:string -> from -> string -> string diff --git a/tools/liquidity/liquidDot.ml b/tools/liquidity/liquidDot.ml index f3326c70..c3f64197 100644 --- a/tools/liquidity/liquidDot.ml +++ b/tools/liquidity/liquidDot.ml @@ -101,6 +101,7 @@ let rec to_dot ~sub_contract_of contract = | N_RECORD _ | N_CONSTR _ | N_SETFIELD _ + | N_SELF _ -> () | N_LOOP_END (x,y,z) diff --git a/tools/liquidity/liquidEmit.ml b/tools/liquidity/liquidEmit.ml index bfecb6f2..8a59f24d 100644 --- a/tools/liquidity/liquidEmit.ml +++ b/tools/liquidity/liquidEmit.ml @@ -30,12 +30,16 @@ let i ~loc exp = { } let var_annot = function - | None -> [] - | Some name -> ["@" ^ name] + | Some name when not !LiquidOptions.no_annot -> ["@" ^ name] + | _ -> [] let field_annot = function + | Some field when not !LiquidOptions.no_annot -> ["%" ^ field] + | _ -> [] + +let entrypoint_annot = function + | Some entry -> ["%" ^ entry] | None -> [] - | Some field -> ["%" ^ field] let rec emit_code ~expand code = let name = code.loc_name in @@ -48,19 +52,19 @@ let rec emit_code ~expand code = [emit_code ~expand ifthen; emit_code ~expand ifelse], var_annot name) | IF_NONE (ifthen, ifelse) -> M_INS_EXP ("IF_NONE", [], - [emit_code ~expand ifthen; emit_code ~expand ifelse], var_annot name) + [emit_code ~expand ifthen; emit_code ~expand ifelse], []) | IF_CONS (ifcons, ifnil) -> M_INS_EXP ("IF_CONS", [], - [emit_code ~expand ifcons; emit_code ~expand ifnil], var_annot name) + [emit_code ~expand ifcons; emit_code ~expand ifnil], []) | IF_LEFT (left, right) -> M_INS_EXP ("IF_LEFT", [], - [emit_code ~expand left; emit_code ~expand right], var_annot name) + [emit_code ~expand left; emit_code ~expand right], []) | LOOP loop -> - M_INS_EXP ("LOOP", [], [emit_code ~expand loop], var_annot name) + M_INS_EXP ("LOOP", [], [emit_code ~expand loop], []) | LOOP_LEFT loop -> M_INS_EXP ("LOOP_LEFT", [], [emit_code ~expand loop], var_annot name) | ITER body -> - M_INS_EXP ("ITER", [], [emit_code ~expand body], var_annot name) + M_INS_EXP ("ITER", [], [emit_code ~expand body], []) | MAP body -> M_INS_EXP ("MAP", [], [emit_code ~expand body], var_annot name) | LAMBDA (arg_type, res_type, body) -> @@ -73,7 +77,8 @@ let rec emit_code ~expand code = | RIGHT (ty, constr) -> M_INS_EXP ("RIGHT", [ty], [], var_annot name @ field_annot (Some "") @ field_annot constr) - | CONTRACT ty -> M_INS_EXP ("CONTRACT", [ty], [], var_annot name) + | CONTRACT (entry, ty) -> + M_INS_EXP ("CONTRACT", [ty], [], entrypoint_annot entry @ var_annot name) | UNPACK ty -> M_INS_EXP ("UNPACK", [ty], [], var_annot name) @@ -87,26 +92,22 @@ let rec emit_code ~expand code = let cst = emit_const ~expand cst in M_INS_CST ("PUSH", ty, cst, var_annot name) - | DIP (0, exp) -> assert false - | DIP (1, exp) -> M_INS_EXP ("DIP", [], [emit_code ~expand exp], var_annot name) - | DIP (n, exp) -> - if expand then - M_INS_EXP ("DIP", [], - [emit_code ~expand @@ i @@ - SEQ [{ code with ins = DIP(n-1, exp) }]], []) - else - M_INS_EXP (Printf.sprintf "D%sP" (String.make n 'I'), [], - [emit_code ~expand exp], var_annot name) + | DIP (0, exp) -> emit_code ~expand exp + | DIP (1, exp) -> M_INS_EXP ("DIP", [], [emit_code ~expand exp], []) + | DIP (n, exp) -> M_INS_EXP_N ("DIP", n, [emit_code ~expand exp], []) | DUP 0 -> assert false | DUP 1 -> M_INS ("DUP", var_annot name) | DUP n -> if expand then emit_code ~expand @@ i @@ SEQ [ - i @@ DIP(1, i @@ SEQ [i @@ DUP(n-1)]); - {ins = SWAP; loc = code.loc; loc_name = name } + i @@ DIP (n - 1, i @@ SEQ [{ code with ins = DUP 1 }]); + i @@ DIG (n-1); ] else M_INS (Printf.sprintf "D%sP" (String.make n 'U'), var_annot name) + | DIG 1 -> M_INS ("SWAP", []) + | DIG n -> M_INS_N ("DIG", n, []) + | DUG n -> M_INS_N ("DUG", n, []) | CDAR (0, field) -> emit_code expand { code with ins = CAR field } | CDDR (0, field) -> emit_code expand { code with ins = CDR field } @@ -124,7 +125,8 @@ let rec emit_code ~expand code = (fun _ -> i @@ CDR None) @ [{ code with ins = CDR field }]) else M_INS (Printf.sprintf "C%sDR" (String.make n 'D'), var_annot name @ field_annot field) - | DROP -> M_INS ("DROP", var_annot name) + | DROP 1 -> M_INS ("DROP", []) + | DROP n -> M_INS_N ("DROP", n, []) | CAR field -> M_INS ("CAR", var_annot name @ field_annot field) | CDR field -> M_INS ("CDR", var_annot name @ field_annot field) | PAIR -> M_INS ("PAIR", var_annot name) @@ -144,22 +146,20 @@ let rec emit_code ~expand code = | ADD -> M_INS ("ADD", var_annot name) | SUB -> M_INS ("SUB", var_annot name) | BALANCE -> M_INS ("BALANCE", var_annot name) - | SWAP -> M_INS ("SWAP", var_annot name) - | DIP_DROP (n,m) -> - emit_code ~expand @@ - i @@ DIP (n, i @@ SEQ (LiquidMisc.list_init m (fun _ -> i DROP))) + | SWAP -> M_INS ("SWAP", []) + | DIP_DROP (n,m) -> emit_code ~expand @@ i @@ DIP (n, i @@ SEQ [ i (DROP m) ]) | SOME -> M_INS ("SOME", var_annot name) | GET -> M_INS ("GET", var_annot name) | UPDATE -> M_INS ("UPDATE", var_annot name) | CONCAT -> M_INS ("CONCAT", var_annot name) | SLICE -> M_INS ("SLICE", var_annot name) | MEM -> M_INS ("MEM", var_annot name) - | SELF -> M_INS ("SELF", var_annot name) + | SELF entry -> M_INS ("SELF", entrypoint_annot entry @ var_annot name) (* | SOURCE -> M_INS "SOURCE" *) | AMOUNT -> M_INS ("AMOUNT", var_annot name) | STEPS_TO_QUOTA -> M_INS ("STEPS_TO_QUOTA", var_annot name) | ADDRESS -> M_INS ("ADDRESS", var_annot name) - | CREATE_ACCOUNT -> M_INS ("CREATE_ACCOUNT", var_annot name) + | CHAIN_ID -> M_INS ("CHAIN_ID", var_annot name) | PACK -> M_INS ("PACK", var_annot name) | BLAKE2B -> M_INS ("BLAKE2B", var_annot name) | SHA256 -> M_INS ("SHA256", var_annot name) @@ -196,6 +196,8 @@ let rec emit_code ~expand code = | IS_IMPLICIT -> M_INS ("IS_IMPLICIT", var_annot name) | BLOCK_LEVEL -> M_INS ("BLOCK_LEVEL", var_annot name) | COLLECT_CALL -> M_INS ("COLLECT_CALL", var_annot name) + | EMPTY_BIG_MAP (k, v) -> + M_INS_EXP ("EMPTY_BIG_MAP", [k; v], [], var_annot name) and emit_const ~expand cst = match cst with | ( CUnit @@ -210,8 +212,7 @@ and emit_const ~expand cst = match cst with | CSignature _ | CNone | CKey_hash _ - | CContract _ - | CAddress _ ) as cst -> cst + | CContract _ ) as cst -> cst | CLambda l -> CLambda { l with body = emit_code ~expand l.body } | CTuple l -> @@ -226,10 +227,11 @@ and emit_const ~expand cst = match cst with CMap (List.map (fun (k, v) -> (emit_const ~expand k, emit_const ~expand v)) l) - | CBigMap l -> - CBigMap (List.map (fun (k, v) -> + | CBigMap BMList l -> + CBigMap (BMList (List.map (fun (k, v) -> (emit_const ~expand k, - emit_const ~expand v)) l) + emit_const ~expand v)) l)) + | CBigMap BMId _ as c -> c | CLeft c -> CLeft (emit_const ~expand c) | CRight c -> @@ -243,8 +245,9 @@ and emit_const ~expand cst = match cst with and emit_contract ~expand (contract : loc_michelson_contract) = if !LiquidOptions.verbosity > 0 then Format.eprintf "Emit Michelson for contract@."; + let root_annots = entrypoint_annot contract.mic_root in [ - M_INS_EXP ("parameter", [contract.mic_parameter], [], []); + M_INS_EXP ("parameter", [contract.mic_parameter], [], root_annots); M_INS_EXP ("storage", [contract.mic_storage], [], []); M_INS_EXP ("code", [], [emit_code ~expand contract.mic_code], []); ] @ match contract.mic_fee_code with diff --git a/tools/liquidity/liquidEncode.ml b/tools/liquidity/liquidEncode.ml index 30d9d41b..aec7004f 100644 --- a/tools/liquidity/liquidEncode.ml +++ b/tools/liquidity/liquidEncode.ml @@ -23,7 +23,6 @@ open LiquidTypes open LiquidNamespace -open LiquidInfer open LiquidPrinter.Liquid (* Elements traversed by uncurrying transformation *) @@ -234,7 +233,7 @@ let rec encode_type ?(decompiling=false) ty = (* else *) match ty with | Ttez | Tunit | Ttimestamp | Tint | Tnat | Tbool | Tkey | Tkey_hash - | Tsignature | Tstring | Tbytes | Toperation | Taddress | Tfail -> ty + | Tsignature | Tstring | Tbytes | Toperation | Taddress | Tfail | Tchainid -> ty | Ttuple tys -> let tys' = List.map (encode_type ~decompiling) tys in if List.for_all2 (==) tys tys' then ty @@ -273,24 +272,11 @@ let rec encode_type ?(decompiling=false) ty = Trecord (name, List.map (fun (l, ty) -> l, encode_type ~decompiling ty) labels) | Tsum (name, cstys) -> Tsum (name, List.map (fun (c, ty) -> c, encode_type ~decompiling ty) cstys) - | Tcontract contract_sig when decompiling -> - Tcontract { contract_sig with - entries_sig = - List.map (fun e -> - { e with parameter = encode_type ~decompiling e. parameter } - ) contract_sig.entries_sig - } - | Tcontract contract_sig -> - let parameter = encode_type ~decompiling (encode_contract_sig contract_sig) in - Tcontract { contract_sig with entries_sig = [{ - entry_name = "main"; - parameter_name = "parameter"; - storage_name = "storage"; - parameter; - }] } + | Tcontract (entry, param) -> + Tcontract (entry, encode_type ~decompiling param) | Tvar _ | Tpartial _ -> - Format.eprintf "%s@." (LiquidPrinter.LiquidDebug.string_of_type ty); - assert false (* Removed during typechecking *) + (* Removed during typechecking (if monomorphized) *) + ty and encode_qual_type env ty = encode_type ~decompiling:env.decompiling (normalize_type ~in_env:env.env ty) @@ -307,7 +293,7 @@ and encode_contract_sig csig = * | None -> "") *) | [{ parameter }] -> parameter | entries -> - Tsum ("_entries", + Tsum (None, List.map (fun { entry_name; parameter = t } -> (entry_name, t) ) entries) @@ -323,63 +309,87 @@ and get_lambda_type ~decompiling args = function | _ -> Ttuple (List.rev args) in Tlambda (t1, t2, default_uncurry ()) -(* returns true if the type has a big map anywhere *) -let rec has_big_map = function - | Tbigmap (_t1, _t2) -> true +let rec allowed_type + ?(allow_big_map=true) + ?(allow_operation=true) + ?(allow_contract=true) = function | Ttez | Tunit | Ttimestamp | Tint | Tnat | Tbool | Tkey | Tkey_hash - | Tsignature | Tstring | Tbytes | Toperation | Taddress | Tfail -> false + | Tsignature | Tstring | Taddress | Tbytes | Tchainid -> true + | Toperation -> allow_operation + | Tfail -> false | Ttuple tys -> - List.exists has_big_map tys - | Tset t | Tlist t | Toption t -> has_big_map t - | Tor (t1, t2) | Tlambda (t1, t2, _) + List.for_all + (allowed_type ~allow_big_map ~allow_operation ~allow_contract) + tys + | Tset t -> + comparable_type t && + allowed_type ~allow_big_map ~allow_operation ~allow_contract t + | Tlist t | Toption t -> + allowed_type ~allow_big_map ~allow_operation ~allow_contract t + | Tcontract (_, t) -> + allow_contract && + allowed_type ~allow_big_map ~allow_operation:false ~allow_contract:true t + | Tor (t1, t2) -> + allowed_type ~allow_big_map ~allow_operation ~allow_contract t1 && + allowed_type ~allow_big_map ~allow_operation ~allow_contract t2 + | Tlambda (t1, t2, _) -> + allowed_type t1 && + allowed_type t2 | Tmap (t1, t2) -> - has_big_map t1 || has_big_map t2 + comparable_type t1 && + allowed_type ~allow_big_map ~allow_operation ~allow_contract t1 && + allowed_type ~allow_big_map ~allow_operation ~allow_contract t2 | Tclosure ((t1, t2), t3, _) -> - has_big_map t1 || has_big_map t2 || has_big_map t3 - | Trecord (_, labels) -> - List.exists (fun (_, ty) -> has_big_map ty) labels - | Tsum (_, cstys) -> - List.exists (fun (_, ty) -> has_big_map ty) cstys - | Tcontract { entries_sig } -> - List.exists (fun { parameter } -> has_big_map parameter) entries_sig - | Tvar _ | Tpartial _ -> assert false (* Removed during typechecking *) + allowed_type t1 && + allowed_type t2 && + allowed_type t3 + | Trecord (_, ltys) + | Tsum (_, ltys) -> + List.for_all (fun (_, ty) -> + allowed_type ~allow_big_map ~allow_operation ~allow_contract ty) ltys + | Tbigmap (t1, t2) -> + allow_big_map && + comparable_type t1 && + allowed_type ~allow_big_map:false ~allow_operation ~allow_contract t1 && + allowed_type + ~allow_big_map:false ~allow_operation:false ~allow_contract:false t2 + | Tvar _ | Tpartial _ -> + (* Removed during typechecking (if monomorphized) *) + true + +let check_allowed_type loc ?allow_operation ?allow_contract ty = + if not @@ allowed_type ?allow_operation ?allow_contract ty then + error loc + "The following type is not allowed: %s" + (string_of_type ty) (* Encode storage type. This checks that big maps appear only as the first component of the toplevel tuple or record storage. *) let encode_storage_type env ty = let ty = encode_qual_type env ty in - match ty with - | Ttuple (Tbigmap (t1, t2) :: r) - when not @@ List.exists has_big_map (t1 :: t2 :: r) -> ty - | Trecord (_, ((_, Tbigmap (t1, t2)) :: r)) - when not @@ List.exists has_big_map (t1 :: t2 :: List.map snd r) -> ty - | _ when not (has_big_map ty) -> ty - | _ -> - error (noloc env) - "only one big map is allowed, and only as first component of storage \ - (either a tuple or a record)" + check_allowed_type (noloc env) ~allow_operation:false ~allow_contract:false ty; + ty (* Encode parameter type. Parameter cannot have big maps. *) let encode_parameter_type env ty = let ty = encode_qual_type env ty in - if has_big_map ty then - error (noloc env) "big maps are not allowed in parameter type"; + check_allowed_type (noloc env) ~allow_operation:false ~allow_contract:true ty; ty -(* Unfortunately, operations are not allowed in Michelson constants, - so when they appear in one, we have to turn them to non constant - expressions. For instance (Set [op]) is turned into +(* Unfortunately, operations and big maps are not allowed in Michelson + constants, so when they appear in one, we have to turn them to non + constant expressions. For instance (Set [op]) is turned into Set.add op (Set : operation set) *) let rec deconstify env loc ty c = - if not @@ type_contains_nonlambda_operation ty then + if env.decompiling || not @@ forbidden_constant_ty ty then mk ~loc (Const { ty; const = c }) ty else match c, (encode_qual_type env ty) with - | (CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ - | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ | CAddress _), + | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ + | CBytes _ | CKey _ | CSignature _ | CNone + | CKey_hash _ | CContract _ ), _ -> - mk ~loc (Const { ty; const =c }) ty + mk ~loc (Const { ty; const = c }) ty | CSome c, Toption ty' -> mk ~loc (Apply { prim = Prim_Some; args = [deconstify env loc ty' c] }) ty @@ -393,6 +403,11 @@ let rec deconstify env loc ty c = mk ~loc (Apply { prim = Prim_tuple; args = List.map2 (deconstify env loc) tys cs }) ty + | CTuple cs, Trecord (_, ltys) -> + mk ~loc (Apply { prim = Prim_tuple; + args = List.map2 (fun (_, ty) -> + deconstify env loc ty) ltys cs }) ty + | CList cs, Tlist ty' -> List.fold_right (fun c acc -> mk ~loc (Apply { prim = Prim_Cons; @@ -418,26 +433,29 @@ let rec deconstify env loc ty c = cs (mk ~loc (Const { ty; const = CMap [] }) ty) - | CBigMap cs, Tbigmap (tk, te) -> + | CBigMap (BMList cs), Tbigmap (tk, te) -> List.fold_right (fun (k, e) acc -> mk (Apply { prim = Prim_map_add; args = [deconstify env loc tk k; deconstify env loc te e; acc] }) ~loc ty ) cs - (mk ~loc (Const { ty; const = CBigMap [] }) ty) + (* (mk ~loc (Const { ty; const = CBigMap [] }) ty) *) + (mk ~loc (Apply { prim = Prim_big_map_create; + (* Ghost unused arguments to carry big map type *) + args = [unused env ~loc tk; unused env ~loc te] }) ty) + + | CBigMap (BMId id ), Tbigmap (tk, te) -> + mk ~loc (Const { ty; const = c }) ty (* Removed by encode const *) | CRecord _, _ | CConstr _, _ -> assert false | _, _ -> - Format.eprintf "%s : %s@." - (LiquidPrinter.Liquid.string_of_const c) - (LiquidPrinter.Liquid.string_of_type ty); - assert false + error loc "Forbidden type %s in constants" (string_of_type ty) -(* Decrement counters for variables that they appear in an expression *) +(* Decrement counters for variables that appear in an expression *) let rec decr_counts_vars env e = if e.effect then () else match e.desc with @@ -448,7 +466,7 @@ let rec decr_counts_vars env e = with Not_found -> () end - | Const _ -> () + | Const _ | Self _ -> () | Failwith e | Project { record = e } @@ -463,7 +481,8 @@ let rec decr_counts_vars env e = | Loop { body = e1; arg = e2 } | LoopLeft { body = e1; arg = e2; acc = None } | Map { body = e1; arg = e2 } - | Transfer { dest = e1; amount = e2 } -> + | Transfer { dest = e1; amount = e2 } + | SelfCall { amount = e1; arg = e2 } -> decr_counts_vars env e1; decr_counts_vars env e2; @@ -505,21 +524,19 @@ let effect_binding env bnd_val = match bnd_val.desc with | _ -> bnd_val.effect let register_inlining ~loc env new_name count inline bnd_val = - if not bnd_val.transfer (* no inlining of values with transfer *) then begin - match !count with - | c when c <= 0 -> - if effect_binding env bnd_val then - () (* No inling of values with side effects which don't - appear later on *) - else begin - decr_counts_vars env bnd_val; - env.to_inline := - StringMap.add new_name (const_unit ~loc) !(env.to_inline) - end - | c when (c = 1 && inline = InAuto) || inline = InForced -> - env.to_inline := StringMap.add new_name bnd_val !(env.to_inline) - | _ -> () - end + match !count with + | c when c <= 0 -> + if effect_binding env bnd_val then + () (* No inling of values with side effects which don't + appear later on *) + else begin + decr_counts_vars env bnd_val; + env.to_inline := + StringMap.add new_name (const_unit ~loc) !(env.to_inline) + end + | c when (c = 1 && inline = InAuto) || inline = InForced -> + env.to_inline := StringMap.add new_name bnd_val !(env.to_inline) + | _ -> () let register_inlining_value env v = try @@ -538,7 +555,7 @@ let uncurry_lambda = function | _ -> false let record_field_name_in_env env field record = - let field_pos = match record.ty with + let field_pos = match expand record.ty with | Trecord (_, ltys) -> (let exception Found of int in try @@ -547,7 +564,7 @@ let record_field_name_in_env env field record = with Found i -> i) | _ -> assert false in let record = { record with ty = encode_qual_type env record.ty } in - let field = match record.ty with + let field = match expand record.ty with | Trecord (_, ltys) -> List.nth ltys field_pos |> fst | _ -> assert false in (field, record) @@ -556,8 +573,8 @@ let record_field_name_in_env env field record = variant values *) let rec encode_const env (c : typed_const) : encoded_const = match c with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _ ) as c -> c | CSome x -> CSome (encode_const env x) | CLeft x -> CLeft (encode_const env x) @@ -570,8 +587,12 @@ let rec encode_const env (c : typed_const) : encoded_const = match c with | CMap l -> CMap (List.map (fun (x,y) -> encode_const env x, encode_const env y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> encode_const env x, encode_const env y) l) + | CBigMap BMList l -> + CBigMap + (BMList + (List.map (fun (x,y) -> encode_const env x, encode_const env y) l)) + + | CBigMap BMId _ as c -> c | CRecord labels when env.decompiling -> CRecord (List.map (fun (f, x) -> f, encode_const env x) labels) @@ -582,21 +603,6 @@ let rec encode_const env (c : typed_const) : encoded_const = match c with | CConstr (constr, x) when env.decompiling -> CConstr (constr, encode_const env x) - | CConstr (constr, x) when is_entry_case constr -> - let entry_name = entry_name_of_case constr in - let rec iter entries = - match entries with - | [] -> assert false - | [e] -> - if e.entry_name <> entry_name then - error (noloc env) "unknown entry point %s" entry_name; - encode_const env x - | e :: entries -> - if e.entry_name = entry_name then CLeft (encode_const env x) - else CRight (iter entries) - in - iter env.t_contract_sig.f_entries_sig - | CConstr (constr, x) -> begin try let constr_ty, (_, _, constr_pos) = @@ -637,7 +643,7 @@ and encode env ( exp : typed_exp ) : encoded_exp = let const = encode_const env const in (* normalize wrt to top level env *) let ty = normalize_type ~in_env:env.env ty in - (* use functions instead of constants if contains operations *) + (* use functions instead of constants if contains operations or big maps *) let c = deconstify env loc ty const in mk ?name:exp.name ~loc c.desc ty @@ -680,6 +686,9 @@ and encode env ( exp : typed_exp ) : encoded_exp = let ifelse = encode env ifelse in mk ?name:exp.name ~loc (If { cond; ifthen; ifelse }) exp.ty + | Self { entry } -> + mk ?name:exp.name ~loc (Self { entry }) exp.ty + | Transfer { dest; amount } -> let dest = encode env dest in let amount = encode env amount in @@ -689,58 +698,15 @@ and encode env ( exp : typed_exp ) : encoded_exp = let amount = encode env amount in let contract = encode env contract in let arg = encode env arg in - let arg = - if env.decompiling then arg - else match entry with - | None -> arg - | Some _ - when match contract.ty with - | Tcontract { entries_sig = [_] } -> true - | _ -> false - -> arg - | Some entry -> - let constr = entry in - let rec iter entries = - match entries with - | [] -> assert false - | [e] -> - if e.entry_name <> entry then - error (noloc env) "unknown entry point %s" entry; - arg - | e :: entries -> - let mk_sums entries = match entries with - | [ e ] -> e.parameter - | _ -> - let cstrs = - List.map (fun e -> e.entry_name, e.parameter) - entries in - Tsum ("", cstrs) - in - let desc = - if e.entry_name = entry then - let right_ty = mk_sums entries in - Apply { prim = Prim_Left; - args = [arg; unused env ~loc ~constr right_ty] } - else - let arg = iter entries in - let left_ty = e.parameter in - let u = match entries with - | [_] -> unused env ~loc ~constr left_ty - | _ -> - (* marker for partially contructed values *) - unused env ~loc ~constr:"_" left_ty in - Apply { prim = Prim_Right; args = [arg; u] } - in - mk ~loc desc (mk_sums (e :: entries)) - in - iter (match contract.ty with - | Tcontract c_sig -> c_sig.entries_sig - | _ -> assert false) - in - let entry = if env.decompiling then entry else None in mk ?name:exp.name ~loc (Call { contract; amount; entry; arg }) Toperation + | SelfCall { amount; entry; arg } -> + let amount = encode env amount in + let arg = encode env arg in + mk ?name:exp.name ~loc + (SelfCall { amount; entry; arg }) Toperation + | Failwith arg -> let arg = encode env arg in mk ~loc (Failwith arg) Tfail @@ -787,6 +753,16 @@ and encode env ( exp : typed_exp ) : encoded_exp = args = [y; mk_typed_nil ~loc ty] }) ty] }) ty in encode env { exp with desc = Apply { prim; args = [l] } } + | Apply { prim = Prim_big_map_create; args = [ _unit ] } -> + let k_ty, v_ty = match exp.ty with + | Tbigmap (k, v) -> k, v + | _ -> assert false in + (* Ghost unused arguments to carry big map type *) + let k = unused env ~loc k_ty in + let v = unused env ~loc v_ty in + let desc = Apply { prim = Prim_big_map_create; args = [k; v] } in + mk ?name:exp.name ~loc desc exp.ty + | Apply { prim; args } -> encode_apply exp.name env prim loc args exp.ty @@ -1076,7 +1052,7 @@ and encode env ( exp : typed_exp ) : encoded_exp = | Tor (left_ty, right_ty) -> left_ty, right_ty | Tsum (_, [_, left_ty; _, right_ty]) -> left_ty, right_ty | Tsum (_, (_, left_ty) :: rcstrs) -> - left_ty, Tsum ("", rcstrs) + left_ty, Tsum (None, rcstrs) | _ -> assert false in let desc = @@ -1140,9 +1116,9 @@ and encode env ( exp : typed_exp ) : encoded_exp = in mk ?name:exp.name ~loc (MatchVariant { arg; cases }) exp.ty - | ContractAt { arg; c_sig } -> + | ContractAt { arg; entry; entry_param } -> let arg = encode env arg in - mk ?name:exp.name ~loc (ContractAt { arg; c_sig }) exp.ty + mk ?name:exp.name ~loc (ContractAt { arg; entry; entry_param }) exp.ty | Unpack { arg; ty } -> let arg = encode env arg in @@ -1339,28 +1315,7 @@ and encode_rec_fun env ~loc ?name f arg_name arg_ty ret_ty lam_ty body = lam_ty in encode env lam - -and encode_entry env entry = - (* "storage/1" *) - let (storage_name, env, _) = - new_binding env entry.entry_sig.storage_name env.t_contract_sig.f_storage in - (* "parameter/2" *) - let (parameter_name, env, _) = - new_binding env entry.entry_sig.parameter_name entry.entry_sig.parameter in - { - entry_sig = { - entry.entry_sig with - parameter = encode_parameter_type env entry.entry_sig.parameter; - parameter_name; - storage_name; - }; - code = encode env entry.code; - fee_code = match entry.fee_code with - | None -> None - | Some fee_code -> Some (encode env fee_code) - } - -(* Contract is encoded to single entry point form (with name "main"): +(* Contract is encoded to single entry point form (with name "default"): {contract C = struct ... let%entry e1 (p1 : ty1) s1 = code_entry_1 @@ -1375,7 +1330,7 @@ and encode_entry env entry = | _Liq_entry_e2 of ty2 | _Liq_entry_e3 of ty3 - let%entry main (paramter : p) storage = + let%entry root (paramter : p) storage = match parameter with | _Liq_entry_e1 p1 -> let s1 = storage in {code_entry_1} @@ -1467,12 +1422,12 @@ and encode_contract ?(annot=false) ?(decompiling=false) contract = encode_modules env contract.subs in let values = List.map fst values in - let parameter = encode_contract_sig (sig_of_full_sig env.t_contract_sig) in - let loc = LiquidLoc.loc_in_file env.env.filename in - if !LiquidOptions.verbosity > 0 then Format.eprintf "Encode contract %s@." (qual_contract_name contract); + let parameter = encode_contract_sig (sig_of_full_sig env.t_contract_sig) in + let loc = LiquidLoc.loc_in_file env.env.filename in + let rec values_on_top mk l exp = match l with | [] -> exp | v :: rest -> @@ -1494,13 +1449,13 @@ and encode_contract ?(annot=false) ?(decompiling=false) contract = e.entry_sig.parameter_name, e.entry_sig.storage_name | _ -> let parameter = mk_typed ~loc (Var "parameter") parameter in - let ecstrs = List.mapi (fun i e -> - let constr = e.entry_sig.entry_name in - env.env.constrs <- StringMap.add constr ("_entries", i) env.env.constrs; - constr, e.entry_sig.parameter - ) contract.entries in - env.env.types <- - StringMap.add "_entries" (fun _ -> Tsum("_entries", ecstrs)) env.env.types; + (* let ecstrs = List.mapi (fun i e -> + * let constr = e.entry_sig.entry_name in + * env.env.constrs <- StringMap.add constr ("_entries", i) env.env.constrs; + * constr, e.entry_sig.parameter + * ) contract.entries in + * env.env.types <- + * StringMap.add "_entries" (fun _ -> Tsum("_entries", ecstrs)) env.env.types; *) let mk_pattern_matching_case entry_name parameter_name storage_name code = let constr = entry_name in let pat = @@ -1589,13 +1544,16 @@ and encode_contract ?(annot=false) ?(decompiling=false) contract = let init_body = encode env i.init_body in Some { i with init_body; init_args } in + let root_name = match contract.entries with + | [e] -> e.entry_sig.entry_name (* Keep entry name as root if only one entry *) + | _ -> "" in let contract = { contract_name = contract.contract_name; values = []; storage = encode_storage_type env contract.storage; entries = [{ entry_sig = { - entry_name = "main"; + entry_name = root_name; parameter_name = pname; storage_name; parameter = encode_parameter_type env parameter; @@ -1632,3 +1590,8 @@ let encode_const env t_contract_sig const = } in encode_const env const + +let encode_type ?decompiling ty = + let ty = encode_type ?decompiling ty in + check_allowed_type (LiquidLoc.loc_in_file "_none_") ty; + ty diff --git a/tools/liquidity/liquidFromParsetree.ml b/tools/liquidity/liquidFromParsetree.ml index d475ef40..33e9c853 100644 --- a/tools/liquidity/liquidFromParsetree.ml +++ b/tools/liquidity/liquidFromParsetree.ml @@ -45,10 +45,13 @@ exception Stop of syntax_contract let ident_counter = ref 0 (* The minimal version of liquidity files that are accepted by this compiler *) -let minimal_version = 0.9 +let minimal_version = 2.0 (* The maximal version of liquidity files that are accepted by this compiler *) -let maximal_version = 1.057 +let maximal_version = + match String.split_on_char '-' LiquidVersion.version with + | x :: _ -> float_of_string x + | [] -> assert false open Asttypes @@ -119,6 +122,30 @@ let remove_stack typ = match typ.ptyp_desc with | Ptyp_extension ( { txt = "stack" }, PTyp t ) -> t | _ -> typ +let add_type_alias ~loc ty_name params ty env = + let pset, params = List.fold_left (fun (acc, params) -> function + | { ptyp_desc = Ptyp_var alpha; ptyp_loc }, Invariant -> + if StringSet.mem alpha acc then + error_loc ptyp_loc "Type parameter '%s occurs several times" alpha; + if ty_name = "storage" && alpha.[0] <> '_' then + LiquidLoc.warn (loc_of_loc ptyp_loc) (WeakParam alpha); + StringSet.add alpha acc, alpha :: params + | { ptyp_loc }, _ -> + error_loc ptyp_loc "Type parameter not allowed"; + ) (StringSet.empty, []) params in + let params = List.rev params in + if StringMap.mem ty_name env.types then + error_loc loc "type %s already defined" ty_name; + let tvars = free_tvars ty in + StringSet.iter (fun v -> + if not @@ StringSet.mem v pset then + error_loc loc "Unbound type parameter '%s" v) tvars; + let mk_ty pvals = + let subst = make_subst params pvals in + instantiate_to subst ty + in + env.types <- StringMap.add ty_name mk_ty env.types + let rec translate_type env ?expected typ = if has_stack typ then error_loc typ.ptyp_loc "Attribute [%%stack] forbidden in this context"; @@ -136,6 +163,7 @@ let rec translate_type env ?expected typ = | { ptyp_desc = Ptyp_constr ({ txt = Lident "signature" }, []) } -> Tsignature | { ptyp_desc = Ptyp_constr ({ txt = Lident "operation" }, []) } -> Toperation | { ptyp_desc = Ptyp_constr ({ txt = Lident "address" }, []) } -> Taddress + | { ptyp_desc = Ptyp_constr ({ txt = Lident "chain_id" }, []) } -> Tchainid | { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [param_type]) } -> let expected = match expected with @@ -224,19 +252,11 @@ let rec translate_type env ?expected typ = Ttuple (List.map2 (fun ty expected -> translate_type env ?expected ty) types expecteds) - | { ptyp_desc = Ptyp_constr ({ txt = ty_name ; loc }, []) } - when Longident.last ty_name = "instance" -> - let contract_type_name = - match List.rev (Longident.flatten ty_name) with - | _ :: rpath -> String.concat "." (List.rev rpath) - | _ -> assert false - in - begin - let loc = loc_of_loc loc in - try Tcontract (find_contract_type ~loc contract_type_name env) - with Not_found -> - unbound_contract_type typ.ptyp_loc contract_type_name - end + | { ptyp_desc = Ptyp_extension ({ txt = "handle" }, PTyp t) } -> + let expected = match expected with + | Some Tcontract (_, t) -> Some t + | _ -> None in + Tcontract (None, translate_type env ?expected t) | { ptyp_desc = Ptyp_constr ({ txt = ty_name; loc }, params); ptyp_loc } -> let ty_name = str_of_id ty_name in @@ -257,6 +277,31 @@ let rec translate_type env ?expected typ = | { ptyp_desc = Ptyp_var id; ptyp_loc } -> mk_tvar id + | { ptyp_desc = Ptyp_variant (fields, Closed, None); ptyp_loc } -> + let constrs = List.map (function + | Rtag ({ txt = c }, [] , _, []) -> + let c = "`" ^ c in + (c, Tunit) + | Rtag ({ txt = c }, [] , _, [arg]) -> + let c = "`" ^ c in + (c, translate_type env arg) + | Rtag _ -> + error_loc ptyp_loc "Only variants of the form `A of x allowed" + | Rinherit _ -> error_loc ptyp_loc "Only variant tags allowed" + ) fields in + let ty = Tsum (None, constrs) in + (* genereate static name *) + let tname = LiquidPrinter.Liquid.string_of_type ty in + List.iteri (fun i (c, _) -> + env.constrs <- StringMap.add c (tname, i) env.constrs; + ) constrs; + let params = StringSet.elements (free_tvars ty) |> List.map (fun v -> + { ptyp_desc = Ptyp_var v; ptyp_loc; + ptyp_attributes = [] }, Invariant + ) in + add_type_alias ~loc:ptyp_loc tname params ty env; + ty + | { ptyp_loc } -> error_loc ptyp_loc "in type" let translate_ext_type env typ = @@ -312,9 +357,9 @@ let translate_ext_type env typ = (* Prevent uncurring of lambda's in a type *) let rec set_curry_flag ty = match ty with | Tunit | Tbool | Tint | Tnat | Ttez | Tstring | Tbytes | Ttimestamp | Tkey - | Tkey_hash | Tsignature | Toperation | Taddress | Tfail -> () + | Tkey_hash | Tsignature | Toperation | Taddress | Tfail | Tchainid -> () | Ttuple tyl -> List.iter set_curry_flag tyl - | Toption ty | Tlist ty | Tset ty -> set_curry_flag ty + | Toption ty | Tlist ty | Tset ty | Tcontract (_, ty) -> set_curry_flag ty | Tmap (ty1, ty2) | Tbigmap (ty1, ty2) | Tor (ty1, ty2) -> set_curry_flag ty1; set_curry_flag ty2 | Tlambda (ty1, ty2, u) -> @@ -325,8 +370,6 @@ let rec set_curry_flag ty = match ty with !u := Some false; | Trecord (rn, fl) -> List.iter (fun (_, ty) -> set_curry_flag ty) fl | Tsum (sn, cl) -> List.iter (fun (_, ty) -> set_curry_flag ty) cl - | Tcontract c -> - List.iter (fun es -> set_curry_flag es.parameter) c.entries_sig | Tvar { contents = { contents = { tyo = Some ty }}} -> set_curry_flag ty | Tvar _ -> () | Tpartial _ -> () @@ -380,28 +423,28 @@ let access_of_deconstruct var_name loc indexes = ] }) ) indexes a -let deconstruct_pat env pat e = +let deconstruct_pat env pat = let vars_infos, ty = vars_info_pat env pat in - match vars_infos with - | [] -> assert false - | [nname, nloc, []] -> { nname; nloc }, ty, e - | _ -> - let var_name = - String.concat "_" ( "" :: (List.rev_map (fun (v,_,_) -> v) vars_infos)) in - let e = - List.fold_left (fun e (v, loc, indexes) -> - let access = access_of_deconstruct var_name loc indexes in - mk ~loc (Let { bnd_var = { nname = v; nloc = loc }; - inline = InAuto; - bnd_val = access; body = e }) - ) e vars_infos - in - let nloc = match vars_infos, List.rev vars_infos with - | (_, first_loc, _) :: _, (_, last_loc, _) :: _ -> - LiquidLoc.merge first_loc last_loc - | _ -> assert false - in - ({ nname = var_name; nloc }, ty, e) + fun e -> match vars_infos with + | [] -> assert false + | [nname, nloc, []] -> { nname; nloc }, ty, e + | _ -> + let var_name = + String.concat "_" ( "" :: (List.rev_map (fun (v,_,_) -> v) vars_infos)) in + let e = + List.fold_left (fun e (v, loc, indexes) -> + let access = access_of_deconstruct var_name loc indexes in + mk ~loc (Let { bnd_var = { nname = v; nloc = loc }; + inline = InAuto; + bnd_val = access; body = e }) + ) e vars_infos + in + let nloc = match vars_infos, List.rev vars_infos with + | (_, first_loc, _) :: _, (_, last_loc, _) :: _ -> + LiquidLoc.merge first_loc last_loc + | _ -> assert false + in + ({ nname = var_name; nloc }, ty, e) let order_labelled_args loc labels args = let labelled_exps, args = @@ -429,30 +472,6 @@ let order_labelled_args loc labels args = | [] -> List.rev args | _ -> error_loc loc "too many arguments" -let add_type_alias ~loc ty_name params ty env = - let pset, params = List.fold_left (fun (acc, params) -> function - | { ptyp_desc = Ptyp_var alpha; ptyp_loc }, Invariant -> - if StringSet.mem alpha acc then - error_loc ptyp_loc "Type parameter '%s occurs several times" alpha; - if ty_name = "storage" && alpha.[0] <> '_' then - LiquidLoc.warn (loc_of_loc ptyp_loc) (WeakParam alpha); - StringSet.add alpha acc, alpha :: params - | { ptyp_loc }, _ -> - error_loc ptyp_loc "Type parameter not allowed"; - ) (StringSet.empty, []) params in - let params = List.rev params in - if StringMap.mem ty_name env.types then - error_loc loc "type %s already defined" ty_name; - let tvars = free_tvars ty in - StringSet.iter (fun v -> - if not @@ StringSet.mem v pset then - error_loc loc "Unbound type parameter '%s" v) tvars; - let mk_ty pvals = - let subst = make_subst params pvals in - instantiate_to subst ty - in - env.types <- StringMap.add ty_name mk_ty env.types - let translate_record ~loc ty_name params labels env = let rtys = List.mapi (fun i pld -> @@ -485,7 +504,7 @@ let translate_variant ~loc ty_name params constrs env = (constr, ty) ) constrs in - let ty = Tsum (ty_name, constrs) in + let ty = Tsum (Some ty_name, constrs) in add_type_alias ~loc ty_name params ty env let check_version = function @@ -584,9 +603,18 @@ let rec translate_const env exp = | { pexp_desc = Pexp_constant (Pconst_integer (s, Some '\233')) } -> CKey_hash s, Some Tkey_hash - (* Address *) + (* Address / Contract *) | { pexp_desc = Pexp_constant (Pconst_integer (s, Some '\236')) } -> - CAddress s, Some Taddress + CContract (s, None), Some Taddress + + (* Address / Contract with entrypoint *) + | { pexp_desc = + Pexp_apply ( + { pexp_desc = Pexp_ident { txt = Lident "%" } }, + [Nolabel, { pexp_desc = Pexp_constant (Pconst_integer (s, Some '\236')) }; + Nolabel, { pexp_desc = Pexp_ident { txt = Lident entry } }]); + } -> + CContract (s, Some entry), Some Taddress (* Key *) | { pexp_desc = Pexp_constant (Pconst_integer (s, Some '\234')) } -> @@ -651,7 +679,13 @@ let rec translate_const env exp = CMap [], Some (Tmap (fresh_tvar (), fresh_tvar ())) | { pexp_desc = Pexp_construct ({ txt = Lident "BigMap" }, None) } -> - CBigMap [], Some (Tbigmap (fresh_tvar (), fresh_tvar ())) + CBigMap (BMList []), Some (Tbigmap (fresh_tvar (), fresh_tvar ())) + + | { pexp_desc = Pexp_construct ( + { txt = Lident "BigMap" }, + Some { pexp_desc = Pexp_constant (Pconst_integer (s ,None)) }) } -> + CBigMap (BMId (LiquidNumber.integer_of_liq s)), + Some (Tbigmap (fresh_tvar (), fresh_tvar ())) | { pexp_desc = Pexp_construct ( { txt = Lident ("Map" | "BigMap" as map_kind) }, @@ -667,7 +701,6 @@ let rec translate_const env exp = let csts, tys = List.split pair_list in let tys = match tys with | (Some ty1, Some ty2) :: tail -> - List.iter (function (Some ty1', Some ty2') when ty1' = ty1 && ty2' = ty2 -> () @@ -689,7 +722,7 @@ let rec translate_const env exp = in begin match map_kind with | "Map" -> CMap csts, tys - | "BigMap" -> CBigMap csts, tys + | "BigMap" -> CBigMap (BMList csts), tys | _ -> assert false end @@ -764,6 +797,21 @@ let rec translate_const env exp = in CConstr (lid, c), ty + | { pexp_desc = Pexp_variant (lid, args); pexp_loc } -> + let loc = loc_of_loc pexp_loc in + let lid = "`" ^ lid in + let c, c_ty = + match args with + | None -> CUnit, Some Tunit + | Some args -> translate_const env args + in + let ty = + try + Some (fst (find_constr ~loc lid env)) + with Not_found -> None + in + CConstr (lid, c), ty + | { pexp_desc = Pexp_record (lab_x_exp_list, None) } -> let lab_x_exp_list = List.map (fun ({ txt = label; loc }, exp) -> @@ -899,25 +947,30 @@ and translate_code contracts env exp = with | [c; t; { pexp_desc = Pexp_ident { txt = e }}; a] -> c, t, str_of_id e, a + | [c; t; { pexp_desc = Pexp_constant (Pconst_string (e, None)) }; a] -> + c, t, e, a | _ -> error_loc pexp_loc "wrong arguments" in - Call { contract = translate_code contracts env contract; - amount = translate_code contracts env amount; - entry = Some entry; - arg = translate_code contracts env arg } + let amount = translate_code contracts env amount in + let arg = translate_code contracts env arg in + begin match contract with + | { pexp_desc = Pexp_construct ({ txt = Lident "Self" }, None) } -> + SelfCall { amount; entry; arg } + | _ -> + Call { contract = translate_code contracts env contract; + amount; entry = Some entry; arg } + end | { pexp_desc = Pexp_apply ( { pexp_desc = Pexp_ident { txt = Ldot(Lident "Contract", "create") } }, - ([_; _; _; _; _; _; _] as args)); + ([_; _; _; _] as args)); pexp_loc } -> - let (manager_exp, delegate_exp, spendable_exp, - delegatable_exp, amount_exp, storage_exp, contract) = + let (delegate_exp, amount_exp, storage_exp, contract) = match order_labelled_args pexp_loc - ["manager"; "delegate"; "spendable"; "delegatable"; - "amount"; "storage"; "code" ] args + ["delegate"; "amount"; "storage"; "code" ] args with - | [d; m; de; s; a; st; + | [d; a; st; { pexp_desc = Pexp_pack { pmod_desc = Pmod_ident { txt = c }; pmod_loc } }] -> @@ -925,8 +978,8 @@ and translate_code contracts env exp = let c = try StringMap.find c contracts with Not_found -> unbound_contract pmod_loc c in - (d, m, de, s, a, st, c) - | [d; m; de; s; a; st; + (d, a, st, c) + | [d; a; st; { pexp_desc = Pexp_pack { pmod_desc = Pmod_structure structure; pmod_loc } }] -> @@ -935,13 +988,10 @@ and translate_code contracts env exp = |> List.map (fun (_, c) -> Syn_other_contract c) in let contract = translate_non_empty_contract inner_env inner_acc structure in - (d, m, de, s, a, st, contract) + (d, a, st, contract) | _ -> error_loc pexp_loc "wrong arguments for Contract.create" in CreateContract - { args = [translate_code contracts env manager_exp; - translate_code contracts env delegate_exp; - translate_code contracts env spendable_exp; - translate_code contracts env delegatable_exp; + { args = [translate_code contracts env delegate_exp; translate_code contracts env amount_exp; translate_code contracts env storage_exp; ]; @@ -954,63 +1004,87 @@ and translate_code contracts env exp = pexp_loc } -> error_loc pexp_loc "Wrong number or order of arguements for Contract.create.\n\ - Expected syntax is : Contract.create \ - \ - (contract )" + Expected syntax is : Contract.create \ + (contract )" - | { pexp_desc = - Pexp_constraint ( - { pexp_desc = - Pexp_apply ( - { pexp_desc = Pexp_ident - { txt = Ldot(Lident "Contract", "at") } }, - [ - Nolabel, addr_exp; - ]) }, - pty) } -> - let c_sig = match translate_type env pty with - | Toption ((Tcontract csig)) -> csig - | _ -> error_loc pty.ptyp_loc - "Contract.at type must be (contract C) option for some C" - in - ContractAt { arg = translate_code contracts env addr_exp; c_sig } + | { pexp_desc = Pexp_apply ( + { pexp_desc = Pexp_ident { txt = Ldot(Lident "Contract", "self") }}, + args); + pexp_loc } -> + begin match args with + | [_, { pexp_desc = Pexp_construct ( { txt = Lident "()" }, None ) }] -> + Self { entry = "default" } + | _ -> error_loc pexp_loc "Argument to Contract.self must be ()" + end - | { pexp_desc = - Pexp_apply ( + | { pexp_desc = Pexp_extension ( + { txt = "handle" }, + PStr [{ pstr_desc = Pstr_eval ( { pexp_desc = Pexp_ident - { txt = Ldot(contract_id, "at") } }, - [ - Nolabel, addr_exp; - ]) } - when StringMap.mem (str_of_id contract_id) env.contract_types -> - let c_sig = StringMap.find (str_of_id contract_id) env.contract_types in - ContractAt { arg = translate_code contracts env addr_exp; c_sig } + { txt = Ldot(Lident "Self", entry_point); + loc = c_loc } }, + [])}] + )} -> + Self { entry = entry_point } | { pexp_desc = Pexp_apply ( - { pexp_desc = Pexp_ident - { txt = Ldot(Lident contract_name, "at") } }, + { pexp_desc = Pexp_extension ( + { txt = "handle" }, + PStr [{ pstr_desc = Pstr_eval ( + { pexp_desc = Pexp_ident + { txt = Ldot(contract_id, entry_point); + loc = c_loc } }, + [])}] + ) + }, [ Nolabel, addr_exp; ]) } - when StringMap.mem contract_name contracts -> - let c_sig = sig_of_contract (StringMap.find contract_name contracts) in - ContractAt { arg = translate_code contracts env addr_exp; c_sig } + (* when StringMap.mem (str_of_id contract_id) env.contract_types *) -> + let contract_name = str_of_id contract_id in + let c_sig = + try find_contract_type ~loc contract_name env + with Not_found -> + error_loc c_loc "Unknown contract type %s" contract_name in + let { parameter = entry_param } = + try List.find (fun { entry_name } -> entry_name = entry_point ) + c_sig.entries_sig + with Not_found -> + error_loc c_loc "%s has no entry point %s" contract_name entry_point + in + ContractAt { arg = translate_code contracts env addr_exp; + entry = entry_point ; + entry_param } + (* [%handle: val%entry entry_name : param_ty ] *) | { pexp_desc = Pexp_apply ( - { pexp_desc = Pexp_ident - { txt = Ldot(Lident "Contract", "at") } }, + { pexp_desc = Pexp_extension ( + { txt = "handle" }, + PSig [{ psig_desc = Psig_extension ( + ({ txt = "entry" }, PSig [{ + psig_desc = Psig_value { + pval_name = { txt = entry_name; loc = name_loc }; + pval_type = param_ty; + pval_prim = []; + (* pval_attributes = []; *) + pval_loc; + }} + ]), []) + }] + ) + }, [ Nolabel, addr_exp; - ]); - pexp_loc } -> - (* let c_sig = Toption (Tvar (Ref.create - * { id = fresh_tv (); tyo = Some (Tpartial (Pcont [])) })) in - * ContractAt { arg = translate_code contracts env addr_exp; c_sig } *) - error_loc pexp_loc - "Contract.at must be annotated by the resulting contract type (option)" + ]) } -> + let entry_param = translate_type env param_ty in + if List.mem entry_name reserved_keywords then + error_loc name_loc "entry point %S forbidden" entry_name; + ContractAt { arg = translate_code contracts env addr_exp; + entry = entry_name; + entry_param } | { pexp_desc = Pexp_constraint ( @@ -1311,23 +1385,15 @@ and translate_code contracts env exp = let arg_name = { nname = arg_name ; nloc = vloc } in MapFold { prim; arg_name; body; arg; acc } + (* Self.entry param ~amount *) | { pexp_desc = Pexp_apply ( - { pexp_desc = Pexp_ident { txt = Ldot(Lident "Account", "create") } }, - args); - pexp_loc } -> - let manager, delegate, delegatable, amount = - match order_labelled_args pexp_loc - ["manager"; "delegate"; "delegatable"; "amount"] args - with - | [m; d; de; a] -> (m, d, de, a) - | _ -> error_loc pexp_loc "wrong arguments for Account.create" in - Apply { prim = Prim_create_account; - args = [ - translate_code contracts env manager; - translate_code contracts env delegate; - translate_code contracts env delegatable; - translate_code contracts env amount; - ] } + { pexp_desc = Pexp_ident { txt = Ldot(Lident "Self", entry) } }, + ( [Nolabel, param; Labelled "amount", amount] + | [Labelled "amount", amount; Nolabel, param] ) + ) } -> + SelfCall { amount = translate_code contracts env amount; + entry; + arg = translate_code contracts env param } (* special case for contract call with contract.entry param ~amount *) | { pexp_desc = Pexp_apply ( @@ -1358,6 +1424,15 @@ and translate_code contracts env exp = { exp with pexp_desc = Pexp_apply (f, [x]) } in exp.desc + (* constant Address / Contract with entrypoint *) + | { pexp_desc = + Pexp_apply ( + { pexp_desc = Pexp_ident { txt = Lident "%" } }, + [Nolabel, { pexp_desc = Pexp_constant (Pconst_integer (s, Some '\236')) }; + Nolabel, { pexp_desc = Pexp_ident { txt = Lident entry } }]); + } -> + Const { const = CContract (s, Some entry); ty = Taddress } + (* f x1 x2 ... xn *) | { pexp_desc = Pexp_apply ( { pexp_desc = Pexp_ident ( { txt = var } ); @@ -1539,6 +1614,14 @@ and translate_code contracts env exp = error_loc exp.pexp_loc "unknown constructor: %s" lid end + | { pexp_desc = Pexp_variant (lid, args) } -> + let lid = "`" ^ lid in + Constructor { constr = Constr lid; + arg = match args with + | None -> + mk ~loc (Const { ty = Tunit; const = CUnit }) + | Some arg -> translate_code contracts env arg } + | { pexp_desc = Pexp_constraint ( { pexp_desc = @@ -1650,8 +1733,13 @@ and translate_case contracts env case : (pattern * syntax_exp * location) = Ppat_construct ( { txt = Lident ("None" | "[]" as c) }, Some _); ppat_loc } -> error_loc ppat_loc "Constructor %S takes no arguments" c + | { ppat_desc = Ppat_construct ( { txt = name } , None); ppat_loc } -> (PConstr (str_of_id name, []), e, loc_of_loc ppat_loc) + + | { ppat_desc = Ppat_variant (name , None); ppat_loc } -> + (PConstr ("`" ^ name, []), e, loc_of_loc ppat_loc) + | { ppat_desc = Ppat_construct ( { txt = Lident "::" } , @@ -1664,6 +1752,10 @@ and translate_case contracts env case : (pattern * syntax_exp * location) = let var_name, _, e = deconstruct_pat env pat e in (PConstr (str_of_id name, [var_name.nname]), e, loc_of_loc ppat_loc) + | { ppat_desc = Ppat_variant (name , Some pat); ppat_loc } -> + let var_name, _, e = deconstruct_pat env pat e in + (PConstr ("`" ^ name, [var_name.nname]), e, loc_of_loc ppat_loc) + | { ppat_loc } -> error_loc ppat_loc "bad pattern" @@ -1833,13 +1925,12 @@ and translate_signature contract_type_name env acc ast = add_type_alias ~loc:ptype_loc ty_name params ty env; translate_signature contract_type_name env acc ast + (* val%entry entry_name : param_ty *) | { psig_desc = Psig_extension ( ({ txt = "entry" }, PSig [{ psig_desc = Psig_value { pval_name = { txt = entry_name; loc = name_loc }; - pval_type = { - ptyp_desc = Ptyp_arrow (param_label, param_ty, ret_ty) - }; + pval_type = param_ty; pval_prim = []; (* pval_attributes = []; *) pval_loc; @@ -1849,38 +1940,10 @@ and translate_signature contract_type_name env acc ast = error_loc name_loc "entry point %S forbidden" entry_name; if List.exists (fun e -> e.entry_name = entry_name) acc then error_loc name_loc "entry point %S is already declared" entry_name; - let parameter_name = match param_label with - | Nolabel -> "parameter" - | Optional _ -> error_loc pval_loc "cannot have optional parameter" - | Labelled p -> p in + let parameter_name = "parameter" in let parameter = translate_type env param_ty in set_curry_flag parameter; - let storage_name, ret_ty = match ret_ty.ptyp_desc with - | Ptyp_arrow (Nolabel, stora_ty, ret_ty) -> - "storage", ret_ty - | Ptyp_arrow (Optional _, stora_ty, _) -> - error_loc ret_ty.ptyp_loc "cannot have optional storage" - | Ptyp_arrow (Labelled s, stora_ty, ret_ty) -> - s, ret_ty - | Ptyp_any -> - "storage", ret_ty - | _ -> - error_loc ret_ty.ptyp_loc - "must be an arrow type storage -> (operation list * storage)" - in - begin match ret_ty.ptyp_desc with - | Ptyp_any -> () - | Ptyp_tuple [ ret_op ; - { ptyp_desc = - Ptyp_constr ({ txt = Lident "storage" }, []) }] -> - begin match translate_type env ret_op with - | Tlist Toperation -> () - | _ -> error_loc ret_op.ptyp_loc - "entry must return operation list as first component" - end - | _ -> error_loc ret_ty.ptyp_loc - "entry must return (operation list * storage)" - end; + let storage_name= "storage" in let entry = { entry_name; parameter; parameter_name; storage_name } in translate_signature contract_type_name env (entry :: acc) ast @@ -1980,6 +2043,7 @@ and translate_structure env acc ast : syntax_exp parsed_struct = in translate_structure env (init :: acc) ast + (* let%entry name = head_exp *) | { pstr_desc = Pstr_extension (({ txt = "entry" }, @@ -1989,7 +2053,9 @@ and translate_structure env acc ast : syntax_exp parsed_struct = Nonrecursive, [ { pvb_pat = { ppat_desc = - Ppat_var { txt = name; loc = name_loc } }; + ( Ppat_var { txt = name } + | Ppat_variant (name , None)); + ppat_loc = name_loc }; pvb_expr = head_exp; } ]) } ] diff --git a/tools/liquidity/liquidInfer.ml b/tools/liquidity/liquidInfer.ml index 8e0156fd..829e4b47 100644 --- a/tools/liquidity/liquidInfer.ml +++ b/tools/liquidity/liquidInfer.ml @@ -65,24 +65,22 @@ let wrap_tvar ty = let rec has_tvar = function | Ttuple tyl -> List.exists has_tvar tyl - | Toption ty | Tlist ty | Tset ty -> has_tvar ty + | Toption ty | Tlist ty | Tset ty | Tcontract (_, ty) -> has_tvar ty | Tmap (ty1, ty2) | Tbigmap (ty1, ty2) | Tor (ty1, ty2) | Tlambda (ty1, ty2, _) -> has_tvar ty1 || has_tvar ty2 | Tclosure ((ty1, ty2), ty3, _) -> has_tvar ty1 || has_tvar ty2 || has_tvar ty3 | Trecord (_, fl) | Tsum (_, fl) ->List.exists (fun (_, ty) -> has_tvar ty) fl - | Tcontract c -> List.exists (fun e -> has_tvar e.parameter) c.entries_sig | Tvar _ -> true | Tpartial _ -> failwith "Anomaly : has_tvar Tpartial should not happen" | _ -> false let rec occurs id = function | Ttuple tyl -> List.exists (fun ty -> occurs id ty) tyl - | Toption ty | Tlist ty | Tset ty -> occurs id ty + | Toption ty | Tlist ty | Tset ty | Tcontract (_, ty) -> occurs id ty | Tmap (ty1, ty2) | Tbigmap (ty1, ty2) | Tor (ty1, ty2) | Tlambda (ty1, ty2, _) -> occurs id ty1 || occurs id ty2 | Tclosure ((ty1, ty2), ty3, _) -> occurs id ty1 || occurs id ty2 ||occurs id ty3 | Trecord (_, fl) | Tsum (_, fl)->List.exists (fun (_, ty) -> occurs id ty) fl - | Tcontract c -> List.exists (fun e -> occurs id e.parameter) c.entries_sig | Tvar tvr -> let tv = Ref.get tvr in tv == id || (match tv.tyo with Some ty -> occurs id ty | _ -> false) @@ -91,7 +89,7 @@ let rec occurs id = function List.exists (fun (ty1, ty2) -> occurs id ty1 || occurs id ty2) cl) el | Tpartial (Ptup al) -> List.exists (fun (_, ty) -> occurs id ty) al | Tpartial (Pmap (ty1, ty2)) -> occurs id ty1 || occurs id ty2 - | Tpartial (Pcont el) -> List.exists (fun (_, ty) -> occurs id ty) el + | Tpartial (Pcont (Some (_, ty))) -> occurs id ty | _ -> false let merge_lists l1 l2 = @@ -146,7 +144,8 @@ let rec generalize tyx1 tyx2 = | Toption ty1, Toption ty2 | Tlist ty1, Tlist ty2 - | Tset ty1, Tset ty2 -> + | Tset ty1, Tset ty2 + | Tcontract (_, ty1), Tcontract (_, ty2) -> generalize ty1 ty2 | Tmap (k_ty1, v_ty1), Tmap (k_ty2, v_ty2) @@ -175,12 +174,6 @@ let rec generalize tyx1 tyx2 = generalize ty1 ty2; ) fl1 fl2 - | Tcontract c1, Tcontract c2 - when List.compare_lengths c1.entries_sig c2.entries_sig = 0 -> - List.iter2 (fun e1 e2 -> - generalize e1.parameter e2.parameter - ) c1.entries_sig c2.entries_sig - | _ , _ -> if not (eq_types tyx1 tyx2) then error noloc "Types %s and %s are not compatible\n" @@ -289,25 +282,29 @@ let rec unify loc ty1 ty2 = end - | Tpartial (Pcont el1), Tpartial (Pcont el2) -> - let el = List.fold_left (fun el (ep1, pty1) -> - try let pty2 = List.assoc ep1 el in unify pty1 pty2; el - with Not_found -> (ep1, pty1) :: el - ) el1 el2 in - Tpartial (Pcont el), [] + | Tpartial (Pcont None), Tpartial (Pcont None) -> + Tpartial (Pcont None), [] + | Tpartial (Pcont (Some (e, ty))), Tpartial (Pcont None) + | Tpartial (Pcont None), Tpartial (Pcont (Some (e, ty))) -> + Tpartial (Pcont (Some (e, ty))), [] + | Tpartial (Pcont (Some (e1, ty1))), Tpartial (Pcont (Some (e2, ty2))) -> + if e1 <> e2 then + error loc "Handles for different entry points (%s and %s)" + e1 e2; + unify ty1 ty2; + tyx1, [] - | Tpartial (Pcont el), ty | ty, Tpartial (Pcont el) -> - begin match ty with - | Tcontract { entries_sig } -> - List.iter (fun (ep, pty) -> - let entry = try - List.find (fun e -> e.entry_name = ep) entries_sig - with Not_found -> - error loc "Contract has no entry point named %S" ep in - unify pty entry.parameter - ) el; - ty, [] - | _ -> error loc "Partial contract incompatible with %S" + | Tpartial (Pcont c), ty | ty, Tpartial (Pcont c) -> + begin match ty, c with + | Tcontract (e, ty), None -> + Tcontract (e, ty), [] + | Tcontract (Some e, ty), Some (ep, typ) -> + unify typ ty; + let e = if e <> ep then None else Some e in + Tcontract (e, ty), [] + | Tcontract (None, ty), Some (ep, typ) -> + Tcontract (Some ep, ty), [] + | _, _ -> error loc "Partial contract incompatible with %S" (string_of_type ty) end @@ -375,18 +372,15 @@ let rec unify loc ty1 ty2 = end; tyx1, [] - | Tcontract c1, Tcontract c2 -> - let ok = try List.for_all2 (fun e1 e2 -> - unify e1.parameter e2.parameter; - e1.entry_name = e2.entry_name - ) c1.entries_sig c2.entries_sig - with Invalid_argument _ -> false in - if not ok then - error loc "Contracts signatures %S and %S are different" - (string_of_type ty1) - (string_of_type ty2) - else - tyx1, [] + | Tcontract (e1, ty1), Tcontract (e2, ty2) -> + (match e1, e2 with + | Some e1, Some e2 when e1 <> e2 -> + error loc "Handles for different entry points (%s and %s)" + e1 e2 + | _ -> () + ); + unify ty1 ty2; + tyx1, [] | _, _ -> if not (eq_types tyx1 tyx2) then @@ -499,8 +493,6 @@ let rec find_variant_type ~loc env = function - - (* Monomorphisation *) let instantiate_to s ty = @@ -518,11 +510,7 @@ let instantiate_to s ty = Trecord (rn, List.map (fun (fn, fty) -> (fn, aux fty)) fl) | Tsum (sn, cl) -> Tsum (sn, List.map (fun (cn, cty) -> (cn, aux cty)) cl) - | Tcontract c -> - Tcontract { c with entries_sig = - List.map (fun es -> - { es with parameter = aux es.parameter } - ) c.entries_sig } + | Tcontract (e, ty) -> Tcontract (e, aux ty) | Tvar tvr -> let tv = Ref.get tvr in begin match tv.tyo with @@ -578,10 +566,7 @@ let get_type env loc ty = Trecord (rn, List.map (fun (f, ty) -> (f, aux ty)) fl) | Tsum (sn, cl) -> Tsum (sn, List.map (fun (c, ty) -> (c, aux ty)) cl) - | Tcontract c -> Tcontract { c with entries_sig = - List.map (fun es -> - { es with parameter = aux es.parameter } - ) c.entries_sig } + | Tcontract (e, ty) -> Tcontract (e, aux ty) | Tvar tvr when (Ref.get tvr).tyo = None -> ty | Tvar tvr -> let tv = Ref.get tvr in @@ -608,39 +593,12 @@ let get_type env loc ty = * TODO might be bigmap also * let ty = Tmap (aux k_ty, aux v_ty) in * Ref.set tvr { tv with tyo = Some ty }; ty *) - | Tpartial (Pcont []) -> - let ty = Tcontract unit_contract_sig in - Ref.set tvr { tv with tyo = Some ty }; ty - | Tpartial (Pcont el) -> - let rec get_contract_types acc env = - let acc = StringMap.fold (fun _ oenv acc -> - match oenv with - | Alias _ -> acc - | Direct env -> get_contract_types acc env - ) env.others acc in - StringMap.union (fun _ _ x -> Some x) acc env.contract_types in - let known_contract_types = - get_contract_types predefined_contract_types env in - let csm = StringMap.filter (fun cn cs -> - List.for_all (fun e1 -> - List.exists (fun e2 -> - fst e1 = e2.entry_name && - eq_types (aux (snd e1)) e2.parameter - ) cs.entries_sig - ) el - ) known_contract_types in - let csig = match StringMap.bindings csm with - | [] -> - (match el with - | ["main", ty] -> contract_sig_of_param ty - | _ -> error loc "No compatible contract signature found") - | [_, csig] -> csig - | (c1, _) :: (c2, _) :: _ -> - error loc "Different compatible contract signature match \ - (Both %s and %s)" c1 c2 - in - let ty = aux (Tcontract csig) in - Ref.set tvr { tv with tyo = Some ty }; ty + | Tpartial (Pcont c) -> + let tyo = match c with + | None -> unit_contract_ty + | Some (e, ty) -> Tcontract (Some e, ty) in + Ref.set tvr { tv with tyo = Some tyo }; ty + | Tpartial (Peqn _) as ty -> let ty, to_unify = resolve loc ty in Ref.set tvr { tv with tyo = Some ty }; @@ -697,7 +655,7 @@ let rec vars_to_unit ?loc ty = match ty with Trecord (rn, List.map (fun (fn, fty) -> (fn, vars_to_unit ?loc fty)) fl) | Tsum (sn, cl) -> Tsum (sn, List.map (fun (cn, cty) -> (cn, vars_to_unit ?loc cty)) cl) - | Tcontract c -> Tcontract (sig_vars_to_unit ?loc c) + | Tcontract (e, ty) -> Tcontract (e, vars_to_unit ?loc ty) | Tvar { contents = { contents = { tyo = Some ty }}} -> vars_to_unit ?loc ty | Tvar _ -> (* Remaining vars correspond to unused arguments *) @@ -716,18 +674,52 @@ let rec vars_to_unit ?loc ty = match ty with end | Tpartial _ -> error (match loc with None -> noloc | Some loc -> loc) - "Type cannot be inferred, please add an annotation" + "Type cannot be inferred, please add an annotation : %s" + (string_of_type ty) | Tunit | Tbool | Tint | Tnat | Ttez | Tstring | Tbytes | Ttimestamp | Tkey - | Tkey_hash | Tsignature | Toperation | Taddress | Tfail -> ty + | Tkey_hash | Tsignature | Toperation | Taddress | Tfail | Tchainid -> ty -and sig_vars_to_unit ?loc c = +let sig_vars_to_unit ?loc c = { c with entries_sig = List.map (fun es -> { es with parameter = vars_to_unit ?loc es.parameter } ) c.entries_sig } -let rec tvars_to_unit ({ desc; ty; loc } as e) = +let rec has_unresolved = function + | Ttuple tyl -> List.exists has_unresolved tyl + | Toption ty | Tlist ty | Tset ty | Tcontract (_, ty) -> has_unresolved ty + | Tmap (ty1, ty2) | Tbigmap (ty1, ty2) | Tor (ty1, ty2) + | Tlambda (ty1, ty2, _) -> has_unresolved ty1 || has_unresolved ty2 + | Tclosure ((ty1, ty2), ty3, _) -> + has_unresolved ty1 || has_unresolved ty2 || has_unresolved ty3 + | Trecord (_, fl) | Tsum (_, fl) -> + List.exists (fun (_, ty) -> has_unresolved ty) fl + | Tvar { contents = { contents = { tyo = Some t }} } -> has_unresolved t + | Tvar _ -> true + | Tpartial _ -> true + | _ -> false + +let vars_to_unit ?(warn=false) ?(err=false) ?loc ty = + if not (warn || err) then vars_to_unit ?loc ty + else + let warning = has_unresolved ty in + let tvars = free_tvars ty in + let str_ty = (string_of_type ty) in + let ty' = vars_to_unit ?loc ty in + if warning then begin + let loc = match loc with None -> noloc | Some loc -> loc in + if err then error loc "Unresolved type %s, add annotation" str_ty + else + let msg = + Printf.sprintf + "Unresolved type %s. Type variables '%s were replaced by unit." + str_ty (String.concat ", '" (StringSet.elements tvars)) in + LiquidLoc.warn loc (WOther msg) + end; + ty' + +let rec tvars_to_unit ?(err=false) ({ desc; ty; loc } as e) = let desc = match desc with | Var _ -> desc | Let { bnd_var; inline; bnd_val; body } -> @@ -741,15 +733,19 @@ let rec tvars_to_unit ({ desc; ty; loc } as e) = | Project { field; record } -> Project { field; record = tvars_to_unit record } | Const { ty; const } -> - Const { ty = vars_to_unit ~loc ty; const = const_tvars_to_unit const } + let const = const_tvars_to_unit ~loc const in + (* if has_unresolved ty then + * error loc "Unresolved constant type %S, add annotation. Constant:\n %s" + * (string_of_type ty) (string_of_const const); *) + Const { ty = vars_to_unit ~err ~warn:true ~loc ty; const } | Apply { prim = Prim_extension (prim_name, effect, targs, nb_arg, nb_ret, minst); args } -> List.iter (fun ty -> - if has_tvar ty then + if has_unresolved ty then error loc "Unresolved type parameter %S for %s, add annotation" (string_of_type ty) prim_name ) targs; - let targs = List.map vars_to_unit targs in + let targs = List.map (vars_to_unit ~loc) targs in let args = List.map tvars_to_unit args in Apply { prim = Prim_extension (prim_name, effect, targs, nb_arg, nb_ret, minst); args } @@ -766,10 +762,15 @@ let rec tvars_to_unit ({ desc; ty; loc } as e) = Transfer { dest = tvars_to_unit dest; amount = tvars_to_unit amount } | Call { contract; amount; entry; arg } -> - Call { contract = tvars_to_unit contract; + Call { contract = tvars_to_unit ~err:true contract; amount = tvars_to_unit amount; entry; - arg = tvars_to_unit arg } + arg = tvars_to_unit ~err:true arg } + | Self { entry } -> Self { entry } + | SelfCall { amount; entry; arg } -> + SelfCall { amount = tvars_to_unit amount; + entry; + arg = tvars_to_unit arg } | MatchOption { arg; ifnone; some_name; ifsome } -> MatchOption { arg = tvars_to_unit arg; ifnone = tvars_to_unit ifnone; @@ -807,16 +808,16 @@ let rec tvars_to_unit ({ desc; ty; loc } as e) = acc = tvars_to_unit acc } | Lambda { arg_name; recursive; arg_ty; body; ret_ty } -> Lambda { arg_name; recursive; - arg_ty = vars_to_unit ~loc:arg_name.nloc arg_ty ; + arg_ty = vars_to_unit ~err ~warn:true ~loc:arg_name.nloc arg_ty ; body = tvars_to_unit body; - ret_ty = vars_to_unit ~loc:body.loc ret_ty } + ret_ty = vars_to_unit ~err ~warn:true ~loc:body.loc ret_ty } | Closure { arg_name; arg_ty; call_env; body; ret_ty } -> Closure { arg_name; - arg_ty = vars_to_unit ~loc:arg_name.nloc arg_ty; + arg_ty = vars_to_unit ~err ~warn:true ~loc:arg_name.nloc arg_ty; call_env = List.map (fun (v, e) -> (v, tvars_to_unit e)) call_env; body = tvars_to_unit body; - ret_ty = vars_to_unit ~loc:arg_name.nloc ret_ty } + ret_ty = vars_to_unit ~err ~warn:true ~loc:arg_name.nloc ret_ty } | Record l -> Record (List.map (fun (f, e) -> (f, tvars_to_unit e)) l) | Constructor { constr; arg } -> @@ -838,46 +839,48 @@ let rec tvars_to_unit ({ desc; ty; loc } as e) = | CreateContract { args; contract } -> CreateContract { args = List.map tvars_to_unit args; contract = contract_tvars_to_unit contract } - | ContractAt { arg; c_sig } -> - ContractAt { arg = tvars_to_unit arg; - c_sig = sig_vars_to_unit c_sig } + | ContractAt { arg; entry; entry_param } -> + ContractAt { arg = tvars_to_unit ~err:true arg; + entry; + entry_param = vars_to_unit ~err:true ~loc entry_param } | Unpack { arg; ty } -> - if has_tvar ty then + if has_unresolved ty then error loc "Unresolved unpack type %S, add annotation" (string_of_type ty) ; Unpack { arg = tvars_to_unit arg; - ty = vars_to_unit ~loc:arg.loc ty } + ty = vars_to_unit ~warn:true ~loc:arg.loc ty } | TypeAnnot _ -> assert false (* Removed during typechecking *) | Type _ -> assert false (* Removed during typechecking*) in - { e with desc; ty = vars_to_unit ~loc ty } + { e with desc; ty = vars_to_unit ~err ~loc ty } -and const_tvars_to_unit c = match c with +and const_tvars_to_unit ~loc c = match c with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c - | CSome x -> CSome (const_tvars_to_unit x) - | CLeft x -> CLeft (const_tvars_to_unit x) - | CRight x -> CRight (const_tvars_to_unit x) - | CTuple xs -> CTuple (List.map (const_tvars_to_unit) xs) - | CList xs -> CList (List.map (const_tvars_to_unit) xs) - | CSet xs -> CSet (List.map (const_tvars_to_unit) xs) + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _) as c -> c + | CSome x -> CSome (const_tvars_to_unit ~loc x) + | CLeft x -> CLeft (const_tvars_to_unit ~loc x) + | CRight x -> CRight (const_tvars_to_unit ~loc x) + | CTuple xs -> CTuple (List.map (const_tvars_to_unit ~loc) xs) + | CList xs -> CList (List.map (const_tvars_to_unit ~loc) xs) + | CSet xs -> CSet (List.map (const_tvars_to_unit ~loc) xs) | CMap l -> CMap (List.map (fun (x,y) -> - const_tvars_to_unit x, const_tvars_to_unit y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> - const_tvars_to_unit x, const_tvars_to_unit y) l) + const_tvars_to_unit ~loc x, const_tvars_to_unit ~loc y) l) + | CBigMap BMList l -> + CBigMap (BMList (List.map (fun (x,y) -> + const_tvars_to_unit ~loc x, const_tvars_to_unit ~loc y) l)) + | CBigMap BMId _ as c -> c | CRecord labels -> CRecord (List.map (fun (f, x) -> - f, const_tvars_to_unit x) labels) + f, const_tvars_to_unit ~loc x) labels) | CConstr (constr, x) -> - CConstr (constr, const_tvars_to_unit x) + CConstr (constr, const_tvars_to_unit ~loc x) | CLambda { arg_name; arg_ty; body; ret_ty; recursive } -> CLambda { arg_name; recursive; - arg_ty = vars_to_unit ~loc:arg_name.nloc arg_ty ; + arg_ty = vars_to_unit ~err:true ~loc:arg_name.nloc arg_ty ; body = tvars_to_unit body; - ret_ty = vars_to_unit ~loc:body.loc ret_ty } + ret_ty = vars_to_unit ~err:true ~loc:body.loc ret_ty } and contract_tvars_to_unit (contract : typed_contract) = let subs = List.map contract_tvars_to_unit contract.subs in @@ -1006,6 +1009,10 @@ let rec mono_exp env subst vtys (e:typed_exp) = contract = mono_exp subst vtys c.contract; amount = mono_exp subst vtys c.amount; arg = mono_exp subst vtys c.arg } + | Self { entry } -> Self { entry } + | SelfCall c -> SelfCall { entry = c.entry; + amount = mono_exp subst vtys c.amount; + arg = mono_exp subst vtys c.arg } | MatchOption mo -> MatchOption { some_name = mo.some_name; arg = mono_exp subst vtys mo.arg; ifnone = mono_exp subst vtys mo.ifnone; @@ -1064,13 +1071,9 @@ let rec mono_exp env subst vtys (e:typed_exp) = CreateContract { args = List.map (mono_exp subst vtys) cc.args; contract = fst @@ mono_contract vtys cc.contract } | ContractAt ca -> - let c_sig = { ca.c_sig with - entries_sig = List.map (fun e -> - { e with parameter = instantiate e.parameter } - ) ca.c_sig.entries_sig - } in ContractAt { arg = mono_exp subst vtys ca.arg; - c_sig } + entry = ca.entry; + entry_param = instantiate ca.entry_param } | Unpack up -> Unpack { arg = mono_exp subst vtys up.arg; ty = instantiate up.ty } @@ -1081,8 +1084,8 @@ let rec mono_exp env subst vtys (e:typed_exp) = and mono_const env subst vtys (c : typed_const) = match c with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _) as c -> c | CSome x -> CSome (mono_const env subst vtys x) | CLeft x -> CLeft (mono_const env subst vtys x) | CRight x -> CRight (mono_const env subst vtys x) @@ -1092,9 +1095,10 @@ and mono_const env subst vtys (c : typed_const) = match c with | CMap l -> CMap (List.map (fun (x,y) -> mono_const env subst vtys x, mono_const env subst vtys y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> - mono_const env subst vtys x, mono_const env subst vtys y) l) + | CBigMap BMList l -> + CBigMap (BMList (List.map (fun (x,y) -> + mono_const env subst vtys x, mono_const env subst vtys y) l)) + | CBigMap BMId _ as c -> c | CRecord labels -> CRecord (List.map (fun (f, x) -> f, mono_const env subst vtys x) labels) | CConstr (constr, x) -> @@ -1124,7 +1128,7 @@ and mono_contract vtys c = | None -> None | Some fee_code -> Some (mono_exp env [] vtys fee_code) in let pty = get_type env code.loc e.entry_sig.parameter in - if not @@ StringSet.is_empty @@ free_tvars pty then + if has_unresolved pty then error e.code.loc "Parameter type for entry %s can't be inferred (%s), \ add an annotation" @@ -1198,7 +1202,7 @@ let copy_ty ty = let rec copy_ty ty = match ty with |Tunit|Tbool|Tint|Tnat|Ttez| Tstring|Tbytes|Ttimestamp|Tkey|Tkey_hash|Tsignature|Toperation|Taddress| - Tfail -> ty + Tfail | Tchainid -> ty | Ttuple tyl -> Ttuple (List.map copy_ty tyl) | Toption ty -> Toption (copy_ty ty) | Tlist ty -> Tlist (copy_ty ty) @@ -1214,11 +1218,7 @@ let copy_ty ty = Trecord (rn, List.map (fun (fn, fty) -> (fn, copy_ty fty)) fl) | Tsum (sn, cl) -> Tsum (sn, List.map (fun (cn, cty) -> (cn, copy_ty cty)) cl) - | Tcontract c -> - Tcontract { c with entries_sig = - List.map (fun es -> - { es with parameter = copy_ty es.parameter } - ) c.entries_sig } + | Tcontract (e, ty) -> Tcontract (e, copy_ty ty) | Tvar tvr -> let tv = Ref.get tvr in let tvr = @@ -1245,8 +1245,9 @@ let copy_ty ty = Tpartial (Ptup (List.map (fun (s, t) -> s, copy_ty t) l)) | Tpartial Pmap (t1, t2) -> Tpartial (Pmap (copy_ty t1, copy_ty t2)) - | Tpartial Pcont l -> - Tpartial (Pcont (List.map (fun (s, t) -> s, copy_ty t) l)) in + | Tpartial Pcont None -> ty + | Tpartial Pcont Some (e, ty) -> + Tpartial (Pcont (Some (e, copy_ty ty))) in copy_ty ty let instantiate_to subst ty = diff --git a/tools/liquidity/liquidInfomark.ml b/tools/liquidity/liquidInfomark.ml new file mode 100644 index 00000000..509d5634 --- /dev/null +++ b/tools/liquidity/liquidInfomark.ml @@ -0,0 +1,61 @@ +(****************************************************************************) +(* Liquidity *) +(* *) +(* Copyright (C) 2017-2019 OCamlPro SAS *) +(* *) +(* Authors: Fabrice Le Fessant *) +(* Alain Mebsout *) +(* David Declerck *) +(* *) +(* This program is free software: you can redistribute it and/or modify *) +(* it under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 3 of the License, or *) +(* (at your option) any later version. *) +(* *) +(* This program is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) +(* GNU General Public License for more details. *) +(* *) +(* You should have received a copy of the GNU General Public License *) +(* along with this program. If not, see . *) +(****************************************************************************) + +let gen_info ~decompile files = + Printf.sprintf + "%s**********************************************************************\n \ + File generated by Liquidity %s version %s\n \ + (commit %s, compiled on %s)\n \ + Date: %s\ + %s\n \ + Options:\n \ + - Inlining: %b\n \ + - Simplifications: %b\n \ + - Peephole optimizations: %b\n \ + %s\ + - Uncurrying: %b\n\ + **********************************************************************%s\n\n" + (if decompile && !LiquidOptions.ocaml_syntax then "(*" else "/*") + (if decompile then "decompiler" else "compiler") + LiquidVersion.version + LiquidVersion.commit + LiquidVersion.en_date + CalendarLib.(Printer.Calendar.to_string (Calendar.now ())) + (match files with + | [] -> "" + | [f] -> "\n From file: " ^ f + | _ -> "\n From files: " ^ String.concat ", " files) + !LiquidOptions.inline + !LiquidOptions.simplify + !LiquidOptions.peephole + (if decompile then + Printf.sprintf + "- Ignore annotations: %b\n " + !LiquidOptions.ignore_annots + else + Printf.sprintf "- Single line output: %b\n \ + - Generate annotations: %b\n " + !LiquidOptions.singleline + (not !LiquidOptions.no_annot)) + (not !LiquidOptions.no_uncurrying) + (if decompile then "*)" else "*/") diff --git a/tools/liquidity/liquidInit.ml b/tools/liquidity/liquidInit.ml index 7f131b76..f0f52130 100644 --- a/tools/liquidity/liquidInit.ml +++ b/tools/liquidity/liquidInit.ml @@ -23,10 +23,9 @@ open LiquidTypes -type init = - | Init_constant of LiquidTypes.encoded_const - | Init_code of (LiquidTypes.encoded_contract * - LiquidTypes.loc_michelson_contract) +type 'a init = + | Init_constant of (datatype, 'a) exp const + | Init_code of ((datatype, 'a) exp contract) let c_empty_op ~loc = mk ~loc (Const { ty = Tlist Toperation; const = CList []}) (Tlist Toperation) @@ -35,200 +34,8 @@ let mk_nat ~loc i = (Const { ty = Tnat; const = CNat (LiquidNumber.integer_of_int i) }) Tnat -let rec subst_empty_big_map storage_ty code = - let empty_big_map loc = - let storage_var = mk ~loc (Var "_storage") storage_ty (* dummy *) in - Apply { prim = Prim_tuple_get; args = [storage_var; mk_nat ~loc 0] } - in - let desc = code.desc in - let loc = code.loc in - let desc = match desc with - | Const { const = CBigMap [] } -> - empty_big_map loc - | Const { const = CBigMap _ } -> - LiquidLoc.raise_error ~loc - "Only use empty big map constants in storage initializer" - | Const _ -> desc - | Var _ -> desc - - | Transfer _ | Call _ -> assert false - - | Failwith arg -> - let arg' = subst_empty_big_map storage_ty arg in - if arg == arg' then desc else Failwith arg' - - - | Project { field; record } -> - let record' = subst_empty_big_map storage_ty record in - if record == record' then desc - else Project { field; record = record' } - - | SetField { record = e1; field; set_val = e2 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - if e1 == e1' && e2 == e2' then desc - else SetField { record = e1'; field; set_val = e2' } - - | Constructor { constr; arg } -> - let arg' = subst_empty_big_map storage_ty arg in - if arg == arg' then desc else Constructor { constr; arg = arg' } - - | Lambda l -> - let e' = subst_empty_big_map storage_ty l.body in - if l.body == e' then desc else Lambda { l with body = e' } - - | Seq (e1, e2) -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - if e1 == e1' && e2 == e2' then desc else Seq (e1', e2') - - | Let { bnd_var; inline; bnd_val = e1; body = e2 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - if e1 == e1' && e2 == e2' then desc - else Let { bnd_var; inline; bnd_val = e1'; body = e2' } - - | Loop { arg_name; body = e1; arg = e2 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - if e1 == e1' && e2 == e2' then desc - else Loop { arg_name; body = e1'; arg = e2' } - - | LoopLeft { arg_name; body = e1; arg = e2; acc= e3 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - let e3' = match e3 with - | None -> e3 - | Some e3 -> Some (subst_empty_big_map storage_ty e3) in - if e1 == e1' && e2 == e2' && e3 == e3' then desc - else LoopLeft { arg_name; body = e1'; arg = e2'; acc = e3' } - - | If { cond = e1; ifthen = e2; ifelse = e3 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - let e3' = subst_empty_big_map storage_ty e3 in - if e1 == e1' && e2 == e2' && e3 == e3' then desc - else If { cond = e1'; ifthen = e2'; ifelse = e3' } - - | MatchOption { arg = e1; ifnone = e2; some_name; ifsome = e3 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - let e3' = subst_empty_big_map storage_ty e3 in - if e1 == e1' && e2 == e2' && e3 == e3' then desc - else MatchOption { arg = e1'; ifnone = e2'; some_name; ifsome = e3' } - - | MatchNat { arg = e1; - plus_name; ifplus = e2; - minus_name; ifminus = e3 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - let e3' = subst_empty_big_map storage_ty e3 in - if e1 == e1' && e2 == e2' && e3 == e3' then desc - else MatchNat { arg = e1'; - plus_name; ifplus = e2'; - minus_name; ifminus = e3' } - - | MatchList { arg = e1; - head_name; tail_name; ifcons = e2; ifnil = e3 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - let e3' = subst_empty_big_map storage_ty e3 in - if e1 == e1' && e2 == e2' && e3 == e3' then desc - else MatchList { arg = e1; - head_name; tail_name; ifcons = e2'; ifnil = e3' } - - | Fold { prim; arg_name; body = e1; arg = e2; acc = e3 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - let e3' = subst_empty_big_map storage_ty e3 in - if e1 == e1' && e2 == e2' && e3 == e3' then desc - else Fold { prim; arg_name; body = e1'; arg = e2'; acc = e3' } - - | Map { prim; arg_name; body = e1; arg = e2 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - if e1 == e1' && e2 == e2' then desc - else Map { prim; arg_name; body = e1'; arg = e2' } - - | MapFold { prim; arg_name; body = e1; arg = e2; acc = e3 } -> - let e1' = subst_empty_big_map storage_ty e1 in - let e2' = subst_empty_big_map storage_ty e2 in - let e3' = subst_empty_big_map storage_ty e3 in - if e1 == e1' && e2 == e2' && e3 == e3' then desc - else MapFold { prim; arg_name; body = e1'; arg = e2'; acc = e3' } - - | Apply { prim = ( Prim_sender - | Prim_source - | Prim_self - | Prim_balance - | Prim_gas - | Prim_create_account ) as p } -> - LiquidLoc.raise_error ~loc - "%s forbidden in initializer (for this version of %s)" - (string_of_primitive p) - (LiquidOptions.network_name ()) - - | Apply { prim; args } -> - let args' = List.map (subst_empty_big_map storage_ty) args in - if List.for_all2 (==) args args' then desc - else Apply { prim; args = args' } - - | Closure { arg_name; arg_ty; call_env; body; ret_ty } -> - let body' = subst_empty_big_map storage_ty body in - let call_env' = - List.map (fun (x, e) -> x, subst_empty_big_map storage_ty e) call_env in - if body == body' && - List.for_all2 (fun (_, e) (_, e') -> e == e') call_env call_env' - then desc - else Closure { arg_name; arg_ty; - call_env = call_env'; body = body'; ret_ty } - - | Record fields -> - let fields' = List.map (fun (x, e) -> x, subst_empty_big_map storage_ty e) fields in - if List.for_all2 (fun (_, e) (_, e') -> e == e') fields fields' - then desc - else Record fields' - - | MatchVariant { arg; cases } -> - let arg' = subst_empty_big_map storage_ty arg in - let cases' = List.map (fun (x, e) -> x, subst_empty_big_map storage_ty e) cases in - if arg == arg' && - List.for_all2 (fun (_, e) (_, e') -> e == e') cases cases' - then desc - else MatchVariant { arg = arg'; cases = cases' } - - | CreateContract { args; contract } -> - let args' = List.map (subst_empty_big_map storage_ty) args in - if List.for_all2 (==) args args' then desc - else CreateContract { args = args'; contract } - - | ContractAt { arg; c_sig } -> - let arg' = subst_empty_big_map storage_ty arg in - if arg == arg' then desc - else ContractAt { arg = arg'; c_sig } - - | Unpack { arg; ty } -> - let arg' = subst_empty_big_map storage_ty arg in - if arg == arg' then desc - else Unpack { arg = arg'; ty } - - | TypeAnnot { e; ty } -> - let e' = subst_empty_big_map storage_ty e in - if e == e' then desc - else TypeAnnot { e = e'; ty } - - | Type _ -> desc - - in - if desc == code.desc then - code - else - { code with desc } - - - -let tmp_contract_of_init ~loc env (init : encoded_exp LiquidTypes.init) storage_ty = +let tmp_contract_of_init ~loc env (init : (datatype, 'a) exp LiquidTypes.init) storage_ty = (* let init = * { init with init_body = (LiquidUntype.untype_code init.init_body : syntax_exp) } in *) let storage = storage_ty in @@ -261,8 +68,6 @@ let tmp_contract_of_init ~loc env (init : encoded_exp LiquidTypes.init) storage_ in parameter, code in - (* Empty big map is fetched in given storage which is always empty *) - let code = subst_empty_big_map storage_ty code in let code = mk ~loc (Apply { prim = Prim_tuple; args = [ c_empty_op ~loc; code ] }) @@ -270,7 +75,7 @@ let tmp_contract_of_init ~loc env (init : encoded_exp LiquidTypes.init) storage_ { contract_name = "_dummy_init"; storage; values = []; - entries = [{ entry_sig = { entry_name = "main"; + entries = [{ entry_sig = { entry_name = "default"; parameter; parameter_name = "_parameter"; storage_name = "_storage" }; @@ -280,7 +85,7 @@ let tmp_contract_of_init ~loc env (init : encoded_exp LiquidTypes.init) storage_ subs = []; } -let compile_liquid_init env contract_sig (init : encoded_exp LiquidTypes.init) (* ((args, sy_init) as init) *) = +let compile_liquid_init env contract_sig (init : (datatype, 'a) exp LiquidTypes.init) = let loc = init.init_body.loc in if init.init_body.transfer then LiquidLoc.raise_error ~loc @@ -291,5 +96,4 @@ let compile_liquid_init env contract_sig (init : encoded_exp LiquidTypes.init) ( with LiquidError _ -> (* non constant initial value *) let init_contract = tmp_contract_of_init ~loc env init contract_sig.f_storage in - let pre_init = LiquidMichelson.translate init_contract in - Init_code (init_contract, pre_init) + Init_code init_contract diff --git a/tools/liquidity/liquidInit.mli b/tools/liquidity/liquidInit.mli index 3e68f0e2..fa4308b5 100644 --- a/tools/liquidity/liquidInit.mli +++ b/tools/liquidity/liquidInit.mli @@ -24,12 +24,11 @@ open LiquidTypes (** Initializer *) -type init = - | Init_constant of LiquidTypes.encoded_const (** constant initializer*) - | Init_code of (LiquidTypes.encoded_contract * - LiquidTypes.loc_michelson_contract) +type 'a init = + | Init_constant of (datatype, 'a) exp LiquidTypes.const (** constant initializer*) + | Init_code of ((datatype, 'a) exp LiquidTypes.contract) (** initializer compiled to michelson contract (to be evaluated by node) *) val compile_liquid_init : - env -> full_contract_sig -> encoded_exp LiquidTypes.init -> init + env -> full_contract_sig -> (datatype, 'a) exp LiquidTypes.init -> 'a init diff --git a/tools/liquidity/liquidInterp.ml b/tools/liquidity/liquidInterp.ml index 9c5d953e..6f6f9bba 100644 --- a/tools/liquidity/liquidInterp.ml +++ b/tools/liquidity/liquidInterp.ml @@ -252,10 +252,10 @@ let rec undo_cdr acc node = let rec constrlabel_is_in_type c = function | Tunit | Tbool | Tint | Tnat | Ttez | Tstring | Tbytes | Ttimestamp - | Tkey | Tkey_hash | Tsignature | Toperation | Taddress | Tfail -> + | Tkey | Tkey_hash | Tsignature | Toperation | Taddress | Tfail | Tchainid -> false | Ttuple tys -> List.exists (constrlabel_is_in_type c) tys - | Toption ty | Tlist ty | Tset ty -> constrlabel_is_in_type c ty + | Toption ty | Tlist ty | Tset ty | Tcontract (_, ty) -> constrlabel_is_in_type c ty | Tmap (t1, t2) | Tbigmap (t1, t2) | Tor (t1, t2) | Tlambda (t1, t2, _) -> constrlabel_is_in_type c t1 || constrlabel_is_in_type c t2 | Tclosure ((t1, t2), t3, _) -> @@ -265,11 +265,6 @@ let rec constrlabel_is_in_type c = function | Trecord (_, l) | Tsum (_, l) -> List.exists (fun (c', _) -> c' = c) l || List.exists (fun (_, t) -> constrlabel_is_in_type c t) l - | Tcontract s -> - List.exists (fun e -> - c = e.entry_name || - constrlabel_is_in_type c e.parameter) - s.entries_sig | Tvar { contents = { contents = { tyo = Some ty }}} -> constrlabel_is_in_type c ty | Tvar _ | Tpartial _ -> (* assert *) false @@ -277,20 +272,21 @@ let rec constrlabel_is_in_type c = function let rec constrlabel_is_in_code c code = match code.ins with | RENAME _ | EXTENSION _ - | EXEC | DUP _ | DIP_DROP _ | DROP | CAR _ | CDR _ | CDAR _ | CDDR _ + | EXEC | DUP _ | DIP_DROP _ | DROP _ | CAR _ | CDR _ | CDAR _ | CDDR _ | PAIR | RECORD _ | COMPARE | LE | LT | GE | GT | NEQ | EQ | FAILWITH | NOW | TRANSFER_TOKENS | ADD | SUB | BALANCE | SWAP | GET | UPDATE | SOME - | CONCAT | MEM | SLICE | SELF | AMOUNT | STEPS_TO_QUOTA | CREATE_ACCOUNT + | CONCAT | MEM | SLICE | SELF _ | AMOUNT | STEPS_TO_QUOTA | BLAKE2B | SHA256 | SHA512 | HASH_KEY | CHECK_SIGNATURE | ADDRESS | CONS | OR | XOR | AND | NOT | INT | ABS | ISNAT | NEG | MUL | EDIV | LSL | LSR | SOURCE | SENDER | SIZE | IMPLICIT_ACCOUNT | SET_DELEGATE | PACK | MOD | DIV - | BLOCK_LEVEL | IS_IMPLICIT | COLLECT_CALL | GET_BALANCE + | BLOCK_LEVEL | IS_IMPLICIT | COLLECT_CALL | GET_BALANCE | EMPTY_BIG_MAP _ + | DIG _ | DUG _ | CHAIN_ID -> false | UNPACK ty | PUSH (ty, _) | LEFT (ty, _) | RIGHT (ty, _) - | CONTRACT ty -> constrlabel_is_in_type c ty + | CONTRACT (_, ty) -> constrlabel_is_in_type c ty | CREATE_CONTRACT contract -> constrlabel_is_in_contract c contract | LAMBDA (ty1, ty2, code) -> constrlabel_is_in_type c ty1 || @@ -317,6 +313,7 @@ and constrlabel_is_in_contract c contract = let curr_contract = ref { mic_parameter = Tunit; + mic_root = None; mic_storage = Tunit; mic_code = { loc = noloc; loc_name = None; @@ -777,16 +774,44 @@ and decompile_aux stack (seq : node) ins = lambda_node :: stack, lambda_node (* Stack modifications *) - | DUP 1, v :: _ -> + | DUP 0, stack -> stack, seq + | DUP n, stack when n <= List.length stack -> + let rec dup n stack = match n, stack with + | 1, v :: _ -> v + | _, _ :: stack -> dup (n - 1) stack + | _, [] -> assert false in + let v = dup n stack in v :: stack, seq - | DROP, _ :: stack -> - stack, seq - | DIP (1, code), x :: stack -> + | DROP n, stack when n <= List.length stack -> + let rec drop n stack = match n, stack with + | 0, _ -> stack + | _, _ :: stack -> drop (n - 1) stack + | _, [] -> assert false in + drop n stack, seq + | DIP (n, code), stack when n <= List.length stack -> + let rec dip n acc stack = match n, stack with + | 0, _ -> List.rev acc, stack + | _, x :: stack -> dip (n - 1) (x :: acc) stack + | _, [] -> assert false in + let top, stack = dip n [] stack in let stack, seq = decompile stack seq code in - x :: stack, seq + top @ stack, seq | SWAP, x :: y :: stack -> y :: x :: stack, seq - + | DIG n, stack when n <= List.length stack -> + let rec dig n acc stack = match n, stack with + | 0, v :: stack -> v, List.rev_append acc stack + | _, x :: stack -> dig (n - 1) (x :: acc) stack + | _, [] -> assert false in + let v, stack = dig n [] stack in + v :: stack, seq + | DUG n, v :: stack when n <= List.length stack -> + let rec dug n acc stack = match n, stack with + | 0, _ -> List.rev acc, stack + | _, x :: stack -> dug (n - 1) (x :: acc) stack + | _, [] -> assert false in + let top, stack = dug n [] stack in + top @ (v :: stack), seq (* Primitives *) @@ -816,9 +841,6 @@ and decompile_aux stack (seq : node) ins = | SENDER, stack -> let x = node ins.loc (N_PRIM "SENDER") [] [seq] in x :: stack, x - | SELF, stack -> - let x = node ins.loc (N_PRIM "SELF") [] [seq] in - x :: stack, x | NOW, stack -> let x = node ins.loc (N_PRIM "NOW") [] [seq] in x :: stack, x @@ -828,6 +850,9 @@ and decompile_aux stack (seq : node) ins = | AMOUNT, stack -> let x = node ins.loc (N_PRIM "AMOUNT") [] [seq] in x :: stack, x + | CHAIN_ID, stack -> + let x = node ins.loc (N_PRIM "CHAIN_ID") [] [seq] in + x :: stack, x | IMPLICIT_ACCOUNT, key :: stack -> let x = node ins.loc (N_PRIM "IMPLICIT_ACCOUNT") [key] [seq] in @@ -837,6 +862,10 @@ and decompile_aux stack (seq : node) ins = let x = node ins.loc (N_PRIM "SET_DELEGATE") [key] [seq] in x :: stack, x + | SELF entry, stack -> + let x = node ins.loc (N_SELF entry) [] [seq] in + x :: stack, x + | ADDRESS, x :: stack -> let x = node ins.loc (N_PRIM "ADDRESS") [x] [seq] in x :: stack, x @@ -876,8 +905,8 @@ and decompile_aux stack (seq : node) ins = let x = node ins.loc (N_RIGHT left_ty) [x] [seq] in x :: stack, x - | CONTRACT ty, x :: stack -> (* TODO : keep types too ! *) - let x = node ins.loc (N_CONTRACT ty) [x] [seq] in + | CONTRACT (entry, ty), x :: stack -> (* TODO : keep types too ! *) + let x = node ins.loc (N_CONTRACT (entry, ty)) [x] [seq] in x :: stack, x | UNPACK ty, x :: stack -> (* TODO : keep types too ! *) let x = node ins.loc (N_UNPACK ty) [x] [seq] in @@ -1085,21 +1114,10 @@ and decompile_aux stack (seq : node) ins = let x = node ins.loc (N_PRIM "STEPS_TO_QUOTA") [] [seq] in x :: stack, x - | CREATE_ACCOUNT, manager :: delegate :: delegatable :: amount :: stack -> - let x = node ins.loc (N_PRIM "CREATE_ACCOUNT") - [manager; delegate; delegatable; amount] [seq] in - let res_op = node ins.loc (N_RESULT (x, 0)) [] [] in - let res_cont = node ins.loc (N_RESULT (x, 1)) [] [] in - res_op :: res_cont :: stack, x - - | CREATE_CONTRACT contract, manager :: delegate :: - spendable :: delegatable :: - amount :: storage :: stack -> + | CREATE_CONTRACT contract, delegate :: amount :: storage :: stack -> let contract = interp contract in let x = node ins.loc (N_CREATE_CONTRACT contract) - [manager; delegate; - spendable; delegatable; - amount; storage] [seq] in + [delegate; amount; storage] [seq] in let res_op = node ins.loc (N_RESULT (x, 0)) [] [] in let res_addr = node ins.loc (N_RESULT (x, 1)) [] [] in res_op :: res_addr :: stack, x @@ -1120,6 +1138,10 @@ and decompile_aux stack (seq : node) ins = let x = node ins.loc (N_PRIM "IS_IMPLICIT") [x] [seq] in x :: stack, x + | EMPTY_BIG_MAP (k, v), stack -> + let x = node ins.loc (N_CONST (Tbigmap (k, v), CBigMap (BMList []))) [] [seq] in + x :: stack, x + | _ -> (* let ins = LiquidEmit.emit_code ins in *) let s = LiquidPrinter.Michelson.string_of_loc_michelson ins in @@ -1138,8 +1160,8 @@ and decompile_lambda loc arg_ty res_ty code = and decompile_const loc cst = match cst with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _ ) as c -> c | CSome x -> CSome (decompile_const loc x) | CLeft x -> CLeft (decompile_const loc x) | CRight x -> CRight (decompile_const loc x) @@ -1148,8 +1170,10 @@ and decompile_const loc cst = match cst with | CSet xs -> CSet (List.map (decompile_const loc) xs) | CMap l -> CMap (List.map (fun (x,y) -> decompile_const loc x, decompile_const loc y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> decompile_const loc x, decompile_const loc y) l) + | CBigMap BMId _ as c -> c + | CBigMap BMList l -> + CBigMap + (BMList (List.map (fun (x,y) -> decompile_const loc x, decompile_const loc y) l)) | CRecord labels -> CRecord (List.map (fun (f, x) -> f, decompile_const loc x) labels) | CConstr (constr, x) -> diff --git a/tools/liquidity/liquidLoc.ml b/tools/liquidity/liquidLoc.ml index 930c19a8..0cbfd219 100644 --- a/tools/liquidity/liquidLoc.ml +++ b/tools/liquidity/liquidLoc.ml @@ -66,9 +66,6 @@ let print_loc ppf loc = | None -> Format.fprintf ppf "%s" loc.loc_file -let report_error ?(kind="Error") fmt { err_loc; err_msg } = - Format.fprintf fmt "%a: %s: @[%s@]\n%!" print_loc err_loc kind err_msg - let default_warning_printer loc w = Format.eprintf "%a: Warning: @[%a@]\n%!" print_loc loc (fun fmt -> function @@ -85,6 +82,7 @@ let default_warning_printer loc w = Format.fprintf fmt "Type parameter '%s is weak" a | Partial_application -> Format.fprintf fmt "This function is partially applied" + | WOther s -> Format.pp_print_string fmt s ) w let warning_printer = ref default_warning_printer diff --git a/tools/liquidity/liquidLoc.mli b/tools/liquidity/liquidLoc.mli index 470de378..2a038f6e 100644 --- a/tools/liquidity/liquidLoc.mli +++ b/tools/liquidity/liquidLoc.mli @@ -31,7 +31,7 @@ val warn : location -> warning -> unit val print_loc : Format.formatter -> location -> unit -val report_error : ?kind:string -> Format.formatter -> error -> unit +(* val report_error : ?kind:string -> Format.formatter -> error -> unit *) val raise_error : ?loc:location -> ('a, Format.formatter, unit, 'b) format4 -> 'a diff --git a/tools/liquidity/liquidMain.ml b/tools/liquidity/liquidMain.ml index e20a57cb..f15534e3 100644 --- a/tools/liquidity/liquidMain.ml +++ b/tools/liquidity/liquidMain.ml @@ -27,11 +27,9 @@ open LiquidTypes - +open Ezcmd.Modules module DebugPrint = LiquidPrinter.LiquidDebug -exception Bad_arg - (* We use the parser of the OCaml compiler parser to parse the file, we then translate it to a simplified AST, before compiling it to Michelson. No type-checking yet. @@ -40,6 +38,8 @@ exception Bad_arg let compile_liquid_files files = let ocaml_asts = List.map (fun filename -> let ocaml_ast = LiquidFromParsetree.read_file filename in + (* Format.eprintf "%s\n================\n@." + * (LiquidPrinter.Syntax.string_of_structure ocaml_ast []); *) if !LiquidOptions.verbosity>0 then FileString.write_file (filename ^ ".ocaml") (LiquidOCamlPrinter.contract_ast ocaml_ast); @@ -113,7 +113,8 @@ let compile_liquid_files files = let output = outprefix ^ ".init.tz" in FileString.write_file output s; Printf.eprintf "Constant initial storage generated in %S\n%!" output - | LiquidInit.Init_code (_, pre_init) -> + | LiquidInit.Init_code init_sim -> + let pre_init = LiquidMichelson.translate init_sim in let mic_init, _ = LiquidToMicheline.convert_contract ~expand:true pre_init in let s, output = if !LiquidOptions.json then @@ -143,7 +144,7 @@ let compile_liquid_files files = Printf.eprintf "File %S generated\n%!" output; Printf.eprintf "If you have a node running, \ you may want to typecheck with:\n"; - Printf.eprintf " curl http://127.0.0.1:8732/chains/main/blocks/head/\ + Printf.eprintf " curl http://127.0.0.1:8733/chains/main/blocks/head/\ helpers/scripts/typecheck_code -H \ \"Content-Type:application/json\" \ -d '{\"program\":'$(cat %s)'}'\n" output @@ -152,6 +153,10 @@ let compile_liquid_files files = if !LiquidOptions.singleline then LiquidToMicheline.line_of_contract c else LiquidToMicheline.string_of_contract c in + let s = + if !LiquidOptions.writeinfo then + LiquidInfomark.gen_info ~decompile:false files ^ s + else s in match match !LiquidOptions.output with | Some output -> output @@ -197,7 +202,8 @@ let compile_tezos_file filename = (DebugPrint.string_of_contract c1); let typed_ast = try - LiquidCheck.typecheck_contract ~warnings:false ~decompiling:true c1 + LiquidCheck.typecheck_contract + ~keep_tvars:true ~warnings:false ~decompiling:true c1 with LiquidError _ -> (* Retry with generalization of types *) LiquidMichelineTypes.set_generalize_types env true; @@ -207,7 +213,8 @@ let compile_tezos_file filename = if !LiquidOptions.verbosity>0 then FileString.write_file (filename ^ ".pre") (DebugPrint.string_of_contract c2); - LiquidCheck.typecheck_contract ~warnings:false ~decompiling:true c2 + LiquidCheck.typecheck_contract + ~keep_tvars:true ~warnings:false ~decompiling:true c2 in let annoted_tz, type_annots, types = LiquidFromMicheline.infos_env env in let encode_ast, to_inline = @@ -225,11 +232,15 @@ let compile_tezos_file filename = | Some output -> output | None -> outprefix ^ if !LiquidOptions.ocaml_syntax then ".liq" else ".reliq" in - let s = try - LiquidPrinter.Syntax.string_of_structure - (LiquidToParsetree.structure_of_contract ~type_annots ~types untyped_ast) [] - with LiquidError _ -> - DebugPrint.string_of_contract untyped_ast in + let s = + LiquidCheck.typecheck_contract ~warnings:false ~decompiling:true untyped_ast + |> LiquidToParsetree.structure_of_contract ~type_annots ~types + |> fun s -> LiquidPrinter.Syntax.string_of_structure s [] + in + let s = + if !LiquidOptions.writeinfo then + LiquidInfomark.gen_info ~decompile:true [filename] ^ s ^ "\n" + else s ^ "\n" in match output with | "-" -> Format.printf "%s%!" s @@ -238,34 +249,26 @@ let compile_tezos_file filename = Printf.eprintf "File %S generated\n%!" output; () +let report_err ?(kind="Error") fmt (err_loc, err_msg) = + Format.fprintf fmt "%a: %s: @[%s@]\n%!" LiquidLoc.print_loc err_loc kind err_msg + let report_error = function | LiquidError error -> - LiquidLoc.report_error Format.err_formatter error; - | LiquidNamespace.Unknown_namespace (p, err_loc) -> - LiquidLoc.report_error Format.err_formatter - { err_loc; - err_msg = - Printf.sprintf "Unknown module or contract %s" (String.concat "." p) }; + report_err Format.err_formatter (error.err_loc, error.err_msg); + | LiquidNamespace.Unknown_namespace (p, err_loc) as exn -> + let backtrace = Printexc.get_backtrace () in + Format.eprintf "Error: %s\nBacktrace:\n%s@." + (Printexc.to_string exn) backtrace ; + report_err Format.err_formatter + (err_loc, + Printf.sprintf "Unknown module or contract %s" (String.concat "." p)); | LiquidFromMicheline.Missing_program_field f -> Format.eprintf "Missing script field %s@." f; - | LiquidDeploy.RequestError (code, msg) -> - Format.eprintf "Request Error (code %d):\n%s@." code msg; - | LiquidDeploy.ResponseError msg -> - Format.eprintf "Response Error:\n%s@." msg; - | LiquidDeploy.RuntimeError (error, _trace) -> - LiquidLoc.report_error ~kind:"Runtime error" Format.err_formatter error; - | LiquidDeploy.LocalizedError error -> - LiquidLoc.report_error ~kind:"Error" Format.err_formatter error; - | LiquidDeploy.RuntimeFailure (error, None, _trace) -> - LiquidLoc.report_error ~kind:"Failed at runtime" Format.err_formatter error; - | LiquidDeploy.RuntimeFailure (error, Some s, _trace) -> - LiquidLoc.report_error ~kind:"Failed at runtime" Format.err_formatter error; - Format.eprintf "Failed with %s@." s; | Failure f -> Format.eprintf "Failure: %s@." f | Syntaxerr.Error (Syntaxerr.Other loc) -> - LiquidLoc.report_error ~kind:"Syntax error" Format.err_formatter - { err_loc = LiquidLoc.loc_of_location loc; err_msg = "unknown" }; + report_err ~kind:"Syntax error" Format.err_formatter + (LiquidLoc.loc_of_location loc, "unknown"); | exn -> let backtrace = Printexc.get_backtrace () in Format.eprintf "Error: %s\nBacktrace:\n%s@." @@ -290,39 +293,8 @@ let compile_tezos_files = List.iter compile_tezos_file module Data = struct - let files = ref [] - let parameter = ref "" - let storage = ref "" - let entry_name = ref "main" - - let contract_address = ref "" - let init_inputs = ref [] - - let get_files () = - let l = List.rev !files in - if l = [] then raise Bad_arg; - l - - let register_deploy_input s = - init_inputs := s :: !init_inputs - - let get_inputs () = List.rev !init_inputs - - let validate_contract_addr s = - if String.length s <> 36 || String.sub s 0 3 <> "KT1" then - failwith (s ^ " is not a valid contract address") - - let validate_key_hash s = - if String.length s <> 36 || - let pref = String.sub s 0 2 in - pref <> "tz" && pref <> "dn" then - failwith (s ^ " is not a valid key hash") - - let validate_private_key s = - if (String.length s <> 54 || let p = String.sub s 0 4 in - p <> "edsk" && p <> "spsk" && p <> "p2sk") then - failwith (s ^ " is not a valid private key") + let get_files () = !files end let compile_files () = @@ -340,8 +312,8 @@ let compile_files () = [] -> begin match liq_files, tz_files with | [], [] -> - Format.eprintf "No files given as arguments@."; - raise Bad_arg + Format.eprintf "Error: No files given as arguments@."; + exit 1 | [], _ -> compile_tezos_files tz_files | _, _ -> @@ -353,216 +325,6 @@ let compile_files () = (Format.pp_print_list Format.pp_print_string) unknown; exit 2 -let translate () = - let files = Data.get_files () in - let parameter = !Data.parameter in - let storage = !Data.storage in - let entry_name = !Data.entry_name in - let ocaml_asts = List.map (fun f -> f, LiquidFromParsetree.read_file f) files in - (* first, extract the types *) - let contract = LiquidFromParsetree.translate_multi ocaml_asts in - let _ = LiquidCheck.typecheck_contract ~warnings:true contract in - let contract_sig = full_sig_of_contract contract in - let entry = - try - List.find (fun e -> e.entry_sig.entry_name = entry_name) - contract.entries - with Not_found -> - Format.eprintf "Contract has no entry point %s@." entry_name; exit 2 - in - let input = - LiquidData.translate { contract.ty_env with filename = "parameter" } - contract_sig parameter - entry.entry_sig.parameter in - let parameter_const = match contract_sig.f_entries_sig with - | [_] -> input - | _ -> LiquidEncode.encode_const contract.ty_env contract_sig - (CConstr (entry_name, - (LiquidDecode.decode_const input))) in - let to_str mic_data = - let mic_data = LiquidMichelson.compile_const mic_data in - if !LiquidOptions.json then - LiquidToMicheline.(json_of_const @@ convert_const ~expand:true mic_data) - else - LiquidToMicheline.(line_of_const @@ convert_const ~expand:false mic_data) in - if storage = "" then - (* Only translate parameter *) - Printf.printf "%s\n%!" (to_str parameter_const) - else - let storage_const = - LiquidData.translate { contract.ty_env with filename = "storage" } - contract_sig storage contract.storage in - if !LiquidOptions.json then - Printf.printf "{\n \"parameter\": %s; \n \"storage\": %s\n}\n%!" - (to_str parameter_const) (to_str storage_const) - else - Printf.printf "parameter: %s \nstorage: %s\n%!" - (to_str parameter_const) (to_str storage_const) - -let inject file = - let signature = match !LiquidOptions.signature with - | None -> - Printf.eprintf "Error: missing --signature option for --inject\n%!"; - exit 2 - | Some signature -> signature - in - (* an hexa encoded operation *) - let operation = FileString.read_file file in - let op_h = LiquidDeploy.Sync.inject ~operation ~signature in - Printf.printf "Operation injected: %s\n%!" op_h - -let run () = - let open LiquidDeploy in - let ops, r_storage, big_map_diff = - Sync.run (From_files (Data.get_files ())) - !Data.entry_name !Data.parameter !Data.storage - in - Printf.printf "%s\n# Internal operations: %d\n%!" - (LiquidPrinter.Liquid.string_of_const r_storage) - (List.length ops); - match big_map_diff with - | None -> () - | Some diff -> - Printf.printf "\nBig map diff:\n"; - List.iter (function - | Big_map_add (k, v) -> - Printf.printf "+ %s --> %s\n" - (match k with - | DiffKeyHash h -> h - | DiffKey k -> LiquidPrinter.Liquid.string_of_const k) - (LiquidPrinter.Liquid.string_of_const v) - | Big_map_remove k -> - Printf.printf "- %s\n" - (match k with - | DiffKeyHash h -> h - | DiffKey k -> LiquidPrinter.Liquid.string_of_const k) - ) diff; - Printf.printf "%!" - - -let forge_deploy () = - let op = - LiquidDeploy.Sync.forge_deploy - ~delegatable:!LiquidOptions.delegatable - ~spendable:!LiquidOptions.spendable - (LiquidDeploy.From_files (Data.get_files ())) (Data.get_inputs ()) - in - Printf.eprintf "Raw operation:\n--------------\n%!"; - Printf.printf "%s\n%!" op - -let init_storage () = - let storage = - LiquidDeploy.Sync.init_storage - (LiquidDeploy.From_files (Data.get_files ())) (Data.get_inputs ()) - in - let outname = - let c = match !LiquidOptions.main with - | Some c -> c - | None -> match List.rev (Data.get_files ()) with - | c :: _ -> c - | [] -> assert false in - String.uncapitalize_ascii c in - let storage = LiquidMichelson.compile_const storage in - if !LiquidOptions.json then - let s = LiquidToMicheline.(json_of_const @@ convert_const ~expand:true storage) in - let output = match !LiquidOptions.output with - | Some output -> output - | None -> outname ^ ".init.json" in - FileString.write_file output s; - Printf.printf "Constant initial storage generated in %S\n%!" output - else - let s = LiquidToMicheline.(line_of_const @@ convert_const ~expand:false storage) in - let output = match !LiquidOptions.output with - | Some output -> output - | None -> outname ^ ".init.tz" in - FileString.write_file output s; - Printf.printf "Constant initial storage generated in %S\n%!" output - -let deploy () = - match - LiquidDeploy.Sync.deploy - ~delegatable:!LiquidOptions.delegatable - ~spendable:!LiquidOptions.spendable - (LiquidDeploy.From_files (Data.get_files ())) (Data.get_inputs ()) - with - | op_h, Ok contract_id -> - Printf.printf "New contract %s deployed in operation %s\n%!" - contract_id op_h - | op_h, Error e -> - Printf.printf "Failed deployment in operation %s\n%!" op_h; - raise e - -let get_storage () = - let r_storage = - LiquidDeploy.Sync.get_storage - (LiquidDeploy.From_files (Data.get_files ())) - !Data.contract_address - in - Printf.printf "%s\n%!" - (LiquidPrinter.Liquid.string_of_const r_storage) - -let call_arg () = - let s = - LiquidDeploy.forge_call_arg - (LiquidDeploy.From_files (Data.get_files ())) - ~entry_name:!Data.entry_name - !Data.parameter - in - match !LiquidOptions.output with - | None -> - Printf.printf "Use --arg '%s'\n%!" s - | Some "-" -> - Printf.printf "'%s'%!" s - | Some file -> - FileString.write_file file s - -let call () = - match - LiquidDeploy.Sync.call - (LiquidDeploy.From_files (Data.get_files ())) - !Data.contract_address - !Data.entry_name - !Data.parameter - with - | op_h, Ok () -> - Printf.printf "Successful call to contract %s in operation %s\n%!" - !Data.contract_address op_h - | op_h, Error e -> - Printf.printf "Failed call to contract %s in operation %s\n%!" - !Data.contract_address op_h; - raise e - -let forge_call () = - let op = - LiquidDeploy.Sync.forge_call - (LiquidDeploy.From_files (Data.get_files ())) - !Data.contract_address - !Data.entry_name - !Data.parameter in - Printf.eprintf "Raw operation:\n--------------\n%!"; - Printf.printf "%s\n%!" op - -let pack const ty = - let liquid = - try Some (LiquidDeploy.From_files (Data.get_files ())) - with Bad_arg -> None in - let bytes = - LiquidDeploy.Sync.pack ?liquid ~const ~ty in - Printf.printf "%s\n%!" bytes - -let parse_tez_to_string expl amount = - match LiquidData.translate (LiquidFromParsetree.initial_env expl) - dummy_contract_sig amount Ttez - with - | CTez t -> - let mutez = match t.mutez with - | Some mutez -> mutez - | None -> "000000" - in - t.tezzies ^ mutez - | _ -> assert false - - let convert_file filename = let is_liq = Filename.check_suffix filename ".liq" in let is_re = Filename.check_suffix filename ".reliq" in @@ -581,252 +343,62 @@ let convert_file filename = LiquidOptions.ocaml_syntax := not is_liq; let s = LiquidPrinter.Syntax.string_of_structure str comments in LiquidOptions.ocaml_syntax := is_liq; - Printf.printf "%s%!" s; - () + match !LiquidOptions.output with + | None | Some "-" -> + Format.printf "%s%!" s + | Some output -> + FileString.write_file output s; + Printf.eprintf "File %S generated\n%!" output; + () + +let docs = Manpage.s_common_options + +let common_args = + LiquidCommonArgs.common @ [ + ["o"; "output"], + Arg.String (fun o -> LiquidOptions.output := Some o), + Ezcmd.info ~docs:Manpage.s_options ~docv:"filename" "Output code in $(docv)"; + + ["json"; "j"], + Arg.Set LiquidOptions.json, + Ezcmd.info ~docs "Output Michelson in JSON representation"; + + ["type-only"], + Arg.Set LiquidOptions.typeonly, + Ezcmd.info ~docs "Stop after type checking"; + + ["parse-only"], + Arg.Set LiquidOptions.parseonly, + Ezcmd.info ~docs "Stop after parsing"; + + ] let main () = - let work_done = ref false in - let arg_list = Arg.align [ - "--verbose", Arg.Unit (fun () -> incr LiquidOptions.verbosity), - " Increment verbosity"; - "-v", Arg.Unit (fun () -> incr LiquidOptions.verbosity), - " Increment verbosity"; - - "--re", Arg.Clear LiquidOptions.ocaml_syntax, " Use ReasonML syntax"; - "--convert", Arg.String (fun s -> - convert_file s; - work_done := true), " Switch between OCaml and ReasonML syntax (stdout)"; - - "--version", Arg.Unit (fun () -> - Format.printf "%s" LiquidToParsetree.output_version; - if !LiquidOptions.verbosity > 0 then - Format.printf " (%s)" LiquidVersion.commit; - if !LiquidOptions.verbosity > 1 then - Format.printf "\nCompiled on %s" LiquidVersion.en_date; - Format.printf "@."; - exit 0 - ), - " Show version and exit"; - - "--network", Arg.String (function - | "dune" | "Dune" | "DUNE" -> - LiquidOptions.network := Dune_network - | "tezos" | "Tezos" | "TEZOS" -> - LiquidOptions.network := Tezos_network - | s -> - Format.eprintf "%s not allowed for network" s; - exit 1 - ), - " Set the network to use"; - - "-o", Arg.String (fun o -> LiquidOptions.output := Some o), - " Output code in "; - - "--main", Arg.String (fun main -> LiquidOptions.main := Some main), - " Produce code for contract named "; - - "--no-inline", Arg.Clear LiquidOptions.inline, - " Disable inlining"; - - "--no-simplify", Arg.Clear LiquidOptions.simplify, - " Disable simplifications"; - - "--no-peephole", Arg.Clear LiquidOptions.peephole, - " Disable peephole optimizations"; - - "--type-only", Arg.Set LiquidOptions.typeonly, - " Stop after type checking"; - - "--parse-only", Arg.Set LiquidOptions.parseonly, - " Stop after parsing"; - - "--compact", Arg.Set LiquidOptions.singleline, - " Produce compact Michelson"; - - "--no-annot", Arg.Set LiquidOptions.no_annot, - " Don't produce any annotations when compiling"; - - "--no-ignore-annots", Arg.Clear LiquidOptions.retry_without_annots, - " Don't ignore annotations of failure when decompiling"; - - "--no-uncurry", Arg.Set LiquidOptions.no_uncurrying, - " Don't uncurry non partially applied lambdas"; - - "--json", Arg.Set LiquidOptions.json, - " Output Michelson in JSON representation"; - - "--amount", Arg.String (fun amount -> - LiquidOptions.amount := parse_tez_to_string "--amount" amount - ), - "<1.99DUN> Set amount for deploying or running a contract (default: 0DUN)"; - - "--fee", Arg.String (fun fee -> - LiquidOptions.fee := Some (parse_tez_to_string "--fee" fee) - ), - "<0.1DUN> Set fee for deploying a contract (default: computed automatically)"; - - "--source", Arg.String (fun s -> - Data.validate_key_hash s; - LiquidOptions.source := Some s), - " Set the source for deploying or running a contract (default: none)"; - - "--private-key", Arg.String (fun s -> - Data.validate_private_key s; - LiquidOptions.private_key := Some s), - " Set the private key for deploying a contract (default: none)"; - - "--counter", Arg.Int (fun n -> LiquidOptions.counter := Some n), - "N Set the counter for the operation instead of retrieving it"; - - "--node", Arg.String (fun s -> LiquidOptions.node := s), - " Set the address and port of a node to run or deploy \ - contracts (default: 127.0.0.1:8733)\ - \n\ - \n\ - Available commands:\ - "; - - "--run", Arg.Tuple [ - Arg.String (fun s -> Data.entry_name := s); - Arg.String (fun s -> Data.parameter := s); - Arg.String (fun s -> Data.storage := s); - Arg.Unit (fun () -> - work_done := true; - run ()); - ], - (Printf.sprintf - "ENTRY PARAMETER STORAGE Run Liquidity contract on %s node" - (LiquidOptions.network_name ()) - ); - - "--delegatable", Arg.Set LiquidOptions.delegatable, - " With --[forge-]deploy, deploy a delegatable contract"; - - "--spendable", Arg.Set LiquidOptions.spendable, - " With --[forge-]deploy, deploy a spendable contract"; - - "--init-storage", Arg.Tuple [ - Arg.Rest Data.register_deploy_input; - Arg.Unit (fun () -> - work_done := true; - init_storage ()); - ], - " [INPUT1 INPUT2 ...] Generate initial storage"; - - "--forge-deploy", Arg.Tuple [ - Arg.Rest Data.register_deploy_input; - Arg.Unit (fun () -> - work_done := true; - forge_deploy ()); - ], - " [INPUT1 INPUT2 ...] Forge deployment operation for contract"; - - "--deploy", Arg.Tuple [ - Arg.Rest Data.register_deploy_input; - Arg.Unit (fun () -> - work_done := true; - deploy ()); - ], - " [INPUT1 INPUT2 ...] Deploy contract"; - - "--get-storage", Arg.Tuple [ - Arg.String (fun s -> - Data.validate_contract_addr s; - Data.contract_address := s); - Arg.Unit (fun () -> - work_done := true; - get_storage ()); - ], - " Get deployed contract storage"; - - "--call", Arg.Tuple [ - Arg.String (fun s -> - Data.validate_contract_addr s; - Data.contract_address := s); - Arg.String (fun s -> Data.entry_name := s); - Arg.String (fun s -> Data.parameter := s); - Arg.Unit (fun () -> - work_done := true; - call ()); - ], - " ENTRY PARAMETER Call deployed contract"; - - "--call-arg", Arg.Tuple [ - Arg.String (fun s -> Data.entry_name := s); - Arg.String (fun s -> Data.parameter := s); - Arg.Unit (fun () -> - work_done := true; - call_arg ()); - ], - "ENTRY PARAMETER Call deployed contract"; - - "--forge-call", Arg.Tuple [ - Arg.String (fun s -> - Data.validate_contract_addr s; - Data.contract_address := s); - Arg.String (fun s -> Data.entry_name := s); - Arg.String (fun s -> Data.parameter := s); - Arg.Unit (fun () -> - work_done := true; - forge_call ()); - ], - " ENTRY PARAMETER Forge call transaction operation"; - - "--data", - (let data_args = ref [] in - Arg.Tuple [ - Arg.String (fun s -> Data.entry_name := s); - Arg.Rest (fun s -> data_args := s :: !data_args); - Arg.Unit (fun () -> - begin match !data_args with - | [p] -> Data.parameter := p - | [s; p] -> Data.parameter := p; Data.storage := s - | _ -> raise Bad_arg - end; - work_done := true; - translate ()); - ]), - "ENTRY PARAMETER [STORAGE] Translate to Michelson"; - - "--pack", - (let const = ref "" in - let ty = ref "" in - Arg.Tuple [ - Arg.String (fun s -> const := s); - Arg.String (fun s -> ty := s); - Arg.Unit (fun () -> - work_done := true; - pack !const !ty); - ]), - "DATA TYPE Pack (serialize) data of type TYPE"; - - "--signature", Arg.String (fun s -> LiquidOptions.signature := Some s), - "SIGNATURE Set the signature for an operation"; - - "--inject", Arg.String (fun op -> - work_done := true; - inject op - ), "OPERATION.bytes Inject a sign operation\n\nMisc:"; - - - ] - in - let arg_usage = String.concat "\n" [ - "liquidity [OPTIONS] FILES [COMMAND]"; - ""; - "The liquidity compiler can translate files from Liquidity to Michelson"; - "and from Michelson to Liquidity. Liquidity files must end with the .liq"; - "extension. Michelson files must end with the .tz extension."; - ""; - "Available options:"; - ] - in - try - Arg.parse arg_list (fun s -> Data.files := s :: !Data.files) arg_usage; - (* if Data.get_files () = [] then raise Bad_arg; *) - if not !work_done then compile_files (); - with Bad_arg -> - Arg.usage arg_list arg_usage + let name = "liquidity" in + let doc = "a compiler for the smart contract Language Liquidity \ + for Dune Network and Tezos" in + let man = [ + `S Manpage.s_description; + `P "Compile Liquidity files to Michelson, or decompile a Michelson file to \ + a Liquidity one."; + `Blocks LiquidCommonArgs.help_secs; + ] in + Ezcmd.main { + Arg.cmd_name = name; + cmd_args = common_args @ [ + ["convert"], + Arg.String (fun f -> convert_file f; exit 0), + Ezcmd.info ~docs:Manpage.s_options ~docv:"filename" + "Convert $(docv) to Liquidity or ReasonML syntax"; + + [], + Arg.Anons (fun s -> Data.files := s), + Ezcmd.info ~docs:Manpage.s_options ~docv:"FILES" "Filenames to compile"; + ]; + cmd_doc = doc; + cmd_man = man; + cmd_action = compile_files; + } let () = diff --git a/tools/liquidity/liquidMichelson.ml b/tools/liquidity/liquidMichelson.ml index 551b8081..fcc77ced 100644 --- a/tools/liquidity/liquidMichelson.ml +++ b/tools/liquidity/liquidMichelson.ml @@ -50,11 +50,18 @@ let ii ~loc ins = { ins; loc; loc_name = None } let seq exprs = ii ~loc:(loc_of_many exprs) (SEQ exprs) -let dup ~loc n = ii ~loc (DUP n) - (* n = size of preserved head of stack *) let dip ~loc n exprs = ii ~loc (DIP (n, seq exprs)) +let dup ~loc n = + (* ii ~loc @@ DUP n *) + (* Better expansion than the one in Michelson_v1_macros *) + match n with + | 0 -> assert false + | 1 -> ii ~loc @@ DUP 1 + | 2 -> seq [dip ~loc 1 [ii ~loc @@ DUP 1]; ii ~loc SWAP] + | _ -> seq [dip ~loc (n-1) [ii ~loc @@ DUP 1]; ii ~loc @@ DIG (n-1)] + let push ~loc ty cst = ii ~loc (PUSH (LiquidEncode.encode_type ty, cst)) let sanitize_name s = @@ -87,14 +94,7 @@ let sanitize_opt = function (* n = size of preserved head of stack *) let drop_stack ~loc n depth = - if depth = 0 then [] else - let rec drop_stack depth = - if depth = 0 then [] else - ii ~loc DROP :: (drop_stack (depth-1)) - in - let exps = drop_stack depth in - if n = 0 then exps else [ii ~loc @@ DIP_DROP (n, List.length exps)] - + ii ~loc @@ DIP_DROP (n, depth) (******************* * Code generation * @@ -164,7 +164,7 @@ let rec compile_desc depth env ~loc desc = the result of e1 is droped (ignored) *) let e1 = compile depth env e1 in let e2 = compile depth env e2 in - e1 @ [ ii ~loc:LiquidLoc.noloc DROP ] @ e2 + e1 @ [ ii ~loc:LiquidLoc.noloc @@ DROP 1 ] @ e2 | Let { bnd_var; bnd_val; body } -> (* Compiling a let binding is compiling the bound value and @@ -212,16 +212,56 @@ let rec compile_desc depth env ~loc desc = amount @ [ push ~loc Tunit CUnit; ii ~loc TRANSFER_TOKENS ] - | Call { entry = Some _ } -> - assert false (* should have been encoded *) - - | Call { contract; amount; entry = None; arg } -> - (* Contract.call (encoded) compiled to TRANSFER_TOKENS *) + | Call { contract = ({ ty = Tcontract _ } as contract); + amount; entry; arg } -> + (* Contract.call compiled to TRANSFER_TOKENS *) let contract = compile depth env contract in let amount = compile (depth+1) env amount in let arg = compile (depth+2) env arg in contract @ amount @ arg @ [ ii ~loc TRANSFER_TOKENS ] + | Call { contract = ({ ty = Taddress } as address); + amount; entry = Some entry; arg } -> + (* Contract.call on addresses compiled to CONTRACT + TRANSFER_TOKENS *) + let address = compile depth env address in + let ty = LiquidEncode.encode_type arg.ty in + let error_msg = Printf.sprintf "No entrypoint %s with parameter type %s" + entry + (LiquidPrinter.Liquid.string_of_type arg.ty) in + let entry = match entry with "default" -> None | _ -> Some entry in + let contract = + address @ + [ ii ~loc (CONTRACT (entry, ty)); + ii ~loc @@ + IF_NONE ( + seq [ push ~loc Tstring (CString error_msg) ; + ii ~loc FAILWITH ], + seq []) ] in + let amount = compile (depth+1) env amount in + let arg = compile (depth+2) env arg in + contract @ amount @ arg @ [ ii ~loc TRANSFER_TOKENS ] + + | Call _ -> assert false + + | Self { entry } -> + if env.in_lambda then + LiquidLoc.raise_error ~loc + "Typing error: \ + Self handle is not allowed inside non-inlined functions\n%!"; + let entry = match entry with "default" -> None | _ -> Some entry in + [ ii ~loc (SELF entry) ] + + | SelfCall { amount; entry; arg } -> + if env.in_lambda then + LiquidLoc.raise_error ~loc + "Typing error: \ + Self call is not allowed inside non-inlined functions\n%!"; + let entry = match entry with "default" -> None | _ -> Some entry in + let contract = [ ii ~loc (SELF entry) ] in + let amount = compile (depth+1) env amount in + let arg = compile (depth+2) env arg in + contract @ amount @ arg @ [ ii ~loc TRANSFER_TOKENS ] + | Failwith arg -> let arg = compile depth env arg in arg @ [ ii ~loc FAILWITH ] @@ -288,12 +328,12 @@ let rec compile_desc depth env ~loc desc = let arg = compile depth env arg in let rec iter cases = match cases with - | [] -> [ii ~loc DROP] + | [] -> [ii ~loc (DROP 1)] | (PConstr (_, args), e) :: cases -> let env, depth, left_start, left_end = match args with | _ :: _ :: _ -> assert false - | [] -> env, depth, [ii ~loc DROP], [] + | [] -> env, depth, [ii ~loc (DROP 1)], [] | [arg_name] -> let env = register_var arg_name depth env in let depth = depth + 1 in @@ -307,7 +347,7 @@ let rec compile_desc depth env ~loc desc = let right = iter cases in [ii ~loc @@ IF_LEFT( seq (left), seq right )] end - | [PAny, e] -> [ii ~loc DROP] @ compile depth env e + | [PAny, e] -> [ii ~loc (DROP 1)] @ compile depth env e | _ -> assert false in arg @ iter cases @@ -419,10 +459,11 @@ let rec compile_desc depth env ~loc desc = args_code @ [contract_code; ii ~loc PAIR] - | ContractAt { arg; c_sig } -> - let param_ty = LiquidEncode.encode_contract_sig c_sig in + | ContractAt { arg; entry; entry_param } -> + let param_ty = LiquidEncode.encode_type entry_param in + let entry = match entry with "default" -> None | _ -> Some entry in compile depth env arg @ - [ ii ~loc (CONTRACT param_ty) ] + [ ii ~loc (CONTRACT (entry, param_ty)) ] | Unpack { arg; ty } -> let ty = LiquidEncode.encode_type ty in @@ -475,21 +516,34 @@ and compile_prim ~loc depth env prim args = x_code @ set_code | Prim_tuple_set, _ -> assert false - | Prim_self, _ when env.in_lambda -> - LiquidLoc.raise_error ~loc - "Typing error: \ - Current.self is not allowed inside non-inlined functions\n%!" + | Prim_address, [contract] -> + compile depth env contract @ + [ + ii PACK; + ii @@ PUSH (Tnat, CNat (LiquidNumber.integer_of_int 22)); + ii @@ PUSH (Tnat, CNat (LiquidNumber.integer_of_int 6)); + ii SLICE; + ii @@ IF_NONE (seq [ ii @@ PUSH (Tunit, CUnit); ii FAILWITH ], seq []); + ii @@ UNPACK Taddress; + ii @@ IF_NONE (seq [ ii @@ PUSH (Tunit, CUnit); ii FAILWITH ], seq []); + ] - | Prim_self, _ -> [ ii SELF ] | Prim_balance, _ -> [ ii BALANCE ] | Prim_now, _ -> [ ii NOW ] | Prim_amount, _ -> [ ii AMOUNT ] | Prim_gas, _ -> [ ii STEPS_TO_QUOTA ] + | Prim_chain_id, _ -> [ ii CHAIN_ID ] | Prim_source, _ -> [ ii SOURCE ] | Prim_sender, _ -> [ ii SENDER ] | Prim_block_level, _ -> [ ii BLOCK_LEVEL ] | Prim_collect_call, _ -> [ ii COLLECT_CALL ] + | Prim_big_map_create, [ + { desc = Apply { prim = Prim_unused None }; ty = k_ty }; + { desc = Apply { prim = Prim_unused None }; ty = v_ty } + ] -> [ ii @@ EMPTY_BIG_MAP (k_ty, v_ty) ] + | Prim_big_map_create, _ -> assert false + | Prim_Left, [ arg; { desc = Apply { prim = Prim_unused constr }; ty = right_ty }] -> let right_ty = LiquidEncode.encode_type right_ty in @@ -527,7 +581,7 @@ and compile_prim ~loc depth env prim args = | Prim_extension (_, _, targs, nb_arg, nb_ret, minst), _ -> let _depth, args_code = compile_args depth env args in let args_code = - if nb_arg = 0 then args_code @ [ ii DROP ] + if nb_arg = 0 then args_code @ [ ii @@ DROP 1 ] else args_code in let res_code = @@ -555,12 +609,11 @@ and compile_prim ~loc depth env prim args = | Prim_string_concat|Prim_bytes_concat|Prim_concat|Prim_concat_two | Prim_string_size|Prim_bytes_size | Prim_string_sub|Prim_bytes_sub|Prim_slice - | Prim_create_account | Prim_blake2b|Prim_sha256|Prim_sha512|Prim_pack | Prim_hash_key|Prim_check|Prim_default_account|Prim_list_size | Prim_set_size|Prim_map_size|Prim_or|Prim_and|Prim_xor | Prim_not|Prim_abs|Prim_int|Prim_neg|Prim_lsr|Prim_lsl|Prim_is_nat - | Prim_exec _|Prim_Cons|Prim_set_delegate|Prim_address + | Prim_exec _|Prim_Cons|Prim_set_delegate|Prim_address|Prim_address_untype | Prim_get_balance|Prim_is_implicit),_ -> let _depth, args_code = compile_args depth env args in let prim_code = match prim, List.length args with @@ -595,8 +648,8 @@ and compile_prim ~loc depth env prim args = | Prim_string_concat, 1 -> [ ii CONCAT ] | Prim_bytes_concat, 1 -> [ ii CONCAT ] - | Prim_address, 1 -> [ ii ADDRESS ] - | Prim_create_account, 4 -> [ ii CREATE_ACCOUNT; ii PAIR ] + | Prim_address_untype, 1 -> [ ii ADDRESS ] + | Prim_blake2b, 1 -> [ ii BLAKE2B ] | Prim_sha256, 1 -> [ ii SHA256 ] | Prim_sha512, 1 -> [ ii SHA512 ] @@ -639,12 +692,12 @@ and compile_prim ~loc depth env prim args = | Prim_string_size|Prim_bytes_size | Prim_string_sub|Prim_bytes_sub | Prim_string_concat|Prim_bytes_concat - | Prim_create_account | Prim_blake2b|Prim_sha256|Prim_sha512|Prim_pack | Prim_hash_key|Prim_check|Prim_default_account|Prim_list_size | Prim_set_size|Prim_map_size|Prim_or|Prim_and|Prim_xor | Prim_not|Prim_abs|Prim_int|Prim_neg|Prim_lsr|Prim_lsl|Prim_is_nat | Prim_exec _|Prim_Cons|Prim_set_delegate|Prim_address + | Prim_address_untype | Prim_get_balance|Prim_is_implicit),n -> Printf.eprintf "Primitive %S: wrong number of args(%d)\n%!" (LiquidTypes.string_of_primitive prim) @@ -654,12 +707,12 @@ and compile_prim ~loc depth env prim args = | (Prim_extension _|Prim_tuple_get | Prim_tuple_set|Prim_tuple - | Prim_self|Prim_balance|Prim_now|Prim_amount|Prim_gas + | Prim_balance|Prim_now|Prim_amount|Prim_gas|Prim_chain_id | Prim_Left|Prim_Right|Prim_source|Prim_sender|Prim_unused _ | Prim_coll_find|Prim_coll_update|Prim_coll_mem | Prim_coll_size|Prim_list_rev|Prim_slice | Prim_concat|Prim_concat_two - | Prim_block_level|Prim_collect_call), _ -> + | Prim_block_level|Prim_collect_call|Prim_big_map_create), _ -> (* already filtered out *) Printf.eprintf "Primitive %S ?\n%!" (LiquidTypes.string_of_primitive prim) @@ -674,7 +727,7 @@ and compile_tuple_set ~loc last depth env n y = let ii = ii ~loc in if n = 0 then if last then - [ ii DROP ] + [ ii @@ DROP 1 ] @ compile (depth-1) env y else [ ii @@ CDR None ] @ compile depth env y @ [ ii PAIR ] @@ -760,8 +813,8 @@ and compile_lambda ~loc { arg_name; arg_ty; body; ret_ty; recursive } = and compile_const ~loc c = match c with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _) as c -> c | CSome x -> CSome (compile_const ~loc x) | CLeft x -> CLeft (compile_const ~loc x) | CRight x -> CRight (compile_const ~loc x) @@ -770,8 +823,11 @@ and compile_const ~loc c = match c with | CSet xs -> CSet (List.map (compile_const ~loc) xs) | CMap l -> CMap (List.map (fun (x,y) -> compile_const ~loc x, compile_const ~loc y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> compile_const ~loc x, compile_const ~loc y) l) + | CBigMap BMList l -> + CBigMap + (BMList + (List.map (fun (x,y) -> compile_const ~loc x, compile_const ~loc y) l)) + | CBigMap BMId _ as c -> c | CRecord labels -> CRecord (List.map (fun (f, x) -> f, compile_const ~loc x) labels) | CConstr (constr, x) -> @@ -809,6 +865,8 @@ and compile_name ~annotafter name code = these are used by the Michelson pretty printer (or translator) to produce variable annotations @name. *) match List.rev code with + | [{ ins = SEQ ({ ins = DIP(_, { ins = SEQ ({ ins = DUP _} as c :: _) }) } :: _) }] + (* ^- special case for duuup expansion *) | c :: _ when name <> None -> c.loc_name <- sanitize_opt name; code @@ -850,7 +908,7 @@ and translate_code ~parameter_name ~storage_name code = (* at the end of the code, drop everything excepted for the top-most element *) let trailer = drop_stack ~loc 1 depth in - seq (header @ exprs @ trailer) + seq (header @ exprs @ [ trailer ]) (* FAILWITH must appear in tail position in Michelson, this function removes instructions that appear after FAILWITH in a code block *) @@ -914,12 +972,14 @@ and translate contract = (LiquidNamespace.qual_contract_name contract); let mic_storage = contract.storage in match contract.entries with - | [{ entry_sig = { parameter = mic_parameter; parameter_name; storage_name }; + | [{ entry_sig = { entry_name; parameter = mic_parameter; parameter_name; storage_name }; code; fee_code }] -> + let mic_root = match entry_name with "" -> None | _ -> Some entry_name in { mic_parameter; mic_storage; - mic_code = translate_code ~parameter_name ~storage_name code - |> finalize_fail_pre ; + mic_root; + mic_code = translate_code ~parameter_name ~storage_name code + |> finalize_fail_pre ; mic_fee_code = match fee_code with | None -> None | Some fee_code -> diff --git a/tools/liquidity/liquidNamespace.ml b/tools/liquidity/liquidNamespace.ml index ea062a5e..83f2af6d 100644 --- a/tools/liquidity/liquidNamespace.ml +++ b/tools/liquidity/liquidNamespace.ml @@ -160,7 +160,8 @@ let rec find_contract_type_aux ~loc s env = let rec normalize_type ?from_env ~in_env ty = match ty with | Tunit | Tbool | Tint | Tnat | Ttez | Tstring | Tbytes | Ttimestamp - | Tkey | Tkey_hash | Tsignature | Toperation | Taddress | Tfail -> ty + | Tkey | Tkey_hash | Tsignature | Toperation | Taddress | Tfail | Tchainid -> + ty | Ttuple l -> Ttuple (List.map (normalize_type ?from_env ~in_env) l) | Toption t -> Toption (normalize_type ?from_env ~in_env t) | Tlist t -> Tlist (normalize_type ?from_env ~in_env t) @@ -177,8 +178,8 @@ let rec normalize_type ?from_env ~in_env ty = | Tlambda (t1, t2, u) -> Tlambda (normalize_type ?from_env ~in_env t1, normalize_type ?from_env ~in_env t2, u) - | Tcontract c_sig -> - Tcontract (normalize_contract_sig ?from_env ~in_env ~build_sig_env:false c_sig) + | Tcontract (e, ty) -> + Tcontract (e, normalize_type ?from_env ~in_env ty) | Trecord (name, fields) -> let _, found_env = try find_type_loose ~loc:noloc name in_env [] @@ -187,11 +188,15 @@ let rec normalize_type ?from_env ~in_env ty = List.map (fun (f, ty) -> qualify_name ?from_env ~at:found_env.path f, normalize_type ?from_env ~in_env ty) fields) - | Tsum (name, constrs) -> + | Tsum (None, constrs) -> + Tsum (None, + List.map (fun (c, ty) -> + c, normalize_type ?from_env ~in_env ty) constrs) + | Tsum (Some name, constrs) -> let _, found_env = try find_type_loose ~loc:noloc name in_env [] with Not_found | Unknown_namespace _ -> assert false in - Tsum (qualify_name ?from_env ~at:found_env.path name, + Tsum (Some (qualify_name ?from_env ~at:found_env.path name), List.map (fun (c, ty) -> qualify_name ?from_env ~at:found_env.path c, normalize_type ?from_env ~in_env ty) constrs) @@ -297,8 +302,6 @@ let lookup_global_value ~loc s env = | Current_namespace -> raise Not_found | Contract_namespace (c, _) -> let v = List.find (fun v -> not v.val_private && v.val_name = s) c.values in - Format.eprintf "Normalize %s@." - (LiquidPrinter.Liquid.string_of_type v.val_exp.ty); let ty = normalize_type ~from_env:env.env ~in_env:c.ty_env v.val_exp.ty in diff --git a/tools/liquidity/liquidNumber.ml b/tools/liquidity/liquidNumber.ml index f8324fa9..5e39324e 100644 --- a/tools/liquidity/liquidNumber.ml +++ b/tools/liquidity/liquidNumber.ml @@ -21,7 +21,11 @@ (* along with this program. If not, see . *) (****************************************************************************) -open LiquidTypes +(** Tez constants are stored with strings *) +type tez = { tezzies : string; mutez : string option } + +(** Unbounded integer constants *) +type integer = { integer : Z.t } let milion = Z.of_int 1_000_000 diff --git a/tools/liquidity/liquidNumber.mli b/tools/liquidity/liquidNumber.mli index a2c6287e..aa4869a5 100644 --- a/tools/liquidity/liquidNumber.mli +++ b/tools/liquidity/liquidNumber.mli @@ -21,7 +21,11 @@ (* along with this program. If not, see . *) (****************************************************************************) -open LiquidTypes +(** Tez constants are stored with strings *) +type tez = { tezzies : string; mutez : string option } + +(** Unbounded integer constants *) +type integer = { integer : Z.t } (** {2 Helper conversion function } *) diff --git a/tools/liquidity/liquidOptions.ml b/tools/liquidity/liquidOptions.ml index f607ccc6..2cd9c4a4 100644 --- a/tools/liquidity/liquidOptions.ml +++ b/tools/liquidity/liquidOptions.ml @@ -73,8 +73,17 @@ let main = ref (None : string option) (** Path/name of ouptut file for compiling/decompiling *) let output = ref (None : string option) +let signature = ref (None : string option) + +let ocaml_syntax = ref true -(** {2 Options of the Liquidity Dune client } *) +let writeinfo = ref true + +type network = + | Dune_network + | Tezos_network + +let network = ref Dune_network (** Address of the node with the RPC port *) let node = ref "127.0.0.1:8733" @@ -82,17 +91,11 @@ let node = ref "127.0.0.1:8733" (** Source (optional) of the transaction, a dn.. or a KT1... *) let source = ref (None : string option) -(** Amount in DUN for the transaction or origination *) -let amount = ref "0" +(** Amount for the transaction or origination *) +let amount = ref (LiquidNumber.{ tezzies = "0"; mutez = None }) (** Fee in mudun *) -let fee = ref (None : string option) - -(** Originate a delegatable contract *) -let delegatable = ref false - -(** Originate a spendable contract *) -let spendable = ref false +let fee = ref (None : LiquidNumber.tez option) (** Gas limit for transactions and originations. *) let gas_limit = ref (None : int option) @@ -104,26 +107,11 @@ let storage_limit = ref (None : int option) injecting signed transactions and originations directly. *) let private_key = ref (None : string option) -let signature = ref (None : string option) -let counter = ref (None : int option) - -let ocaml_syntax = ref true - -type network = - | Dune_network - | Tezos_network +(** Private key can be given to the liquidity dune-client for + revelations *) +let public_key = ref (None : string option) -let network = - ref - (match Sys.getenv "LIQUID_NETWORK" with - | "dune" | "Dune" | "DUNE" -> Dune_network - | "tezos" | "Tezos" | "TEZOS" -> Tezos_network - | _ -> - Format.eprintf - "Warning: wrong value for LIQUID_NETWORK, defaulting to Dune@."; - Dune_network - | exception Not_found -> Dune_network - ) +let counter = ref (None : int option) let curreny () = match !network with | Dune_network -> "DUN" diff --git a/tools/liquidity/liquidPeephole.ml b/tools/liquidity/liquidPeephole.ml index ba14b0ee..e986bc7d 100644 --- a/tools/liquidity/liquidPeephole.ml +++ b/tools/liquidity/liquidPeephole.ml @@ -33,10 +33,10 @@ open LiquidTypes let ii ~loc ins = { ins; loc; loc_name = None } let lii = ii -let drops ~loc n = LiquidMisc.list_init n (fun _ -> ii ~loc DROP) +let drop ~loc n = ii ~loc (DROP n) let dip_drop ~loc (a,b)= - if a = 0 then drops ~loc b else [ii ~loc (DIP_DROP(a,b))] + if a = 0 then drop ~loc b else ii ~loc (DIP_DROP(a,b)) let rec simplify_pre ({ ins } as e) = { e with @@ -65,6 +65,7 @@ and simplify_seq exprs = let e = simplify_pre e in match e.ins with | FAILWITH -> [e] + | SEQ e_exprs -> simplify_seq (e_exprs @ exprs) | _ -> let exprs = simplify_seq exprs in simplify_step e exprs @@ -74,10 +75,13 @@ and simplify_step e exprs = match e.ins, exprs with | SEQ e, exprs -> simplify_steps e exprs - | DIP_DROP(n,0), exprs -> exprs + | DIP_DROP(n, 0), exprs -> exprs + | DIP_DROP(0, n), exprs -> simplify_step { e with ins = DROP n } exprs | DIP (0, e), exprs -> simplify_step e exprs - | DUP _, {ins=DROP} :: exprs -> exprs - | DUP 1, {ins=SWAP} :: {ins=DROP} :: exprs -> exprs + | DROP 0, exprs -> exprs + | DUP _, {ins=DROP 1} :: exprs -> exprs + | DUP _, ({ins=DROP n} as e) :: exprs -> { e with ins = DROP (n-1) } :: exprs + | DUP 1, {ins=SWAP} :: {ins=DROP 1} :: exprs -> exprs | SWAP, {ins=SWAP} :: exprs -> exprs | SWAP, ({ins= (ADD|MUL|AND|OR|XOR)} as e) :: exprs -> simplify_step e exprs | EQ, { ins = NOT } :: exprs -> simplify_step { e with ins = NEQ } exprs @@ -97,8 +101,9 @@ and simplify_step e exprs = | IF(i1,i2), exprs -> begin match i1.ins, i2.ins, exprs with - | SEQ ({ins=DROP} :: e1), SEQ ({ins=DROP} :: e2), exprs -> - simplify_stepi ~loc:e.loc (DIP_DROP(1,1)) + | SEQ ({ins=DROP n1} :: e1), SEQ ({ins=DROP n2} :: e2), exprs + when n1 = n2 -> + simplify_stepi ~loc:e.loc (DIP_DROP(1, n1)) (simplify_stepi ~loc:e.loc (IF ( lii ~loc:i1.loc @@ SEQ e1, lii ~loc:i2.loc @@ SEQ e2 )) exprs) @@ -118,21 +123,22 @@ and simplify_step e exprs = end (* takes nothing, add one item on stack : 0 -> 1 *) - | (PUSH _ | NOW | BALANCE | SELF | SOURCE | SENDER | AMOUNT | STEPS_TO_QUOTA + | (PUSH _ | NOW | BALANCE | SELF _ | SOURCE | SENDER | AMOUNT | STEPS_TO_QUOTA | LAMBDA _ ), {ins=DIP_DROP (n,m); loc} :: exprs -> if n > 0 then - dip_drop ~loc (n-1,m) @ simplify_step e exprs + dip_drop ~loc (n-1, m) :: simplify_step e exprs else if m = 1 then exprs else lii ~loc (DIP_DROP (n,m-1)) :: exprs - | (PUSH _ | NOW | BALANCE | SELF | SOURCE | SENDER | AMOUNT | STEPS_TO_QUOTA + | (PUSH _ | NOW | BALANCE | SELF _ | SOURCE | SENDER | AMOUNT | STEPS_TO_QUOTA | LAMBDA _ - ), {ins=DROP} :: exprs -> exprs + ), ({ins=DROP n} as e) :: exprs when n > 0 -> + if n = 1 then exprs else { e with ins = DROP (n-1) } :: exprs (* takes one item on stack, creates one : 1 -> 1 *) @@ -156,7 +162,7 @@ and simplify_step e exprs = | BLAKE2B | SHA256 | SHA512 | CONCAT | RENAME _ | PACK | UNPACK _ ), - {ins=DROP; loc} :: exprs -> lii ~loc DROP :: exprs + {ins = DROP n; loc} :: exprs -> lii ~loc (DROP n) :: exprs (* takes two items on stack, creates one : 2 -> 1 *) @@ -188,8 +194,8 @@ and simplify_step e exprs = (simplify_step e exprs) - | DIP (n,e), {ins=DROP; loc} :: exprs when n > 0 -> - ii DROP :: simplify_stepi ~loc (DIP(n-1,e)) exprs + | DIP (n,e), {ins = DROP m; loc} :: exprs when n >= m -> + ii (DROP m) :: simplify_stepi ~loc (DIP(n-m,e)) exprs | DIP_DROP (n,m), {ins=DIP_DROP (n',m')} :: exprs when n = n' -> @@ -204,19 +210,19 @@ and simplify_step e exprs = | DUP 1, {ins=DIP_DROP (1,m)} :: exprs when m > 1 -> simplify_stepi ~loc:e.loc (DIP_DROP (1, m-1)) exprs - | DUP 2, {ins=DIP_DROP (1,1); loc} :: exprs -> - simplify_stepi ~loc DROP (simplify_stepi ~loc:e.loc (DUP 1) exprs) + | DUP n, {ins=DIP_DROP (1, m); loc} :: exprs when m = n - 1 && n > 1 -> + simplify_stepi ~loc (DROP m) (simplify_stepi ~loc:e.loc (DUP 1) exprs) - | DUP 2, {ins=DIP_DROP (1,2); loc} :: exprs -> - simplify_stepi ~loc DROP exprs + | DUP n, {ins=DIP_DROP (1, m); loc} :: exprs when m >= n && n > 1 -> + simplify_stepi ~loc (DROP (m - n)) exprs | DUP 3, {ins=DIP_DROP (2,2); loc} :: exprs -> simplify_stepi ~loc:e.loc SWAP - (simplify_stepi ~loc DROP + (simplify_stepi ~loc (DROP 1) (simplify_stepi ~loc:e.loc SWAP exprs)) - | DUP 2, {ins=SWAP} :: {ins=DROP; loc} :: exprs -> - simplify_stepi ~loc DROP + | DUP 2, {ins=SWAP} :: {ins=DROP 1; loc} :: exprs -> + simplify_stepi ~loc (DROP 1) (simplify_stepi ~loc:e.loc (DUP 1) exprs) | DUP 2, {ins=DIP_DROP (2,1)} :: exprs -> @@ -226,14 +232,14 @@ and simplify_step e exprs = let after = if n= m+p then if m = 1 then - drops ~loc p @ (simplify_stepi ~loc:e.loc (DUP (n-p)) exprs) + drop ~loc p :: simplify_stepi ~loc:e.loc (DUP (n-p)) exprs else simplify_stepi ~loc (DIP_DROP (m-1,p)) (simplify_stepi ~loc:e.loc (DUP (n-p)) exprs) @@ -254,7 +260,7 @@ and simplify_step e exprs = in let code = if x > 0 then - dip_drop ~loc (m-1, x) @ code + dip_drop ~loc (m-1, x) :: code else code in code diff --git a/tools/liquidity/liquidPrinter.ml b/tools/liquidity/liquidPrinter.ml index 563f46b5..0e0ed474 100644 --- a/tools/liquidity/liquidPrinter.ml +++ b/tools/liquidity/liquidPrinter.ml @@ -54,24 +54,24 @@ module Michelson = struct bprinter fmt b indent x; Buffer.contents b - let bprint_annots b annots = - if not !LiquidOptions.no_annot then + let bprint_annots ?(parameter=false) b annots = + if parameter || not !LiquidOptions.no_annot then match annots with | [] -> () | _ -> Printf.bprintf b "%s" (String.concat " " ("" :: annots)) - let bprint_wrap_annots b bprint_type annots = + let bprint_wrap_annots ?parameter b bprint_type annots = match annots with | [] -> bprint_type () | _ -> Printf.bprintf b "("; bprint_type (); - bprint_annots b annots; + bprint_annots ?parameter b annots; Printf.bprintf b ")" let is_word_type = function | Tfail | Tunit | Tbool | Tint | Tnat | Ttez | Tstring | Tbytes - | Ttimestamp | Tkey | Tkey_hash | Tsignature | Toperation | Taddress -> + | Ttimestamp | Tkey | Tkey_hash | Tsignature | Toperation | Taddress | Tchainid -> true | Ttuple _ | Trecord _ | Tsum _ | Tcontract _ | Tor _ | Toption _ | Tlist _ | Tset _ | Tmap _ | Tbigmap _ | Tlambda _ | Tclosure _ -> @@ -79,7 +79,7 @@ module Michelson = struct | Tvar _ -> true | Tpartial _ -> false - let bprint_type_base fmt b indent ty annots = + let bprint_type_base ?parameter fmt b indent ty annots = let rec bprint_type_rec fmt b indent ty annots = match ty with | Tfail -> Printf.bprintf b "unit" (* use unit for failure in michelson *) @@ -96,23 +96,20 @@ module Michelson = struct | Tsignature -> Printf.bprintf b "signature" | Toperation -> Printf.bprintf b "operation" | Taddress -> Printf.bprintf b "address" + | Tchainid -> Printf.bprintf b "chain_id" | Ttuple tys -> bprint_type_pairs fmt b indent tys annots | Trecord (name, labels) -> bprint_type_record name fmt b indent labels annots | Tsum (name, constrs) -> bprint_type_sum name fmt b indent constrs annots - | Tcontract { sig_name; entries_sig = [{ parameter = ty }] } -> + | Tcontract (_entry, ty) -> let indent = fmt.increase_indent indent in Printf.bprintf b "(contract"; - bprint_annots b - (match sig_name with - | None -> annots - | Some name -> (":" ^ name) :: annots); + bprint_annots b annots; Printf.bprintf b "%c%s" fmt.newline indent; bprint_type fmt b indent ty []; Printf.bprintf b ")"; - | Tcontract _ -> assert false | Tor (ty1, ty2) -> let indent = fmt.increase_indent indent in Printf.bprintf b "(or"; @@ -198,7 +195,7 @@ module Michelson = struct | ty :: tys -> let indent = fmt.increase_indent indent in Printf.bprintf b "(pair"; - bprint_annots b annots; + bprint_annots ?parameter b annots; Printf.bprintf b "%c%s" fmt.newline indent; bprint_type fmt b indent ty []; Printf.bprintf b "%c%s" fmt.newline indent; @@ -207,6 +204,13 @@ module Michelson = struct () and bprint_type_composed ty_c name fmt b indent labels annots = + let annots = match name with + | None | Some "" -> annots + | Some name -> + let name = + if name.[0] = '`' then String.sub name 1 (String.length name - 1) + else name in + (":" ^ name) :: annots in match labels with | [] -> assert false | [label, ty] -> @@ -217,36 +221,34 @@ module Michelson = struct | [label_bigmap, (Tbigmap _ as ty_b); label_r, ty_r] -> let indent = fmt.increase_indent indent in Printf.bprintf b "(%s" ty_c; - let annots = if name = "" then annots else (":" ^ name) :: annots in - bprint_annots b annots; + bprint_annots ?parameter b annots; Printf.bprintf b "%c%s" fmt.newline indent; bprint_type fmt b indent ty_b []; Printf.bprintf b "%c%s" fmt.newline indent; bprint_type fmt b indent ty_r []; Printf.bprintf b ")" | (label, ty) :: labels -> - let annots = if name = "" then annots else (":" ^ name) :: annots in let indent = fmt.increase_indent indent in Printf.bprintf b "(%s" ty_c; - bprint_annots b annots; + bprint_annots ?parameter b annots; Printf.bprintf b "%c%s" fmt.newline indent; let annots = match ty with | Tbigmap _ -> [":" ^ label] | _ -> ["%" ^ label] in bprint_type fmt b indent ty annots; Printf.bprintf b "%c%s" fmt.newline indent; - bprint_type_composed ty_c "" fmt b indent labels []; + bprint_type_composed ty_c None fmt b indent labels []; Printf.bprintf b ")" and bprint_type_record name fmt b indent labels annots = - bprint_type_composed "pair" name fmt b indent labels annots + bprint_type_composed "pair" (Some name) fmt b indent labels annots and bprint_type_sum name fmt b indent constrs annots = bprint_type_composed "or" name fmt b indent constrs annots and bprint_type fmt b indent ty annots = if is_word_type ty then - bprint_wrap_annots b + bprint_wrap_annots ?parameter b (fun () -> bprint_type_rec fmt b indent ty []) annots else bprint_type_rec fmt b indent ty annots @@ -254,20 +256,18 @@ module Michelson = struct in bprint_type fmt b indent ty annots - let rec bprint_type fmt b indent ty = - bprint_type_base fmt b indent ty [] + let rec bprint_type ?parameter fmt b indent ty = + bprint_type_base ?parameter fmt b indent ty [] let annot a = - if !LiquidOptions.no_annot then "" - else match a with - | Some s -> " @" ^ s - | None -> "" + match a with + | Some s -> " @" ^ s + | None -> "" let annots_to_string annots = - if !LiquidOptions.no_annot then "" - else match annots with - | [] -> "" - | annots -> " " ^ String.concat " " annots + match annots with + | [] -> "" + | annots -> " " ^ String.concat " " annots let rec bprint_const (bprint_mic : format -> Buffer.t -> string -> 'a -> unit) fmt b ?(inseq=false) indent (cst : 'a const) = @@ -276,9 +276,9 @@ module Michelson = struct | CBytes s -> Printf.bprintf b "%s" s | CKey s -> Printf.bprintf b "%S" s | CKey_hash s -> Printf.bprintf b "%S" s - | CContract s -> Printf.bprintf b "%S" s - | CAddress s -> Printf.bprintf b "%S" s | CSignature s -> Printf.bprintf b "%S" s + | CContract (s, None) -> Printf.bprintf b "%S" s + | CContract (s, Some entry) -> Printf.bprintf b "%S" (String.concat "%" [s; entry]) | CTez s -> Printf.bprintf b "%s" (Z.to_string (LiquidNumber.mic_mutez_of_tez s)) | CInt n -> Printf.bprintf b "%s" (Z.to_string (LiquidNumber.mic_of_integer n)) | CNat n -> Printf.bprintf b "%s" (Z.to_string (LiquidNumber.mic_of_integer n)) @@ -306,7 +306,7 @@ module Michelson = struct bprint_const bprint_mic fmt b indent cst; if not inseq then Printf.bprintf b ")"; | CTuple tys -> bprint_const_pairs bprint_mic fmt b ~inseq indent tys - | CMap pairs | CBigMap pairs -> + | CMap pairs | CBigMap BMList pairs -> let indent = fmt.increase_indent indent in Printf.bprintf b "{"; let _ = List.fold_left (fun first (cst1, cst2) -> @@ -322,6 +322,8 @@ module Michelson = struct ) true pairs in Printf.bprintf b "}"; + | CBigMap BMId id -> + Printf.bprintf b "%s" (Z.to_string (LiquidNumber.mic_of_integer id)) | CList csts | CSet csts -> let indent = fmt.increase_indent indent in Printf.bprintf b "{"; @@ -358,6 +360,8 @@ module Michelson = struct match code with | M_INS (ins, annots) -> Printf.bprintf b "%s%s ;" ins (annots_to_string annots) + | M_INS_N (ins, n, annots) -> + Printf.bprintf b "%s%s %d ;" ins (annots_to_string annots) n | M_INS_CST (ins, ty, cst, annots) -> let indent = fmt.increase_indent indent in Printf.bprintf b "%s%s%c%s" @@ -376,11 +380,20 @@ module Michelson = struct bprint_code fmt b indent_in exp) exps; Printf.bprintf b "%c%s}" fmt.newline indent | M_INS_EXP (ins,tys, exps, annots) -> + let parameter = ins = "parameter" in let indent = fmt.increase_indent indent in Printf.bprintf b "%s%s" ins (annots_to_string annots); List.iter (fun ty -> Printf.bprintf b "%c%s" fmt.newline indent; - bprint_type fmt b indent ty) tys; + bprint_type ~parameter fmt b indent ty) tys; + List.iter (fun exp -> + Printf.bprintf b "%c%s" fmt.newline indent; + bprint_code fmt b indent exp) exps; + Printf.bprintf b "%c%s;" fmt.newline indent; + | M_INS_EXP_N (ins, n, exps, annots) -> + let indent = fmt.increase_indent indent in + Printf.bprintf b "%s%s" ins (annots_to_string annots); + Printf.bprintf b "%c%s%d" fmt.newline indent n; List.iter (fun exp -> Printf.bprintf b "%c%s" fmt.newline indent; bprint_code fmt b indent exp) exps; @@ -451,6 +464,8 @@ module Michelson = struct | Some field -> Printf.bprintf b " %%%s " field | None -> () + let bprint_pre_entry b e = bprint_pre_field b e + let rec bprint_pre_michelson bprint_arg fmt b name (m : 'a pre_michelson) = match m with (* = function *) @@ -461,9 +476,12 @@ module Michelson = struct Printf.bprintf b "{ "; List.iter (fun a -> bprint_arg fmt b a; Printf.bprintf b " ; ") args; Printf.bprintf b " }"; + | DIP (1, a) -> + Printf.bprintf b "DIP "; + bprint_pre_name b name; + bprint_arg fmt b a; | DIP (i, a) -> - Printf.bprintf b "D%sP " - (String.concat "" (LiquidMisc.list_init i (fun _ -> "I"))); + Printf.bprintf b "DIP %n " i; bprint_pre_name b name; bprint_arg fmt b a; | IF (a1, a2) -> @@ -517,10 +535,16 @@ module Michelson = struct (String.concat "" (LiquidMisc.list_init i (fun _ -> "U"))); bprint_pre_name b name; | DIP_DROP (i, r) -> - Printf.bprintf b "DIP_DROP (%d, %d)" i r; + Printf.bprintf b "DIP %d { DROP %d }" i r; + bprint_pre_name b name; + | DROP n -> + Printf.bprintf b "DROP %d" n; bprint_pre_name b name; - | DROP -> - Printf.bprintf b "DROP"; + | DIG n -> + Printf.bprintf b "DIG %d" n; + bprint_pre_name b name; + | DUG n -> + Printf.bprintf b "DUG %d" n; bprint_pre_name b name; | CAR field -> Printf.bprintf b "CAR"; @@ -546,6 +570,11 @@ module Michelson = struct bprint_type fmt b "" ty; Printf.bprintf b " "; bprint_const (fun fmt b ident a -> bprint_arg fmt b a) fmt b "" c; + | EMPTY_BIG_MAP (k, v) -> + Printf.bprintf b "EMPTY_BIG_MAP "; + bprint_pre_name b name; + bprint_type fmt b "" k; + bprint_type fmt b "" v; | PAIR -> Printf.bprintf b "PAIR"; bprint_pre_name b name; @@ -613,9 +642,10 @@ module Michelson = struct | MEM -> Printf.bprintf b "MEM"; bprint_pre_name b name; - | SELF -> + | SELF e -> Printf.bprintf b "SELF"; bprint_pre_name b name; + bprint_pre_entry b e; | AMOUNT -> Printf.bprintf b "AMOUNT"; bprint_pre_name b name; @@ -625,8 +655,8 @@ module Michelson = struct | ADDRESS -> Printf.bprintf b "ADDRESS"; bprint_pre_name b name; - | CREATE_ACCOUNT -> - Printf.bprintf b "CREATE_ACCOUNT"; + | CHAIN_ID -> + Printf.bprintf b "CHAIN_ID"; bprint_pre_name b name; | CREATE_CONTRACT contract -> Printf.bprintf b "CREATE_CONTRACT { parameter "; @@ -699,9 +729,10 @@ module Michelson = struct bprint_pre_name b name; bprint_pre_field b constr; bprint_type fmt b "" ty; - | CONTRACT ty -> + | CONTRACT (e, ty) -> Printf.bprintf b "CONTRACT"; bprint_pre_name b name; + bprint_pre_entry b e; bprint_type fmt b "" ty; | EDIV -> Printf.bprintf b "EDIV"; @@ -854,6 +885,7 @@ module LiquidDebug = struct | Tsignature -> Printf.bprintf b "signature" | Toperation -> Printf.bprintf b "operation" | Taddress -> Printf.bprintf b "address" + | Tchainid -> Printf.bprintf b "chain_id" | Ttuple [] -> assert false | Ttuple (ty :: tys) -> Printf.bprintf b "("; @@ -874,6 +906,16 @@ module LiquidDebug = struct Printf.bprintf b " }"; | Trecord (name, _) -> Printf.bprintf b "%s" name; + | Tsum (None, []) -> + Printf.bprintf b "[]"; + | Tsum (None, (c, ty) :: rtys) -> + Printf.bprintf b "[ %s of " c; + bprint_type b "" ty; + List.iter (fun (c, ty) -> + Printf.bprintf b " | %s of " c; + bprint_type b "" ty; + ) rtys; + Printf.bprintf b " ]"; | Tsum (_, (c, ty) :: rtys) when expand -> Printf.bprintf b "%s of " c; bprint_type b "" ty; @@ -881,13 +923,16 @@ module LiquidDebug = struct Printf.bprintf b " | %s of " c; bprint_type b "" ty; ) rtys; - | Tsum (name, _) -> + | Tsum (Some name, _) -> Printf.bprintf b "%s" name; - | Tcontract { sig_name = Some s } -> - Printf.bprintf b "%s.instance" s; - | Tcontract contract_sig -> - bprint_contract_sig expand b indent contract_sig; - Printf.bprintf b ".instance"; + | Tcontract (Some entry, ty) -> + Printf.bprintf b "[%%handle %s : " entry; + bprint_type b "" ty; + Printf.bprintf b "]"; + | Tcontract (None, ty) -> + Printf.bprintf b "[%%handle "; + bprint_type b "" ty; + Printf.bprintf b "]"; | Tor (ty1, ty2) -> Printf.bprintf b "("; bprint_type b "" ty1; @@ -939,7 +984,11 @@ module LiquidDebug = struct Printf.bprintf b " %d:%s" n id) pl; Printf.bprintf b ")"; | Tpartial (Pmap _) -> Printf.bprintf b "pmap" - | Tpartial (Pcont _) -> Printf.bprintf b "pcont" + | Tpartial (Pcont None) -> Printf.bprintf b "pcont none" + | Tpartial (Pcont Some (e, ty)) -> + Printf.bprintf b "pcont[%s : " e; + bprint_type b indent (LiquidTypes.expand ty); + Printf.bprintf b "]"; | Tpartial (Ppar) -> Printf.bprintf b "ppar" in bprint_type b indent ty @@ -982,8 +1031,8 @@ module LiquidDebug = struct | CBytes s -> Printf.bprintf b "%s" s | CKey s -> Printf.bprintf b "%s" s | CKey_hash s -> Printf.bprintf b "%s" s - | CContract s -> Printf.bprintf b "%s" s - | CAddress s -> Printf.bprintf b "%s" s + | CContract (s, None) -> Printf.bprintf b "%s" s + | CContract (s, Some e) -> Printf.bprintf b "%s%%%s" s e | CSignature s -> Printf.bprintf b "%s" s | CTez s -> Printf.bprintf b "%s%s" (LiquidNumber.liq_of_tez s) (LiquidOptions.curreny ()) @@ -1015,8 +1064,10 @@ module LiquidDebug = struct ) cs; Printf.bprintf b ")"; | CMap [] -> Printf.bprintf b "(Map [])"; - | CBigMap [] -> Printf.bprintf b "(BigMap [])"; - | CMap ((c1, c2) :: pairs) | CBigMap ((c1, c2) :: pairs) -> + | CBigMap BMId id -> + Printf.bprintf b "(BigMap %s)" (LiquidNumber.liq_of_integer id); + | CBigMap BMList [] -> Printf.bprintf b "(BigMap [])"; + | CMap ((c1, c2) :: pairs) | CBigMap BMList ((c1, c2) :: pairs) -> let indent2 = indent ^ " " in if String.length indent > 2 then Printf.bprintf b "\n%s" indent; Printf.bprintf b "(%s [" (match cst with @@ -1146,10 +1197,10 @@ module LiquidDebug = struct Printf.bprintf b ")" | Call { contract; amount; entry = None; arg } -> Printf.bprintf b "\n%s(Contract.call" indent; + bprint_code_rec ~debug b indent contract; let indent2 = indent ^ " " in - bprint_code_rec ~debug b indent2 contract; - bprint_code_rec ~debug b indent2 amount; bprint_code_rec ~debug b indent2 arg; + bprint_code_rec ~debug b indent2 amount; Printf.bprintf b ")" | Call { contract; amount; entry = Some entry; arg } -> Printf.bprintf b "\n%s(" indent; @@ -1159,6 +1210,14 @@ module LiquidDebug = struct bprint_code_rec ~debug b indent2 arg; bprint_code_rec ~debug b indent2 amount; Printf.bprintf b ")" + | Self { entry } -> + Printf.bprintf b "\n%s[%%handle Self.%s]" indent entry; + | SelfCall { amount; entry; arg } -> + Printf.bprintf b "\n%s(Self.%s" indent entry; + let indent2 = indent ^ " " in + bprint_code_rec ~debug b indent2 arg; + bprint_code_rec ~debug b indent2 amount; + Printf.bprintf b ")" | MatchOption { arg; ifnone; some_name; ifsome } -> let indent2 = indent ^ " " in let indent4 = indent2 ^ " " in @@ -1321,13 +1380,10 @@ module LiquidDebug = struct bprint_code_rec ~debug b indent2 exp ) args; Printf.bprintf b "\n%s(contract %s)" indent contract.contract_name; - | ContractAt { arg; c_sig } -> - Printf.bprintf b "\n%s(Contract.at" indent; - let indent2 = indent ^ " " in - bprint_code_rec ~debug b indent2 arg; - Printf.bprintf b " : "; - bprint_type b (indent ^ " ") (Toption (Tcontract c_sig)); - Printf.bprintf b ")" + | ContractAt { arg; entry; entry_param } -> + Printf.bprintf b "\n%s[%%%%handle val%%entry %s : " indent entry; + bprint_type b (indent ^ " ") entry_param; + Printf.bprintf b " -> _ ]" | Unpack { arg; ty } -> Printf.bprintf b "\n%s(Bytes.unpack" indent; let indent2 = indent ^ " " in @@ -1474,7 +1530,8 @@ let string_of_node node = | N_END -> "N_END" | N_LEFT _ -> "N_LEFT" | N_RIGHT _ -> "N_RIGHT" - | N_CONTRACT _ -> "N_CONTRACT" + | N_CONTRACT (None, _) -> "N_CONTRACT" + | N_CONTRACT (Some e, _) -> Printf.sprintf "N_CONTRACT %s" e | N_UNPACK _ -> "N_UNPACK" | N_ABS -> "N_ABS" | N_CREATE_CONTRACT _ -> "N_CREATE_CONTRACT" @@ -1483,7 +1540,9 @@ let string_of_node node = | N_CONSTR c -> "N_CONSTR " ^ c | N_SETFIELD f -> "N_SETFIELD " ^ f | N_RESULT (_, i) -> Printf.sprintf "N_RESULT %d" i - | N_LOOP_LEFT _ -> Printf.sprintf "N_LOOP_LEFT" - | N_LOOP_LEFT_BEGIN _ -> Printf.sprintf "N_LOOP_LEFT_BEGIN" - | N_LOOP_LEFT_END _ -> Printf.sprintf "N_LOOP_LEFT_END" - | N_LOOP_LEFT_RESULT _ -> Printf.sprintf "N_LOOP_LEFT_RESULT" + | N_LOOP_LEFT _ -> "N_LOOP_LEFT" + | N_LOOP_LEFT_BEGIN _ -> "N_LOOP_LEFT_BEGIN" + | N_LOOP_LEFT_END _ -> "N_LOOP_LEFT_END" + | N_LOOP_LEFT_RESULT _ -> "N_LOOP_LEFT_RESULT" + | N_SELF None -> "N_SELF" + | N_SELF Some e -> Printf.sprintf "N_SELF %s" e diff --git a/tools/liquidity/liquidSimplify.ml b/tools/liquidity/liquidSimplify.ml index 845fa19b..84c972e4 100644 --- a/tools/liquidity/liquidSimplify.ml +++ b/tools/liquidity/liquidSimplify.ml @@ -26,6 +26,8 @@ open LiquidTypes +let fixpoint_limit = 5000 + let rec compute decompile code to_inline = let old_to_inline = to_inline in @@ -36,7 +38,7 @@ let rec compute decompile code to_inline = let rec size exp = match exp.desc with - | Const _ | Var _ | SetField _ | Project _ -> 1 + | Const _ | Var _ | SetField _ | Project _ | Self _ -> 1 | Failwith arg | ContractAt { arg } @@ -61,6 +63,8 @@ let rec compute decompile code to_inline = | MapFold { body; arg; acc } -> 30 + size body + size arg + size acc | Call { contract; amount; arg } -> 1 + size contract + size amount + size arg + | SelfCall { amount; arg } -> + 1 + size amount + size arg | Transfer { dest; amount } -> 1 + size dest + size amount @@ -295,6 +299,9 @@ let rec compute decompile code to_inline = let args = List.map iter args in { exp with desc = Apply { prim; args } } + | Self { entry } -> + { exp with desc = Self { entry } } + | Transfer { dest; amount } -> let dest = iter dest in let amount = iter amount in @@ -306,6 +313,11 @@ let rec compute decompile code to_inline = let arg = iter arg in { exp with desc = Call { contract; amount; entry; arg } } + | SelfCall { amount; entry; arg } -> + let amount = iter amount in + let arg = iter arg in + { exp with desc = SelfCall { amount; entry; arg } } + | Lambda { arg_name; arg_ty; body; ret_ty; recursive } -> let body = iter body in { exp with @@ -329,9 +341,9 @@ let rec compute decompile code to_inline = (* contract is already simplified *) { exp with desc = CreateContract { args; contract } } - | ContractAt { arg; c_sig } -> + | ContractAt { arg; entry; entry_param } -> let arg = iter arg in - { exp with desc = ContractAt { arg; c_sig } } + { exp with desc = ContractAt { arg; entry; entry_param } } | Unpack { arg; ty } -> let arg = iter arg in @@ -349,8 +361,8 @@ let rec compute decompile code to_inline = and iter_const c = match c with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _) as c -> c | CSome x -> CSome (iter_const x) | CLeft x -> CLeft (iter_const x) | CRight x -> CRight (iter_const x) @@ -359,8 +371,9 @@ let rec compute decompile code to_inline = | CSet xs -> CSet (List.map (iter_const) xs) | CMap l -> CMap (List.map (fun (x,y) -> iter_const x, iter_const y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> iter_const x, iter_const y) l) + | CBigMap BMList l -> + CBigMap (BMList (List.map (fun (x,y) -> iter_const x, iter_const y) l)) + | CBigMap BMId _ as c -> c | CRecord labels -> CRecord (List.map (fun (f, x) -> f, iter_const x) labels) | CConstr (constr, x) -> @@ -370,10 +383,17 @@ let rec compute decompile code to_inline = CLambda { arg_name; arg_ty; body; ret_ty; recursive } in + let cpt = ref 0 in let rec fixpoint code = - let c = iter code in - if eq_syntax_exp c code then c else fixpoint c + incr cpt; + if !cpt > fixpoint_limit then + code + (* Format.kasprintf failwith + * "Reached fixpoint limit (%d) in inlining" fixpoint_limit *) + else + let c = iter code in + if eq_syntax_exp c code then c else fixpoint c in fixpoint code @@ -386,7 +406,7 @@ and simplify_contract ?(decompile_annoted=false) contract (to_inline, to_inline_ (LiquidNamespace.qual_contract_name contract); match contract.entries with - | [{ entry_sig = { entry_name = "main" }; + | [{ entry_sig = { entry_name = _ }; code; fee_code } as entry ] -> { contract with entries = [{ entry with diff --git a/tools/liquidity/liquidToParsetree.ml b/tools/liquidity/liquidToParsetree.ml index 2bdfac32..c7f20250 100644 --- a/tools/liquidity/liquidToParsetree.ml +++ b/tools/liquidity/liquidToParsetree.ml @@ -22,7 +22,10 @@ (****************************************************************************) (* The version that will be required to compile the generated files. *) -let output_version = "1.057" +let output_version = + match String.split_on_char '-' LiquidVersion.version with + | x :: _ -> x + | [] -> assert false open Asttypes open Longident @@ -78,7 +81,7 @@ module HAbbrev = Hashtbl.Make (struct | Tvar { contents = { contents = { tyo = Some ty }}} -> erase_names ty | Tunit|Tbool|Tint|Tnat|Ttez | Tstring|Tbytes|Ttimestamp|Tkey|Tkey_hash|Tsignature|Toperation|Taddress - | Tfail | Tpartial _ | Tvar _ -> ty + | Tfail | Tpartial _ | Tvar _ | Tchainid -> ty | Ttuple tyl -> Ttuple (List.map erase_names tyl) | Toption ty -> Toption (erase_names ty) | Tlist ty -> Tlist (erase_names ty) @@ -93,12 +96,8 @@ module HAbbrev = Hashtbl.Make (struct | Trecord (_rn, fl) -> Trecord ("", List.map (fun (fn, fty) -> (fn, erase_names fty)) fl) | Tsum (_sn, cl) -> - Tsum ("", List.map (fun (cn, cty) -> (cn, erase_names cty)) cl) - | Tcontract c -> - Tcontract { c with entries_sig = - List.map (fun es -> - { es with parameter = erase_names es.parameter } - ) c.entries_sig } + Tsum (None, List.map (fun (cn, cty) -> (cn, erase_names cty)) cl) + | Tcontract (entry, ty) -> Tcontract (entry, erase_names ty) let hash ty = Hashtbl.hash (erase_names ty) let equal ty1 ty2 = eq_types (erase_names ty1) (erase_names ty2) end) @@ -186,7 +185,17 @@ let rec convert_type ~abbrev ?name ty = | Tbytes -> typ_constr "bytes" [] | Toperation -> typ_constr "operation" [] | Taddress -> typ_constr "address" [] - | Tsum (name, _) + | Tchainid -> typ_constr "chain_id" [] + | Tsum (None, constrs) -> + let rows = List.map (fun (n, ty) -> + let n = match n.[0] with + | '`' -> String.sub n 1 (String.length n - 1) + | _ -> n in + let ty = convert_type ~abbrev ty in + Rtag (id n, [], false, [ty]) + ) constrs in + Typ.variant rows Closed None + | Tsum (Some name, _) | Trecord (name, _) -> let args = try @@ -196,7 +205,8 @@ let rec convert_type ~abbrev ?name ty = (StringMap.bindings subst) with Not_found -> params in typ_constr name args - | Tcontract contract_sig -> convert_contract_sig ~abbrev contract_sig + | Tcontract (_, ty) -> + Typ.extension (id "handle", PTyp (convert_type ~abbrev ty)) | Tvar { contents = { contents = { id; tyo = None | Some Tpartial _ }}} -> Typ.var id | Tvar { contents = { contents = { tyo = Some ty }}} -> @@ -209,7 +219,7 @@ let rec convert_type ~abbrev ?name ty = let caml_ty, t_name = match ty with | Ttez | Tunit | Ttimestamp | Tint | Tnat | Tbool | Tkey | Tkey_hash | Tsignature | Tstring | Tbytes | Toperation | Taddress - | Tfail | Trecord _ | Tsum _ | Tcontract _ -> assert false + | Tfail | Trecord _ | Tsum _ | Tcontract _ | Tchainid -> assert false | Ttuple args -> Typ.tuple (List.map (convert_type ~abbrev) args), "pair_t" | Tor (x,y) -> @@ -244,40 +254,6 @@ let rec convert_type ~abbrev ?name ty = | _ -> caml_ty -and convert_contract_sig ~abbrev csig = - let name = match csig.sig_name with - | None -> "ContractType" (* ^ (string_of_int !cpt_abbrev) *) - | Some name -> name in - let val_items = List.map (fun e -> - let parameter = convert_type ~abbrev e.parameter in - Sig.extension ( - id "entry", - PSig [ - Sig.value - (Val.mk (id e.entry_name) - (Typ.arrow (Labelled e.parameter_name) parameter - (Typ.arrow Nolabel (typ_constr "storage" []) - (Typ.tuple [typ_constr "list" [typ_constr "operation" []]; - typ_constr "storage" []])))) - ]) - ) csig.entries_sig in - let abstr_storage = Sig.type_ Recursive [ - Type.mk ~kind:Ptype_abstract (id "storage") - ] in - let signature = Mty.signature (abstr_storage :: val_items) in - let typ = StringMap.fold (fun n csig' -> function - | Some _ as acc -> acc - | None -> - match csig'.sig_name with - | Some name when eq_types (Tcontract csig') (Tcontract csig) -> - Some (typ_constr (name ^ ".instance") []) - | _ -> None - ) predefined_contract_types None in - match typ with - | Some typ -> typ - | None -> add_abbrev name (Tcontract csig) (ContractType signature) - - let convert_primitive prim args = match prim, args with | Prim_and, x :: _ when x.ty = Tnat -> "land" @@ -343,17 +319,15 @@ let rec convert_const ~abbrev (expr : (datatype, 'a) exp const) = let c = Exp.constant (Pconst_integer (n, Some '\235')) in if n.[0] <> '0' then c, true else Exp.constraint_ c (convert_type ~abbrev Tsignature), true - | CContract n -> + | CContract (n, (None | Some "default")) -> Exp.constant (Pconst_integer (n, Some '\236')), false - | CAddress n when - String.length n >= 2 && - let pref = String.sub n 0 2 in pref = "tz" || pref = "dn" - -> - Exp.constraint_ - (Exp.constant (Pconst_integer (n, Some '\236'))) - (convert_type ~abbrev Taddress), true - | CAddress n -> - Exp.constant (Pconst_integer (n, Some '\236')), true + | CContract (n, Some entry) -> + Exp.ident (lid (String.concat "%" [n; entry])), false + (* Exp.apply + * (Exp.ident (lid "%")) + * [Nolabel, Exp.constant (Pconst_integer (n, Some '\236')); + * Nolabel, Exp.ident (lid entry)], + * false *) | CBytes n -> Exp.constant (Pconst_integer (n, Some '\237')), true | CList [] -> Exp.construct (lid "[]") None, false @@ -369,9 +343,12 @@ let rec convert_const ~abbrev (expr : (datatype, 'a) exp const) = Exp.construct (lid "Set") (Some list), inferable_type | CMap [] -> Exp.construct (lid "Map") None, false - | CBigMap [] -> + | CBigMap BMList [] -> Exp.construct (lid "BigMap") None, false - | CMap list | CBigMap list -> + | CBigMap BMId id -> + let id = Exp.constant (Const.integer (LiquidNumber.liq_of_integer id)) in + Exp.construct (lid "BigMap") (Some id), false + | CMap list | CBigMap BMList list -> let list = List.map (fun (key, value) -> CTuple [key; value]) list in let list, inferable_type = convert_const ~abbrev (CList list) in let m = match expr with @@ -534,11 +511,13 @@ and convert_code ~abbrev (expr : (datatype, 'a) exp) = ] | Call { contract; amount; entry = None; arg } -> - Exp.apply ~loc (Exp.ident (lid "Contract.call")) + let contract_exp = convert_code ~abbrev contract in + Exp.apply ~loc + (Exp.ident (lid "Contract.call")) [ - Labelled "dest", convert_code ~abbrev contract; + Labelled "dest", contract_exp; + Nolabel, convert_code ~abbrev arg; Labelled "amount", convert_code ~abbrev amount; - Labelled "parameter", convert_code ~abbrev arg; ] | Call { contract; amount; entry = Some entry; arg } -> @@ -550,6 +529,21 @@ and convert_code ~abbrev (expr : (datatype, 'a) exp) = Labelled "amount", convert_code ~abbrev amount; ] + | Self { entry } -> + Exp.extension ( + id ~loc "handle", + PStr [ + Str.eval (Exp.ident (lid ("Self." ^ entry))) + ]) + + | SelfCall { amount; entry; arg } -> + Exp.apply ~loc + (Exp.ident (lid ("Self." ^ entry))) + [ + Nolabel, convert_code ~abbrev arg; + Labelled "amount", convert_code ~abbrev amount; + ] + | Loop { arg_name; body; arg } -> Exp.apply ~loc (Exp.ident (lid "Loop.loop")) @@ -722,8 +716,7 @@ and convert_code ~abbrev (expr : (datatype, 'a) exp) = (Typ.constr (lid "variant") [convert_type ~abbrev left_ty; Typ.any ()]) - | CreateContract { args = [manager; delegate; spendable; - delegatable; init_balance; init_storage]; + | CreateContract { args = [delegate; init_balance; init_storage]; contract } -> let restore_env = save_env () in let structure = structure_of_contract ~abbrev contract in @@ -736,10 +729,7 @@ and convert_code ~abbrev (expr : (datatype, 'a) exp) = (* top_level_contracts := contract_struct_item :: !top_level_contracts; *) Exp.apply ~loc (Exp.ident (lid "Contract.create")) - [Labelled "manager", convert_code ~abbrev manager; - Labelled "delegate", convert_code ~abbrev delegate; - Labelled "spendable", convert_code ~abbrev spendable; - Labelled "delegatable", convert_code ~abbrev delegatable; + [Labelled "delegate", convert_code ~abbrev delegate; Labelled "amount", convert_code ~abbrev init_balance; Labelled "storage", convert_code ~abbrev init_storage; Nolabel, Exp.pack (Mod.structure structure) @@ -747,12 +737,20 @@ and convert_code ~abbrev (expr : (datatype, 'a) exp) = | CreateContract _ -> assert false - | ContractAt { arg; c_sig } -> - Exp.constraint_ ~loc - (Exp.apply ~loc - (Exp.ident (lid "Contract.at")) - [ Nolabel, convert_code ~abbrev arg ]) - (convert_type ~abbrev (Toption (Tcontract c_sig))) + | ContractAt { arg; entry; entry_param } -> + Exp.apply ~loc + (Exp.extension ( + id ~loc "handle", + PSig [ + Sig.extension ( + id ~loc "entry", + PSig [ + Sig.value + (Val.mk (id entry) + (convert_type ~abbrev entry_param)) + ]) + ])) + [ Nolabel, convert_code ~abbrev arg ] | Unpack { arg; ty } -> Exp.constraint_ ~loc @@ -811,7 +809,8 @@ and structure_of_contract reset_env (); let ignore_type s = StringMap.mem s predefined_types - || String.length s >= 8 && String.sub s 0 8 = "_entries" in + || (List.length contract.entries > 1 && + String.length s >= 8 && String.sub s 0 8 = "_entries") in List.iter (fun (s, ty) -> if not (ignore_type s) then ignore (add_abbrev s ty (TypeName (convert_type ~abbrev:false ty))) @@ -865,7 +864,7 @@ and structure_of_contract List.map (fun (label, ty) -> Type.field (id label) (convert_type ~abbrev:false ty) ) fields)) - | Tsum (name, cstrs) when not @@ StringSet.mem name !seen -> + | Tsum (Some name, cstrs) when not @@ StringSet.mem name !seen -> seen := StringSet.add name !seen; Type.mk (id txt) ~params @@ -880,7 +879,8 @@ and structure_of_contract | ContractType typ -> Str.modtype (Mtd.mk (id txt) ~typ) ) in - [ version_caml ] @ types_caml @ + (if output_version = "inf" then [] else [ version_caml ] ) @ + types_caml @ List.rev !top_level_contracts @ values @ entries diff --git a/tools/liquidity/liquidTypes.ml b/tools/liquidity/liquidTypes.ml index 57fa9ebb..b8cc6165 100644 --- a/tools/liquidity/liquidTypes.ml +++ b/tools/liquidity/liquidTypes.ml @@ -21,6 +21,8 @@ (* along with this program. If not, see . *) (****************************************************************************) +open LiquidNumber + module StringMap = Map.Make(String) module StringSet = Set.Make(String) module IntMap = Map.Make(struct type t = int let compare = compare end) @@ -52,12 +54,6 @@ type location = { loc_pos : ((int * int) * (int * int)) option; } -(** Tez constants are stored with strings *) -type tez = { tezzies : string; mutez : string option } - -(** Unbounded integer constants *) -type integer = { integer : Z.t } - type inline = | InForced (** Force inlining *) | InDont (** Disable inlining *) @@ -87,6 +83,7 @@ type datatype = | Tkey_hash | Tsignature | Toperation + | Tchainid | Taddress | Ttuple of datatype list @@ -97,13 +94,13 @@ type datatype = | Tmap of datatype * datatype | Tbigmap of datatype * datatype - | Tcontract of contract_sig + | Tcontract of string option * datatype | Tor of datatype * datatype | Tlambda of datatype * datatype * uncurry_flag (* liquidity extensions *) | Trecord of string * (string * datatype) list - | Tsum of string * (string * datatype) list + | Tsum of string option * (string * datatype) list | Tclosure of (datatype * datatype) * datatype * uncurry_flag | Tfail @@ -116,7 +113,7 @@ and partial_type = | Peqn of ((datatype * datatype) list * datatype) list * location (*overload*) | Ptup of (int * datatype) list (* partial tuple *) | Pmap of datatype * datatype (* map or bigmap *) - | Pcont of (string * datatype) list (* unknown contract *) + | Pcont of (string * datatype) option (* unknown contract *) | Ppar (* equation parameter *) (** A signature for an entry point *) @@ -235,7 +232,7 @@ let size_of_type = function (** Comparable types can be used as, e.g., keys in a map. This corresponds to comparable types in Michelson *) -let comparable_type = function +let rec comparable_type = function | Tbool | Tint | Tnat @@ -245,6 +242,8 @@ let comparable_type = function | Ttimestamp | Tkey_hash | Taddress -> true + | Ttuple l -> List.for_all comparable_type l + | Trecord (_, l) -> List.for_all (fun (_f, ty) -> comparable_type ty) l | Tvar _ | Tpartial _ -> true (* maybe *) | _ -> false @@ -255,23 +254,21 @@ let is_arrow_type = function let rec may_contain_arrow_type ty = match expand ty with | Tlambda _ | Tclosure _ -> true | Toperation | Tunit | Tbool | Tint | Tnat | Ttez | Tstring | Tbytes - | Ttimestamp | Tkey | Tkey_hash | Tsignature | Taddress | Tfail -> false + | Ttimestamp | Tkey | Tkey_hash | Tsignature | Taddress | Tfail | Tchainid -> + false | Ttuple l -> List.exists may_contain_arrow_type l - | Toption ty | Tlist ty | Tset ty -> + | Toption ty | Tlist ty | Tset ty | Tcontract (_, ty) -> may_contain_arrow_type ty | Tmap (t1, t2) | Tbigmap (t1, t2) | Tor (t1, t2) -> may_contain_arrow_type t1 || may_contain_arrow_type t2 | Trecord (_, l) | Tsum (_, l) -> List.exists (fun (_, t) -> may_contain_arrow_type t) l - | Tcontract s -> - List.exists (fun e -> may_contain_arrow_type e.parameter) - s.entries_sig | Tvar _ | Tpartial _ -> true (** Equality between types. Contract signatures are first order values in types, and equality between those is modulo renaming (of signatures). *) -let rec eq_types ty1 ty2 = match expand ty1, expand ty2 with +let rec eq_types ty1 ty2 = ty1 == ty2 || match expand ty1, expand ty2 with | Tunit, Tunit | Tbool, Tbool | Tint, Tint @@ -285,6 +282,7 @@ let rec eq_types ty1 ty2 = match expand ty1, expand ty2 with | Tsignature, Tsignature | Toperation, Toperation | Taddress, Taddress + | Tchainid, Tchainid | Tfail, Tfail -> true @@ -310,7 +308,13 @@ let rec eq_types ty1 ty2 = match expand ty1, expand ty2 with | Tclosure ((a1, b1), c1, u2), Tclosure ((a2, b2), c2, u1) -> eq_types a1 a2 && eq_types b1 b2 && eq_types c1 c2 - | Trecord (n1, l1), Trecord (n2, l2) + | Trecord (n1, l1), Trecord (n2, l2) -> + n1 = n2 && + begin try + List.for_all2 (fun (x1, t1) (x2, t2) -> x1 = x2 && eq_types t1 t2) l1 l2 + with Invalid_argument _ -> false + end + | Tsum (n1, l1), Tsum (n2, l2) -> n1 = n2 && begin try @@ -318,7 +322,8 @@ let rec eq_types ty1 ty2 = match expand ty1, expand ty2 with with Invalid_argument _ -> false end - | Tcontract csig1, Tcontract csig2 -> eq_signature csig1 csig2 + | Tcontract (Some e1, ty1), Tcontract (Some e2, ty2) -> e1 = e2 && eq_types ty1 ty2 + | Tcontract (_, ty1), Tcontract (_, ty2) -> eq_types ty1 ty2 | Tvar tvr1, Tvar tvr2 -> (Ref.get tvr1).id = (Ref.get tvr2).id @@ -336,25 +341,25 @@ and eq_signature { entries_sig = s1 } { entries_sig = s2 } = ) s1 s2 with Invalid_argument _ -> false -(** Returns true if a type contains an operation (excepted in lambda's - where they are allowed in Michelson). *) -let rec type_contains_nonlambda_operation ty = match expand ty with +(** Returns true if a type contains is forbidden for a constant: + - operation (excepted in lambda's where they are allowed in Michelson) + - big maps *) +let rec forbidden_constant_ty ty = match expand ty with | Toperation -> true + | Tbigmap _ -> true | Tunit | Tbool | Tint | Tnat | Ttez | Tstring | Tbytes - | Ttimestamp | Tkey | Tkey_hash | Tsignature | Taddress | Tfail -> false - | Ttuple l -> List.exists type_contains_nonlambda_operation l - | Toption ty | Tlist ty | Tset ty -> - type_contains_nonlambda_operation ty - | Tmap (t1, t2) | Tbigmap (t1, t2) | Tor (t1, t2) -> - type_contains_nonlambda_operation t1 || type_contains_nonlambda_operation t2 + | Ttimestamp | Tkey | Tkey_hash | Tsignature | Taddress | Tfail | Tchainid -> + false + | Ttuple l -> List.exists forbidden_constant_ty l + | Toption ty | Tlist ty | Tset ty | Tcontract (_, ty) -> + forbidden_constant_ty ty + | Tmap (t1, t2) | Tor (t1, t2) -> + forbidden_constant_ty t1 || forbidden_constant_ty t2 | Trecord (_, l) | Tsum (_, l) -> - List.exists (fun (_, t) -> type_contains_nonlambda_operation t) l - | Tcontract s -> - List.exists (fun e -> type_contains_nonlambda_operation e.parameter) - s.entries_sig + List.exists (fun (_, t) -> forbidden_constant_ty t) l | Tlambda _ | Tclosure _ -> false | Tvar _ | Tpartial _ -> - raise (Invalid_argument "type_contains_nonlambda_operation") + raise (Invalid_argument "forbidden_constant_ty") (** Extract the signature of a contract *) let sig_of_contract c = { @@ -380,14 +385,12 @@ let is_only_module c = c.entries = [] let free_tvars ty = let rec aux fv ty = match expand ty with | Ttuple tyl -> List.fold_left aux fv tyl - | Toption ty | Tlist ty | Tset ty -> aux fv ty + | Toption ty | Tlist ty | Tset ty | Tcontract (_, ty) -> aux fv ty | Tmap (ty1, ty2) | Tbigmap (ty1, ty2) | Tor (ty1, ty2) | Tlambda (ty1, ty2, _) -> aux (aux fv ty1) ty2 | Tclosure ((ty1, ty2), ty3, _) -> aux (aux (aux fv ty1) ty2) ty3 | Trecord (_, fl) | Tsum (_, fl) -> List.fold_left (fun fv (_, ty) -> aux fv ty) fv fl - | Tcontract c -> - List.fold_left (fun fv { parameter = ty } -> aux fv ty) fv c.entries_sig | Tvar tvr -> begin match (Ref.get tvr).tyo with | None -> StringSet.add (Ref.get tvr).id fv | Some ty -> aux fv ty @@ -400,7 +403,7 @@ let free_tvars ty = ) fv el | Tpartial (Ptup pl) -> List.fold_left (fun fv (_, ty) -> aux fv ty) fv pl | Tpartial (Pmap (ty1, ty2)) -> aux (aux fv ty1) ty2 - | Tpartial (Pcont el) -> List.fold_left (fun fv (_, ty) -> aux fv ty) fv el + | Tpartial (Pcont (Some (_, ty))) -> aux fv ty | _ -> fv in aux StringSet.empty ty @@ -427,10 +430,7 @@ let build_subst aty cty = List.fold_left2 (fun s (_, ty1) (_, ty2) -> aux s ty1 ty2) s fl1 fl2 | Tsum (_, cl1), Tsum (_, cl2) -> List.fold_left2 (fun s (_, ty1) (_, ty2) -> aux s ty1 ty2) s cl1 cl2 - | Tcontract c1, Tcontract c2 -> - List.fold_left2 (fun s e1 e2 -> - aux s e1.parameter e2.parameter - ) s c1.entries_sig c2.entries_sig + | Tcontract (_, ty1), Tcontract (_, ty2) -> aux s ty1 ty2 | Tvar tvr, _ -> let tv = Ref.get tvr in begin match tv.tyo with @@ -452,6 +452,7 @@ exception LiquidError of error (** Type of Michelson contracts *) type 'a mic_contract = { mic_parameter : datatype; + mic_root : string option; mic_storage : datatype; mic_code : 'a; mic_fee_code : 'a option; @@ -476,7 +477,6 @@ type primitive = | Prim_tuple_set | Prim_tuple - | Prim_self | Prim_balance | Prim_now | Prim_amount @@ -504,6 +504,8 @@ type primitive = | Prim_map_mem | Prim_map_size + | Prim_big_map_create + | Prim_set_update | Prim_set_add | Prim_set_remove @@ -515,7 +517,6 @@ type primitive = | Prim_list_size | Prim_list_rev - | Prim_create_account | Prim_blake2b | Prim_sha256 | Prim_sha512 @@ -523,6 +524,7 @@ type primitive = | Prim_check | Prim_default_account | Prim_set_delegate + | Prim_address_untype | Prim_address | Prim_pack @@ -552,6 +554,8 @@ type primitive = | Prim_string_concat | Prim_bytes_concat + | Prim_chain_id + (* Dune specific *) | Prim_block_level | Prim_get_balance @@ -615,9 +619,10 @@ let () = "Array.set", Prim_tuple_set; "Current.balance", Prim_balance; + "Contract.balance", Prim_balance; "Current.time", Prim_now; "Current.amount", Prim_amount; - "Current.gas", Prim_gas; + "[%deprecated Current.gas]", Prim_gas; "Current.source", Prim_source; "Current.sender", Prim_sender; @@ -644,6 +649,9 @@ let () = "Map.cardinal", Prim_map_size; "Map.size", Prim_map_size; + "BigMap.empty", Prim_big_map_create; (* same as BigMap.create *) + "BigMap.create", Prim_big_map_create; + "Set.update", Prim_set_update; "Set.add", Prim_set_add; "Set.remove", Prim_set_remove; @@ -658,10 +666,9 @@ let () = "List.size", Prim_list_size; "Contract.set_delegate", Prim_set_delegate; + "Contract.untype", Prim_address_untype; "Contract.address", Prim_address; - "Contract.self", Prim_self; - "Account.create", Prim_create_account; "Account.default", Prim_default_account; "Crypto.blake2b", Prim_blake2b; @@ -683,6 +690,8 @@ let () = "String.slice", Prim_string_sub; "String.sub", Prim_string_sub; + "Chain.id", Prim_chain_id; + "@", Prim_concat_two; "::", Prim_Cons; @@ -870,7 +879,7 @@ and 'exp const = | CSome of 'exp const | CMap of ('exp const * 'exp const) list - | CBigMap of ('exp const * 'exp const) list + | CBigMap of 'exp big_map_const | CList of 'exp const list | CSet of 'exp const list @@ -878,14 +887,17 @@ and 'exp const = | CRight of 'exp const | CKey_hash of string - | CContract of string - | CAddress of string + | CContract of string * string option | CRecord of (string * 'exp const) list | CConstr of string * 'exp const | CLambda of 'exp lambda +and 'exp big_map_const = + | BMList of ('exp const * 'exp const) list + | BMId of integer + and 'exp lambda = { arg_name: loc_name; arg_ty: datatype; @@ -936,6 +948,14 @@ and ('ty, 'a) exp_desc = (** Transfers: - {[ Account.transfer ~dest ~amount ]} *) + | Self of { entry: string } + + | SelfCall of { amount: ('ty, 'a) exp; + entry: string; + arg: ('ty, 'a) exp } + (** Self contract calls: + - {[ Self.entry arg ~amount ]} *) + | Call of { contract: ('ty, 'a) exp; amount: ('ty, 'a) exp; entry: string option; @@ -1045,12 +1065,12 @@ and ('ty, 'a) exp_desc = | CreateContract of { args: ('ty, 'a) exp list; contract: ('ty, 'a) exp contract } (** Oringinating contracts: - {[ Contract.create ~manager ~delegate ~spendable ~delegatable ~amount - (contract C) ]} *) + {[ Contract.create ~delegate~amount (contract C) ]} *) | ContractAt of { arg: ('ty, 'a) exp; - c_sig: contract_sig } - (** Contract from address: {[ (Contract.at arg : (contract C_sig) option ]} *) + entry: string; + entry_param: datatype } + (** Contract handle from address: {[%handle ] arg} *) | Unpack of { arg: ('ty, 'a) exp; ty: datatype } @@ -1122,6 +1142,12 @@ let mk = contract.effect || amount.effect || arg.effect, true + | Self _ -> false, false + + | SelfCall { amount; arg } -> + amount.effect || arg.effect, + true + | If { cond = e1; ifthen = e2; ifelse = e3 } | MatchOption { arg = e1; ifnone = e2; ifsome = e3 } | MatchNat { arg = e1; ifplus = e2; ifminus = e3 } @@ -1138,7 +1164,6 @@ let mk = | _ -> false in prim_eff || List.exists (fun e -> e.effect) args, prim = Prim_set_delegate - || prim = Prim_create_account (* || List.exists (fun e -> e.transfer) args *) | Closure { call_env; body } -> @@ -1176,7 +1201,9 @@ let rec eq_exp_desc eq_ty eq_var e1 e2 = match e1, e2 with | Constructor c1, Constructor c2 -> c1.constr = c2.constr && eq_exp eq_ty eq_var c1.arg c2.arg | ContractAt c1, ContractAt c2 -> - eq_signature c1.c_sig c2.c_sig && eq_exp eq_ty eq_var c1.arg c2.arg + c1.entry = c2.entry && + eq_types c1.entry_param c2.entry_param && + eq_exp eq_ty eq_var c1.arg c2.arg | Unpack u1, Unpack u2 -> eq_types u1.ty u2.ty && eq_exp eq_ty eq_var u1.arg u2.arg | Lambda l1, Lambda l2 -> @@ -1218,6 +1245,11 @@ let rec eq_exp_desc eq_ty eq_var e1 e2 = match e1, e2 with eq_exp eq_ty eq_var t1.contract t2.contract && eq_exp eq_ty eq_var t1.amount t2.amount && eq_exp eq_ty eq_var t1.arg t2.arg + | Self e1, Self e2 -> e1.entry = e2.entry + | SelfCall t1, SelfCall t2 -> + t1.entry = t2.entry && + eq_exp eq_ty eq_var t1.amount t2.amount && + eq_exp eq_ty eq_var t1.arg t2.arg | Transfer t1, Transfer t2 -> eq_exp eq_ty eq_var t1.dest t2.dest && eq_exp eq_ty eq_var t1.amount t2.amount @@ -1285,11 +1317,11 @@ let rec eq_exp_desc eq_ty eq_var e1 e2 = match e1, e2 with and eq_const eq_ty eq_var c1 c2 = match c1, c2 with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ), + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _), ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) -> c1 = c2 + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _ ) -> c1 = c2 | CSome c1, CSome c2 | CLeft c1, CLeft c2 | CRight c1, CRight c2 @@ -1302,13 +1334,14 @@ and eq_const eq_ty eq_var c1 c2 = match c1, c2 with with Invalid_argument _ -> false end | CMap l1, CMap l2 - | CBigMap l1, CBigMap l2 -> + | CBigMap BMList l1, CBigMap BMList l2 -> begin try List.for_all2 (fun (k1, v1) (k2, v2) -> eq_const eq_ty eq_var k1 k2 && eq_const eq_ty eq_var v1 v2) l1 l2 with Invalid_argument _ -> false end + | CBigMap BMId i1, CBigMap BMId i2 -> i1 = i2 | CRecord l1, CRecord l2 -> begin try List.for_all2 (fun (s1, c1) (s2, c2) -> @@ -1324,8 +1357,9 @@ and eq_const eq_ty eq_var c1 c2 = match c1, c2 with (** Generic equality between expressions modulo location, renaming, etc. *) and eq_exp eq_ty eq_var e1 e2 = - eq_ty e1.ty e2.ty && - eq_exp_desc eq_ty eq_var e1.desc e2.desc + e1 == e2 || + (eq_ty e1.ty e2.ty && + eq_exp_desc eq_ty eq_var e1.desc e2.desc) (** Instances of above function {!eq_exp} *) let eq_typed_exp eq_var e1 e2 = eq_exp eq_types eq_var e1 e2 @@ -1335,8 +1369,10 @@ let eq_syntax_exp e1 e2 = eq_exp (fun _ _ -> true) (=) e1 e2 (** Type of Michelson expression *) type michelson_exp = | M_INS of string * string list + | M_INS_N of string * int * string list | M_INS_CST of string * datatype * michelson_exp const * string list | M_INS_EXP of string * datatype list * michelson_exp list * string list + | M_INS_EXP_N of string * int * michelson_exp list * string list (** Intermediate representation for Michelson expressions, the first parameter to allow annotated (or not) expressions *) @@ -1358,7 +1394,9 @@ type 'a pre_michelson = | DUP of int | DIP_DROP of int * int - | DROP + | DROP of int + | DIG of int + | DUG of int | CAR of string option | CDR of string option | CDAR of int * string option @@ -1382,16 +1420,16 @@ type 'a pre_michelson = | MEM | SLICE - | SELF + | SELF of string option | AMOUNT | STEPS_TO_QUOTA - | CREATE_ACCOUNT | BLAKE2B | SHA256 | SHA512 | HASH_KEY | CHECK_SIGNATURE | ADDRESS + | CHAIN_ID | CONS | OR @@ -1407,7 +1445,7 @@ type 'a pre_michelson = | LEFT of datatype * string option | RIGHT of datatype * string option - | CONTRACT of datatype + | CONTRACT of string option * datatype | EDIV | LSL @@ -1427,6 +1465,8 @@ type 'a pre_michelson = | EXTENSION of string * datatype list + | EMPTY_BIG_MAP of datatype * datatype + (* obsolete *) | MOD | DIV @@ -1567,7 +1607,7 @@ and node_kind = | N_END | N_LEFT of datatype | N_RIGHT of datatype - | N_CONTRACT of datatype + | N_CONTRACT of string option * datatype | N_UNPACK of datatype | N_ABS | N_RECORD of string list @@ -1575,6 +1615,7 @@ and node_kind = | N_PROJ of string | N_CONSTR of string | N_RESULT of node * int + | N_SELF of string option and node_exp = node * node @@ -1589,16 +1630,18 @@ let noloc = { loc_file = ""; loc_pos = None } (** Build a default contract signature (with a single [main] entry point) for a parameter type *) -let contract_sig_of_param ?sig_name parameter = { +let contract_sig_of_default ?sig_name parameter = { sig_name; entries_sig = [ { - entry_name = "main"; + entry_name = "default"; parameter; parameter_name = "parameter"; storage_name = "storage"; }]; } +let contract_type_of_default ty = Tcontract (Some "default", ty) + let dummy_contract_sig = { f_sig_name = None; f_storage = Tunit; @@ -1613,6 +1656,7 @@ type warning = | AlwaysFails | WeakParam of string | Partial_application + | WOther of string (** {2 Reserved symbols in parsing } *) @@ -1642,11 +1686,12 @@ let predefined_types = "set", Tunit; "big_map", Tunit; "variant", Tunit; - "instance", Tunit; + "chain_id", Tunit; ] (** Predefined signature for contract with unit parameter *) -let unit_contract_sig = contract_sig_of_param ~sig_name:"UnitContract" Tunit +let unit_contract_sig = contract_sig_of_default ~sig_name:"UnitContract" Tunit +let unit_contract_ty = contract_type_of_default Tunit let predefined_contract_types = List.fold_left (fun acc (name, cty) -> @@ -1659,8 +1704,7 @@ let reserved_keywords = [ "let"; "in"; "match" ; "int"; "bool"; "string"; "bytes"; "get"; "set"; "tuple"; "with"; "fun"; "or"; "and"; "land"; "lor"; "xor"; "not"; "lsl"; "lsr"; "lxor"; "abs"; "type"; - "is_nat"; - "at"; (* Reserved for ContractSig.at *) + "is_nat"; "do"; "done"; "for"; "while"; "to"; ] let has_reserved_prefix s = @@ -1689,7 +1733,7 @@ let prefixes_entry = ["_Liq_entry_"] (** Prefix for constructor used to encode contracts *) let prefix_contract = "_Liq_contract_" -let entry_name_of_case s = +let entry_name_of_case ?(allow_capital=false) s = let rec iter = function | [] -> raise Not_found | prefix_entry :: prefixes -> @@ -1702,12 +1746,14 @@ let entry_name_of_case s = with _ -> if String.length s = 0 then raise Not_found else match s.[0] with - | '_' | 'a' .. 'z' -> s - | _ -> raise Not_found + | '_' | 'a' .. 'z' -> s + (* | 'A' .. 'Z' when allow_capital -> "_" ^ s *) + | '`' -> String.sub s 1 (String.length s - 1) |> String.uncapitalize_ascii + | _ -> raise Not_found -let is_entry_case s = +let is_entry_case ?allow_capital s = try - ignore (entry_name_of_case s); + ignore (entry_name_of_case ?allow_capital s); true with _ -> false diff --git a/tools/liquidity/liquidUntype.ml b/tools/liquidity/liquidUntype.ml index d1183117..417261fa 100644 --- a/tools/liquidity/liquidUntype.ml +++ b/tools/liquidity/liquidUntype.ml @@ -52,8 +52,8 @@ let base_of_var arg = try let pos = String.index arg '/' in String.sub arg 0 pos - with Not_found -> - raise (Invalid_argument ("base_of_var: "^arg)) + with Not_found -> arg + (* raise (Invalid_argument ("base_of_var: "^arg)) *) let base_of_lvar arg = { arg with nname = base_of_var arg.nname } @@ -67,13 +67,6 @@ let find_name env name = hacks allows to bypass this. *) base_of_var name -let escape_var arg = - try - let pos = String.index arg '/' in - String.sub arg 0 pos ^ "_" ^ - String.sub arg (pos+1) (String.length arg - pos - 1) - with Not_found -> assert false - let find_free env var_arg bv = let var_arg' = base_of_var var_arg in if not (StringSet.mem var_arg bv) then @@ -105,7 +98,7 @@ let find_lfree env v bv = scopes. Unfortunately, without hash-consing, this can be quite expensive. *) -let rec untype (env : env) (code : (datatype, 'a) exp) : (datatype, 'b) exp = +let rec untype (env : env) (code : (datatype, 'a) exp) : (unit, 'b) exp = let desc = match code.desc with | If { cond; ifthen; ifelse } -> @@ -220,6 +213,13 @@ let rec untype (env : env) (code : (datatype, 'a) exp) : (datatype, 'b) exp = entry; arg = untype env arg } + | Self { entry } -> Self { entry } + + | SelfCall { amount; entry; arg } -> + SelfCall { amount = untype env amount; + entry; + arg = untype env arg } + | MatchVariant { arg; cases } -> let arg = untype env arg in let cases = List.map (function @@ -237,8 +237,8 @@ let rec untype (env : env) (code : (datatype, 'a) exp) : (datatype, 'b) exp = CreateContract { args = List.map (untype env) args; contract = untype_contract contract } - | ContractAt { arg; c_sig } -> - ContractAt { arg = untype env arg; c_sig } + | ContractAt { arg; entry; entry_param } -> + ContractAt { arg = untype env arg; entry; entry_param } | Unpack { arg; ty } -> Unpack { arg = untype env arg; ty } @@ -257,14 +257,14 @@ let rec untype (env : env) (code : (datatype, 'a) exp) : (datatype, 'b) exp = * (LiquidPrinter.Liquid.string_of_code code) *) in - mk ~loc:code.loc desc code.ty + mk ~loc:code.loc desc ()(* code.ty *) and untype_lambda { arg_name; arg_ty; body; ret_ty; recursive } = let base = base_of_lvar arg_name in let env = empty_env () in let env = new_lbinding arg_name base env in let recursive, env, ret_ty = match recursive with - | None -> recursive, env, Tunit + | None -> recursive, env, ret_ty | Some f -> let f_base = base_of_var f in let env = new_binding f f_base env in @@ -276,8 +276,8 @@ and untype_lambda { arg_name; arg_ty; body; ret_ty; recursive } = and untype_const c = match c with | ( CUnit | CBool _ | CInt _ | CNat _ | CTez _ | CTimestamp _ | CString _ - | CBytes _ | CKey _ | CContract _ | CSignature _ | CNone | CKey_hash _ - | CAddress _ ) as c -> c + | CBytes _ | CKey _ | CSignature _ | CNone | CKey_hash _ + | CContract _ ) as c -> c | CSome x -> CSome (untype_const x) | CLeft x -> CLeft (untype_const x) | CRight x -> CRight (untype_const x) @@ -286,8 +286,9 @@ and untype_const c = match c with | CSet xs -> CSet (List.map (untype_const) xs) | CMap l -> CMap (List.map (fun (x,y) -> untype_const x, untype_const y) l) - | CBigMap l -> - CBigMap (List.map (fun (x,y) -> untype_const x, untype_const y) l) + | CBigMap BMList l -> + CBigMap (BMList (List.map (fun (x,y) -> untype_const x, untype_const y) l)) + | CBigMap BMId _ as c -> c | CRecord labels -> CRecord (List.map (fun (f, x) -> f, untype_const x) labels) | CConstr (constr, x) -> diff --git a/tools/liquidity/liquidUntype.mli b/tools/liquidity/liquidUntype.mli index 368289f8..f3e71395 100644 --- a/tools/liquidity/liquidUntype.mli +++ b/tools/liquidity/liquidUntype.mli @@ -25,6 +25,6 @@ open LiquidTypes -val untype_contract : (datatype, 'a) exp contract -> (datatype, 'b) exp contract -val untype_code : (datatype, 'a) exp -> (datatype, 'b) exp -val untype_const : (datatype, 'a) exp const -> (datatype, 'b) exp const +val untype_contract : (datatype, 'a) exp contract -> syntax_contract +val untype_code : (datatype, 'a) exp -> syntax_exp +val untype_const : (datatype, 'a) exp const -> syntax_const diff --git a/tools/liquidity/liquidVersion.ml b/tools/liquidity/liquidVersion.ml index 37fbd867..9f2cc6c5 100644 --- a/tools/liquidity/liquidVersion.ml +++ b/tools/liquidity/liquidVersion.ml @@ -21,5 +21,6 @@ (* along with this program. If not, see . *) (****************************************************************************) +let version = string_of_float infinity let commit = "" let en_date = "" diff --git a/tools/liquidity/with-dune-network/liquidFromMicheline.ml b/tools/liquidity/with-dune-network/liquidFromMicheline.ml index 62a78bd5..eb64f050 100644 --- a/tools/liquidity/with-dune-network/liquidFromMicheline.ml +++ b/tools/liquidity/with-dune-network/liquidFromMicheline.ml @@ -179,8 +179,8 @@ let type_name_of_annots ?(allow_capital=false) annots = | Found s -> Some (sanitize_name ~allow_capital s) -let type_constr_or_label_of_annots ~allow_capital ?(keep_empty=false) annots = - if !LiquidOptions.ignore_annots then [] +let type_constr_or_label_of_annots ~allow_capital ?(keep_empty=false) ?(no_ignore=false) annots = + if not no_ignore && !LiquidOptions.ignore_annots then [] else let exception Found of string in List.fold_left (fun acc a -> @@ -199,6 +199,14 @@ let type_constr_of_annots annots = let type_label_of_annots annots = type_constr_or_label_of_annots ~allow_capital:false annots +let entryname_of_annots annots = + let cstrs = + type_constr_or_label_of_annots ~allow_capital:true ~keep_empty:false ~no_ignore:true annots in + match cstrs with + | [] -> None + | x :: _ -> Some (String.uncapitalize_ascii x) + + let add_generalize_to_env = let cpt = ref 0 in fun name ty env -> @@ -250,47 +258,22 @@ let rec convert_type ?(parameter=false) env expr = | Prim(_, "or", [x;y], _debug) -> begin match name with - | None when not parameter -> Tor (convert_type env x, convert_type env y) + (* | None when not parameter -> Tor (convert_type env x, convert_type env y) *) | _ -> - let name = match name with None -> "_entries" | Some n -> n in + let is_variant = match name with None -> true | Some _ -> false in try - let ty = Tsum (name, type_constrs ~gen:false env expr) in - let ty_gen = Tsum (name, type_constrs ~gen:true env expr) in - add_generalize_to_env name ty_gen env; + let ty = Tsum (name, type_constrs ~gen:false ~is_variant env expr) in + let ty_gen = Tsum (name, type_constrs ~gen:true ~is_variant env expr) in + (match name with + | None -> () + | Some name -> add_generalize_to_env name ty_gen env); ty with Exit -> Tor (convert_type env x, convert_type env y) end | Prim(_, "contract", [x], annots) -> - let sig_name = type_name_of_annots ~allow_capital:true annots in let parameter = convert_type env x in - let entries_sig = match get_type parameter with - | Tsum (_, constrs) - when List.for_all (fun (s, _) -> is_entry_case s) constrs -> - List.map (fun (s, ty) -> - { entry_name = entry_name_of_case s; - parameter = ty; - parameter_name = "parameter"; - storage_name = "storage" } - ) constrs - | _ -> [{ - entry_name = "main"; - parameter_name = "parameter"; - storage_name = "storage"; - parameter; - }] in - let c_sig = { sig_name; entries_sig } in - begin match - sig_name, - List.find_opt (fun (n, c_sig') -> eq_signature c_sig c_sig') - env.contract_types - with - | None, None -> Tcontract c_sig - | Some n, None -> - env.contract_types <- (n, c_sig) :: env.contract_types; - Tcontract c_sig - | _, Some (n, c_sig) -> Tcontract c_sig - end + Tcontract (None, parameter) | Prim(_, "lambda", [x;y], _debug) -> Tlambda @@ -344,8 +327,14 @@ and type_components ~allow_capital ~gen env t = end | _ -> raise Exit -and type_constrs ~gen env t = type_components ~allow_capital:true ~gen env t -and type_labels ~gen env t = type_components ~allow_capital:false ~gen env t +and type_constrs ~gen ~is_variant env t = + let constrs = type_components ~allow_capital:true ~gen env t in + if is_variant then + List.map (fun (c, ty) -> ("`" ^ c, ty)) constrs + else constrs + +and type_labels ~gen env t = + type_components ~allow_capital:false ~gen env t (* @@ -373,8 +362,8 @@ let rec find nodes ?annots name = | Prim(_, name_maybe, [ v ], a) :: nodes -> if name_maybe = name then match annots with - | None -> v - | Some a' when a = a' -> v + | None -> v, a + | Some a' when a = a' -> v, a | Some _ -> find nodes ?annots name else find nodes ?annots name @@ -405,6 +394,8 @@ let rec convert_const env ?ty expr = | Some Tnat -> CNat (LiquidNumber.integer_of_mic n) | Some Tint | None -> CInt (LiquidNumber.integer_of_mic n) | Some Ttez -> CTez (LiquidNumber.tez_of_mic_mutez n) + | Some (Tbigmap (_k, _v)) -> + CBigMap (BMId (LiquidNumber.integer_of_mic n)) | Some ty -> wrong_type env expr ty end @@ -416,8 +407,11 @@ let rec convert_const env ?ty expr = CTimestamp (ISO8601.of_string s) | Some Tkey -> CKey s | Some Tkey_hash -> CKey_hash s - | Some Tcontract _ -> CContract s - | Some Taddress -> CAddress s + | Some Taddress | Some Tcontract _ -> + (match String.split_on_char '%' s with + | [s] -> CContract (s, None) + | [s; e] -> CContract (s, Some e) + | _ -> assert false) | Some Tsignature -> CSignature s | Some Tstring | None -> CString s | Some ty -> wrong_type env expr ty @@ -437,10 +431,13 @@ let rec convert_const env ?ty expr = | Some Tsignature -> (* CSignature Ed25519.Signature.(to_b58check s) *) CSignature (to_hex s) - | Some Taddress -> - CAddress (to_hex s) - | Some (Tcontract _) -> - CContract (to_hex s) + | Some (Taddress | Tcontract _) -> + let c = MBytes.sub s 0 22 in + let e = MBytes.sub s 22 (MBytes.length s - 22) in + let e = + if MBytes.equal e MBytes.empty then None + else Some (MBytes.to_string e) in + CContract (to_hex c, e) | Some ty -> wrong_type env expr ty end @@ -512,19 +509,26 @@ let rec convert_const env ?ty expr = unknown_expr env "convert_const map element" expr ) elems) | Some (Tbigmap (ty_k, ty_e)) -> - CBigMap (List.map (function + CBigMap (BMList (List.map (function | Prim(_, "Elt", [k;e], _debug) -> convert_const env ~ty:ty_k k, convert_const env ~ty:ty_e e | expr -> unknown_expr env "convert_const big map element" expr - ) elems) + ) elems)) | Some (Tlambda (arg_ty, ret_ty, _)) -> CLambda { arg_name = { nname = "_" ; nloc = loc }; recursive = None; arg_ty; ret_ty; body = convert_code env expr } | None -> - CList (List.map (convert_const env) elems) + (try CList (List.map (convert_const env) elems) + with _ -> + (* maybe it's a lambda *) + CLambda { arg_name = { nname = "_" ; nloc = loc }; + recursive = None; + arg_ty = LiquidInfer.fresh_tvar (); + ret_ty = LiquidInfer.fresh_tvar (); + body = convert_code env expr }) | Some ty -> wrong_type env expr ty end @@ -552,9 +556,17 @@ and convert_code env expr = | Prim(index, "DUP", [], annot) -> mic_loc env index annot (DUP 1) | Prim(index, "DROP", [], annot) -> - mic_loc env index annot (DROP) + mic_loc env index annot (DROP 1) + | Prim(index, "DROP", [ Int (_, i) ], annot) -> + mic_loc env index annot (DROP (Z.to_int i)) | Prim(index, "DIP", [ arg ], annot) -> mic_loc env index annot (DIP (1, convert_code env arg)) + | Prim(index, "DIP", [ Int (_, i); arg ], annot) -> + mic_loc env index annot (DIP (Z.to_int i, convert_code env arg)) + | Prim(index, "DIG", [ Int (_, i) ], annot) -> + mic_loc env index annot (DIG (Z.to_int i)) + | Prim(index, "DUG", [ Int (_, i) ], annot) -> + mic_loc env index annot (DUG (Z.to_int i)) | Prim(index, "CAR", [], annot) -> begin match type_label_of_annots annot with | [f] -> mic_loc env index annot (CAR (Some f)) @@ -581,6 +593,8 @@ and convert_code env expr = (IF_CONS (convert_code env x, convert_code env y)) | Prim(index, "NOW", [], annot) -> mic_loc env index annot (NOW) + | Prim(index, "CHAIN_ID", [], annot) -> + mic_loc env index annot (CHAIN_ID) | Prim(index, "PAIR", [], annot) -> begin match type_label_of_annots annot with | [x] -> mic_loc env index annot (RECORD (x, None)) @@ -620,7 +634,8 @@ and convert_code env expr = | Prim(index, "SENDER", [], annot) -> mic_loc env index annot (SENDER) | Prim(index, "SELF", [], annot) -> - mic_loc env index annot (SELF) + let entry = entryname_of_annots annot in + mic_loc env index annot (SELF entry) | Prim(index, "OR", [], annot) -> mic_loc env index annot (OR) | Prim(index, "LAMBDA", [ty1; ty2; expr], annot) -> @@ -697,8 +712,8 @@ and convert_code env expr = | _ -> mic_loc env index annot (RIGHT (ty, None)) end | Prim(index, "CONTRACT", [ty], annot) -> - mic_loc env index annot - (CONTRACT (convert_type env ty)) + let entry = entryname_of_annots annot in + mic_loc env index annot (CONTRACT (entry, convert_type env ty)) | Prim(index, "UNPACK", [ty], annot) -> mic_loc env index annot (UNPACK (convert_type env ty)) @@ -736,8 +751,6 @@ and convert_code env expr = mic_loc env index annot (LSR) | Prim(index, "STEPS_TO_QUOTA", [], annot) -> mic_loc env index annot (STEPS_TO_QUOTA) - | Prim(index, "CREATE_ACCOUNT", [], annot) -> - mic_loc env index annot (CREATE_ACCOUNT) | Prim(index, "CREATE_CONTRACT", [Seq (_, contract)], annot) -> let contract = convert_raw_contract env contract in mic_loc env index annot (CREATE_CONTRACT contract) @@ -757,17 +770,31 @@ and convert_code env expr = | Prim(index, "GET_BALANCE", [], annot) -> mic_loc env index annot (GET_BALANCE) + | Prim(index, "EMPTY_BIG_MAP", [ k; v ], annot) -> + let k = convert_type env k in + let v = convert_type env v in + mic_loc env index annot (EMPTY_BIG_MAP (k, v)) + | _ -> unknown_expr env "convert_code" expr +and root_name_of_param p annots = + match entryname_of_annots annots with + | Some _ as e -> e + | None -> match p with + | Prim(_, "or", [_; _], annots) -> entryname_of_annots annots + | _ -> None + and convert_raw_contract env c = - let mic_parameter = convert_type env ~parameter:true (find c "parameter") in - let mic_storage = convert_type env (find c "storage") in - let mic_code = convert_code env (find c "code" ~annots:[]) in + let param_node, param_annots = find c "parameter" in + let mic_parameter = convert_type env ~parameter:true param_node in + let mic_root = root_name_of_param param_node param_annots in + let mic_storage = convert_type env (find c "storage" |> fst) in + let mic_code = convert_code env (find c "code" ~annots:[] |> fst) in let mic_fee_code = try - Some (convert_code env (find c "code" ~annots:["@fee"])) + Some (convert_code env (find c "code" ~annots:["@fee"] |> fst)) with Missing_program_field _ -> None in - { mic_storage; mic_parameter; mic_code; mic_fee_code } + { mic_storage; mic_parameter; mic_code; mic_fee_code; mic_root } let convert_contract env c = if !LiquidOptions.verbosity > 0 then @@ -843,7 +870,7 @@ let convert_env env = List.iteri (fun i (label, l_ty) -> ty_env.labels <- StringMap.add label (name, i) ty_env.labels; ) labels; - | Tsum (name, constrs) -> + | Tsum (Some name, constrs) -> List.iteri (fun i (constr, c_ty) -> ty_env.constrs <- StringMap.add constr (name, i) ty_env.constrs; diff --git a/tools/liquidity/with-dune-network/liquidToMicheline.ml b/tools/liquidity/with-dune-network/liquidToMicheline.ml index 2c812352..11422a9d 100644 --- a/tools/liquidity/with-dune-network/liquidToMicheline.ml +++ b/tools/liquidity/with-dune-network/liquidToMicheline.ml @@ -41,9 +41,15 @@ let loc_of_many (l : loc_michelson list) = match l, List.rev l with | [], _ | _, [] -> LiquidLoc.noloc | first :: _, last :: _ -> LiquidLoc.merge first.loc last.loc +let drop_bq l = + if l = "" then l + else match l.[0] with + | '`' -> String.sub l 1 (String.length l - 1) + | _ -> l + let convert_annot = function | Tannot l -> ":" ^ l - | Fannot l | Eannot l -> "%" ^ l + | Fannot l | Eannot l -> "%" ^ drop_bq l | Nannot l -> "@" ^ l let convert_annots annots = @@ -70,8 +76,11 @@ let parse_annots annots = | Some a -> a :: acc | None -> acc) [] annots |> List.rev -let prim ~loc ?(fields=[]) name args var_name = +let prim ~loc ?(fields=[]) ?entry name args var_name = let annots = List.map (fun f -> Fannot f) fields in + let annots = match entry with + | None -> annots + | Some e -> Eannot e :: annots in let annots = match var_name with | Some s -> (Nannot s) :: annots | None -> annots @@ -84,8 +93,10 @@ let seq ~loc exprs = let prim_type ~loc ?(annots=[]) name args = Micheline.Prim(loc, name, args, convert_annots annots) +let int ~loc n = + Micheline.Int (loc, LiquidNumber.(mic_of_integer @@ integer_of_int n)) -let rec convert_type ~loc expr = +let rec convert_type ~loc ?parameter expr = match expr with | Tunit -> prim_type ~loc "unit" [] | Ttimestamp -> prim_type ~loc "timestamp" [] @@ -100,6 +111,7 @@ let rec convert_type ~loc expr = | Tbytes -> prim_type ~loc "bytes" [] | Toperation -> prim_type ~loc "operation" [] | Taddress -> prim_type ~loc "address" [] + | Tchainid -> prim_type ~loc "chain_id" [] | Ttuple [x] -> assert false | Ttuple [] -> assert false | Ttuple [x;y] -> @@ -107,12 +119,8 @@ let rec convert_type ~loc expr = | Ttuple (x :: tys) -> prim_type ~loc "pair" [convert_type ~loc x; convert_type ~loc (Ttuple tys)] | Tor (x,y) -> prim_type ~loc "or" [convert_type ~loc x; convert_type ~loc y] - | Tcontract { sig_name; entries_sig = [{ parameter }]} -> - let annots = match sig_name with - | None -> [] - | Some n -> [Tannot n] in - prim_type ~loc "contract" [convert_type ~loc parameter] ~annots - | Tcontract _ -> assert false + | Tcontract (e, parameter) -> + prim_type ~loc "contract" [convert_type ~loc parameter] | Tlambda (x,y, _) -> prim_type ~loc "lambda" [convert_type ~loc x; convert_type ~loc y] @@ -124,23 +132,25 @@ let rec convert_type ~loc expr = | Tset x -> prim_type ~loc "set" [convert_type ~loc x] | Tlist x -> prim_type ~loc "list" [convert_type ~loc x] | Toption x -> prim_type ~loc "option" [convert_type ~loc x] - | Trecord (name, labels) -> convert_record_type ~loc name labels - | Tsum (name, constrs) -> convert_sum_type ~loc name constrs + | Trecord (name, labels) -> convert_record_type ~loc ?parameter name labels + | Tsum (name, constrs) -> convert_sum_type ~loc ?parameter name constrs | Tfail -> convert_type ~loc Tunit (* use unit for failures *) | Tvar _ | Tpartial _ -> assert false -and convert_record_type ~loc name labels = - convert_composed_type "pair" ~loc name labels +and convert_record_type ~loc ?parameter name labels = + convert_composed_type "pair" ~loc ?parameter (Some name) labels -and convert_sum_type ~loc name constrs = - convert_composed_type "or" ~loc name constrs +and convert_sum_type ~loc ?parameter name constrs = + convert_composed_type "or" ~loc ?parameter name constrs and convert_composed_type ty_c ~loc ?(parameter=false) name labels = - let parameter = parameter || name = "_entries" in + let annots = match name with + | None -> [] + | Some name -> [Tannot name] in match labels with | [] -> assert false | [l, ty] -> - begin match convert_type ~loc ty with + begin match convert_type ~loc ~parameter ty with | Micheline.Prim(loc, "big_map", args, _annots) -> prim_type ~loc "big_map" args ~annots:[Tannot l] | Micheline.Prim(loc, name, args, annots) -> @@ -151,13 +161,11 @@ and convert_composed_type ty_c ~loc ?(parameter=false) name labels = end | [lb, (Tbigmap _ as ty_b); lr, ty_r] -> (* workaround for { lb : _ big_map; lr : _ } => pair *) - let annots = if name = "" then [] else [Tannot name] in let ty_b = convert_type ~loc ty_b in let ty_r = convert_type ~loc ty_r in prim_type ~loc ~annots ty_c [ty_b; ty_r] | (l, ty) :: labels -> - let annots = if name = "" then [] else [Tannot name] in - let ty = match convert_type ~loc ty with + let ty = match convert_type ~loc ~parameter ty with | Micheline.Prim(loc, "big_map", args, annots) -> prim_type ~loc "big_map" args ~annots:[Tannot l] | Micheline.Prim(loc, name, args, annots) -> @@ -166,7 +174,7 @@ and convert_composed_type ty_c ~loc ?(parameter=false) name labels = ]) | _ -> assert false in prim_type ~loc ~annots ty_c - [ty; convert_composed_type ty_c ~loc ~parameter "" labels] + [ty; convert_composed_type ty_c ~loc ~parameter None labels] let rec convert_const ~loc expand (expr : loc_michelson const) = let bytes_of_hex s = @@ -197,14 +205,15 @@ let rec convert_const ~loc expand (expr : loc_michelson const) = | CList args | CSet args -> Micheline.Seq(loc, List.map (convert_const ~loc expand) args) - | CMap args | CBigMap args -> + | CMap args | CBigMap BMList args -> Micheline.Seq(loc, List.map (fun (x,y) -> Micheline.Prim(loc, "Elt", [convert_const ~loc expand x; convert_const ~loc expand y], [] )) args) - + | CBigMap BMId n -> + Micheline.Int (loc, LiquidNumber.mic_of_integer n) | CNat n -> Micheline.Int (loc, LiquidNumber.mic_of_integer n) | CTez n -> Micheline.Int (loc, LiquidNumber.mic_mutez_of_tez n) (* @@ -217,10 +226,14 @@ let rec convert_const ~loc expand (expr : loc_michelson const) = | CKey s -> Micheline.String (loc, s) | CKey_hash s when s.[0] = '0' -> Micheline.Bytes (loc, bytes_of_hex s) | CKey_hash s -> Micheline.String (loc, s) - | CContract s when s.[0] = '0' -> Micheline.Bytes (loc, bytes_of_hex s) - | CContract s -> Micheline.String (loc, s) - | CAddress s when s.[0] = '0' -> Micheline.Bytes (loc, bytes_of_hex s) - | CAddress s -> Micheline.String (loc, s) + | CContract (s, e) when s.[0] = '0' -> + let s = bytes_of_hex s in + let se = match e with + | None -> MBytes.empty + | Some e -> MBytes.of_string e in + Micheline.Bytes (loc, MBytes.concat "" [s; se]) + | CContract (s, (None | Some "default")) -> Micheline.String (loc, s) + | CContract (s, Some e) -> Micheline.String (loc, String.concat "%" [s; e]) | CSignature s when s.[0] = '0' -> Micheline.Bytes (loc, bytes_of_hex s) | CSignature s -> Micheline.String (loc, s) @@ -239,38 +252,36 @@ and convert_code expand expr = let ii = ii ~loc:expr.loc in let seq = seq ~loc:(expr.loc, None) in let prim = prim ~loc:(expr.loc, None) in + let int = int ~loc:(expr.loc, None) in let convert_type ty = convert_type ~loc:(expr.loc, None) ty in let convert_const c = convert_const ~loc:(expr.loc, None) expand c in match expr.ins with | RENAME a -> prim "RENAME" [] a | SEQ exprs -> seq (List.map (convert_code expand) exprs) - | FAILWITH -> prim "FAILWITH" [] name + | FAILWITH -> prim "FAILWITH" [] None - | DROP -> prim "DROP" [] name - | DIP (0, arg) -> assert false - | DIP (1, arg) -> prim "DIP" [ convert_code expand arg ] name - | DIP (n, arg) -> - if expand then - prim "DIP" [ convert_code expand @@ ii @@ - SEQ [{ expr with ins = DIP(n-1, arg)}] - ] None - else - prim (Printf.sprintf "D%sP" (String.make n 'I')) - [ convert_code expand arg ] name + | DROP 1 -> prim "DROP" [] None + | DROP n -> prim "DROP" [int n] None + | DIP (0, arg) -> convert_code expand arg + | DIP (1, arg) -> prim "DIP" [ convert_code expand arg ] None + | DIP (n, arg) -> prim "DIP" [ int n; convert_code expand arg ] None + | DIG 1 -> convert_code expand { expr with ins = SWAP } + | DIG n -> prim "DIG" [int n] None + | DUG n -> prim "DUG" [int n] None | CAR None -> prim "CAR" [] name | CAR (Some field) -> prim "CAR" [] ~fields:[field] name | CDR None -> prim "CDR" [] name | CDR (Some field) -> prim "CDR" [] ~fields:[field] name - | SWAP -> prim "SWAP" [] name + | SWAP -> prim "SWAP" [] None | IF (x,y) -> prim "IF" [convert_code expand x; convert_code expand y] name | IF_NONE (x,y) -> - prim "IF_NONE" [convert_code expand x; convert_code expand y] name + prim "IF_NONE" [convert_code expand x; convert_code expand y] None | IF_LEFT (x,y) -> - prim "IF_LEFT" [convert_code expand x; convert_code expand y] name + prim "IF_LEFT" [convert_code expand x; convert_code expand y] None | IF_CONS (x,y) -> - prim "IF_CONS" [convert_code expand x; convert_code expand y] name + prim "IF_CONS" [convert_code expand x; convert_code expand y] None | NOW -> prim "NOW" [] name | PAIR -> prim "PAIR" [] name | RECORD (f1, None) -> prim "PAIR" [] ~fields:[f1] name @@ -315,6 +326,7 @@ and convert_code expand expr = | MOD -> prim "MOD" [] name | DIV -> prim "DIV" [] name | AMOUNT -> prim "AMOUNT" [] name + | CHAIN_ID -> prim "CHAIN_ID" [] name (* | prim "EMPTY_MAP" [ty1; ty2] -> PUSH (Tmap (convert_type ty1, convert_type ty2), CMap []) @@ -332,12 +344,12 @@ and convert_code expand expr = prim "RIGHT" [convert_type ty] name ~fields:[""; c] | CONS -> prim "CONS" [] name - | LOOP loop -> prim "LOOP" [convert_code expand loop] name + | LOOP loop -> prim "LOOP" [convert_code expand loop] None | LOOP_LEFT loop -> prim "LOOP_LEFT" [convert_code expand loop] name - | ITER body -> prim "ITER" [convert_code expand body] name + | ITER body -> prim "ITER" [convert_code expand body] None | MAP body -> prim "MAP" [convert_code expand body] name - | CONTRACT ty -> - prim "CONTRACT" [convert_type ty] name + | CONTRACT (entry, ty) -> + prim "CONTRACT" [convert_type ty] ?entry name | UNPACK ty -> prim "UNPACK" [convert_type ty] name | INT -> prim "INT" [] name @@ -349,15 +361,15 @@ and convert_code expand expr = if expand then convert_code expand @@ ii @@ SEQ [ - ii @@ DIP(1, ii @@ SEQ [{ expr with ins = DUP(n-1) }]); - ii SWAP + ii @@ DIP (n - 1, ii @@ SEQ [{ expr with ins = DUP 1 }]); + ii @@ DIG (n-1); ] else prim (Printf.sprintf "D%sP" (String.make n 'U')) [] name - | SELF -> prim "SELF" [] name + | SELF entry -> + prim "SELF" [] ?entry name | STEPS_TO_QUOTA -> prim "STEPS_TO_QUOTA" [] name - | CREATE_ACCOUNT -> prim "CREATE_ACCOUNT" [] name | CREATE_CONTRACT contract -> let p, s, c, f = convert_contract_raw expand contract in let p = Micheline.map_node (fun l -> l, None) (fun n -> n) p in @@ -371,8 +383,7 @@ and convert_code expand expr = | LSL -> prim "LSL" [] name | LSR -> prim "LSR" [] name | DIP_DROP (ndip, ndrop) -> - convert_code expand @@ - ii @@ DIP (ndip, ii @@ SEQ (LiquidMisc.list_init ndrop (fun _ -> ii DROP))) + convert_code expand @@ ii @@ DIP (ndip, ii @@ SEQ [ii @@ DROP ndrop]) | CDAR (0, field) -> convert_code expand { expr with ins = CAR field } | CDDR (0, field) -> convert_code expand { expr with ins = CDR field } @@ -402,25 +413,25 @@ and convert_code expand expr = | EXTENSION (minst, tys) -> prim minst (List.map convert_type tys) name - | BLOCK_LEVEL when expand -> prim "LEVEL" [] name - | COLLECT_CALL when expand -> prim "COLLCALL" [] name - | GET_BALANCE when expand -> prim "GETBAL" [] name - | IS_IMPLICIT when expand-> prim "ISIMP" [] name - | BLOCK_LEVEL -> prim "BLOCK_LEVEL" [] name | COLLECT_CALL -> prim "COLLECT_CALL" [] name | GET_BALANCE -> prim "GET_BALANCE" [] name | IS_IMPLICIT -> prim "IS_IMPLICIT" [] name + | EMPTY_BIG_MAP (k, v) -> + prim "EMPTY_BIG_MAP" [convert_type k; convert_type v] name and convert_contract_raw expand c = let loc = LiquidLoc.noloc in - let arg_type = convert_type ~loc c.mic_parameter in + let arg_type = convert_type ~loc ~parameter:true c.mic_parameter in + let root_annots = match c.mic_root with + | None -> [] + | Some r -> convert_annots [Eannot r] in let storage_type = convert_type ~loc c.mic_storage in let code = convert_code expand c.mic_code in let fee_code = match c.mic_fee_code with | None -> None | Some mic_fee -> Some (convert_code expand mic_fee) in - let p = Micheline.Prim(loc, "parameter", [arg_type], []) in + let p = Micheline.Prim(loc, "parameter", [arg_type], root_annots) in let s = Micheline.Prim(loc, "storage", [storage_type], []) in let c = Micheline.Prim((loc, None), "code", [code], []) in let f = match fee_code with @@ -597,9 +608,5 @@ let convert_const ~expand c = let convert_type ty = convert_type ~loc:(LiquidLoc.noloc, None) ty |> Micheline.strip_locations -let arg_list work_done = [ -] - -(* force linking not anymore ? - let execute = Script_interpreter.execute -*) +let const_encoding = Data_encoding.Json.convert const_encoding +let contract_encoding = Data_encoding.Json.convert contract_encoding diff --git a/tools/liquidity/with-dune-network/liquidToMicheline.mli b/tools/liquidity/with-dune-network/liquidToMicheline.mli index 6a6a000e..2a154589 100644 --- a/tools/liquidity/with-dune-network/liquidToMicheline.mli +++ b/tools/liquidity/with-dune-network/liquidToMicheline.mli @@ -46,6 +46,11 @@ val convert_type : datatype -> LiquidMichelineTypes.expr (** {2 Pretty printing Micheline } *) +(** {3 Micheline encodings } *) + +val const_encoding : LiquidMichelineTypes.expr Json_encoding.encoding +val contract_encoding : LiquidMichelineTypes.contract Json_encoding.encoding + (** {3 Pretty printing Micheline to string } *) val line_of_contract : LiquidMichelineTypes.contract -> string @@ -68,6 +73,3 @@ val const_of_ezjson : LiquidMichelineTypes.json -> LiquidMichelineTypes.expr val read_micheline_file : string -> LiquidMichelineTypes.contract * LiquidMichelineTypes.env val read_micheline_json : string -> LiquidMichelineTypes.contract * LiquidMichelineTypes.env - -val arg_list : bool ref -> - (Arg.key * Arg.spec * Arg.doc) list diff --git a/tools/liquidity/without-dune-network/liquidDeploy.ml b/tools/liquidity/without-dune-network/liquidDeploy.ml deleted file mode 100644 index 7e35d6b0..00000000 --- a/tools/liquidity/without-dune-network/liquidDeploy.ml +++ /dev/null @@ -1,165 +0,0 @@ -(****************************************************************************) -(* Liquidity *) -(* *) -(* Copyright (C) 2017-2019 OCamlPro SAS *) -(* *) -(* Authors: Fabrice Le Fessant *) -(* Alain Mebsout *) -(* David Declerck *) -(* *) -(* This program is free software: you can redistribute it and/or modify *) -(* it under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 3 of the License, or *) -(* (at your option) any later version. *) -(* *) -(* This program is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* GNU General Public License for more details. *) -(* *) -(* You should have received a copy of the GNU General Public License *) -(* along with this program. If not, see . *) -(****************************************************************************) - -open LiquidTypes - -type from = - | From_strings of string list - | From_files of string list - -let post = ref (fun ~data _ -> - failwith "mini version cannot do post request") - -let get = ref (fun _ -> - failwith "mini version cannot do get request") - -type key_diff = - | DiffKeyHash of string - | DiffKey of typed_const - -type big_map_diff_item = - | Big_map_add of key_diff * typed_const - | Big_map_remove of key_diff - -type big_map_diff = big_map_diff_item list - -type stack_item = - | StackConst of typed_const - | StackCode of int - -type trace_item = { - loc : location option; - gas : int; - stack : (stack_item * string option) list; -} - -type trace = trace_item array - -type internal_operation = - | Reveal of string - | Transaction of { - amount : string; - destination : string; - parameters : typed_const option; - } - | Origination of { - manager: string ; - delegate: string option ; - script: (typed_contract * typed_const) option ; - spendable: bool ; - delegatable: bool ; - balance: string ; - } - | Delegation of string option - -type operation = { - source : string; - nonce : int; - op : internal_operation; -} - -exception RequestError of int * string -exception ResponseError of string -exception RuntimeError of error * trace option -exception LocalizedError of error -exception RuntimeFailure of error * string option * trace option - - - -module type S = sig - type 'a t - val run : from -> string -> string -> string -> - (operation list * LiquidTypes.typed_const * big_map_diff option) t - val run_debug : from -> string -> string -> string -> - (operation list * LiquidTypes.typed_const * big_map_diff option * trace) t - val init_storage : from -> string list -> LiquidTypes.encoded_const t - val forge_deploy_script : - source:string -> from -> string list -> - (string * string * LiquidToMicheline.loc_table) t - val forge_deploy : ?delegatable:bool -> ?spendable:bool -> - from -> string list -> string t - val deploy : ?delegatable:bool -> ?spendable:bool -> - from -> string list -> (string * (string, exn) result) t - val get_storage : from -> string -> LiquidTypes.typed_const t - val get_big_map_value : - from -> string -> string -> LiquidTypes.typed_const option t - val forge_call_parameter : - from -> string -> string -> string * LiquidToMicheline.loc_table - val forge_call : from -> string -> string -> string -> string t - val call : from -> string -> string -> string -> - (string * (unit, exn) result) t - val activate : secret:string -> string t - val inject : operation:string -> signature:string -> string t - val pack : ?liquid:from -> const:string -> ty:string -> string t -end - -module Dummy = struct - - let run _ _ _ _ = - failwith "mini version cannot run" - - let run_debug _ _ _ _ = - failwith "mini version cannot run debug" - - let init_storage _ _ = - failwith "mini version cannot deploy" - - let forge_deploy_script ~source:_ _ _ = - failwith "mini version cannot deploy" - - let forge_deploy ?(delegatable=false) ?(spendable=false) _ _ = - failwith "mini version cannot deploy" - - let deploy ?(delegatable=false) ?(spendable=false) _ _ = - failwith "mini version cannot deploy" - - let get_storage _ _ = - failwith "mini version cannot query node" - - let get_big_map_value _ _ _ = - failwith "mini version cannot query node" - - let forge_call_parameter _ _ _ = - failwith "mini version cannot call" - - let forge_call _ _ _ _ = - failwith "mini version cannot call" - - let call _ _ _ _ = - failwith "mini version cannot call" - - let activate ~secret = - failwith "mini version cannot activate" - - let inject ~operation ~signature = - failwith "mini version cannot inject" - - let pack ?liquid ~const ~ty = - failwith "mini version cannot pack" -end - -module Async = struct include Dummy type 'a t = 'a Lwt.t end - -module Sync = struct include Dummy type 'a t = 'a end - -let forge_call_arg ?entry_name liquid arg = "" diff --git a/tools/liquidity/without-dune-network/liquidDeploy.mli b/tools/liquidity/without-dune-network/liquidDeploy.mli deleted file mode 120000 index 0aede3be..00000000 --- a/tools/liquidity/without-dune-network/liquidDeploy.mli +++ /dev/null @@ -1 +0,0 @@ -../liquidDeploy.mli \ No newline at end of file diff --git a/travis-scripts/build-dune.sh b/travis-scripts/build-dune.sh index 4978414e..3b937837 100755 --- a/travis-scripts/build-dune.sh +++ b/travis-scripts/build-dune.sh @@ -28,8 +28,9 @@ DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )" export OPAMYES=1 +make clone-dune-network pushd $DUNE -make build-deps +make build-deps || (rm -rf _opam; make build_deps) eval `opam config env` make popd diff --git a/travis-scripts/prepare-opam.sh b/travis-scripts/prepare-opam.sh index 8fecb2a7..d3bde77e 100755 --- a/travis-scripts/prepare-opam.sh +++ b/travis-scripts/prepare-opam.sh @@ -35,4 +35,3 @@ eval $(opam config env) opam update make build-deps -make clone-dune-network diff --git a/travis-scripts/start-dune-sandbox.sh b/travis-scripts/start-dune-sandbox.sh index a6227207..d3059f55 100755 --- a/travis-scripts/start-dune-sandbox.sh +++ b/travis-scripts/start-dune-sandbox.sh @@ -31,11 +31,11 @@ DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )" rm -f $DUNE_PID_FILE eval `opam config env` -$DUNE/src/bin_node/tezos-sandboxed-node.sh 5 &> /tmp/dune-log & +$DUNE/src/bin_node/dune-sandboxed-node.sh 5 &> /tmp/dune-log & echo $! > $DUNE_PID_FILE echo "Waiting a bit for node to be started" sleep 5 -eval `$DUNE/src/bin_client/tezos-init-sandboxed-client.sh 5` +eval `$DUNE/src/bin_client/dune-init-sandboxed-client.sh 5` -tezos-activate-alpha +dune-activate-alpha