Merge.
This commit is contained in:
Sander Spies
commit
d273d0fbfe
@ -11,6 +11,7 @@ stages:
|
||||
- build_and_package_binaries
|
||||
- build_docker
|
||||
- build_and_deploy
|
||||
- ide-unit-test
|
||||
- ide-build
|
||||
- ide-e2e-test
|
||||
- ide-deploy
|
||||
@ -23,9 +24,8 @@ dont-merge-to-master:
|
||||
only:
|
||||
- master
|
||||
|
||||
.build_binary:
|
||||
&build_binary # To run in sequence and save CPU usage, use stage: build_and_package_binaries
|
||||
stage: test
|
||||
.build_binary: &build_binary
|
||||
stage: test # To run in sequence and save CPU usage, use stage: build_and_package_binaries
|
||||
script:
|
||||
- $build_binary_script "$target_os_family" "$target_os" "$target_os_version"
|
||||
- $package_binary_script "$target_os_family" "$target_os" "$target_os_version"
|
||||
@ -35,7 +35,7 @@ dont-merge-to-master:
|
||||
|
||||
.website_build: &website_build
|
||||
stage: build_and_deploy
|
||||
image: node:12-alpine
|
||||
image: node:12
|
||||
dependencies:
|
||||
- build-and-package-debian-9
|
||||
- build-and-package-debian-10
|
||||
@ -62,11 +62,11 @@ dont-merge-to-master:
|
||||
# copy .deb packages into website
|
||||
- find dist -name \*.deb -exec sh -c 'cp {} gitlab-pages/website/static/deb/ligo_$(basename $(dirname {})).deb' \;
|
||||
|
||||
# npm
|
||||
# yarn
|
||||
- cd gitlab-pages/website
|
||||
- npm install
|
||||
- yarn install
|
||||
script:
|
||||
- npm run build
|
||||
- yarn build
|
||||
# move internal odoc documentation to the website folder
|
||||
- mv ../../_build/default/_doc/_html/ build/odoc
|
||||
after_script:
|
||||
@ -213,15 +213,20 @@ pages-attempt:
|
||||
# WEBIDE jobs
|
||||
|
||||
run-webide-unit-tests:
|
||||
stage: test
|
||||
image: node:12-alpine
|
||||
stage: ide-unit-test
|
||||
dependencies:
|
||||
- build-and-package-debian-10
|
||||
image: node:12-buster
|
||||
script:
|
||||
- mv $(realpath dist/package/debian-10/*.deb) ligo_deb10.deb
|
||||
- apt-get update && apt-get -y install libev-dev perl pkg-config libgmp-dev libhidapi-dev m4 libcap-dev bubblewrap rsync
|
||||
- dpkg -i ligo_deb10.deb
|
||||
- cd tools/webide/packages/server
|
||||
- npm ci
|
||||
- npm run test
|
||||
- export LIGO_CMD=/bin/ligo && npm run test
|
||||
rules:
|
||||
- changes:
|
||||
- tools/webide/**
|
||||
- tools/webide/**
|
||||
when: always
|
||||
|
||||
build-publish-ide-image:
|
||||
@ -245,7 +250,7 @@ build-publish-ide-image:
|
||||
- docker push "${WEBIDE_IMAGE_NAME}:${CI_COMMIT_SHORT_SHA}"
|
||||
rules:
|
||||
- changes:
|
||||
- tools/webide/**
|
||||
- tools/webide/**
|
||||
when: always
|
||||
- if: '$CI_COMMIT_REF_NAME == "dev"'
|
||||
when: always
|
||||
@ -260,7 +265,7 @@ run-webide-e2e-tests:
|
||||
- docker-compose run e2e
|
||||
rules:
|
||||
- changes:
|
||||
- tools/webide/**
|
||||
- tools/webide/**
|
||||
when: always
|
||||
- if: '$CI_COMMIT_REF_NAME == "dev"'
|
||||
when: always
|
||||
|
||||
@ -2,7 +2,11 @@
|
||||
|
||||
## [Unreleased]
|
||||
|
||||
## [Add crypto reference page to docs](https://gitlab.com/ligolang/ligo/-/merge_requests/459)
|
||||
## [Support for self] (https://gitlab.com/ligolang/ligo/-/merge_requests/453)
|
||||
### Added
|
||||
- support for `Tezos.self(%Entrypoint)`
|
||||
|
||||
## [Support for create_contract](https://gitlab.com/ligolang/ligo/-/merge_requests/459)
|
||||
### Added
|
||||
- support for `Tezos.create_contract` origination
|
||||
|
||||
|
||||
@ -310,7 +310,7 @@ let main (action, store: parameter * storage) : return =
|
||||
```reasonligo group=c
|
||||
let owner : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address);
|
||||
|
||||
let main = ((action, store) : (parameter, storage)) : storage => {
|
||||
let main = ((action, store) : (parameter, storage)) : return => {
|
||||
if (Tezos.source != owner) { (failwith ("Access denied.") : return); }
|
||||
else { (([] : list (operation)), store); };
|
||||
};
|
||||
@ -478,4 +478,3 @@ let proxy = ((action, store): (parameter, storage)) : return => {
|
||||
> *deprecated*.
|
||||
|
||||
</Syntax>
|
||||
|
||||
|
||||
@ -1,21 +1,19 @@
|
||||
---
|
||||
id: what-and-why
|
||||
id: michelson-and-ligo
|
||||
title: Michelson and LIGO
|
||||
---
|
||||
|
||||
import Syntax from '@theme/Syntax';
|
||||
|
||||
Before we get into what LIGO is and why LIGO needs to exist, let us
|
||||
take a look at what options the Tezos blockchain offers us out of the
|
||||
box. If you want to implement smart contracts natively on Tezos, you
|
||||
have to learn
|
||||
[Michelson](https://tezos.gitlab.io/whitedoc/michelson.html).
|
||||
Currently LIGO compiles to [Michelson](https://tezos.gitlab.io/whitedoc/michelson.html),
|
||||
the native smart contract language supported by Tezos. This page explains the
|
||||
relationship between LIGO and the underlying Michelson it compiles to. Understanding
|
||||
Michelson is not a requirement to use LIGO, but it does become important if you want
|
||||
to formally verify contracts using [Mi-Cho-Coq](https://gitlab.com/nomadic-labs/mi-cho-coq/)
|
||||
or tune the performance of contracts outputted by the LIGO compiler.
|
||||
|
||||
**The rationale and design of Michelson**
|
||||
|
||||
The language native to the Tezos blockchain for writing smart
|
||||
contracts is *Michelson*, a Domain-Specific Language (DSL) inspired by
|
||||
Lisp and Forth. This unusual lineage aims at satisfying unusual
|
||||
Michelson is a Domain-Specific Language (DSL) for writing Tezos smart contracts
|
||||
inspired by Lisp and Forth. This unusual lineage aims at satisfying unusual
|
||||
constraints, but entails some tensions in the design.
|
||||
|
||||
First, to measure stepwise gas consumption, *Michelson is interpreted*.
|
||||
@ -137,131 +135,3 @@ We cannot run Javascript on the Tezos blockchain, but we can choose
|
||||
LIGO, which will abstract the stack management and allow us to create
|
||||
readable, type-safe, and efficient smart contracts.
|
||||
|
||||
## LIGO for Programming Smart Contracts on Tezos
|
||||
|
||||
Perhaps the most striking feature of LIGO is that it comes in
|
||||
different concrete syntaxes, and even different programming
|
||||
paradigms. In other words, LIGO is not defined by one syntax and one
|
||||
paradigm, like imperative versus functional.
|
||||
|
||||
- There is **PascaLIGO**, which is inspired by Pascal, hence is an
|
||||
imperative language with lots of keywords, where values can be
|
||||
locally mutated after they have been annotated with their types
|
||||
(declaration).
|
||||
|
||||
- There is **CameLIGO**, which is inspired by the pure subset of
|
||||
[OCaml](https://ocaml.org/), hence is a functional language with
|
||||
few keywords, where values cannot be mutated, but still require
|
||||
type annotations (unlike OCaml, whose compiler performs almost
|
||||
full type inference).
|
||||
|
||||
- There is **ReasonLIGO**, which is inspired by the pure subset of
|
||||
[ReasonML](https://reasonml.github.io/), which is based upon
|
||||
OCaml.
|
||||
|
||||
Let us decline the same LIGO contract in the three flavours above. Do
|
||||
not worry if it is a little confusing at first; we will explain all
|
||||
the syntax in the upcoming sections of the documentation.
|
||||
|
||||
|
||||
<Syntax syntax="pascaligo">
|
||||
|
||||
```pascaligo group=a
|
||||
type storage is int
|
||||
|
||||
type parameter is
|
||||
Increment of int
|
||||
| Decrement of int
|
||||
| Reset
|
||||
|
||||
type return is list (operation) * storage
|
||||
|
||||
function main (const action : parameter; const store : storage) : return is
|
||||
((nil : list (operation)),
|
||||
case action of
|
||||
Increment (n) -> store + n
|
||||
| Decrement (n) -> store - n
|
||||
| Reset -> 0
|
||||
end)
|
||||
```
|
||||
|
||||
</Syntax>
|
||||
<Syntax syntax="cameligo">
|
||||
|
||||
```cameligo group=a
|
||||
type storage = int
|
||||
|
||||
type parameter =
|
||||
Increment of int
|
||||
| Decrement of int
|
||||
| Reset
|
||||
|
||||
type return = operation list * storage
|
||||
|
||||
let main (action, store : parameter * storage) : return =
|
||||
([] : operation list),
|
||||
(match action with
|
||||
Increment n -> store + n
|
||||
| Decrement n -> store - n
|
||||
| Reset -> 0)
|
||||
```
|
||||
|
||||
</Syntax>
|
||||
<Syntax syntax="reasonligo">
|
||||
|
||||
```reasonligo group=a
|
||||
type storage = int;
|
||||
|
||||
type parameter =
|
||||
Increment (int)
|
||||
| Decrement (int)
|
||||
| Reset;
|
||||
|
||||
type return = (list (operation), storage);
|
||||
|
||||
let main = ((action, store): (parameter, storage)) : return => {
|
||||
(([] : list (operation)),
|
||||
(switch (action) {
|
||||
| Increment (n) => store + n
|
||||
| Decrement (n) => store - n
|
||||
| Reset => 0}));
|
||||
};
|
||||
```
|
||||
|
||||
</Syntax>
|
||||
|
||||
|
||||
|
||||
<!--
|
||||
> 💡 You can find the Michelson compilation output of the contract -->
|
||||
<!--above in **`ligo-counter.tz`** -->
|
||||
|
||||
This LIGO contract behaves almost exactly* like the Michelson
|
||||
contract we saw first, and it accepts the following LIGO expressions:
|
||||
`Increment(n)`, `Decrement(n)` and `Reset`. Those serve as
|
||||
`entrypoint` identification, same as `%add` `%sub` or `%default` in
|
||||
the Michelson contract.
|
||||
|
||||
**The Michelson contract also checks if the `AMOUNT` sent is `0`*
|
||||
|
||||
---
|
||||
|
||||
## Runnable code snippets & exercises
|
||||
|
||||
Some of the sections in this documentation will include runnable code snippets and exercises. Sources for those are available at
|
||||
the [LIGO Gitlab repository](https://gitlab.com/ligolang/ligo).
|
||||
|
||||
### Snippets
|
||||
For example **code snippets** for the *Types* subsection of this doc, can be found here:
|
||||
`gitlab-pages/docs/language-basics/src/types/**`
|
||||
|
||||
### Exercises
|
||||
Solutions to exercises can be found e.g. here: `gitlab-pages/docs/language-basics/exercises/types/**/solutions/**`
|
||||
|
||||
### Running snippets / exercise solutions
|
||||
In certain cases it makes sense to be able to run/evaluate the given snippet or a solution, usually there'll be an example command which you can use, such as:
|
||||
|
||||
```shell
|
||||
ligo evaluate-value -s pascaligo gitlab-pages/docs/language-basics/src/variables-and-constants/const.ligo age
|
||||
# Outputs: 25
|
||||
```
|
||||
155
gitlab-pages/docs/intro/ligo-intro.md
Normal file
155
gitlab-pages/docs/intro/ligo-intro.md
Normal file
@ -0,0 +1,155 @@
|
||||
---
|
||||
id: introduction
|
||||
title: Introduction To LIGO
|
||||
---
|
||||
|
||||
import Tabs from '@theme/Tabs';
|
||||
import TabItem from '@theme/TabItem';
|
||||
|
||||
LIGO is a programming language for writing [Tezos](https://tezos.com/) smart contracts.
|
||||
Smart contracts are a unique domain with extreme resource constraints and even
|
||||
more extreme security risks. Unlike desktop, mobile, or web
|
||||
application development smart contracts cannot rely on cheap CPU time and memory.
|
||||
All resources used by contracts are expensive, and tracked as 'gas costs'. Smart
|
||||
contracts often directly control money or assets, which if stolen could rack up to
|
||||
a large financial loss to the contracts controllers and users. Tezos smart contracts
|
||||
live on the blockchain forever, if there's a bug in them they can't be patched or
|
||||
amended. Naturally under these conditions it's not possible to develop smart contracts
|
||||
the way we're used to developing user facing applications.
|
||||
|
||||
LIGO is designed with these problems in mind. The design philosophy can be
|
||||
described in a few bullet points:
|
||||
|
||||
1. Make a clean, simple language with no unnecessary parts.
|
||||
|
||||
2. Offer multiple familiar syntaxes so users can get up and running quickly.
|
||||
|
||||
3. Encourage people to write simple code, so that it's easy to formally verify the
|
||||
compiled output using a project like [Mi-Cho-Coq](https://gitlab.com/nomadic-labs/mi-cho-coq/).
|
||||
|
||||
4. Significantly reduce the risk that your smart contract will lose its balance to an [avoidable exploit](https://www.wired.com/2016/06/50-million-hack-just-showed-dao-human/).
|
||||
|
||||
LIGO is a functional language designed to include the features you need, while
|
||||
avoiding patterns that make formal verification hard. Most useful smart contracts
|
||||
can express their core functionality in under a thousand lines of code. This makes
|
||||
them a good target for formal methods, and what can't be easily proven can at least
|
||||
be extensively tested. The simplicity of LIGO also keeps its compiled output
|
||||
unbloated. Our hope is to have a simple, strongly typed language with a low footprint.
|
||||
|
||||
LIGO currently offers three syntaxes:
|
||||
|
||||
- **PascaLIGO**, a syntax inspired by Pascal which provides an
|
||||
imperative developer experience.
|
||||
|
||||
- **CameLIGO**, an [OCaml]((https://ocaml.org/)) inspired
|
||||
syntax that allows you to write in a functional style.
|
||||
|
||||
- **ReasonLIGO**, an [ReasonML]((https://reasonml.github.io/)) inspired syntax
|
||||
that builds on the strong points of OCaml. It aims to be familiar for those
|
||||
coming from JavaScript.
|
||||
|
||||
Let's define some LIGO contract in the three flavours above. Do
|
||||
not worry if it is a little confusing at first; we will explain all
|
||||
the syntax in the upcoming sections of the documentation.
|
||||
|
||||
|
||||
<Tabs
|
||||
defaultValue="pascaligo"
|
||||
values={[
|
||||
{ label: 'PascaLIGO', value: 'pascaligo', },
|
||||
{ label: 'CameLIGO', value: 'cameligo', },
|
||||
{ label: 'ReasonLIGO', value: 'reasonligo', },
|
||||
]
|
||||
}>
|
||||
<TabItem value="pascaligo">
|
||||
|
||||
```pascaligo group=a
|
||||
type storage is int
|
||||
|
||||
type parameter is
|
||||
Increment of int
|
||||
| Decrement of int
|
||||
| Reset
|
||||
|
||||
type return is list (operation) * storage
|
||||
|
||||
function main (const action : parameter; const store : storage) : return is
|
||||
((nil : list (operation)),
|
||||
case action of
|
||||
Increment (n) -> store + n
|
||||
| Decrement (n) -> store - n
|
||||
| Reset -> 0
|
||||
end)
|
||||
```
|
||||
|
||||
</TabItem>
|
||||
<TabItem value="cameligo">
|
||||
|
||||
```cameligo group=a
|
||||
type storage = int
|
||||
|
||||
type parameter =
|
||||
Increment of int
|
||||
| Decrement of int
|
||||
| Reset
|
||||
|
||||
type return = operation list * storage
|
||||
|
||||
let main (action, store : parameter * storage) : return =
|
||||
([] : operation list),
|
||||
(match action with
|
||||
Increment n -> store + n
|
||||
| Decrement n -> store - n
|
||||
| Reset -> 0)
|
||||
```
|
||||
|
||||
</TabItem>
|
||||
<TabItem value="reasonligo">
|
||||
|
||||
```reasonligo group=a
|
||||
type storage = int;
|
||||
|
||||
type parameter =
|
||||
Increment (int)
|
||||
| Decrement (int)
|
||||
| Reset;
|
||||
|
||||
type return = (list (operation), storage);
|
||||
|
||||
let main = ((action, store): (parameter, storage)) : return => {
|
||||
(([] : list (operation)),
|
||||
(switch (action) {
|
||||
| Increment (n) => store + n
|
||||
| Decrement (n) => store - n
|
||||
| Reset => 0}));
|
||||
};
|
||||
```
|
||||
|
||||
</TabItem>
|
||||
</Tabs>
|
||||
|
||||
This LIGO contract accepts the following LIGO expressions:
|
||||
`Increment(n)`, `Decrement(n)` and `Reset`. Those serve as
|
||||
`entrypoint` identification.
|
||||
|
||||
---
|
||||
|
||||
## Runnable code snippets & exercises
|
||||
|
||||
Some of the sections in this documentation will include runnable code snippets and exercises. Sources for those are available at
|
||||
the [LIGO Gitlab repository](https://gitlab.com/ligolang/ligo).
|
||||
|
||||
### Snippets
|
||||
For example **code snippets** for the *Types* subsection of this doc, can be found here:
|
||||
`gitlab-pages/docs/language-basics/src/types/**`
|
||||
|
||||
### Exercises
|
||||
Solutions to exercises can be found e.g. here: `gitlab-pages/docs/language-basics/exercises/types/**/solutions/**`
|
||||
|
||||
### Running snippets / exercise solutions
|
||||
In certain cases it makes sense to be able to run/evaluate the given snippet or a solution, usually there'll be an example command which you can use, such as:
|
||||
|
||||
```shell
|
||||
ligo evaluate-value -s pascaligo gitlab-pages/docs/language-basics/src/variables-and-constants/const.ligo age
|
||||
# Outputs: 25
|
||||
```
|
||||
@ -321,6 +321,37 @@ let main = (p : unit) : address => Tezos.self_address;
|
||||
|
||||
</Syntax>
|
||||
|
||||
## Self
|
||||
|
||||
Typecast the currently running contract with an entrypoint annotation.
|
||||
If your are using entrypoints: use "%bar" for constructor Bar
|
||||
If you are not using entrypoints: use "%default"
|
||||
|
||||
<Syntax syntax="pascaligo">
|
||||
|
||||
```pascaligo
|
||||
function main (const p : unit) : contract(unit) is block {
|
||||
const c : contract(unit) = Tezos.self("%Default") ;
|
||||
} with c
|
||||
```
|
||||
|
||||
</Syntax>
|
||||
<Syntax syntax="cameligo">
|
||||
|
||||
```cameligo
|
||||
let main (p : unit) : unit contract =
|
||||
(Tezos.self("%Default") : unit contract)
|
||||
```
|
||||
|
||||
</Syntax>
|
||||
<Syntax syntax="reasonligo">
|
||||
|
||||
```reasonligo
|
||||
let main = (p: unit) : contract(unit) =>
|
||||
(Tezos.self("%Default") : contract(unit));
|
||||
```
|
||||
|
||||
</Syntax>
|
||||
|
||||
## Implicit Account
|
||||
|
||||
|
||||
@ -153,7 +153,7 @@ const siteConfig = {
|
||||
links: [
|
||||
{ href: 'https://ide.ligolang.org/', label: 'Try Online' },
|
||||
{ to: 'docs/intro/installation', label: 'Install' },
|
||||
{ to: 'docs/intro/what-and-why', label: 'Docs' },
|
||||
{ to: 'docs/intro/introduction', label: 'Docs' },
|
||||
{
|
||||
to: 'docs/tutorials/get-started/tezos-taco-shop-smart-contract',
|
||||
label: 'Tutorials'
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"docs": {
|
||||
"Intro": ["intro/what-and-why", "intro/installation", "intro/editor-support"],
|
||||
"Intro": ["intro/introduction", "intro/installation", "intro/editor-support"],
|
||||
"Language Basics": [
|
||||
"language-basics/types",
|
||||
"language-basics/constants-and-variables",
|
||||
@ -18,7 +18,8 @@
|
||||
"advanced/timestamps-addresses",
|
||||
"advanced/entrypoints-contracts",
|
||||
"advanced/include",
|
||||
"advanced/first-contract"
|
||||
"advanced/first-contract",
|
||||
"advanced/michelson-and-ligo"
|
||||
],
|
||||
"API & Reference": [
|
||||
"api/cli-commands",
|
||||
|
||||
@ -59,7 +59,10 @@ function DocPage(props) {
|
||||
sidebar={sidebar}
|
||||
sidebarCollapsible={sidebarCollapsible}
|
||||
syntax={syntax}
|
||||
onSyntaxChange={l => setSyntax(l)}
|
||||
onSyntaxChange={l => {
|
||||
localStorage.setItem('syntax', l);
|
||||
setSyntax(l)
|
||||
}}
|
||||
/>
|
||||
</div>
|
||||
)}
|
||||
|
||||
@ -582,7 +582,6 @@ a:hover {
|
||||
}
|
||||
|
||||
#homePage #intro #preview {
|
||||
min-width: 700px;
|
||||
min-height: 450px;
|
||||
max-width: 400px
|
||||
}
|
||||
@ -896,6 +895,9 @@ a:hover {
|
||||
.nav-footer .sitemap {
|
||||
max-width: 1400px;
|
||||
}
|
||||
#homePage #intro #preview {
|
||||
min-width: 700px;
|
||||
}
|
||||
}
|
||||
|
||||
@media (min-width: 1500px) {
|
||||
@ -919,7 +921,7 @@ a:hover {
|
||||
|
||||
#homePage #intro #preview {
|
||||
order: 1;
|
||||
width: 100%;
|
||||
min-width: 100%;
|
||||
}
|
||||
|
||||
#homePage #intro #preview .hljs {
|
||||
|
||||
@ -66,10 +66,18 @@ let amount =
|
||||
let open Arg in
|
||||
let info =
|
||||
let docv = "AMOUNT" in
|
||||
let doc = "$(docv) is the amount the Michelson interpreter will use." in
|
||||
let doc = "$(docv) is the amount the Michelson interpreter will use for the transaction." in
|
||||
info ~docv ~doc ["amount"] in
|
||||
value @@ opt string "0" info
|
||||
|
||||
let balance =
|
||||
let open Arg in
|
||||
let info =
|
||||
let docv = "BALANCE" in
|
||||
let doc = "$(docv) is the balance the Michelson interpreter will use for the contract balance." in
|
||||
info ~docv ~doc ["balance"] in
|
||||
value @@ opt string "0" info
|
||||
|
||||
let sender =
|
||||
let open Arg in
|
||||
let info =
|
||||
@ -126,7 +134,7 @@ let compile_file =
|
||||
let f source_file entry_point syntax display_format michelson_format =
|
||||
toplevel ~display_format @@
|
||||
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile (Contract entry_point) simplified in
|
||||
let%bind mini_c = Compile.Of_typed.compile typed in
|
||||
let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in
|
||||
let%bind contract = Compile.Of_michelson.build_contract michelson in
|
||||
@ -166,7 +174,7 @@ let print_typed_ast =
|
||||
let f source_file syntax display_format = (
|
||||
toplevel ~display_format @@
|
||||
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile Env simplified in
|
||||
ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed
|
||||
)
|
||||
in
|
||||
@ -179,7 +187,7 @@ let print_mini_c =
|
||||
let f source_file syntax display_format = (
|
||||
toplevel ~display_format @@
|
||||
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile Env simplified in
|
||||
let%bind mini_c = Compile.Of_typed.compile typed in
|
||||
ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c
|
||||
)
|
||||
@ -193,7 +201,7 @@ let measure_contract =
|
||||
let f source_file entry_point syntax display_format =
|
||||
toplevel ~display_format @@
|
||||
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile (Contract entry_point) simplified in
|
||||
let%bind mini_c = Compile.Of_typed.compile typed in
|
||||
let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in
|
||||
let%bind contract = Compile.Of_michelson.build_contract michelson in
|
||||
@ -207,10 +215,10 @@ let measure_contract =
|
||||
(Term.ret term , Term.info ~doc cmdname)
|
||||
|
||||
let compile_parameter =
|
||||
let f source_file entry_point expression syntax amount sender source predecessor_timestamp display_format michelson_format =
|
||||
let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
|
||||
toplevel ~display_format @@
|
||||
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in
|
||||
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
|
||||
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
|
||||
let env = Ast_typed.program_environment typed_prg in
|
||||
@ -225,23 +233,23 @@ let compile_parameter =
|
||||
let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in
|
||||
let%bind () = Compile.Of_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in
|
||||
let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_parameter michelson_prg compiled_param in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
|
||||
let%bind value = Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty in
|
||||
ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
|
||||
in
|
||||
let term =
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ amount $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in
|
||||
let cmdname = "compile-parameter" in
|
||||
let doc = "Subcommand: Compile parameters to a Michelson expression. The resulting Michelson expression can be passed as an argument in a transaction which calls a contract." in
|
||||
(Term.ret term , Term.info ~doc cmdname)
|
||||
|
||||
let interpret =
|
||||
let f expression init_file syntax amount sender source predecessor_timestamp display_format =
|
||||
let f expression init_file syntax amount balance sender source predecessor_timestamp display_format =
|
||||
toplevel ~display_format @@
|
||||
let%bind (decl_list,state,env) = match init_file with
|
||||
| Some init_file ->
|
||||
let%bind simplified = Compile.Of_source.compile init_file (Syntax_name syntax) in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile Env simplified in
|
||||
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
|
||||
let env = Ast_typed.program_environment typed_prg in
|
||||
ok (mini_c_prg,state,env)
|
||||
@ -252,7 +260,7 @@ let interpret =
|
||||
let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_exp in
|
||||
let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in
|
||||
let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
|
||||
let%bind runres = Run.run_expression ~options compiled_exp.expr compiled_exp.expr_ty in
|
||||
match runres with
|
||||
| Fail fail_res ->
|
||||
@ -263,7 +271,7 @@ let interpret =
|
||||
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
|
||||
in
|
||||
let term =
|
||||
Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ sender $ source $ predecessor_timestamp $ display_format ) in
|
||||
Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format ) in
|
||||
let cmdname = "interpret" in
|
||||
let doc = "Subcommand: Interpret the expression in the context initialized by the provided source file." in
|
||||
(Term.ret term , Term.info ~doc cmdname)
|
||||
@ -272,7 +280,7 @@ let temp_ligo_interpreter =
|
||||
let f source_file syntax display_format =
|
||||
toplevel ~display_format @@
|
||||
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed,_ = Compile.Of_simplified.compile Env simplified in
|
||||
let%bind res = Compile.Of_typed.some_interpret typed in
|
||||
ok @@ Format.asprintf "%s\n" res
|
||||
in
|
||||
@ -283,10 +291,10 @@ let temp_ligo_interpreter =
|
||||
(Term.ret term , Term.info ~doc cmdname)
|
||||
|
||||
let compile_storage =
|
||||
let f source_file entry_point expression syntax amount sender source predecessor_timestamp display_format michelson_format =
|
||||
let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format =
|
||||
toplevel ~display_format @@
|
||||
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in
|
||||
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
|
||||
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
|
||||
let env = Ast_typed.program_environment typed_prg in
|
||||
@ -301,21 +309,21 @@ let compile_storage =
|
||||
let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in
|
||||
let%bind () = Compile.Of_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in
|
||||
let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_storage michelson_prg compiled_param in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
|
||||
let%bind value = Run.evaluate_expression ~options compiled_param.expr compiled_param.expr_ty in
|
||||
ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
|
||||
in
|
||||
let term =
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ amount $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ amount $ balance $ sender $ source $ predecessor_timestamp $ display_format $ michelson_code_format) in
|
||||
let cmdname = "compile-storage" in
|
||||
let doc = "Subcommand: Compile an initial storage in ligo syntax to a Michelson expression. The resulting Michelson expression can be passed as an argument in a transaction which originates a contract." in
|
||||
(Term.ret term , Term.info ~doc cmdname)
|
||||
|
||||
let dry_run =
|
||||
let f source_file entry_point storage input amount sender source predecessor_timestamp syntax display_format =
|
||||
let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
|
||||
toplevel ~display_format @@
|
||||
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in
|
||||
let env = Ast_typed.program_environment typed_prg in
|
||||
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
|
||||
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
|
||||
@ -330,7 +338,7 @@ let dry_run =
|
||||
let%bind compiled_params = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c in
|
||||
let%bind args_michelson = Run.evaluate_expression compiled_params.expr compiled_params.expr_ty in
|
||||
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
|
||||
let%bind runres = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in
|
||||
match runres with
|
||||
| Fail fail_res ->
|
||||
@ -341,17 +349,17 @@ let dry_run =
|
||||
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
|
||||
in
|
||||
let term =
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
|
||||
let cmdname = "dry-run" in
|
||||
let doc = "Subcommand: Run a smart-contract with the given storage and input." in
|
||||
(Term.ret term , Term.info ~doc cmdname)
|
||||
|
||||
let run_function =
|
||||
let f source_file entry_point parameter amount sender source predecessor_timestamp syntax display_format =
|
||||
let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
|
||||
toplevel ~display_format @@
|
||||
let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in
|
||||
let%bind simplified_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile simplified_prg in
|
||||
let%bind typed_prg,state = Compile.Of_simplified.compile Env simplified_prg in
|
||||
let env = Ast_typed.program_environment typed_prg in
|
||||
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
|
||||
|
||||
@ -362,7 +370,7 @@ let run_function =
|
||||
let%bind compiled_applied = Compile.Of_typed.compile_expression typed_app in
|
||||
|
||||
let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
|
||||
let%bind runres = Run.run_expression ~options michelson.expr michelson.expr_ty in
|
||||
match runres with
|
||||
| Fail fail_res ->
|
||||
@ -373,26 +381,26 @@ let run_function =
|
||||
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
|
||||
in
|
||||
let term =
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
|
||||
let cmdname = "run-function" in
|
||||
let doc = "Subcommand: Run a function with the given parameter." in
|
||||
(Term.ret term , Term.info ~doc cmdname)
|
||||
|
||||
let evaluate_value =
|
||||
let f source_file entry_point amount sender source predecessor_timestamp syntax display_format =
|
||||
let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format =
|
||||
toplevel ~display_format @@
|
||||
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
|
||||
let%bind typed_prg,_ = Compile.Of_simplified.compile simplified in
|
||||
let%bind typed_prg,_ = Compile.Of_simplified.compile Env simplified in
|
||||
let%bind mini_c = Compile.Of_typed.compile typed_prg in
|
||||
let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in
|
||||
let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in
|
||||
let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; balance ; sender ; source } in
|
||||
let%bind michelson_output = Run.run_no_failwith ~options compiled.expr compiled.expr_ty in
|
||||
let%bind simplified_output = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in
|
||||
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
|
||||
in
|
||||
let term =
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
|
||||
Term.(const f $ source_file 0 $ entry_point 1 $ amount $ balance $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in
|
||||
let cmdname = "evaluate-value" in
|
||||
let doc = "Subcommand: Evaluate a given definition." in
|
||||
(Term.ret term , Term.info ~doc cmdname)
|
||||
|
||||
@ -7,7 +7,7 @@ let bad_contract basename =
|
||||
|
||||
let%expect_test _ =
|
||||
run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ;
|
||||
[%expect {| 1747 bytes |}] ;
|
||||
[%expect {| 1870 bytes |}] ;
|
||||
|
||||
run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ;
|
||||
[%expect {| 1324 bytes |}] ;
|
||||
@ -16,7 +16,7 @@ let%expect_test _ =
|
||||
[%expect {| 3231 bytes |}] ;
|
||||
|
||||
run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ;
|
||||
[%expect {| 642 bytes |}] ;
|
||||
[%expect {| 589 bytes |}] ;
|
||||
|
||||
run_ligo_good [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ;
|
||||
[%expect {| (Left (Left 1)) |}] ;
|
||||
@ -86,7 +86,9 @@ let%expect_test _ =
|
||||
SWAP ;
|
||||
DIP { DUP ; CAR ; CAR } ;
|
||||
GET ;
|
||||
IF_NONE { PUSH string "MAP FIND" ; FAILWITH } {} ;
|
||||
IF_NONE
|
||||
{ PUSH string "buy_single: No card pattern." ; FAILWITH }
|
||||
{ DUP ; DIP { DROP } } ;
|
||||
DUP ;
|
||||
CAR ;
|
||||
DIP { DUP ; CDR ; PUSH nat 1 ; ADD } ;
|
||||
@ -159,7 +161,9 @@ let%expect_test _ =
|
||||
SWAP ;
|
||||
DIP { DUP ; CAR ; CDR } ;
|
||||
GET ;
|
||||
IF_NONE { PUSH string "MAP FIND" ; FAILWITH } {} ;
|
||||
IF_NONE
|
||||
{ PUSH string "sell_single: No card." ; FAILWITH }
|
||||
{ DUP ; DIP { DROP } } ;
|
||||
DUP ;
|
||||
CAR ;
|
||||
SENDER ;
|
||||
@ -173,7 +177,9 @@ let%expect_test _ =
|
||||
CDR ;
|
||||
DIP { DIP 2 { DUP } ; DIG 2 ; CAR ; CAR } ;
|
||||
GET ;
|
||||
IF_NONE { PUSH string "MAP FIND" ; FAILWITH } {} ;
|
||||
IF_NONE
|
||||
{ PUSH string "sell_single: No card pattern." ; FAILWITH }
|
||||
{ DUP ; DIP { DROP } } ;
|
||||
DUP ;
|
||||
DIP { DUP } ;
|
||||
SWAP ;
|
||||
@ -209,7 +215,9 @@ let%expect_test _ =
|
||||
MUL ;
|
||||
SENDER ;
|
||||
CONTRACT unit ;
|
||||
IF_NONE { PUSH string "bad address for get_contract" ; FAILWITH } {} ;
|
||||
IF_NONE
|
||||
{ PUSH string "sell_single: No contract." ; FAILWITH }
|
||||
{ DUP ; DIP { DROP } } ;
|
||||
DIP { DUP } ;
|
||||
SWAP ;
|
||||
DIP { DUP } ;
|
||||
@ -246,7 +254,9 @@ let%expect_test _ =
|
||||
CAR ;
|
||||
DIP { DUP } ;
|
||||
GET ;
|
||||
IF_NONE { PUSH string "MAP FIND" ; FAILWITH } {} ;
|
||||
IF_NONE
|
||||
{ PUSH string "transfer_single: No card." ; FAILWITH }
|
||||
{ DUP ; DIP { DROP } } ;
|
||||
DUP ;
|
||||
CAR ;
|
||||
SENDER ;
|
||||
@ -938,40 +948,27 @@ let%expect_test _ =
|
||||
run_ligo_good [ "compile-contract" ; contract "vote.mligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
{ parameter
|
||||
(or (pair %init
|
||||
(pair (timestamp %beginning_time) (timestamp %finish_time))
|
||||
(string %title))
|
||||
(string %vote)) ;
|
||||
(or (pair %reset (pair (timestamp %finish_time) (timestamp %start_time)) (string %title))
|
||||
(or %vote (unit %nay) (unit %yea))) ;
|
||||
storage
|
||||
(pair (pair (pair (timestamp %beginning_time) (map %candidates string int))
|
||||
(pair (timestamp %finish_time) (string %title)))
|
||||
(set %voters address)) ;
|
||||
(pair (pair (pair (timestamp %finish_time) (nat %nay))
|
||||
(pair (timestamp %start_time) (string %title)))
|
||||
(pair (set %voters address) (nat %yea))) ;
|
||||
code { DUP ;
|
||||
DUP ;
|
||||
CAR ;
|
||||
IF_LEFT
|
||||
{ DUP ;
|
||||
DIP { DIP { DUP } ; SWAP ; CDR } ;
|
||||
PAIR ;
|
||||
DUP ;
|
||||
CAR ;
|
||||
CAR ;
|
||||
CAR ;
|
||||
DIP { PUSH int 0 ;
|
||||
SOME ;
|
||||
DIP { PUSH int 0 ;
|
||||
SOME ;
|
||||
EMPTY_MAP string int ;
|
||||
SWAP ;
|
||||
PUSH string "Yes" ;
|
||||
UPDATE } ;
|
||||
PUSH string "No" ;
|
||||
UPDATE } ;
|
||||
PAIR ;
|
||||
DIP { DUP ; CAR ; CAR ; CDR ; DIP { DUP ; CAR ; CDR } ; PAIR } ;
|
||||
PAIR ;
|
||||
EMPTY_SET address ;
|
||||
PUSH nat 0 ;
|
||||
SWAP ;
|
||||
PAIR ;
|
||||
DIP { DUP ; CAR ; CDR ; DIP { DUP ; CDR } ; PAIR } ;
|
||||
PAIR ;
|
||||
DIP { PUSH nat 0 ; EMPTY_SET address ; PAIR } ;
|
||||
PAIR ;
|
||||
NIL operation ;
|
||||
PAIR ;
|
||||
DIP { DROP 2 } }
|
||||
@ -979,41 +976,56 @@ let%expect_test _ =
|
||||
DIP { DIP { DUP } ; SWAP ; CDR } ;
|
||||
PAIR ;
|
||||
DUP ;
|
||||
CDR ;
|
||||
DIP { DUP } ;
|
||||
SWAP ;
|
||||
CAR ;
|
||||
DIP { DUP ; CDR ; CAR ; CAR ; CDR } ;
|
||||
GET ;
|
||||
IF_NONE { PUSH string "MAP FIND" ; FAILWITH } {} ;
|
||||
IF_LEFT
|
||||
{ DIP { DUP } ;
|
||||
SWAP ;
|
||||
DIP 2 { DUP } ;
|
||||
DIG 2 ;
|
||||
CAR ;
|
||||
CAR ;
|
||||
CDR ;
|
||||
PUSH nat 1 ;
|
||||
ADD ;
|
||||
DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CDR ; SWAP ; CAR ; CAR } ;
|
||||
SWAP ;
|
||||
PAIR ;
|
||||
PAIR ;
|
||||
PAIR ;
|
||||
DIP { DROP } }
|
||||
{ DIP { DUP } ;
|
||||
SWAP ;
|
||||
DIP 2 { DUP } ;
|
||||
DIG 2 ;
|
||||
CDR ;
|
||||
CDR ;
|
||||
PUSH nat 1 ;
|
||||
ADD ;
|
||||
DIP { DUP ; CAR ; SWAP ; CDR ; CAR } ;
|
||||
SWAP ;
|
||||
PAIR ;
|
||||
SWAP ;
|
||||
PAIR ;
|
||||
DIP { DROP } } ;
|
||||
DUP ;
|
||||
DIP { DUP } ;
|
||||
SWAP ;
|
||||
CDR ;
|
||||
CAR ;
|
||||
CAR ;
|
||||
CAR ;
|
||||
DIP { DIP { DUP } ;
|
||||
SWAP ;
|
||||
CAR ;
|
||||
DIP { DUP ;
|
||||
PUSH int 1 ;
|
||||
ADD ;
|
||||
SOME ;
|
||||
DIP { DIP { DUP } ; SWAP ; CDR ; CAR ; CAR ; CDR } } ;
|
||||
UPDATE } ;
|
||||
PUSH bool True ;
|
||||
SENDER ;
|
||||
UPDATE ;
|
||||
DIP { DUP ; CAR ; SWAP ; CDR ; CDR } ;
|
||||
PAIR ;
|
||||
DIP { DIP { DUP } ;
|
||||
SWAP ;
|
||||
CDR ;
|
||||
CAR ;
|
||||
CDR ;
|
||||
CAR ;
|
||||
DIP { DIP { DUP } ; SWAP ; CDR ; CAR ; CDR ; CDR } ;
|
||||
PAIR } ;
|
||||
PAIR ;
|
||||
DIP { DIP { DUP } ; SWAP ; CDR ; CDR ; PUSH bool True ; SENDER ; UPDATE } ;
|
||||
SWAP ;
|
||||
PAIR ;
|
||||
NIL operation ;
|
||||
PAIR ;
|
||||
DIP { DROP 3 } } ;
|
||||
DIP { DROP } } } |}]
|
||||
DIP { DROP 4 } } ;
|
||||
DIP { DROP 2 } } } |}]
|
||||
|
||||
let%expect_test _ =
|
||||
run_ligo_good [ "compile-contract" ; contract "implicit.mligo" ; "main" ] ;
|
||||
@ -1054,7 +1066,7 @@ let%expect_test _ =
|
||||
let%expect_test _ =
|
||||
run_ligo_bad [ "compile-contract" ; contract "bad_address_format.religo" ; "main" ] ;
|
||||
[%expect {|
|
||||
ligo: in file "bad_address_format.religo", line 2, characters 25-47. Badly formatted literal: @"KT1badaddr" {"location":"in file \"bad_address_format.religo\", line 2, characters 25-47"}
|
||||
ligo: in file "bad_address_format.religo", line 2, characters 26-48. Badly formatted literal: @"KT1badaddr" {"location":"in file \"bad_address_format.religo\", line 2, characters 26-48"}
|
||||
|
||||
|
||||
If you're not sure how to fix this error, you can
|
||||
@ -1127,6 +1139,19 @@ let%expect_test _ =
|
||||
storage (pair (map %one key_hash nat) (big_map %two key_hash bool)) ;
|
||||
code { DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } } } |}]
|
||||
|
||||
let%expect_test _ =
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "long_sum_type_names.ligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
ligo: Too long constructor 'Incrementttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt': names length is limited to 32 (tezos limitation)
|
||||
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}]
|
||||
|
||||
let%expect_test _ =
|
||||
run_ligo_good [ "dry-run" ; contract "super-counter.mligo" ; "main" ; "test_param" ; "test_storage" ] ;
|
||||
[%expect {|
|
||||
@ -1149,29 +1174,29 @@ let%expect_test _ =
|
||||
let%expect_test _ =
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P : ( nat * string ):Some(( nat * string ))) : None return let rhs#756 = #P in let p = rhs#756.0 in let s = rhs#756.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
|
||||
ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P : ( nat * string ):Some(( nat * string ))) : None return let rhs#809 = #P in let p = rhs#809.0 in let s = rhs#809.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
|
||||
|
||||
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}] ;
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}] ;
|
||||
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P : ( nat * int ):Some(( nat * int ))) : None return let rhs#759 = #P in let p = rhs#759.0 in let s = rhs#759.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
|
||||
ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P : ( nat * int ):Some(( nat * int ))) : None return let rhs#812 = #P in let p = rhs#812.0 in let s = rhs#812.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
|
||||
|
||||
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}] ;
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}] ;
|
||||
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_no_inline.mligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
@ -1206,3 +1231,117 @@ let%expect_test _ =
|
||||
DIP { DIP { DUP } ; SWAP ; CDR } ;
|
||||
PAIR ;
|
||||
DIP { DROP 2 } } } |}]
|
||||
|
||||
let%expect_test _ =
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "self_type_annotation.ligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
ligo: in file "self_type_annotation.ligo", line 8, characters 41-64. bad self type: expected (TO_Contract (int)) but got (TO_Contract (nat)) {"location":"in file \"self_type_annotation.ligo\", line 8, characters 41-64"}
|
||||
|
||||
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}] ;
|
||||
|
||||
run_ligo_good [ "compile-contract" ; contract "self_type_annotation.ligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
{ parameter nat ;
|
||||
storage int ;
|
||||
code { DUP ;
|
||||
SELF %default ;
|
||||
SWAP ;
|
||||
CDR ;
|
||||
NIL operation ;
|
||||
PAIR ;
|
||||
DIP { DROP 2 } } } |}]
|
||||
|
||||
let%expect_test _ =
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract.mligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
ligo: in file "", line 0, characters 0-0. badly typed contract: unexpected entrypoint type {"location":"in file \"\", line 0, characters 0-0","entrypoint":"main","entrypoint_type":"( nat * int ) -> int"}
|
||||
|
||||
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}] ;
|
||||
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract2.mligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
ligo: in file "", line 0, characters 0-0. bad return type: expected (TO_list(operation)), got string {"location":"in file \"\", line 0, characters 0-0","entrypoint":"main"}
|
||||
|
||||
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}] ;
|
||||
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract3.mligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
ligo: in file "", line 0, characters 0-0. badly typed contract: expected {int} and {string} to be the same in the entrypoint type {"location":"in file \"\", line 0, characters 0-0","entrypoint":"main","entrypoint_type":"( nat * int ) -> ( (TO_list(operation)) * string )"}
|
||||
|
||||
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}]
|
||||
|
||||
let%expect_test _ =
|
||||
run_ligo_good [ "compile-contract" ; contract "self_with_entrypoint.ligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
{ parameter (or (unit %default) (int %toto)) ;
|
||||
storage nat ;
|
||||
code { SELF %toto ;
|
||||
DUP ;
|
||||
PUSH mutez 300000000 ;
|
||||
PUSH int 2 ;
|
||||
TRANSFER_TOKENS ;
|
||||
DUP ;
|
||||
NIL operation ;
|
||||
SWAP ;
|
||||
CONS ;
|
||||
DIP { DIP 2 { DUP } ; DIG 2 ; CDR } ;
|
||||
PAIR ;
|
||||
DIP { DROP 3 } } } |}] ;
|
||||
|
||||
run_ligo_good [ "compile-contract" ; contract "self_without_entrypoint.ligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
{ parameter int ;
|
||||
storage nat ;
|
||||
code { SELF %default ;
|
||||
DUP ;
|
||||
PUSH mutez 300000000 ;
|
||||
PUSH int 2 ;
|
||||
TRANSFER_TOKENS ;
|
||||
DUP ;
|
||||
NIL operation ;
|
||||
SWAP ;
|
||||
CONS ;
|
||||
DIP { DIP 2 { DUP } ; DIG 2 ; CDR } ;
|
||||
PAIR ;
|
||||
DIP { DROP 3 } } } |}] ;
|
||||
|
||||
run_ligo_bad [ "compile-contract" ; bad_contract "self_bad_entrypoint_format.ligo" ; "main" ] ;
|
||||
[%expect {|
|
||||
ligo: in file "self_bad_entrypoint_format.ligo", line 8, characters 52-58. bad entrypoint format: entrypoint "Toto" is badly formatted. We expect "%bar" for entrypoint Bar and "%default" when no entrypoint used {"location":"in file \"self_bad_entrypoint_format.ligo\", line 8, characters 52-58"}
|
||||
|
||||
|
||||
If you're not sure how to fix this error, you can
|
||||
do one of the following:
|
||||
|
||||
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
|
||||
* Ask a question on our Discord: https://discord.gg/9rhYaEt
|
||||
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
|
||||
* Check the changelog by running 'ligo changelog' |}]
|
||||
@ -226,7 +226,12 @@ let%expect_test _ =
|
||||
|
||||
OPTIONS
|
||||
--amount=AMOUNT (absent=0)
|
||||
AMOUNT is the amount the Michelson interpreter will use.
|
||||
AMOUNT is the amount the Michelson interpreter will use for the
|
||||
transaction.
|
||||
|
||||
--balance=BALANCE (absent=0)
|
||||
BALANCE is the balance the Michelson interpreter will use for the
|
||||
contract balance.
|
||||
|
||||
--format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT
|
||||
(absent=human-readable)
|
||||
@ -292,7 +297,12 @@ let%expect_test _ =
|
||||
|
||||
OPTIONS
|
||||
--amount=AMOUNT (absent=0)
|
||||
AMOUNT is the amount the Michelson interpreter will use.
|
||||
AMOUNT is the amount the Michelson interpreter will use for the
|
||||
transaction.
|
||||
|
||||
--balance=BALANCE (absent=0)
|
||||
BALANCE is the balance the Michelson interpreter will use for the
|
||||
contract balance.
|
||||
|
||||
--format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT
|
||||
(absent=human-readable)
|
||||
@ -359,7 +369,12 @@ let%expect_test _ =
|
||||
|
||||
OPTIONS
|
||||
--amount=AMOUNT (absent=0)
|
||||
AMOUNT is the amount the Michelson interpreter will use.
|
||||
AMOUNT is the amount the Michelson interpreter will use for the
|
||||
transaction.
|
||||
|
||||
--balance=BALANCE (absent=0)
|
||||
BALANCE is the balance the Michelson interpreter will use for the
|
||||
contract balance.
|
||||
|
||||
--format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT
|
||||
(absent=human-readable)
|
||||
@ -418,7 +433,12 @@ let%expect_test _ =
|
||||
|
||||
OPTIONS
|
||||
--amount=AMOUNT (absent=0)
|
||||
AMOUNT is the amount the Michelson interpreter will use.
|
||||
AMOUNT is the amount the Michelson interpreter will use for the
|
||||
transaction.
|
||||
|
||||
--balance=BALANCE (absent=0)
|
||||
BALANCE is the balance the Michelson interpreter will use for the
|
||||
contract balance.
|
||||
|
||||
--format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT
|
||||
(absent=human-readable)
|
||||
@ -472,7 +492,12 @@ let%expect_test _ =
|
||||
|
||||
OPTIONS
|
||||
--amount=AMOUNT (absent=0)
|
||||
AMOUNT is the amount the Michelson interpreter will use.
|
||||
AMOUNT is the amount the Michelson interpreter will use for the
|
||||
transaction.
|
||||
|
||||
--balance=BALANCE (absent=0)
|
||||
BALANCE is the balance the Michelson interpreter will use for the
|
||||
contract balance.
|
||||
|
||||
--format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT
|
||||
(absent=human-readable)
|
||||
|
||||
@ -9,6 +9,7 @@
|
||||
interpreter
|
||||
ast_simplified
|
||||
self_ast_simplified
|
||||
self_ast_typed
|
||||
typer_new
|
||||
typer
|
||||
ast_typed
|
||||
|
||||
@ -23,6 +23,9 @@ module Errors = struct
|
||||
let code = Format.asprintf "%a" Michelson.pp c in
|
||||
"bad contract type\n"^code in
|
||||
error title_type_check_msg message
|
||||
let ran_out_of_gas () =
|
||||
let message () = "Ran out of gas!" in
|
||||
error title_type_check_msg message
|
||||
let unknown () =
|
||||
let message () =
|
||||
"unknown error" in
|
||||
@ -47,6 +50,7 @@ let build_contract : Compiler.compiled_expression -> Michelson.michelson result
|
||||
| Err_parameter -> fail @@ Errors.bad_parameter contract ()
|
||||
| Err_storage -> fail @@ Errors.bad_storage contract ()
|
||||
| Err_contract -> fail @@ Errors.bad_contract contract ()
|
||||
| Err_gas -> fail @@ Errors.ran_out_of_gas ()
|
||||
| Err_unknown -> fail @@ Errors.unknown ()
|
||||
|
||||
type check_type = Check_parameter | Check_storage
|
||||
|
||||
@ -1,14 +1,23 @@
|
||||
open Trace
|
||||
|
||||
let compile (program : Ast_simplified.program) : (Ast_typed.program * Typer.Solver.state) result =
|
||||
type form =
|
||||
| Contract of string
|
||||
| Env
|
||||
|
||||
let compile (cform: form) (program : Ast_simplified.program) : (Ast_typed.program * Typer.Solver.state) result =
|
||||
let%bind (prog_typed , state) = Typer.type_program program in
|
||||
let () = Typer.Solver.discard_state state in
|
||||
ok @@ (prog_typed, state)
|
||||
let%bind prog_typed' = match cform with
|
||||
| Contract entrypoint -> Self_ast_typed.all_contract entrypoint prog_typed
|
||||
| Env -> ok prog_typed in
|
||||
ok @@ (prog_typed', state)
|
||||
|
||||
let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression)
|
||||
: (Ast_typed.expression * Typer.Solver.state) result =
|
||||
let%bind (ae_typed,state) = Typer.type_expression_subst env state ae in
|
||||
let () = Typer.Solver.discard_state state in
|
||||
Typer.type_expression_subst env state ae
|
||||
let%bind ae_typed' = Self_ast_typed.all_expression ae_typed in
|
||||
ok @@ (ae_typed',state)
|
||||
|
||||
let apply (entry_point : string) (param : Ast_simplified.expression) : Ast_simplified.expression result =
|
||||
let name = Var.of_name entry_point in
|
||||
|
||||
@ -1,12 +0,0 @@
|
||||
open Trace
|
||||
|
||||
let source_to_typed syntax source_file =
|
||||
let%bind simplified = Of_source.compile source_file syntax in
|
||||
let%bind typed,state = Of_simplified.compile simplified in
|
||||
let env = Ast_typed.program_environment typed in
|
||||
ok (typed,state,env)
|
||||
|
||||
let source_to_typed_expression ~env ~state parameter syntax =
|
||||
let%bind simplified = Of_source.compile_expression syntax parameter in
|
||||
let%bind (typed,_) = Of_simplified.compile_expression ~env ~state simplified in
|
||||
ok typed
|
||||
@ -31,6 +31,7 @@ type run_res =
|
||||
|
||||
type dry_run_options =
|
||||
{ amount : string ;
|
||||
balance : string ;
|
||||
predecessor_timestamp : string option ;
|
||||
sender : string option ;
|
||||
source : string option }
|
||||
@ -47,6 +48,9 @@ let make_dry_run_options (opts : dry_run_options) : options result =
|
||||
let open Proto_alpha_utils.Trace in
|
||||
let open Proto_alpha_utils.Memory_proto_alpha in
|
||||
let open Protocol.Alpha_context in
|
||||
let%bind balance = match Tez.of_string opts.balance with
|
||||
| None -> simple_fail "invalid amount"
|
||||
| Some balance -> ok balance in
|
||||
let%bind amount = match Tez.of_string opts.amount with
|
||||
| None -> simple_fail "invalid amount"
|
||||
| Some amount -> ok amount in
|
||||
@ -75,7 +79,7 @@ let make_dry_run_options (opts : dry_run_options) : options result =
|
||||
match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with
|
||||
| Some t -> ok (Some t)
|
||||
| None -> simple_fail ("\""^st^"\" is a bad timestamp notation") in
|
||||
ok @@ make_options ?predecessor_timestamp:predecessor_timestamp ~amount ?sender ?source ()
|
||||
ok @@ make_options ?predecessor_timestamp:predecessor_timestamp ~amount ~balance ?sender ?source ()
|
||||
|
||||
let ex_value_ty_to_michelson (v : ex_typed_value) : Michelson.t result =
|
||||
let (Ex_typed_value (value , ty)) = v in
|
||||
|
||||
@ -540,9 +540,13 @@ fun_expr:
|
||||
in raise (Error (WrongFunctionArguments e))
|
||||
in
|
||||
let binders = fun_args_to_pattern $1 in
|
||||
let lhs_type = match $1 with
|
||||
EAnnot {value = {inside = _ , _, t; _}; region = r} -> Some (r,t)
|
||||
| _ -> None
|
||||
in
|
||||
let f = {kwd_fun;
|
||||
binders;
|
||||
lhs_type=None;
|
||||
lhs_type;
|
||||
arrow;
|
||||
body
|
||||
}
|
||||
|
||||
@ -828,6 +828,18 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
|
||||
ok (Raw.EFun {region=Region.ghost ; value=fun_},List.fold_right' aux lhs_type' ty)
|
||||
in
|
||||
let%bind rhs' = simpl_expression let_rhs in
|
||||
let%bind lhs_type = match lhs_type with
|
||||
| None -> (match let_rhs with
|
||||
| EFun {value={binders;lhs_type}} ->
|
||||
let f_args = nseq_to_list (binders) in
|
||||
let%bind lhs_type' = bind_map_option (fun x -> simpl_type_expression (snd x)) lhs_type in
|
||||
let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in
|
||||
let aux acc ty = Option.map (t_function (snd ty)) acc in
|
||||
ok @@ (List.fold_right' aux lhs_type' ty)
|
||||
| _ -> ok None
|
||||
)
|
||||
| Some t -> ok @@ Some t
|
||||
in
|
||||
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
|
||||
)
|
||||
|
||||
|
||||
25
src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml
Normal file
25
src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml
Normal file
@ -0,0 +1,25 @@
|
||||
open Ast_simplified
|
||||
open Trace
|
||||
open Stage_common.Helpers
|
||||
|
||||
module Errors = struct
|
||||
let bad_string_timestamp name () =
|
||||
let title = thunk @@ Format.asprintf ("Too long constructor '%s'") name in
|
||||
let message () = "names length is limited to 32 (tezos limitation)" in
|
||||
error title message ()
|
||||
end
|
||||
open Errors
|
||||
|
||||
let peephole_type_expression : type_expression -> type_expression result = fun e ->
|
||||
let return type_content = ok { e with type_content } in
|
||||
match e.type_content with
|
||||
| T_sum cmap ->
|
||||
let%bind _uu = bind_map_cmapi
|
||||
(fun k _ ->
|
||||
let (Constructor name) = k in
|
||||
if (String.length name >= 32) then fail @@ bad_string_timestamp name
|
||||
else ok ()
|
||||
)
|
||||
cmap in
|
||||
ok e
|
||||
| e -> return e
|
||||
@ -19,10 +19,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
||||
| E_look_up ab ->
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
ok res
|
||||
| E_loop {condition;body} ->
|
||||
let ab = (condition,body) in
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
ok res
|
||||
| E_application {expr1;expr2} -> (
|
||||
let ab = (expr1,expr2) in
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
@ -90,8 +86,12 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
||||
ok res
|
||||
)
|
||||
|
||||
type mapper = expression -> expression result
|
||||
let rec map_expression : mapper -> expression -> expression result = fun f e ->
|
||||
type exp_mapper = expression -> expression result
|
||||
type ty_exp_mapper = type_expression -> type_expression result
|
||||
type abs_mapper =
|
||||
| Expression of exp_mapper
|
||||
| Type_expression of ty_exp_mapper
|
||||
let rec map_expression : exp_mapper -> expression -> expression result = fun f e ->
|
||||
let self = map_expression f in
|
||||
let%bind e' = f e in
|
||||
let return expression_content = ok { e' with expression_content } in
|
||||
@ -116,11 +116,6 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
|
||||
let%bind ab' = bind_map_pair self ab in
|
||||
return @@ E_look_up ab'
|
||||
)
|
||||
| E_loop {condition;body} -> (
|
||||
let ab = (condition,body) in
|
||||
let%bind (a,b) = bind_map_pair self ab in
|
||||
return @@ E_loop {condition = a; body = b}
|
||||
)
|
||||
| E_ascription ascr -> (
|
||||
let%bind e' = self ascr.anno_expr in
|
||||
return @@ E_ascription {ascr with anno_expr=e'}
|
||||
@ -167,8 +162,25 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
|
||||
)
|
||||
| E_literal _ | E_variable _ | E_skip as e' -> return e'
|
||||
|
||||
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
|
||||
let self = map_type_expression f in
|
||||
let%bind te' = f te in
|
||||
let return type_content = ok { te' with type_content } in
|
||||
match te'.type_content with
|
||||
| T_sum temap ->
|
||||
let%bind temap' = bind_map_cmap self temap in
|
||||
return @@ (T_sum temap')
|
||||
| T_record temap ->
|
||||
let%bind temap' = bind_map_lmap self temap in
|
||||
return @@ (T_record temap')
|
||||
| T_arrow {type1 ; type2} ->
|
||||
let%bind type1' = self type1 in
|
||||
let%bind type2' = self type2 in
|
||||
return @@ (T_arrow {type1=type1' ; type2=type2'})
|
||||
| T_operator _
|
||||
| T_variable _ | T_constant _ -> ok te'
|
||||
|
||||
and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
|
||||
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
|
||||
match m with
|
||||
| Match_bool { match_true ; match_false } -> (
|
||||
let%bind match_true = map_expression f match_true in
|
||||
@ -198,14 +210,19 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
|
||||
ok @@ Match_variant (lst', ())
|
||||
)
|
||||
|
||||
and map_program : mapper -> program -> program result = fun m p ->
|
||||
and map_program : abs_mapper -> program -> program result = fun m p ->
|
||||
let aux = fun (x : declaration) ->
|
||||
match x with
|
||||
| Declaration_constant (t , o , i, e) -> (
|
||||
let%bind e' = map_expression m e in
|
||||
match x,m with
|
||||
| (Declaration_constant (t , o , i, e), Expression m') -> (
|
||||
let%bind e' = map_expression m' e in
|
||||
ok (Declaration_constant (t , o , i, e'))
|
||||
)
|
||||
| Declaration_type _ -> ok x
|
||||
| (Declaration_type (tv,te), Type_expression m') -> (
|
||||
let%bind te' = map_type_expression m' te in
|
||||
ok (Declaration_type (tv, te'))
|
||||
)
|
||||
| decl,_ -> ok decl
|
||||
(* | Declaration_type of (type_variable * type_expression) *)
|
||||
in
|
||||
bind_map_list (bind_map_location aux) p
|
||||
|
||||
@ -237,11 +254,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
||||
let%bind (res, ab') = bind_fold_map_pair self init' ab in
|
||||
ok (res, return @@ E_look_up ab')
|
||||
)
|
||||
| E_loop {condition;body} -> (
|
||||
let ab = (condition,body) in
|
||||
let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
|
||||
ok (res, return @@ E_loop {condition = a; body = b})
|
||||
)
|
||||
| E_ascription ascr -> (
|
||||
let%bind (res,e') = self init' ascr.anno_expr in
|
||||
ok (res, return @@ E_ascription {ascr with anno_expr=e'})
|
||||
|
||||
@ -1,17 +1,24 @@
|
||||
open Trace
|
||||
|
||||
let all = [
|
||||
let all_expression_mapper = [
|
||||
Tezos_type_annotation.peephole_expression ;
|
||||
None_variant.peephole_expression ;
|
||||
Literals.peephole_expression ;
|
||||
]
|
||||
let all_type_expression_mapper = [
|
||||
Entrypoints_lenght_limit.peephole_type_expression ;
|
||||
]
|
||||
|
||||
let all_exp = List.map (fun el -> Helpers.Expression el) all_expression_mapper
|
||||
let all_ty = List.map (fun el -> Helpers.Type_expression el) all_type_expression_mapper
|
||||
|
||||
let all_program =
|
||||
let all_p = List.map Helpers.map_program all in
|
||||
bind_chain all_p
|
||||
let all_p = List.map Helpers.map_program all_exp in
|
||||
let all_p2 = List.map Helpers.map_program all_ty in
|
||||
bind_chain (List.append all_p all_p2)
|
||||
|
||||
let all_expression =
|
||||
let all_p = List.map Helpers.map_expression all in
|
||||
let all_p = List.map Helpers.map_expression all_expression_mapper in
|
||||
bind_chain all_p
|
||||
|
||||
let map_expression = Helpers.map_expression
|
||||
|
||||
@ -159,14 +159,6 @@ module Errors = struct
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
let not_supported_yet_untranspile (message : string) (ae : O.expression) () =
|
||||
let title = (thunk "not supported yet") in
|
||||
let message () = message in
|
||||
let data = [
|
||||
("expression" , fun () -> Format.asprintf "%a" O.PP.expression ae)
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
end
|
||||
|
||||
open Errors
|
||||
@ -734,11 +726,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
|
||||
* tv_opt in
|
||||
* return (O.E_matching (ex', m')) tv
|
||||
* ) *)
|
||||
| E_loop {condition; body} ->
|
||||
let%bind (expr' , state') = type_expression e state condition in
|
||||
let%bind (body' , state'') = type_expression e state' body in
|
||||
let wrapped = Wrap.loop expr'.type_expression body'.type_expression in
|
||||
return_wrapped (O.E_loop {condition=expr';body=body'}) state'' wrapped
|
||||
| E_let_in {let_binder ; rhs ; let_result; inline} ->
|
||||
let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd let_binder) in
|
||||
(* TODO: the binder annotation should just be an annotation node *)
|
||||
@ -1100,7 +1087,6 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
||||
(* | E_failwith ae ->
|
||||
* let%bind ae' = untype_expression ae in
|
||||
* return (e_failwith ae') *)
|
||||
| E_loop _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e
|
||||
| E_let_in {let_binder; rhs;let_result; inline} ->
|
||||
let%bind tv = untype_type_value rhs.type_expression in
|
||||
let%bind rhs = untype_expression rhs in
|
||||
|
||||
@ -675,28 +675,6 @@ and type_expression : environment -> ?tv_opt:O.type_expression -> I.expression -
|
||||
a'.location) @@
|
||||
Ast_typed.assert_type_expression_eq (t_unit () , a'_type_annot) in
|
||||
return (O.E_sequence (a' , b')) (get_type_annotation b')
|
||||
| E_loop (expr , body) ->
|
||||
let%bind expr' = type_expression e expr in
|
||||
let%bind body' = type_expression e body in
|
||||
let t_expr' = get_type_annotation expr' in
|
||||
let%bind () =
|
||||
trace_strong (type_error
|
||||
~msg:"while condition isn't of type bool"
|
||||
~expected:(O.t_bool ())
|
||||
~actual:t_expr'
|
||||
~expression:expr
|
||||
expr'.location) @@
|
||||
Ast_typed.assert_type_expression_eq (t_bool () , t_expr') in
|
||||
let t_body' = get_type_annotation body' in
|
||||
let%bind () =
|
||||
trace_strong (type_error
|
||||
~msg:"while body isn't of unit type"
|
||||
~expected:(O.t_unit ())
|
||||
~actual:t_body'
|
||||
~expression:body
|
||||
body'.location) @@
|
||||
Ast_typed.assert_type_expression_eq (t_unit () , t_body') in
|
||||
return (O.E_loop (expr' , body')) (t_unit ())
|
||||
| E_assign (name , path , expr) ->
|
||||
let%bind typed_name =
|
||||
let%bind ele = Environment.get_trace name e in
|
||||
@ -834,7 +812,6 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
|
||||
let%bind ae' = untype_expression ae in
|
||||
return (e_failwith ae')
|
||||
| E_sequence _
|
||||
| E_loop _
|
||||
| E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression
|
||||
| E_let_in {binder;rhs;result} ->
|
||||
let%bind tv = untype_type_expression rhs.type_annotation in
|
||||
|
||||
@ -205,14 +205,6 @@ module Errors = struct
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
let not_supported_yet_untranspile (message : string) (ae : O.expression) () =
|
||||
let title = (thunk "not suported yet") in
|
||||
let message () = message in
|
||||
let data = [
|
||||
("expression" , fun () -> Format.asprintf "%a" O.PP.expression ae)
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
end
|
||||
open Errors
|
||||
|
||||
@ -774,28 +766,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
||||
tv_opt in
|
||||
return (O.E_matching {matchee=ex'; cases=m'}) tv
|
||||
)
|
||||
| E_loop {condition; body} ->
|
||||
let%bind expr' = type_expression' e condition in
|
||||
let%bind body' = type_expression' e body in
|
||||
let t_expr' = get_type_expression expr' in
|
||||
let%bind () =
|
||||
trace_strong (type_error
|
||||
~msg:"while condition isn't of type bool"
|
||||
~expected:(O.t_bool ())
|
||||
~actual:t_expr'
|
||||
~expression:condition
|
||||
expr'.location) @@
|
||||
Ast_typed.assert_type_expression_eq (t_bool () , t_expr') in
|
||||
let t_body' = get_type_expression body' in
|
||||
let%bind () =
|
||||
trace_strong (type_error
|
||||
~msg:"while body isn't of unit type"
|
||||
~expected:(O.t_unit ())
|
||||
~actual:t_body'
|
||||
~expression:body
|
||||
body'.location) @@
|
||||
Ast_typed.assert_type_expression_eq (t_unit () , t_body') in
|
||||
return (O.E_loop {condition=expr'; body=body'}) (t_unit ())
|
||||
| E_let_in {let_binder ; rhs ; let_result; inline} ->
|
||||
let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd let_binder) in
|
||||
let%bind rhs = type_expression' ?tv_opt:rhs_tv_opt e rhs in
|
||||
@ -909,7 +879,6 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
||||
let%bind ae' = untype_expression matchee in
|
||||
let%bind m' = untype_matching untype_expression cases in
|
||||
return (e_matching ae' m')
|
||||
| E_loop _-> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e
|
||||
| E_let_in {let_binder;rhs;let_result; inline} ->
|
||||
let%bind tv = untype_type_expression rhs.type_expression in
|
||||
let%bind rhs = untype_expression rhs in
|
||||
|
||||
72
src/passes/5-self_ast_typed/contract_passes.ml
Normal file
72
src/passes/5-self_ast_typed/contract_passes.ml
Normal file
@ -0,0 +1,72 @@
|
||||
open Ast_typed
|
||||
open Trace
|
||||
|
||||
type contract_pass_data = {
|
||||
contract_type : Helpers.contract_type ;
|
||||
main_name : string ;
|
||||
}
|
||||
|
||||
module Errors = struct
|
||||
let bad_self_type expected got loc () =
|
||||
let title = thunk "bad self type" in
|
||||
let message () = Format.asprintf "expected %a but got %a" Ast_typed.PP.type_expression expected Ast_typed.PP.type_expression got in
|
||||
let data = [
|
||||
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
let bad_format_entrypoint_ann ep loc () =
|
||||
let title = thunk "bad entrypoint format" in
|
||||
let message () = Format.asprintf "entrypoint \"%s\" is badly formatted. We expect \"%%bar\" for entrypoint Bar and \"%%default\" when no entrypoint used" ep in
|
||||
let data = [
|
||||
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
let entrypoint_annotation_not_literal loc () =
|
||||
let title = thunk "entrypoint annotation must be a string literal" in
|
||||
let message () = Format.asprintf "" in
|
||||
let data = [
|
||||
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
let unmatched_entrypoint loc () =
|
||||
let title = thunk "No constructor matches the entrypoint annotation" in
|
||||
let message () = Format.asprintf "" in
|
||||
let data = [
|
||||
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ;
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
end
|
||||
|
||||
let check_entrypoint_annotation_format ep exp =
|
||||
match String.split_on_char '%' ep with
|
||||
| [ "" ; ep'] ->
|
||||
let cap = String.capitalize_ascii ep' in
|
||||
if String.equal cap ep' then fail @@ Errors.bad_format_entrypoint_ann ep exp.location
|
||||
else ok cap
|
||||
| _ -> fail @@ Errors.bad_format_entrypoint_ann ep exp.location
|
||||
|
||||
|
||||
let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression) result = fun dat e ->
|
||||
let bad_self_err () = Errors.bad_self_type
|
||||
e.type_expression
|
||||
{e.type_expression with type_content = T_operator (TC_contract dat.contract_type.parameter)}
|
||||
e.location
|
||||
in
|
||||
match e.expression_content , e.type_expression with
|
||||
| E_constant {cons_name=C_SELF ; arguments=[entrypoint_exp]}, {type_content = T_operator (TC_contract t) ; type_meta=_} ->
|
||||
let%bind entrypoint = match entrypoint_exp.expression_content with
|
||||
| E_literal (Literal_string ep) -> check_entrypoint_annotation_format ep entrypoint_exp
|
||||
| _ -> fail @@ Errors.entrypoint_annotation_not_literal entrypoint_exp.location in
|
||||
let%bind entrypoint_t = match dat.contract_type.parameter.type_content with
|
||||
| T_sum cmap -> trace_option (Errors.unmatched_entrypoint entrypoint_exp.location)
|
||||
@@ Stage_common.Types.CMap.find_opt (Constructor entrypoint) cmap
|
||||
| t -> ok {dat.contract_type.parameter with type_content = t} in
|
||||
let%bind () =
|
||||
trace_strong (bad_self_err ()) @@
|
||||
Ast_typed.assert_type_expression_eq (entrypoint_t , t) in
|
||||
ok (true, dat, e)
|
||||
| _ -> ok (true,dat,e)
|
||||
12
src/passes/5-self_ast_typed/dune
Normal file
12
src/passes/5-self_ast_typed/dune
Normal file
@ -0,0 +1,12 @@
|
||||
(library
|
||||
(name self_ast_typed)
|
||||
(public_name ligo.self_ast_typed)
|
||||
(libraries
|
||||
simple-utils
|
||||
ast_typed
|
||||
)
|
||||
(preprocess
|
||||
(pps ppx_let bisect_ppx --conditional)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
|
||||
)
|
||||
380
src/passes/5-self_ast_typed/helpers.ml
Normal file
380
src/passes/5-self_ast_typed/helpers.ml
Normal file
@ -0,0 +1,380 @@
|
||||
open Ast_typed
|
||||
open Trace
|
||||
open Stage_common.Helpers
|
||||
|
||||
type 'a folder = 'a -> expression -> 'a result
|
||||
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
|
||||
let self = fold_expression f in
|
||||
let%bind init' = f init e in
|
||||
match e.expression_content with
|
||||
| E_literal _ | E_variable _ -> ok init'
|
||||
| E_list lst | E_set lst | E_constant {arguments=lst} -> (
|
||||
let%bind res = bind_fold_list self init' lst in
|
||||
ok res
|
||||
)
|
||||
| E_map lst | E_big_map lst -> (
|
||||
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
|
||||
ok res
|
||||
)
|
||||
| E_look_up ab ->
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
ok res
|
||||
| E_application {expr1;expr2} -> (
|
||||
let ab = (expr1,expr2) in
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
ok res
|
||||
)
|
||||
| E_lambda { binder = _ ; result = e }
|
||||
| E_constructor {element=e} -> (
|
||||
let%bind res = self init' e in
|
||||
ok res
|
||||
)
|
||||
| E_matching {matchee=e; cases} -> (
|
||||
let%bind res = self init' e in
|
||||
let%bind res = fold_cases f res cases in
|
||||
ok res
|
||||
)
|
||||
| E_record m -> (
|
||||
let aux init'' _ expr =
|
||||
let%bind res = fold_expression self init'' expr in
|
||||
ok res
|
||||
in
|
||||
let%bind res = bind_fold_lmap aux (ok init') m in
|
||||
ok res
|
||||
)
|
||||
| E_record_update {record;update} -> (
|
||||
let%bind res = self init' record in
|
||||
let%bind res = fold_expression self res update in
|
||||
ok res
|
||||
)
|
||||
| E_record_accessor {expr} -> (
|
||||
let%bind res = self init' expr in
|
||||
ok res
|
||||
)
|
||||
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
||||
let%bind res = self init' rhs in
|
||||
let%bind res = self res let_result in
|
||||
ok res
|
||||
)
|
||||
|
||||
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
||||
match m with
|
||||
| Match_bool { match_true ; match_false } -> (
|
||||
let%bind res = fold_expression f init match_true in
|
||||
let%bind res = fold_expression f res match_false in
|
||||
ok res
|
||||
)
|
||||
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
|
||||
let%bind res = fold_expression f init match_nil in
|
||||
let%bind res = fold_expression f res cons in
|
||||
ok res
|
||||
)
|
||||
| Match_option { match_none ; match_some = (_ , some, _) } -> (
|
||||
let%bind res = fold_expression f init match_none in
|
||||
let%bind res = fold_expression f res some in
|
||||
ok res
|
||||
)
|
||||
| Match_tuple ((_ , e), _) -> (
|
||||
let%bind res = fold_expression f init e in
|
||||
ok res
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
let aux init' ((_ , _) , e) =
|
||||
let%bind res' = fold_expression f init' e in
|
||||
ok res' in
|
||||
let%bind res = bind_fold_list aux init lst in
|
||||
ok res
|
||||
)
|
||||
|
||||
type mapper = expression -> expression result
|
||||
let rec map_expression : mapper -> expression -> expression result = fun f e ->
|
||||
let self = map_expression f in
|
||||
let%bind e' = f e in
|
||||
let return expression_content = ok { e' with expression_content } in
|
||||
match e'.expression_content with
|
||||
| E_list lst -> (
|
||||
let%bind lst' = bind_map_list self lst in
|
||||
return @@ E_list lst'
|
||||
)
|
||||
| E_set lst -> (
|
||||
let%bind lst' = bind_map_list self lst in
|
||||
return @@ E_set lst'
|
||||
)
|
||||
| E_map lst -> (
|
||||
let%bind lst' = bind_map_list (bind_map_pair self) lst in
|
||||
return @@ E_map lst'
|
||||
)
|
||||
| E_big_map lst -> (
|
||||
let%bind lst' = bind_map_list (bind_map_pair self) lst in
|
||||
return @@ E_big_map lst'
|
||||
)
|
||||
| E_look_up ab -> (
|
||||
let%bind ab' = bind_map_pair self ab in
|
||||
return @@ E_look_up ab'
|
||||
)
|
||||
| E_matching {matchee=e;cases} -> (
|
||||
let%bind e' = self e in
|
||||
let%bind cases' = map_cases f cases in
|
||||
return @@ E_matching {matchee=e';cases=cases'}
|
||||
)
|
||||
| E_record_accessor acc -> (
|
||||
let%bind e' = self acc.expr in
|
||||
return @@ E_record_accessor {acc with expr = e'}
|
||||
)
|
||||
| E_record m -> (
|
||||
let%bind m' = bind_map_lmap self m in
|
||||
return @@ E_record m'
|
||||
)
|
||||
| E_record_update {record; path; update} -> (
|
||||
let%bind record = self record in
|
||||
let%bind update = self update in
|
||||
return @@ E_record_update {record;path;update}
|
||||
)
|
||||
| E_constructor c -> (
|
||||
let%bind e' = self c.element in
|
||||
return @@ E_constructor {c with element = e'}
|
||||
)
|
||||
| E_application {expr1;expr2} -> (
|
||||
let ab = (expr1,expr2) in
|
||||
let%bind (a,b) = bind_map_pair self ab in
|
||||
return @@ E_application {expr1=a;expr2=b}
|
||||
)
|
||||
| E_let_in { let_binder ; rhs ; let_result; inline } -> (
|
||||
let%bind rhs = self rhs in
|
||||
let%bind let_result = self let_result in
|
||||
return @@ E_let_in { let_binder ; rhs ; let_result; inline }
|
||||
)
|
||||
| E_lambda { binder ; result } -> (
|
||||
let%bind result = self result in
|
||||
return @@ E_lambda { binder ; result }
|
||||
)
|
||||
| E_constant c -> (
|
||||
let%bind args = bind_map_list self c.arguments in
|
||||
return @@ E_constant {c with arguments=args}
|
||||
)
|
||||
| E_literal _ | E_variable _ as e' -> return e'
|
||||
|
||||
|
||||
and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
|
||||
match m with
|
||||
| Match_bool { match_true ; match_false } -> (
|
||||
let%bind match_true = map_expression f match_true in
|
||||
let%bind match_false = map_expression f match_false in
|
||||
ok @@ Match_bool { match_true ; match_false }
|
||||
)
|
||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, te) } -> (
|
||||
let%bind match_nil = map_expression f match_nil in
|
||||
let%bind cons = map_expression f cons in
|
||||
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, te) }
|
||||
)
|
||||
| Match_option { match_none ; match_some = (name , some, te) } -> (
|
||||
let%bind match_none = map_expression f match_none in
|
||||
let%bind some = map_expression f some in
|
||||
ok @@ Match_option { match_none ; match_some = (name , some, te) }
|
||||
)
|
||||
| Match_tuple ((names , e), _) -> (
|
||||
let%bind e' = map_expression f e in
|
||||
ok @@ Match_tuple ((names , e'), [])
|
||||
)
|
||||
| Match_variant (lst, te) -> (
|
||||
let aux ((a , b) , e) =
|
||||
let%bind e' = map_expression f e in
|
||||
ok ((a , b) , e')
|
||||
in
|
||||
let%bind lst' = bind_map_list aux lst in
|
||||
ok @@ Match_variant (lst', te)
|
||||
)
|
||||
|
||||
and map_program : mapper -> program -> program result = fun m p ->
|
||||
let aux = fun (x : declaration) ->
|
||||
match x with
|
||||
| Declaration_constant (v , e , i, env) -> (
|
||||
let%bind e' = map_expression m e in
|
||||
ok (Declaration_constant (v , e' , i, env))
|
||||
)
|
||||
in
|
||||
bind_map_list (bind_map_location aux) p
|
||||
|
||||
type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
|
||||
let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
|
||||
let self = fold_map_expression f in
|
||||
let%bind (continue, init',e') = f a e in
|
||||
if (not continue) then ok(init',e')
|
||||
else
|
||||
let return expression_content = { e' with expression_content } in
|
||||
match e'.expression_content with
|
||||
| E_list lst -> (
|
||||
let%bind (res, lst') = bind_fold_map_list self init' lst in
|
||||
ok (res, return @@ E_list lst')
|
||||
)
|
||||
| E_set lst -> (
|
||||
let%bind (res, lst') = bind_fold_map_list self init' lst in
|
||||
ok (res, return @@ E_set lst')
|
||||
)
|
||||
| E_map lst -> (
|
||||
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
|
||||
ok (res, return @@ E_map lst')
|
||||
)
|
||||
| E_big_map lst -> (
|
||||
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
|
||||
ok (res, return @@ E_big_map lst')
|
||||
)
|
||||
| E_look_up ab -> (
|
||||
let%bind (res, ab') = bind_fold_map_pair self init' ab in
|
||||
ok (res, return @@ E_look_up ab')
|
||||
)
|
||||
| E_matching {matchee=e;cases} -> (
|
||||
let%bind (res, e') = self init' e in
|
||||
let%bind (res,cases') = fold_map_cases f res cases in
|
||||
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
||||
)
|
||||
| E_record_accessor acc -> (
|
||||
let%bind (res, e') = self init' acc.expr in
|
||||
ok (res, return @@ E_record_accessor {acc with expr = e'})
|
||||
)
|
||||
| E_record m -> (
|
||||
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
||||
let m' = LMap.of_list lst' in
|
||||
ok (res, return @@ E_record m')
|
||||
)
|
||||
| E_record_update {record; path; update} -> (
|
||||
let%bind (res, record) = self init' record in
|
||||
let%bind (res, update) = self res update in
|
||||
ok (res, return @@ E_record_update {record;path;update})
|
||||
)
|
||||
| E_constructor c -> (
|
||||
let%bind (res,e') = self init' c.element in
|
||||
ok (res, return @@ E_constructor {c with element = e'})
|
||||
)
|
||||
| E_application {expr1;expr2} -> (
|
||||
let ab = (expr1,expr2) in
|
||||
let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
|
||||
ok (res, return @@ E_application {expr1=a;expr2=b})
|
||||
)
|
||||
| E_let_in { let_binder ; rhs ; let_result; inline } -> (
|
||||
let%bind (res,rhs) = self init' rhs in
|
||||
let%bind (res,let_result) = self res let_result in
|
||||
ok (res, return @@ E_let_in { let_binder ; rhs ; let_result ; inline })
|
||||
)
|
||||
| E_lambda { binder ; result } -> (
|
||||
let%bind (res,result) = self init' result in
|
||||
ok ( res, return @@ E_lambda { binder ; result })
|
||||
)
|
||||
| E_constant c -> (
|
||||
let%bind (res,args) = bind_fold_map_list self init' c.arguments in
|
||||
ok (res, return @@ E_constant {c with arguments=args})
|
||||
)
|
||||
| E_literal _ | E_variable _ as e' -> ok (init', return e')
|
||||
|
||||
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
|
||||
match m with
|
||||
| Match_bool { match_true ; match_false } -> (
|
||||
let%bind (init, match_true) = fold_map_expression f init match_true in
|
||||
let%bind (init, match_false) = fold_map_expression f init match_false in
|
||||
ok @@ (init, Match_bool { match_true ; match_false })
|
||||
)
|
||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, te) } -> (
|
||||
let%bind (init, match_nil) = fold_map_expression f init match_nil in
|
||||
let%bind (init, cons) = fold_map_expression f init cons in
|
||||
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, te) })
|
||||
)
|
||||
| Match_option { match_none ; match_some = (name , some, te) } -> (
|
||||
let%bind (init, match_none) = fold_map_expression f init match_none in
|
||||
let%bind (init, some) = fold_map_expression f init some in
|
||||
ok @@ (init, Match_option { match_none ; match_some = (name , some, te) })
|
||||
)
|
||||
| Match_tuple ((names , e), _) -> (
|
||||
let%bind (init, e') = fold_map_expression f init e in
|
||||
ok @@ (init, Match_tuple ((names , e'), []))
|
||||
)
|
||||
| Match_variant (lst, te) -> (
|
||||
let aux init ((a , b) , e) =
|
||||
let%bind (init,e') = fold_map_expression f init e in
|
||||
ok (init, ((a , b) , e'))
|
||||
in
|
||||
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
||||
ok @@ (init, Match_variant (lst', te))
|
||||
)
|
||||
|
||||
and fold_map_program : 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p ->
|
||||
let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
|
||||
match Location.unwrap x with
|
||||
| Declaration_constant (v , e , i, env) -> (
|
||||
let%bind (acc',e') = fold_map_expression m acc e in
|
||||
let wrap_content = Declaration_constant (v , e' , i, env) in
|
||||
ok (acc', List.append acc_prg [{x with wrap_content}])
|
||||
)
|
||||
in
|
||||
bind_fold_list aux (init,[]) p
|
||||
|
||||
module Errors = struct
|
||||
let bad_contract_io entrypoint e () =
|
||||
let title = thunk "badly typed contract" in
|
||||
let message () = Format.asprintf "unexpected entrypoint type" in
|
||||
let data = [
|
||||
("location" , fun () -> Format.asprintf "%a" Location.pp e.location);
|
||||
("entrypoint" , fun () -> entrypoint);
|
||||
("entrypoint_type" , fun () -> Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression)
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
let expected_list_operation entrypoint got e () =
|
||||
let title = thunk "bad return type" in
|
||||
let message () = Format.asprintf "expected %a, got %a"
|
||||
Ast_typed.PP.type_expression {got with type_content= T_operator (TC_list {got with type_content=T_constant TC_operation})}
|
||||
Ast_typed.PP.type_expression got
|
||||
in
|
||||
let data = [
|
||||
("location" , fun () -> Format.asprintf "%a" Location.pp e.location);
|
||||
("entrypoint" , fun () -> entrypoint)
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
let expected_same entrypoint t1 t2 e () =
|
||||
let title = thunk "badly typed contract" in
|
||||
let message () = Format.asprintf "expected {%a} and {%a} to be the same in the entrypoint type"
|
||||
Ast_typed.PP.type_expression t1
|
||||
Ast_typed.PP.type_expression t2
|
||||
in
|
||||
let data = [
|
||||
("location" , fun () -> Format.asprintf "%a" Location.pp e.location);
|
||||
("entrypoint" , fun () -> entrypoint);
|
||||
("entrypoint_type" , fun () -> Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression)
|
||||
] in
|
||||
error ~data title message ()
|
||||
|
||||
end
|
||||
|
||||
type contract_type = {
|
||||
parameter : Ast_typed.type_expression ;
|
||||
storage : Ast_typed.type_expression ;
|
||||
}
|
||||
|
||||
let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
|
||||
let main_decl = List.rev @@ List.filter
|
||||
(fun declt ->
|
||||
let (Declaration_constant (v , _ , _ , _)) = Location.unwrap declt in
|
||||
String.equal (Var.to_name v) main_fname
|
||||
)
|
||||
program
|
||||
in
|
||||
match main_decl with
|
||||
| (hd::_) -> (
|
||||
let (Declaration_constant (_,e,_,_)) = Location.unwrap hd in
|
||||
match e.type_expression.type_content with
|
||||
| T_arrow {type1 ; type2} -> (
|
||||
match type1.type_content , type2.type_content with
|
||||
| T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
|
||||
let%bind (parameter,storage) = Stage_common.Helpers.get_pair tin in
|
||||
let%bind (listop,storage') = Stage_common.Helpers.get_pair tout in
|
||||
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop e) @@
|
||||
Ast_typed.assert_t_list_operation listop in
|
||||
let%bind () = trace_strong (Errors.expected_same main_fname storage storage' e) @@
|
||||
Ast_typed.assert_type_expression_eq (storage,storage') in
|
||||
(* TODO: on storage/parameter : assert_storable, assert_passable ? *)
|
||||
ok { parameter ; storage }
|
||||
| _ -> fail @@ Errors.bad_contract_io main_fname e
|
||||
)
|
||||
| _ -> fail @@ Errors.bad_contract_io main_fname e
|
||||
)
|
||||
| [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist")
|
||||
24
src/passes/5-self_ast_typed/self_ast_typed.ml
Normal file
24
src/passes/5-self_ast_typed/self_ast_typed.ml
Normal file
@ -0,0 +1,24 @@
|
||||
open Trace
|
||||
|
||||
let all_passes = []
|
||||
|
||||
let contract_passes = [
|
||||
Contract_passes.self_typing ;
|
||||
]
|
||||
|
||||
let all_program =
|
||||
let all_p = List.map Helpers.map_program all_passes in
|
||||
bind_chain all_p
|
||||
|
||||
let all_expression =
|
||||
let all_p = List.map Helpers.map_expression all_passes in
|
||||
bind_chain all_p
|
||||
|
||||
let all_contract main_name prg =
|
||||
let%bind contract_type = Helpers.fetch_contract_type main_name prg in
|
||||
let data : Contract_passes.contract_pass_data = {
|
||||
contract_type = contract_type ;
|
||||
main_name = main_name ;
|
||||
} in
|
||||
let all_p = List.map (fun pass -> Helpers.fold_map_program pass data) contract_passes in
|
||||
bind_chain_ignore_acc all_p prg
|
||||
@ -371,7 +371,7 @@ and eval : Ast_typed.expression -> env -> value result
|
||||
| _ -> simple_fail "not yet supported case"
|
||||
(* ((ctor,name),body) *)
|
||||
)
|
||||
| E_look_up _ | E_loop _ ->
|
||||
| E_look_up _ ->
|
||||
let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in
|
||||
simple_fail serr
|
||||
|
||||
|
||||
@ -431,11 +431,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
|
||||
let%bind (ds', i') = bind_map_pair f dsi in
|
||||
return @@ E_constant {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']}
|
||||
)
|
||||
| E_loop {condition; body} -> (
|
||||
let%bind expr' = transpile_annotated_expression condition in
|
||||
let%bind body' = transpile_annotated_expression body in
|
||||
return @@ E_while (expr' , body')
|
||||
)
|
||||
| E_matching {matchee=expr; cases=m} -> (
|
||||
let%bind expr' = transpile_annotated_expression expr in
|
||||
match m with
|
||||
|
||||
@ -80,10 +80,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
ok res
|
||||
)
|
||||
| E_assignment (_, _, exp) -> (
|
||||
let%bind res = self init' exp in
|
||||
ok res
|
||||
)
|
||||
| E_record_update (r, _, e) -> (
|
||||
let%bind res = self init' r in
|
||||
let%bind res = self res e in
|
||||
@ -150,10 +146,6 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
|
||||
let%bind ab' = bind_map_pair self ab in
|
||||
return @@ E_sequence ab'
|
||||
)
|
||||
| E_assignment (s, lrl, exp) -> (
|
||||
let%bind exp' = self exp in
|
||||
return @@ E_assignment (s, lrl, exp')
|
||||
)
|
||||
| E_record_update (r, l, e) -> (
|
||||
let%bind r = self r in
|
||||
let%bind e = self e in
|
||||
@ -166,4 +158,4 @@ let map_sub_level_expression : mapper -> expression -> expression result = fun f
|
||||
let%bind body = map_expression f body in
|
||||
let content = E_closure {binder; body} in
|
||||
ok @@ { e with content }
|
||||
| _ -> ok e
|
||||
| _ -> ok e
|
||||
|
||||
@ -79,10 +79,6 @@ let rec is_pure : expression -> bool = fun e ->
|
||||
is near... *)
|
||||
| E_while _ -> false
|
||||
|
||||
|
||||
(* definitely not pure *)
|
||||
| E_assignment _ -> false
|
||||
|
||||
let occurs_in : expression_variable -> expression -> bool =
|
||||
fun x e ->
|
||||
let fvs = Free_variables.expression [] e in
|
||||
@ -93,63 +89,6 @@ let occurs_count : expression_variable -> expression -> int =
|
||||
let fvs = Free_variables.expression [] e in
|
||||
Free_variables.mem_count x fvs
|
||||
|
||||
(* If `ignore_lambdas` is true, ignore assignments which occur inside
|
||||
lambdas, which have no effect on the value of the variable outside
|
||||
of the lambda. *)
|
||||
let rec is_assigned : ignore_lambdas:bool -> expression_variable -> expression -> bool =
|
||||
fun ~ignore_lambdas x e ->
|
||||
let self = is_assigned ~ignore_lambdas x in
|
||||
let selfs = List.exists self in
|
||||
let it = Var.equal x in
|
||||
let self_binder binder body =
|
||||
if it binder
|
||||
then false
|
||||
else self body in
|
||||
let self_binder2 binder1 binder2 body =
|
||||
if it binder1 || it binder2
|
||||
then false
|
||||
else self body in
|
||||
match e.content with
|
||||
| E_assignment (x, _, e) ->
|
||||
it x || self e
|
||||
| E_record_update (r, _, e) ->
|
||||
self r || self e
|
||||
| E_closure { binder; body } ->
|
||||
if ignore_lambdas
|
||||
then false
|
||||
else self_binder binder body
|
||||
| E_constant (c) ->
|
||||
selfs c.arguments
|
||||
| E_application (f, arg) ->
|
||||
selfs [ f ; arg ]
|
||||
| E_iterator (_, ((x, _), e1), e2) ->
|
||||
self_binder x e1 || self e2
|
||||
| E_fold (((x, _), e1), e2, e3) ->
|
||||
self_binder x e1 || selfs [ e2 ; e3 ]
|
||||
| E_if_bool (e1, e2, e3) ->
|
||||
selfs [ e1 ; e2 ; e3 ]
|
||||
| E_if_none (e1, e2, ((x, _), e3)) ->
|
||||
selfs [ e1 ; e2 ] || self_binder x e3
|
||||
| E_if_cons (e1, e2, (((hd, _), (tl, _)), e3)) ->
|
||||
selfs [ e1 ; e2 ] || self_binder2 hd tl e3
|
||||
| E_if_left (e1, ((l, _), e2), ((r, _), e3)) ->
|
||||
self e1 || self_binder l e2 || self_binder r e3
|
||||
| E_let_in ((x, _), _, e1, e2) ->
|
||||
self e1 || self_binder x e2
|
||||
| E_sequence (e1, e2) ->
|
||||
selfs [ e1 ; e2 ]
|
||||
| E_while (e1, e2) ->
|
||||
selfs [ e1 ; e2 ]
|
||||
| E_literal _
|
||||
| E_skip
|
||||
| E_variable _
|
||||
| E_make_empty_map _
|
||||
| E_make_empty_big_map _
|
||||
| E_make_empty_list _
|
||||
| E_make_empty_set _
|
||||
| E_make_none _ ->
|
||||
false
|
||||
|
||||
(* Let "inlining" mean transforming the code:
|
||||
|
||||
let x = e1 in e2
|
||||
@ -163,25 +102,11 @@ let rec is_assigned : ignore_lambdas:bool -> expression_variable -> expression -
|
||||
Things which can go wrong for inlining:
|
||||
|
||||
- If `e1` is not pure, inlining may fail to preserve semantics.
|
||||
- If assignments to `x` occur in e2, inlining does not make sense.
|
||||
- Free variables of `e1` may be assigned in e2, before usages of `x`.
|
||||
- Free variables of `e1` may be shadowed in e2, at usages of `x`. This
|
||||
is not a problem if the substitution is capture-avoiding.
|
||||
- ?
|
||||
*)
|
||||
|
||||
let can_inline : expression_variable -> expression -> expression -> bool =
|
||||
fun x e1 e2 ->
|
||||
is_pure e1 &&
|
||||
(* if x does not occur in e2, there can be no other problems:
|
||||
substitution will be a noop up to alpha-equivalence *)
|
||||
(not (occurs_in x e2) ||
|
||||
(* else, must worry about assignment *)
|
||||
(not (is_assigned ~ignore_lambdas:false x e2) &&
|
||||
List.for_all
|
||||
(fun y -> not (is_assigned ~ignore_lambdas:true y e2))
|
||||
(Free_variables.expression [] e2)))
|
||||
|
||||
let should_inline : expression_variable -> expression -> bool =
|
||||
fun x e ->
|
||||
occurs_count x e <= 1
|
||||
@ -190,10 +115,8 @@ let inline_let : bool ref -> expression -> expression =
|
||||
fun changed e ->
|
||||
match e.content with
|
||||
| E_let_in ((x, _a), should_inline_here, e1, e2) ->
|
||||
if can_inline x e1 e2 && (should_inline_here || should_inline x e2)
|
||||
if is_pure e1 && (should_inline_here || should_inline x e2)
|
||||
then
|
||||
(* can raise Subst.Bad_argument, but should not happen, due to
|
||||
can_inline *)
|
||||
let e2' = Subst.subst_expression ~body:e2 ~x:x ~expr:e1 in
|
||||
(changed := true ; e2')
|
||||
else
|
||||
@ -215,26 +138,15 @@ let inline_lets : bool ref -> expression -> expression =
|
||||
|
||||
Things which can go wrong for beta reduction:
|
||||
|
||||
- If e1 contains (meaningful) assignments to free variables, semantics
|
||||
will not be preserved.
|
||||
- ?
|
||||
- Nothing?
|
||||
*)
|
||||
|
||||
let can_beta : anon_function -> bool =
|
||||
fun lam ->
|
||||
List.for_all
|
||||
(fun x -> not (is_assigned ~ignore_lambdas:true x lam.body))
|
||||
(Free_variables.lambda [] lam)
|
||||
|
||||
let beta : bool ref -> expression -> expression =
|
||||
fun changed e ->
|
||||
match e.content with
|
||||
| E_application ({ content = E_closure { binder = x ; body = e1 } ; type_value = T_function (xtv, tv) }, e2) ->
|
||||
if can_beta { binder = x ; body = e1 }
|
||||
then
|
||||
(changed := true ;
|
||||
Expression.make (E_let_in ((x, xtv), false, e2, e1)) tv)
|
||||
else e
|
||||
(changed := true ;
|
||||
Expression.make (E_let_in ((x, xtv), false, e2, e1)) tv)
|
||||
|
||||
(* also do CAR (PAIR x y) ↦ x, or CDR (PAIR x y) ↦ y, only if x and y are pure *)
|
||||
| E_constant {cons_name = C_CAR| C_CDR as const; arguments = [ { content = E_constant {cons_name = C_PAIR; arguments = [ e1 ; e2 ]} ; type_value = _ } ]} ->
|
||||
|
||||
@ -90,10 +90,6 @@ let rec replace : expression -> var_name -> var_name -> expression =
|
||||
let e1 = replace e1 in
|
||||
let e2 = replace e2 in
|
||||
return @@ E_sequence (e1, e2)
|
||||
| E_assignment (v, path, e) ->
|
||||
let v = replace_var v in
|
||||
let e = replace e in
|
||||
return @@ E_assignment (v, path, e)
|
||||
| E_record_update (r, p, e) ->
|
||||
let r = replace r in
|
||||
let e = replace e in
|
||||
@ -107,7 +103,6 @@ let rec replace : expression -> var_name -> var_name -> expression =
|
||||
Computes `body[x := expr]`.
|
||||
This raises Bad_argument in the case of assignments with a name clash. (`x <- 42[x := 23]` makes no sense.)
|
||||
**)
|
||||
exception Bad_argument
|
||||
let rec subst_expression : body:expression -> x:var_name -> expr:expression -> expression =
|
||||
fun ~body ~x ~expr ->
|
||||
let self body = subst_expression ~body ~x ~expr in
|
||||
@ -204,11 +199,6 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
|
||||
let ab' = Tuple.map2 self ab in
|
||||
return @@ E_sequence ab'
|
||||
)
|
||||
| E_assignment (s, lrl, exp) -> (
|
||||
let exp' = self exp in
|
||||
if Var.equal s x then raise Bad_argument ;
|
||||
return @@ E_assignment (s, lrl, exp')
|
||||
)
|
||||
| E_record_update (r, p, e) -> (
|
||||
let r' = self r in
|
||||
let e' = self e in
|
||||
|
||||
@ -35,29 +35,6 @@ let get : environment -> expression_variable -> michelson result = fun e s ->
|
||||
|
||||
ok code
|
||||
|
||||
let set : environment -> expression_variable -> michelson result = fun e n ->
|
||||
let%bind (_ , position) =
|
||||
generic_try (simple_error "Environment.set") @@
|
||||
(fun () -> Environment.get_i n e) in
|
||||
let rec aux_bubble = fun n ->
|
||||
match n with
|
||||
| 0 -> dip i_drop
|
||||
| n -> seq [
|
||||
i_swap ;
|
||||
dip (aux_bubble (n - 1)) ;
|
||||
]
|
||||
in
|
||||
let aux_dug = fun n -> seq [
|
||||
dipn (n + 1) i_drop ;
|
||||
i_dug n ;
|
||||
] in
|
||||
let code =
|
||||
if position < 2
|
||||
then aux_bubble position
|
||||
else aux_dug position in
|
||||
|
||||
ok code
|
||||
|
||||
let pack_closure : environment -> selector -> michelson result = fun e lst ->
|
||||
let%bind () = Assert.assert_true (e <> []) in
|
||||
|
||||
|
||||
@ -8,7 +8,6 @@ module Stack = Meta_michelson.Stack
|
||||
*)
|
||||
val empty: environment
|
||||
val get : environment -> expression_variable -> michelson result
|
||||
val set : environment -> expression_variable -> michelson result
|
||||
|
||||
val pack_closure : environment -> selector -> michelson result
|
||||
val unpack_closure : environment -> michelson result
|
||||
|
||||
@ -32,6 +32,20 @@ let rec get_operator : constant' -> type_value -> expression list -> predicate r
|
||||
| Ok (x,_) -> ok x
|
||||
| Error _ -> (
|
||||
match s with
|
||||
| C_SELF -> (
|
||||
let%bind entrypoint_as_string = match lst with
|
||||
| [{ content = E_literal (D_string s); type_value = _ }] -> (
|
||||
match String.split_on_char '%' s with
|
||||
| ["" ; s] -> ok @@ String.concat "" ["%" ; (String.uncapitalize_ascii s)]
|
||||
| _ -> fail @@ corner_case ~loc:__LOC__ "mini_c . SELF"
|
||||
)
|
||||
| _ ->
|
||||
fail @@ corner_case ~loc:__LOC__ "mini_c . SELF" in
|
||||
ok @@ simple_unary @@ seq [
|
||||
i_drop ;
|
||||
prim ~annot:[entrypoint_as_string] I_SELF
|
||||
]
|
||||
)
|
||||
| C_NONE -> (
|
||||
let%bind ty' = Mini_c.get_t_option ty in
|
||||
let%bind m_ty = Compiler_type.type_ ty' in
|
||||
@ -403,42 +417,6 @@ and translate_expression (expr:expression) (env:environment) : michelson result
|
||||
] in
|
||||
ok code
|
||||
)
|
||||
| E_assignment (name , lrs , expr) -> (
|
||||
let%bind expr' = translate_expression expr env in
|
||||
let%bind get_code = Compiler_environment.get env name in
|
||||
let modify_code =
|
||||
let aux acc step = match step with
|
||||
| `Left -> seq [dip i_unpair ; acc ; i_pair]
|
||||
| `Right -> seq [dip i_unpiar ; acc ; i_piar]
|
||||
in
|
||||
let init = dip i_drop in
|
||||
List.fold_right' aux init lrs
|
||||
in
|
||||
let%bind set_code = Compiler_environment.set env name in
|
||||
let error =
|
||||
let title () = "michelson type-checking patch" in
|
||||
let content () =
|
||||
let aux ppf = function
|
||||
| `Left -> Format.fprintf ppf "left"
|
||||
| `Right -> Format.fprintf ppf "right" in
|
||||
Format.asprintf "Sub path: %a\n"
|
||||
PP_helpers.(list_sep aux (const " , ")) lrs
|
||||
in
|
||||
error title content in
|
||||
trace error @@
|
||||
return @@ seq [
|
||||
i_comment "assign: start # env" ;
|
||||
expr' ;
|
||||
i_comment "assign: compute rhs # rhs : env" ;
|
||||
dip get_code ;
|
||||
i_comment "assign: get name # rhs : name : env" ;
|
||||
modify_code ;
|
||||
i_comment "assign: modify code # name+rhs : env" ;
|
||||
set_code ;
|
||||
i_comment "assign: set new # new_env" ;
|
||||
i_push_unit ;
|
||||
]
|
||||
)
|
||||
| E_record_update (record, path, expr) -> (
|
||||
let%bind record' = translate_expression record env in
|
||||
|
||||
|
||||
@ -66,33 +66,32 @@ module Simplify = struct
|
||||
module Pascaligo = struct
|
||||
let constants = function
|
||||
(* Tezos module (ex-Michelson) *)
|
||||
|
||||
| "Tezos.chain_id" -> ok C_CHAIN_ID
|
||||
| "chain_id" -> ok C_CHAIN_ID (* Deprecated *)
|
||||
| "get_chain_id" -> ok C_CHAIN_ID (* Deprecated *)
|
||||
| "chain_id" -> ok C_CHAIN_ID (* Deprecated *)
|
||||
| "get_chain_id" -> ok C_CHAIN_ID (* Deprecated *)
|
||||
| "Tezos.balance" -> ok C_BALANCE
|
||||
| "balance" -> ok C_BALANCE (* Deprecated *)
|
||||
| "balance" -> ok C_BALANCE (* Deprecated *)
|
||||
| "Tezos.now" -> ok C_NOW
|
||||
| "now" -> ok C_NOW (* Deprecated *)
|
||||
| "now" -> ok C_NOW (* Deprecated *)
|
||||
| "Tezos.amount" -> ok C_AMOUNT
|
||||
| "amount" -> ok C_AMOUNT (* Deprecated *)
|
||||
| "amount" -> ok C_AMOUNT (* Deprecated *)
|
||||
| "Tezos.sender" -> ok C_SENDER
|
||||
| "sender" -> ok C_SENDER (* Deprecated *)
|
||||
| "sender" -> ok C_SENDER (* Deprecated *)
|
||||
| "Tezos.address" -> ok C_ADDRESS
|
||||
| "address" -> ok C_ADDRESS (* Deprecated *)
|
||||
| "Tezos.self" -> ok C_SELF
|
||||
| "Tezos.self_address" -> ok C_SELF_ADDRESS
|
||||
| "self_address" -> ok C_SELF_ADDRESS (* Deprecated *)
|
||||
| "self_address" -> ok C_SELF_ADDRESS (* Deprecated *)
|
||||
| "Tezos.implicit_account" -> ok C_IMPLICIT_ACCOUNT
|
||||
| "implicit_account" -> ok C_IMPLICIT_ACCOUNT (* Deprecated *)
|
||||
| "implicit_account" -> ok C_IMPLICIT_ACCOUNT (* Deprecated *)
|
||||
| "Tezos.source" -> ok C_SOURCE
|
||||
| "source" -> ok C_SOURCE (* Deprecated *)
|
||||
| "source" -> ok C_SOURCE (* Deprecated *)
|
||||
| "Tezos.failwith" -> ok C_FAILWITH
|
||||
| "failwith" -> ok C_FAILWITH
|
||||
| "failwith" -> ok C_FAILWITH
|
||||
| "Tezos.create_contract" -> ok C_CREATE_CONTRACT
|
||||
|
||||
| "Tezos.transaction" -> ok C_CALL
|
||||
| "Tezos.transaction" -> ok C_CALL
|
||||
| "transaction" -> ok C_CALL (* Deprecated *)
|
||||
| "Tezos.set_delegate" -> ok C_SET_DELEGATE
|
||||
| "Tezos.set_delegate" -> ok C_SET_DELEGATE
|
||||
| "set_delegate" -> ok C_SET_DELEGATE (* Deprecated *)
|
||||
| "get_contract" -> ok C_CONTRACT (* Deprecated *)
|
||||
| "Tezos.get_contract_opt" -> ok C_CONTRACT_OPT
|
||||
@ -145,7 +144,7 @@ module Simplify = struct
|
||||
| "Bytes.unpack" -> ok C_BYTES_UNPACK
|
||||
| "bytes_unpack" -> ok C_BYTES_UNPACK (* Deprecated *)
|
||||
| "Bytes.length" -> ok C_SIZE
|
||||
| "Bytes.size" -> ok C_SIZE
|
||||
| "Bytes.size" -> ok C_SIZE (* Deprecated *)
|
||||
| "bytes_concat" -> ok C_CONCAT (* Deprecated *)
|
||||
| "Bytes.concat" -> ok C_CONCAT
|
||||
| "Bytes.slice" -> ok C_SLICE
|
||||
@ -166,7 +165,8 @@ module Simplify = struct
|
||||
|
||||
(* Set module *)
|
||||
|
||||
| "Set.size" -> ok C_SIZE
|
||||
| "Set.cardinal" -> ok C_SIZE
|
||||
| "Set.size" -> ok C_SIZE (* Deprecated *)
|
||||
| "set_size" -> ok C_SIZE (* Deprecated *)
|
||||
| "set_empty" -> ok C_SET_EMPTY (* Deprecated *)
|
||||
| "Set.mem" -> ok C_SET_MEM
|
||||
@ -267,6 +267,7 @@ module Simplify = struct
|
||||
| "sender" -> ok C_SENDER (* Deprecated *)
|
||||
| "Tezos.address" -> ok C_ADDRESS
|
||||
| "Current.address" -> ok C_ADDRESS (* Deprecated *)
|
||||
| "Tezos.self" -> ok C_SELF
|
||||
| "Tezos.self_address" -> ok C_SELF_ADDRESS
|
||||
| "Current.self_address" -> ok C_SELF_ADDRESS (* Deprecated *)
|
||||
| "Tezos.implicit_account" -> ok C_IMPLICIT_ACCOUNT
|
||||
@ -326,9 +327,9 @@ module Simplify = struct
|
||||
| "Bytes.pack" -> ok C_BYTES_PACK
|
||||
| "Bytes.unpack" -> ok C_BYTES_UNPACK
|
||||
| "Bytes.length" -> ok C_SIZE
|
||||
| "Bytes.size" -> ok C_SIZE
|
||||
| "Bytes.size" -> ok C_SIZE (* Deprecated *)
|
||||
| "Bytes.concat" -> ok C_CONCAT
|
||||
| "Bytes.slice" -> ok C_SLICE
|
||||
| "Bytes.slice" -> ok C_SLICE (* Deprecated *)
|
||||
| "Bytes.sub" -> ok C_SLICE
|
||||
|
||||
(* List module *)
|
||||
@ -341,14 +342,15 @@ module Simplify = struct
|
||||
|
||||
(* Set module *)
|
||||
|
||||
| "Set.mem" -> ok C_SET_MEM
|
||||
| "Set.iter" -> ok C_SET_ITER
|
||||
| "Set.empty" -> ok C_SET_EMPTY
|
||||
| "Set.literal" -> ok C_SET_LITERAL
|
||||
| "Set.add" -> ok C_SET_ADD
|
||||
| "Set.remove" -> ok C_SET_REMOVE
|
||||
| "Set.fold" -> ok C_SET_FOLD
|
||||
| "Set.size" -> ok C_SIZE
|
||||
| "Set.mem" -> ok C_SET_MEM
|
||||
| "Set.iter" -> ok C_SET_ITER
|
||||
| "Set.empty" -> ok C_SET_EMPTY
|
||||
| "Set.literal" -> ok C_SET_LITERAL
|
||||
| "Set.add" -> ok C_SET_ADD
|
||||
| "Set.remove" -> ok C_SET_REMOVE
|
||||
| "Set.fold" -> ok C_SET_FOLD
|
||||
| "Set.size" -> ok C_SIZE (* Deprecated *)
|
||||
| "Set.cardinal" -> ok C_SIZE
|
||||
|
||||
(* Map module *)
|
||||
|
||||
@ -790,6 +792,12 @@ module Typer = struct
|
||||
let self_address = typer_0 "SELF_ADDRESS" @@ fun _ ->
|
||||
ok @@ t_address ()
|
||||
|
||||
let self = typer_1_opt "SELF" @@ fun entrypoint_as_string tv_opt ->
|
||||
let%bind () = assert_t_string entrypoint_as_string in
|
||||
match tv_opt with
|
||||
| None -> simple_fail "untyped SELF"
|
||||
| Some t -> ok @@ t
|
||||
|
||||
let implicit_account = typer_1 "IMPLICIT_ACCOUNT" @@ fun key_hash ->
|
||||
let%bind () = assert_t_key_hash key_hash in
|
||||
ok @@ t_contract (t_unit () ) ()
|
||||
@ -1227,6 +1235,7 @@ module Typer = struct
|
||||
| C_SENDER -> ok @@ sender ;
|
||||
| C_SOURCE -> ok @@ source ;
|
||||
| C_ADDRESS -> ok @@ address ;
|
||||
| C_SELF -> ok @@ self;
|
||||
| C_SELF_ADDRESS -> ok @@ self_address;
|
||||
| C_IMPLICIT_ACCOUNT -> ok @@ implicit_account;
|
||||
| C_SET_DELEGATE -> ok @@ set_delegate ;
|
||||
|
||||
@ -48,8 +48,6 @@ let rec expression ppf (e : expression) =
|
||||
| E_matching {matchee; cases; _} ->
|
||||
fprintf ppf "match %a with %a" expression matchee (matching expression)
|
||||
cases
|
||||
| E_loop l ->
|
||||
fprintf ppf "while %a do %a" expression l.condition expression l.body
|
||||
| E_let_in { let_binder ; mut; rhs ; let_result; inline } ->
|
||||
fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result
|
||||
| E_skip ->
|
||||
|
||||
@ -122,7 +122,6 @@ let e_accessor ?loc a b = location_wrap ?loc @@ E_record_accessor {expr = a; lab
|
||||
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
|
||||
let e_variable ?loc v = location_wrap ?loc @@ E_variable v
|
||||
let e_skip ?loc () = location_wrap ?loc @@ E_skip
|
||||
let e_loop ?loc condition body = location_wrap ?loc @@ E_loop {condition; body}
|
||||
let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
|
||||
location_wrap ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline }
|
||||
let e_annotation ?loc anno_expr ty = location_wrap ?loc @@ E_ascription {anno_expr; type_annotation = ty}
|
||||
|
||||
@ -83,7 +83,6 @@ val e_accessor : ?loc:Location.t -> expression -> string -> expression
|
||||
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
|
||||
val e_variable : ?loc:Location.t -> expression_variable -> expression
|
||||
val e_skip : ?loc:Location.t -> unit -> expression
|
||||
val e_loop : ?loc:Location.t -> expression -> expression -> expression
|
||||
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
|
||||
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression
|
||||
|
||||
@ -184,7 +184,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
|
||||
| (E_application _, _) | (E_let_in _, _)
|
||||
| (E_record_accessor _, _)
|
||||
| (E_look_up _, _) | (E_matching _, _)
|
||||
| (E_loop _, _) | (E_skip, _) -> simple_fail "comparing not a value"
|
||||
| (E_skip, _) -> simple_fail "comparing not a value"
|
||||
|
||||
let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)
|
||||
|
||||
|
||||
@ -51,7 +51,6 @@ and expression_content =
|
||||
| E_set of expression list
|
||||
| E_look_up of (expression * expression)
|
||||
(* Advanced *)
|
||||
| E_loop of loop
|
||||
| E_ascription of ascription
|
||||
|
||||
and constant =
|
||||
@ -79,8 +78,6 @@ and accessor = {expr: expression; label: label}
|
||||
|
||||
and update = {record: expression; path: label ; update: expression}
|
||||
|
||||
and loop = {condition: expression; body: expression}
|
||||
|
||||
and matching_expr = (expr,unit) matching_content
|
||||
and matching =
|
||||
{ matchee: expression
|
||||
|
||||
@ -44,8 +44,6 @@ let rec expression ppf (e : expression) =
|
||||
expression result
|
||||
| E_matching {matchee; cases;} ->
|
||||
fprintf ppf "match %a with %a" expression matchee (matching expression) cases
|
||||
| E_loop l ->
|
||||
fprintf ppf "while %a do %a" expression l.condition expression l.body
|
||||
| E_let_in {let_binder; rhs; let_result; inline} ->
|
||||
fprintf ppf "let %a = %a%a in %a" expression_variable let_binder expression
|
||||
rhs option_inline inline expression let_result
|
||||
|
||||
@ -233,6 +233,10 @@ let assert_t_bytes = fun t ->
|
||||
let%bind _ = get_t_bytes t in
|
||||
ok ()
|
||||
|
||||
let assert_t_string = fun t ->
|
||||
let%bind _ = get_t_string t in
|
||||
ok ()
|
||||
|
||||
let assert_t_operation (t:type_expression) : unit result =
|
||||
match t.type_content with
|
||||
| T_constant (TC_operation) -> ok ()
|
||||
|
||||
@ -91,6 +91,7 @@ val is_t_bytes : type_expression -> bool
|
||||
val is_t_int : type_expression -> bool
|
||||
|
||||
val assert_t_bytes : type_expression -> unit result
|
||||
val assert_t_string : type_expression -> unit result
|
||||
(*
|
||||
val assert_t_operation : type_expression -> unit result
|
||||
*)
|
||||
|
||||
@ -216,7 +216,6 @@ module Free_variables = struct
|
||||
| (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
|
||||
| E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
|
||||
| E_matching {matchee; cases;_} -> union (self matchee) (matching_expression b cases)
|
||||
| E_loop {condition ; body} -> unions @@ List.map self [ condition ; body ]
|
||||
| E_let_in { let_binder; rhs; let_result; _} ->
|
||||
let b' = union (singleton let_binder) b in
|
||||
union
|
||||
@ -533,7 +532,7 @@ let rec assert_value_eq (a, b: (expression*expression)) : unit result =
|
||||
| (E_lambda _, _) | (E_let_in _, _)
|
||||
| (E_record_accessor _, _) | (E_record_update _,_)
|
||||
| (E_look_up _, _) | (E_matching _, _)
|
||||
| (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
|
||||
-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
|
||||
|
||||
let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result =
|
||||
match a, b with
|
||||
|
||||
@ -89,9 +89,6 @@ module Captured_variables = struct
|
||||
let%bind a' = self matchee in
|
||||
let%bind cs' = matching_expression b cases in
|
||||
ok @@ union a' cs'
|
||||
| E_loop {condition; body} ->
|
||||
let%bind lst' = bind_map_list self [ condition ; body ] in
|
||||
ok @@ unions lst'
|
||||
| E_let_in li ->
|
||||
let b' = union (singleton li.let_binder) b in
|
||||
expression b' li.let_result
|
||||
|
||||
@ -55,14 +55,10 @@ and expression_content =
|
||||
| E_list of expression list
|
||||
| E_set of expression list
|
||||
| E_look_up of (expression * expression)
|
||||
(* Advanced *)
|
||||
| E_loop of loop
|
||||
(* | E_ascription of ascription *)
|
||||
|
||||
and constant = {
|
||||
cons_name: constant' ;
|
||||
arguments: expression list ;
|
||||
}
|
||||
and constant =
|
||||
{ cons_name: constant'
|
||||
; arguments: expression list }
|
||||
|
||||
and application = {expr1: expression; expr2: expression}
|
||||
|
||||
@ -96,15 +92,10 @@ and update = {
|
||||
update: expression ;
|
||||
}
|
||||
|
||||
and loop = {
|
||||
condition: expression ;
|
||||
body: expression ;
|
||||
}
|
||||
|
||||
and matching_expr = (expression, type_expression) matching_content
|
||||
and matching = {
|
||||
matchee: expression ;
|
||||
cases: matching_expr ;
|
||||
and matching_expr = (expression,type_expression) matching_content
|
||||
and matching =
|
||||
{ matchee: expression
|
||||
; cases: matching_expr
|
||||
}
|
||||
|
||||
and ascription = {
|
||||
|
||||
@ -143,6 +143,7 @@ let constant ppf : constant' -> unit = function
|
||||
| C_SOURCE -> fprintf ppf "SOURCE"
|
||||
| C_SENDER -> fprintf ppf "SENDER"
|
||||
| C_ADDRESS -> fprintf ppf "ADDRESS"
|
||||
| C_SELF -> fprintf ppf "SELF"
|
||||
| C_SELF_ADDRESS -> fprintf ppf "SELF_ADDRESS"
|
||||
| C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT"
|
||||
| C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE"
|
||||
|
||||
@ -28,6 +28,8 @@ let bind_fold_lmap f init (lmap:_ LMap.t) =
|
||||
|
||||
let bind_map_lmap f map = bind_lmap (LMap.map f map)
|
||||
let bind_map_cmap f map = bind_cmap (CMap.map f map)
|
||||
let bind_map_lmapi f map = bind_lmap (LMap.mapi f map)
|
||||
let bind_map_cmapi f map = bind_cmap (CMap.mapi f map)
|
||||
|
||||
let range i j =
|
||||
let rec aux i j acc = if i >= j then acc else aux i (j-1) (j-1 :: acc) in
|
||||
@ -38,3 +40,9 @@ let label_range i j =
|
||||
|
||||
let is_tuple_lmap m =
|
||||
List.for_all (fun i -> LMap.mem i m) @@ (label_range 0 (LMap.cardinal m))
|
||||
|
||||
let get_pair m =
|
||||
let open Trace in
|
||||
match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with
|
||||
| Some e1, Some e2 -> ok (e1,e2)
|
||||
| _ -> simple_fail "not a pair"
|
||||
|
||||
@ -16,3 +16,15 @@ val bind_map_cmap :
|
||||
'a Types.constructor_map ->
|
||||
('b Types.constructor_map * 'c list, 'd) result
|
||||
val is_tuple_lmap : 'a Types.label_map -> bool
|
||||
val get_pair :
|
||||
'a Types.label_map ->
|
||||
(('a * 'a) * 'b list, unit -> Trace.error) result
|
||||
|
||||
|
||||
|
||||
val bind_map_lmapi :
|
||||
(Types.label -> 'a -> ('b * 'c list, 'd) result) ->
|
||||
'a Types.label_map -> ('b Types.label_map * 'c list, 'd) result
|
||||
val bind_map_cmapi :
|
||||
(Types.constructor' -> 'a -> ('b * 'c list, 'd) result) ->
|
||||
'a Types.constructor_map -> ('b Types.constructor_map * 'c list, 'd) result
|
||||
|
||||
@ -285,6 +285,7 @@ and constant' =
|
||||
| C_SOURCE
|
||||
| C_SENDER
|
||||
| C_ADDRESS
|
||||
| C_SELF
|
||||
| C_SELF_ADDRESS
|
||||
| C_IMPLICIT_ACCOUNT
|
||||
| C_SET_DELEGATE
|
||||
|
||||
@ -104,8 +104,6 @@ and expression' ppf (e:expression') = match e with
|
||||
| E_fold (((name , _) , body) , collection , initial) ->
|
||||
fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Var.pp name expression body
|
||||
|
||||
| E_assignment (r , path , e) ->
|
||||
fprintf ppf "%a.%a := %a" Var.pp r (list_sep lr (const ".")) path expression e
|
||||
| E_record_update (r, path,update) ->
|
||||
fprintf ppf "%a with { %a = %a }" expression r (list_sep lr (const ".")) path expression update
|
||||
| E_while (e , b) ->
|
||||
@ -239,6 +237,7 @@ and constant ppf : constant' -> unit = function
|
||||
| C_SOURCE -> fprintf ppf "SOURCE"
|
||||
| C_SENDER -> fprintf ppf "SENDER"
|
||||
| C_ADDRESS -> fprintf ppf "ADDRESS"
|
||||
| C_SELF -> fprintf ppf "SELF"
|
||||
| C_SELF_ADDRESS -> fprintf ppf "SELF_ADDRESS"
|
||||
| C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT"
|
||||
| C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE"
|
||||
|
||||
@ -79,8 +79,6 @@ module Free_variables = struct
|
||||
expression (union (singleton v) b) body ;
|
||||
]
|
||||
| E_sequence (x, y) -> union (self x) (self y)
|
||||
(* NB different from ast_typed... *)
|
||||
| E_assignment (v, _, e) -> unions [ var_name b v ; self e ]
|
||||
| E_record_update (r, _,e) -> union (self r) (self e)
|
||||
| E_while (cond , body) -> union (self cond) (self body)
|
||||
|
||||
|
||||
@ -72,7 +72,6 @@ and expression' =
|
||||
| E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression)
|
||||
| E_let_in of ((var_name * type_value) * inline * expression * expression)
|
||||
| E_sequence of (expression * expression)
|
||||
| E_assignment of (expression_variable * [`Left | `Right] list * expression)
|
||||
| E_record_update of (expression * [`Left | `Right] list * expression)
|
||||
| E_while of (expression * expression)
|
||||
|
||||
|
||||
@ -212,10 +212,6 @@ module Substitution = struct
|
||||
let%bind matchee = s_expression ~substs matchee in
|
||||
let%bind cases = s_matching_expr ~substs cases in
|
||||
ok @@ T.E_matching {matchee;cases}
|
||||
| T.E_loop {condition;body} ->
|
||||
let%bind condition = s_expression ~substs condition in
|
||||
let%bind body = s_expression ~substs body in
|
||||
ok @@ T.E_loop {condition;body}
|
||||
|
||||
and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; environment; location } ->
|
||||
let%bind expression_content = s_expression_content ~substs expression_content in
|
||||
|
||||
@ -5,7 +5,7 @@ open Test_helpers
|
||||
|
||||
let type_file f =
|
||||
let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in
|
||||
let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in
|
||||
let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in
|
||||
ok @@ (typed,state)
|
||||
|
||||
let get_program =
|
||||
@ -21,7 +21,7 @@ let get_program =
|
||||
|
||||
let compile_main () =
|
||||
let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/coase.ligo" (Syntax_name "pascaligo") in
|
||||
let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in
|
||||
let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in
|
||||
let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in
|
||||
let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
|
||||
let%bind (_contract: Tezos_utils.Michelson.michelson) =
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
// function main (const c : contract (unit)) : address is address (c)
|
||||
|
||||
function main (const p : key_hash) : address is block {
|
||||
const c : contract (unit) = implicit_account (p);
|
||||
} with address (c)
|
||||
const c : contract (unit) = Tezos.implicit_account (p);
|
||||
} with Tezos.address (c)
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
let main (p : key_hash) =
|
||||
let c : unit contract = Current.implicit_account p in
|
||||
Current.address c
|
||||
let c : unit contract = Tezos.implicit_account p
|
||||
in Tezos.address c
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
let main = (p : key_hash) : address => {
|
||||
let c : contract(unit) = Current.implicit_account(p) ;
|
||||
Current.address(c) ;
|
||||
let c : contract (unit) = Tezos.implicit_account (p);
|
||||
Tezos.address(c);
|
||||
};
|
||||
|
||||
@ -1,8 +1,5 @@
|
||||
function check (const p: unit) : int is
|
||||
begin
|
||||
function check (const p : unit) : int is
|
||||
block {
|
||||
var result : int := 0;
|
||||
if amount = 100tz then
|
||||
result := 42
|
||||
else
|
||||
result := 0
|
||||
end with result
|
||||
if amount = 100tez then result := 42 else result := 0
|
||||
} with result
|
||||
|
||||
@ -1 +1 @@
|
||||
let check_ (p: unit) : int = if Current.amount = 100tz then 42 else 0
|
||||
let check_ (p : unit) : int = if Tezos.amount = 100tez then 42 else 0
|
||||
|
||||
@ -1,7 +1,2 @@
|
||||
let check_ = (p: unit) : int =>
|
||||
if (Current.amount == 100tz) {
|
||||
42;
|
||||
}
|
||||
else {
|
||||
0;
|
||||
};
|
||||
let check_ = (p : unit) : int =>
|
||||
if (Tezos.amount == 100tez) { 42; } else { 0; };
|
||||
|
||||
@ -1,15 +1,7 @@
|
||||
// Test PascaLIGO arithmetic operators
|
||||
|
||||
function mod_op (const n : int) : nat is n mod 42
|
||||
|
||||
function plus_op (const n : int) : int is n + 42
|
||||
|
||||
function mod_op (const n : int) : nat is n mod 42
|
||||
function plus_op (const n : int) : int is n + 42
|
||||
function minus_op (const n : int) : int is n - 42
|
||||
|
||||
function times_op (const n : int) : int is n * 42
|
||||
|
||||
function div_op (const n : int) : int is n / 2
|
||||
|
||||
function int_op (const n : nat) : int is int (n)
|
||||
|
||||
function neg_op (const n : int) : int is -n
|
||||
function div_op (const n : int) : int is n / 2
|
||||
function int_op (const n : nat) : int is int (n)
|
||||
function neg_op (const n : int) : int is -n
|
||||
|
||||
@ -1,30 +1,8 @@
|
||||
// Test CameLIGO arithmetic operators
|
||||
|
||||
let mod_op (n : int) : nat =
|
||||
n mod 42
|
||||
|
||||
let plus_op (n : int) : int =
|
||||
n + 42
|
||||
|
||||
let minus_op (n : int) : int =
|
||||
n - 42
|
||||
|
||||
let times_op (n : int) : int =
|
||||
n * 42
|
||||
|
||||
let div_op (n : int) : int =
|
||||
n / 2
|
||||
|
||||
(* TODO (?): Support conversion from nat to int and back
|
||||
|
||||
let int_op (n : nat) : int =
|
||||
Int n
|
||||
|
||||
*)
|
||||
|
||||
let neg_op (n : int) : int =
|
||||
-n
|
||||
|
||||
let foo (n : int) : int = n + 10
|
||||
|
||||
let neg_op_2 (b: int) : int = -(foo b)
|
||||
let mod_op (n : int) : nat = n mod 42
|
||||
let plus_op (n : int) : int = n + 42
|
||||
let minus_op (n : int) : int = n - 42
|
||||
let times_op (n : int) : int = n * 42
|
||||
let div_op (n : int) : int = n / 2
|
||||
let neg_op (n : int) : int = -n
|
||||
let foo (n : int) : int = n + 10
|
||||
let neg_op_2 (b : int) : int = -(foo b)
|
||||
|
||||
@ -1,24 +1,10 @@
|
||||
/* Test ReasonLIGO arithmetic operators */
|
||||
|
||||
let mod_op = (n: int): nat => n mod 42;
|
||||
|
||||
let plus_op = (n: int): int => n + 42;
|
||||
|
||||
let minus_op = (n: int): int => n - 42;
|
||||
|
||||
let times_op = (n: int): int => n * 42;
|
||||
|
||||
let div_op = (n: int): int => n / 2;
|
||||
|
||||
/* TODO (?): Support conversion from nat to int and back
|
||||
|
||||
let int_op (n : nat) : int =
|
||||
Int n
|
||||
|
||||
*/
|
||||
|
||||
let neg_op = (n: int): int => - n;
|
||||
|
||||
let foo = (n: int): int => n + 10;
|
||||
|
||||
let neg_op_2 = (b: int): int => - foo(b);
|
||||
let mod_op = (n : int) : nat => n mod 42;
|
||||
let plus_op = (n : int) : int => n + 42;
|
||||
let minus_op = (n : int) : int => n - 42;
|
||||
let times_op = (n : int) : int => n * 42;
|
||||
let div_op = (n : int) : int => n / 2;
|
||||
let neg_op = (n : int): int => - n;
|
||||
let foo = (n : int): int => n + 10;
|
||||
let neg_op_2 = (b : int): int => -foo(b);
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
let main (p, s: bool * unit) =
|
||||
let main (p, s : bool * unit) =
|
||||
let u : unit = assert p
|
||||
in ([] : operation list), s
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
let main = (p: bool, s: unit) => {
|
||||
let u: unit = assert(p);
|
||||
([]: list(operation), s);
|
||||
let main = (p, s : bool, unit) => {
|
||||
let u : unit = assert (p);
|
||||
([]: list (operation), s);
|
||||
};
|
||||
|
||||
@ -1,4 +1 @@
|
||||
function main (const i : int) : int is
|
||||
block {
|
||||
i := i + 1
|
||||
} with i
|
||||
function main (const i : int) : int is block {i := i + 1} with i
|
||||
|
||||
@ -1,10 +1,7 @@
|
||||
let x = 1 [@@inline]
|
||||
|
||||
let foo (a: int): int =
|
||||
let foo (a : int): int =
|
||||
(let test = 2 + a [@@inline] in test) [@@inline]
|
||||
|
||||
let y = 1 [@@inline][@@other]
|
||||
|
||||
let bar (b: int): int =
|
||||
let test = fun (z: int) -> 2 + b + z [@@inline][@@foo][@@bar]
|
||||
let bar (b : int): int =
|
||||
let test = fun (z : int) -> 2 + b + z [@@inline][@@foo][@@bar]
|
||||
in test b
|
||||
|
||||
@ -2,7 +2,7 @@
|
||||
let x = 1;
|
||||
|
||||
[@inline]
|
||||
let foo = (a: int): int => {
|
||||
let foo = (a : int) : int => {
|
||||
[@inline]
|
||||
let test = 2 + a;
|
||||
test;
|
||||
@ -11,8 +11,8 @@ let foo = (a: int): int => {
|
||||
[@inline][@other]
|
||||
let y = 1;
|
||||
|
||||
let bar = (b: int): int => {
|
||||
let bar = (b : int) : int => {
|
||||
[@inline][@foo][@bar]
|
||||
let test = (z: int) => 2 + b + z;
|
||||
test(b);
|
||||
let test = (z : int) => 2 + b + z;
|
||||
test (b);
|
||||
};
|
||||
|
||||
@ -1,3 +1,2 @@
|
||||
let main = (parameter: int, storage: address) => {
|
||||
([]:list(operation), "KT1badaddr" : address);
|
||||
};
|
||||
let main = (parameter : int, storage : address) =>
|
||||
([] : list (operation), "KT1badaddr" : address);
|
||||
|
||||
@ -6,4 +6,4 @@ function main (const p : parameter; const s : storage) : return is
|
||||
block {
|
||||
var stamp : timestamp := ("badtimestamp" : timestamp)
|
||||
}
|
||||
with ((nil: list(operation)), stamp)
|
||||
with ((nil : list (operation)), stamp)
|
||||
|
||||
@ -9,4 +9,4 @@ type storage is tez
|
||||
type return is list (operation) * storage
|
||||
|
||||
function main (const param : parameter; const store: storage) : return is
|
||||
((nil : list (operation)), balance)
|
||||
((nil : list (operation)), Tezos.balance)
|
||||
|
||||
@ -1,17 +1,18 @@
|
||||
(**
|
||||
|
||||
(*
|
||||
This test makes sure that the balance is accessible in CameLIGO.
|
||||
It's there to detect a regression of: https://gitlab.com/ligolang/ligo/issues/61
|
||||
|
||||
Which results in this error when you attempt to compile this contract:
|
||||
It is there to detect a regression of:
|
||||
https://gitlab.com/ligolang/ligo/issues/61
|
||||
|
||||
which results in this error when you attempt to compile this contract:
|
||||
|
||||
generated. unrecognized constant: {"constant":"BALANCE","location":"generated"}
|
||||
|
||||
|
||||
*)
|
||||
|
||||
type parameter = unit
|
||||
type storage = tez
|
||||
type return = operation list * storage
|
||||
|
||||
let main (p, s : unit * storage) =
|
||||
([] : operation list), balance
|
||||
|
||||
let main (p, s : parameter * storage) : return =
|
||||
([] : operation list), Tezos.balance
|
||||
|
||||
@ -12,6 +12,7 @@ generated. unrecognized constant: {"constant":"BALANCE","location":"generated"}
|
||||
|
||||
type storage = tez;
|
||||
|
||||
let main2 = (p: unit, s: storage) => ([]: list(operation), balance);
|
||||
let main2 = (p : unit, s: storage) =>
|
||||
([]: list (operation), Tezos.balance);
|
||||
|
||||
let main = (x: (unit, storage)) => main2(x[0],x[1]);
|
||||
let main = (x : (unit, storage)) => main2 (x[0], x[1]);
|
||||
|
||||
@ -8,7 +8,7 @@ function main (const p : parameter; const s : storage) : return is
|
||||
toto := s.0[23];
|
||||
s.0[2] := 444
|
||||
}
|
||||
with ((nil: list(operation)), s)
|
||||
with ((nil : list (operation)), s)
|
||||
|
||||
type foo is big_map (int, int)
|
||||
|
||||
@ -16,14 +16,12 @@ function set_ (var n : int; var m : foo) : foo is block {
|
||||
m[23] := n
|
||||
} with m
|
||||
|
||||
function add (var n : int ; var m : foo) : foo is set_(n,m)
|
||||
function add (var n : int ; var m : foo) : foo is set_ (n,m)
|
||||
|
||||
function rm (var m : foo) : foo is block {
|
||||
remove 42 from map m
|
||||
} with m
|
||||
|
||||
function gf (const m : foo) : int is get_force (23, m)
|
||||
|
||||
function get (const m : foo) : option (int) is m[42]
|
||||
|
||||
const empty_big_map : big_map (int,int) = big_map []
|
||||
|
||||
@ -1,23 +1,18 @@
|
||||
type foo = (int, int) big_map
|
||||
|
||||
let set_ (n, m: int * foo) : foo = Big_map.update 23 (Some n) m
|
||||
|
||||
let add (n,m : int * foo) : foo = Big_map.add 23 n m
|
||||
let add (n, m : int * foo) : foo = Big_map.add 23 n m
|
||||
|
||||
let rm (m : foo) : foo = Big_map.remove 42 m
|
||||
|
||||
let gf (m : foo) : int = Big_map.find 23 m
|
||||
|
||||
let get (m: foo): int option = Big_map.find_opt 42 m
|
||||
let get (m : foo): int option = Big_map.find_opt 42 m
|
||||
|
||||
let empty_map : foo = Big_map.empty
|
||||
|
||||
let map1 : foo = Big_map.literal
|
||||
[ (23 , 0) ; (42, 0) ]
|
||||
|
||||
let map1 : foo = Big_map.literal
|
||||
[ (23 , 0) ; (42, 0) ]
|
||||
let map1 : foo = Big_map.literal [(23,0); (42,0)]
|
||||
let map1 : foo = Big_map.literal [(23,0); (42,0)]
|
||||
|
||||
let mutimaps (m : foo) (n : foo) : foo =
|
||||
let bar : foo = Big_map.update 42 (Some 0) m in
|
||||
Big_map.update 42 (get bar) n
|
||||
let bar : foo = Big_map.update 42 (Some 0) m
|
||||
in Big_map.update 42 (get bar) n
|
||||
|
||||
@ -1,24 +1,22 @@
|
||||
type foo = big_map(int, int);
|
||||
|
||||
let set2 = (n: int, m: foo): foo => Big_map.update(23, Some(n), m);
|
||||
let set2 = (n : int, m : foo) : foo => Big_map.update (23, Some (n), m);
|
||||
|
||||
let set_ = (x: (int, foo)): foo => set2(x[0], x[1]);
|
||||
let set_ = (x : (int, foo)) : foo => set2 (x[0], x[1]);
|
||||
|
||||
let add = ((n,m): (int, foo)): foo => Big_map.add(23, n, m);
|
||||
let add = ((n,m) : (int, foo)) : foo => Big_map.add (23, n, m);
|
||||
|
||||
let rm = (m: foo): foo => Big_map.remove(42, m);
|
||||
let rm = (m : foo) : foo => Big_map.remove (42, m);
|
||||
|
||||
let gf = (m: foo): int => Big_map.find(23, m);
|
||||
let gf = (m : foo) : int => Big_map.find (23, m);
|
||||
|
||||
let get = (m: foo): option(int) => Big_map.find_opt(42, m);
|
||||
let get = (m : foo) : option (int) => Big_map.find_opt (42, m);
|
||||
|
||||
let empty_map: foo = Big_map.empty;
|
||||
let empty_map : foo = Big_map.empty;
|
||||
|
||||
let map1: foo = Big_map.literal([(23, 0), (42, 0)]);
|
||||
|
||||
let map1: foo = Big_map.literal([(23, 0), (42, 0)]);
|
||||
let map1 : foo = Big_map.literal ([(23,0), (42,0)]);
|
||||
|
||||
let mutimaps = (m: foo, n: foo): foo => {
|
||||
let bar: foo = Big_map.update(42, Some(0), m);
|
||||
Big_map.update(42, get(bar), n);
|
||||
let bar : foo = Big_map.update (42, Some (0), m);
|
||||
Big_map.update (42, get (bar), n);
|
||||
};
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
(* Test CameLIGO bitwise operators *)
|
||||
|
||||
let or_op (n: nat) : nat = Bitwise.or n 4n
|
||||
let and_op (n: nat) : nat = Bitwise.and n 7n
|
||||
let xor_op (n: nat) : nat = Bitwise.xor n 7n
|
||||
let lsl_op (n: nat) : nat = Bitwise.shift_left n 7n
|
||||
let lsr_op (n: nat) : nat = Bitwise.shift_right n 7n
|
||||
let or_op (n : nat) : nat = Bitwise.or n 4n
|
||||
let and_op (n : nat) : nat = Bitwise.and n 7n
|
||||
let xor_op (n : nat) : nat = Bitwise.xor n 7n
|
||||
let lsl_op (n : nat) : nat = Bitwise.shift_left n 7n
|
||||
let lsr_op (n : nat) : nat = Bitwise.shift_right n 7n
|
||||
|
||||
@ -1,11 +1,5 @@
|
||||
// Test PascaLIGO boolean operators
|
||||
|
||||
function or_true (const b : bool) : bool is b or True
|
||||
|
||||
function or_false (const b : bool) : bool is b or False
|
||||
|
||||
function and_true (const b : bool) : bool is b and True
|
||||
|
||||
function or_true (const b : bool) : bool is b or True
|
||||
function or_false (const b : bool) : bool is b or False
|
||||
function and_true (const b : bool) : bool is b and True
|
||||
function and_false (const b : bool) : bool is b and False
|
||||
|
||||
function not_bool (const b : bool) : bool is not b
|
||||
function not_bool (const b : bool) : bool is not b
|
||||
|
||||
@ -1,16 +1,7 @@
|
||||
// Test CameLIGO boolean operators
|
||||
|
||||
let or_true (b : bool) : bool =
|
||||
b || true
|
||||
|
||||
let or_false (b : bool) : bool =
|
||||
b || false
|
||||
|
||||
let and_true (b : bool) : bool =
|
||||
b && true
|
||||
|
||||
let and_false (b : bool) : bool =
|
||||
b && false
|
||||
|
||||
let not_bool (b: bool) : bool =
|
||||
not b
|
||||
let or_true (b : bool) : bool = b || true
|
||||
let or_false (b : bool) : bool = b || false
|
||||
let and_true (b : bool) : bool = b && true
|
||||
let and_false (b : bool) : bool = b && false
|
||||
let not_bool (b : bool) : bool = not b
|
||||
|
||||
@ -1,11 +1,7 @@
|
||||
// Test ReasonLIGO boolean operators
|
||||
|
||||
let or_true = (b: bool): bool => b || true;
|
||||
|
||||
let or_false = (b: bool): bool => b || false;
|
||||
|
||||
let and_true = (b: bool): bool => b && true;
|
||||
|
||||
let and_false = (b: bool): bool => b && false;
|
||||
|
||||
let not_bool = (b: bool): bool => !b;
|
||||
let or_true = (b : bool) : bool => b || true;
|
||||
let or_false = (b : bool) : bool => b || false;
|
||||
let and_true = (b : bool) : bool => b && true;
|
||||
let and_false = (b : bool) : bool => b && false;
|
||||
let not_bool = (b : bool) : bool => !b;
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
function concat_op (const s : bytes) : bytes is bytes_concat (s, 0x7070)
|
||||
|
||||
function slice_op (const s : bytes) : bytes is bytes_slice (1n, 2n, s)
|
||||
|
||||
function hasherman (const s : bytes) : bytes is sha_256 (s)
|
||||
function concat_op (const s : bytes) : bytes is Bytes.concat (s, 0x7070)
|
||||
function slice_op (const s : bytes) : bytes is Bytes.sub (1n, 2n, s)
|
||||
function hasherman (const s : bytes) : bytes is Crypto.sha256 (s)
|
||||
|
||||
@ -1,8 +1,3 @@
|
||||
let concat_op (s : bytes) : bytes =
|
||||
Bytes.concat s 0x7070
|
||||
|
||||
let slice_op (s : bytes) : bytes =
|
||||
Bytes.slice 1n 2n s
|
||||
|
||||
let hasherman (s : bytes) : bytes =
|
||||
Crypto.sha256 s
|
||||
let concat_op (s : bytes) : bytes = Bytes.concat s 0x7070
|
||||
let slice_op (s : bytes) : bytes = Bytes.sub 1n 2n s
|
||||
let hasherman (s : bytes) : bytes = Crypto.sha256 s
|
||||
|
||||
@ -1,11 +1,11 @@
|
||||
function id_string (const p : string) : option (string) is block {
|
||||
const packed : bytes = bytes_pack (p)
|
||||
} with (bytes_unpack (packed) : option (string))
|
||||
const packed : bytes = Bytes.pack (p)
|
||||
} with (Bytes.unpack (packed) : option (string))
|
||||
|
||||
function id_int (const p : int) : option (int) is block {
|
||||
const packed : bytes = bytes_pack (p)
|
||||
} with (bytes_unpack (packed) : option (int))
|
||||
const packed : bytes = Bytes.pack (p)
|
||||
} with (Bytes.unpack (packed) : option (int))
|
||||
|
||||
function id_address (const p : address) : option (address) is block {
|
||||
const packed : bytes = bytes_pack (p)
|
||||
} with (bytes_unpack (packed) : option (address))
|
||||
const packed : bytes = Bytes.pack (p)
|
||||
} with (Bytes.unpack (packed) : option (address))
|
||||
|
||||
@ -1,11 +1,11 @@
|
||||
let id_string (p: string) : string option =
|
||||
let packed: bytes = Bytes.pack p in
|
||||
((Bytes.unpack packed): string option)
|
||||
let id_string (p : string) : string option =
|
||||
let packed : bytes = Bytes.pack p in
|
||||
(Bytes.unpack packed : string option)
|
||||
|
||||
let id_int (p: int) : int option =
|
||||
let packed: bytes = Bytes.pack p in
|
||||
((Bytes.unpack packed): int option)
|
||||
let id_int (p : int) : int option =
|
||||
let packed : bytes = Bytes.pack p in
|
||||
(Bytes.unpack packed : int option)
|
||||
|
||||
let id_address (p: address) : address option =
|
||||
let packed: bytes = Bytes.pack p in
|
||||
((Bytes.unpack packed): address option)
|
||||
let id_address (p : address) : address option =
|
||||
let packed : bytes = Bytes.pack p in
|
||||
(Bytes.unpack packed : address option)
|
||||
|
||||
@ -1,14 +1,14 @@
|
||||
let id_string = (p: string) : option(string) => {
|
||||
let packed : bytes = Bytes.pack(p);
|
||||
((Bytes.unpack(packed)): option(string));
|
||||
let id_string = (p : string) : option(string) => {
|
||||
let packed : bytes = Bytes.pack (p);
|
||||
((Bytes.unpack (packed)) : option (string));
|
||||
};
|
||||
|
||||
let id_int = (p: int) : option(int) => {
|
||||
let packed: bytes = Bytes.pack(p);
|
||||
((Bytes.unpack(packed)): option(int));
|
||||
let id_int = (p : int) : option (int) => {
|
||||
let packed : bytes = Bytes.pack (p);
|
||||
((Bytes.unpack (packed)) : option (int));
|
||||
};
|
||||
|
||||
let id_address = (p: address) : option(address) => {
|
||||
let packed: bytes = Bytes.pack(p);
|
||||
((Bytes.unpack(packed)): option(address));
|
||||
let id_address = (p : address) : option (address) => {
|
||||
let packed : bytes = Bytes.pack (p);
|
||||
((Bytes.unpack (packed)) : option (address));
|
||||
};
|
||||
|
||||
@ -1 +1 @@
|
||||
function chain_id (const tt : chain_id) : chain_id is get_chain_id
|
||||
function chain_id (const tt : chain_id) : chain_id is Tezos.chain_id
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
function check_signature (const pk : key;
|
||||
function check_signature (const pk : key;
|
||||
const signed : signature;
|
||||
const msg: bytes) : bool
|
||||
is crypto_check (pk, signed, msg)
|
||||
const msg : bytes) : bool
|
||||
is Crypto.check (pk, signed, msg)
|
||||
|
||||
@ -1,2 +1,24 @@
|
||||
let check_signature (pk, signed, msg: key * signature * bytes) : bool =
|
||||
let check_signature (pk, signed, msg : key * signature * bytes) : bool =
|
||||
Crypto.check pk signed msg
|
||||
|
||||
(*
|
||||
$ tezos-client gen keys testsign
|
||||
|
||||
$ tezos-client show address testsign -S
|
||||
Hash: tz1RffmtWjy435AXZuWwLWG6UaJ66ERmgviA
|
||||
Public Key: edpktz4xg6csJnJ5vcmMb2H37sWXyBDcoAp3XrBvjRaTSQ1zmZTeRQ
|
||||
Secret Key: unencrypted:edsk34mH9qhMdVWtbammJfYkUoQfwW6Rw5K6rbGW1ajppy3LPNbiJA
|
||||
|
||||
$ tezos-client hash data '"hello"' of type string
|
||||
Raw packed data: 0x05010000000568656c6c6f
|
||||
...
|
||||
|
||||
$ tezos-client sign bytes 0x05010000000568656c6c6f for testsign
|
||||
Signature: edsigtnzKd51CDomKVMFBoU8SzFZgNqRkYUaQH4DLUg8Lsimz98DFB82uiHAkdvx29DDqHxPf1noQ8noWpKMZoxTCsfprrbs4Xo
|
||||
*)
|
||||
|
||||
let example : bool =
|
||||
Crypto.check
|
||||
("edpktz4xg6csJnJ5vcmMb2H37sWXyBDcoAp3XrBvjRaTSQ1zmZTeRQ" : key)
|
||||
("edsigtnzKd51CDomKVMFBoU8SzFZgNqRkYUaQH4DLUg8Lsimz98DFB82uiHAkdvx29DDqHxPf1noQ8noWpKMZoxTCsfprrbs4Xo" : signature)
|
||||
0x05010000000568656c6c6f
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
let check_signature = (param: (key, signature, bytes)) : bool => {
|
||||
let check_signature = (param : (key, signature, bytes)) : bool => {
|
||||
let pk, signed, msg = param;
|
||||
Crypto.check(pk, signed, msg);
|
||||
Crypto.check (pk, signed, msg);
|
||||
};
|
||||
|
||||
@ -1,9 +1,7 @@
|
||||
(* Test whether closures retain values in CameLIGO *)
|
||||
(* Test whether closures capture variables in CameLIGO *)
|
||||
|
||||
let test (k: int) : int =
|
||||
let j: int = k + 5 in
|
||||
let close: (int -> int) =
|
||||
fun (i: int) -> i + j
|
||||
in
|
||||
let j: int = 20 in (* Shadow original variable to see if value close'd *)
|
||||
close 20
|
||||
let test (k : int) : int =
|
||||
let j : int = k + 5 in
|
||||
let close : int -> int = fun (i : int) -> i + j in
|
||||
let j : int = 20 (* Shadow original variable *)
|
||||
in close 20
|
||||
|
||||
@ -1,9 +1,9 @@
|
||||
/* Test whether closures retain values in ReasonLIGO */
|
||||
|
||||
let test = (k: int): int => {
|
||||
let j: int = k + 5;
|
||||
let close: (int => int) = (i: int) => i + j;
|
||||
let test = (k : int) : int => {
|
||||
let j : int = k + 5;
|
||||
let close : (int => int) = (i : int) => i + j;
|
||||
|
||||
let j: int = 20; /* Shadow original variable to see if value close'd */
|
||||
close(20);
|
||||
let j : int = 20; /* Shadow original variable */
|
||||
close (20);
|
||||
};
|
||||
|
||||
@ -45,27 +45,38 @@ type parameter is
|
||||
| Transfer_single of action_transfer_single
|
||||
|
||||
function transfer_single (const action : action_transfer_single;
|
||||
const s : storage) : return is block {
|
||||
const s : storage) : return is
|
||||
block {
|
||||
const cards : cards = s.cards;
|
||||
const card : card = get_force (action.card_to_transfer, cards);
|
||||
const card : card =
|
||||
case cards[action.card_to_transfer] of
|
||||
Some (card) -> card
|
||||
| None -> (failwith ("transfer_single: No card.") : card)
|
||||
end;
|
||||
if card.card_owner =/= sender then
|
||||
failwith ("This card doesn't belong to you")
|
||||
else skip;
|
||||
card.card_owner := action.destination;
|
||||
cards[action.card_to_transfer] := card;
|
||||
s.cards := cards;
|
||||
const operations : list (operation) = nil
|
||||
} with (operations, s)
|
||||
s.cards := cards
|
||||
} with ((nil : list (operation)), s)
|
||||
|
||||
function sell_single (const action : action_sell_single;
|
||||
const s : storage) : return is
|
||||
block {
|
||||
const card : card = get_force (action.card_to_sell, s.cards);
|
||||
const card : card =
|
||||
case s.cards[action.card_to_sell] of
|
||||
Some (card) -> card
|
||||
| None -> (failwith ("sell_single: No card.") : card)
|
||||
end;
|
||||
if card.card_owner =/= sender
|
||||
then failwith ("This card doesn't belong to you")
|
||||
else skip;
|
||||
const card_pattern : card_pattern =
|
||||
get_force (card.card_pattern, s.card_patterns);
|
||||
case s.card_patterns[card.card_pattern] of
|
||||
Some (pattern) -> pattern
|
||||
| None -> (failwith ("sell_single: No card pattern.") : card_pattern)
|
||||
end;
|
||||
card_pattern.quantity := abs (card_pattern.quantity - 1n);
|
||||
const card_patterns : card_patterns = s.card_patterns;
|
||||
card_patterns[card.card_pattern] := card_pattern;
|
||||
@ -74,8 +85,12 @@ function sell_single (const action : action_sell_single;
|
||||
remove action.card_to_sell from map cards;
|
||||
s.cards := cards;
|
||||
const price : tez = card_pattern.coefficient * card_pattern.quantity;
|
||||
const receiver : contract (unit) = get_contract (sender);
|
||||
const op : operation = transaction (unit, price, receiver);
|
||||
const receiver : contract (unit) =
|
||||
case (Tezos.get_contract_opt (Tezos.sender) : option (contract (unit))) of
|
||||
Some (contract) -> contract
|
||||
| None -> (failwith ("sell_single: No contract.") : contract (unit))
|
||||
end;
|
||||
const op : operation = Tezos.transaction (unit, price, receiver);
|
||||
const operations : list (operation) = list [op]
|
||||
} with (operations, s)
|
||||
|
||||
@ -84,12 +99,13 @@ function buy_single (const action : action_buy_single;
|
||||
block {
|
||||
// Check funds
|
||||
const card_pattern : card_pattern =
|
||||
get_force (action.card_to_buy, s.card_patterns);
|
||||
case s.card_patterns[action.card_to_buy] of
|
||||
Some (pattern) -> pattern
|
||||
| None -> (failwith ("buy_single: No card pattern.") : card_pattern)
|
||||
end;
|
||||
const price : tez =
|
||||
card_pattern.coefficient * (card_pattern.quantity + 1n);
|
||||
if price > amount then failwith ("Not enough money") else skip;
|
||||
// Administrative procedure
|
||||
const operations : list(operation) = nil;
|
||||
// Increase quantity
|
||||
card_pattern.quantity := card_pattern.quantity + 1n;
|
||||
const card_patterns : card_patterns = s.card_patterns;
|
||||
@ -103,7 +119,7 @@ function buy_single (const action : action_buy_single;
|
||||
];
|
||||
s.cards := cards;
|
||||
s.next_id := s.next_id + 1n
|
||||
} with (operations, s)
|
||||
} with ((nil : list (operation)), s)
|
||||
|
||||
function main (const action : parameter; const s : storage) : return is
|
||||
case action of
|
||||
|
||||
@ -1,2 +1,4 @@
|
||||
let main (i: int) =
|
||||
if (i=2 : bool) then (42: int) else (0: int)
|
||||
type integer = int
|
||||
|
||||
let main (i : int) =
|
||||
if (i = 2 : bool) then (42 : int) else (0 : integer)
|
||||
|
||||
@ -1,6 +1,2 @@
|
||||
let main = (i: int) =>
|
||||
if (((i == 2): bool)) {
|
||||
(42: int);
|
||||
} else {
|
||||
(0: int);
|
||||
};
|
||||
let main = (i : int) =>
|
||||
if (((i == 2) : bool)) { (42 : int); } else { (0 : int); };
|
||||
|
||||
@ -1,8 +1,5 @@
|
||||
(* TODO : make a test using mutation, not shadowing *)
|
||||
|
||||
let main (i: int) =
|
||||
let main (i : int) =
|
||||
let result = 0 in
|
||||
if i = 2 then
|
||||
let result = 42 in result
|
||||
else
|
||||
let result = 0 in result
|
||||
if i = 2
|
||||
then let result = 42 in result
|
||||
else let result = 0 in result
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user