balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'dev' of gitlab.com:ligolang/ligo into rinderknecht@contracts

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-02-10 19:33:04 +01:00
commit 9b5d63de1f
249 changed files with 51872 additions and 3587 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -5,6 +5,8 @@ cache/*
Version.ml
/_opam/
/*.pp.ligo
/*.pp.mligo
/*.pp.religo
**/.DS_Store
.vscode/
/ligo.install

15
.gitlab-ci.yml
View File

@ -3,9 +3,11 @@ variables:
GIT_SUBMODULE_STRATEGY: recursive
build_binary_script: "./scripts/distribution/generic/build.sh"
package_binary_script: "./scripts/distribution/generic/package.sh"
LIGO_REGISTRY_IMAGE_BASE_NAME: "${CI_PROJECT_PATH}/${CI_PROJECT_NAME}"
stages:
- test
- ide
- build_and_package_binaries
- build_docker
- build_and_deploy_docker
@ -75,9 +77,9 @@ dont-merge-to-master:
- public
.docker: &docker
image: docker:1.11
image: docker:19
services:
- docker:dind
- docker:19-dind
.before_script: &before_script
@ -130,7 +132,7 @@ build-and-publish-latest-docker-image:
- sh scripts/build_docker_image.sh
- sh scripts/test_cli.sh
- docker login -u $LIGO_REGISTRY_USER -p $LIGO_REGISTRY_PASSWORD
- docker push $LIGO_REGISTRY_IMAGE:next
- docker push ${LIGO_REGISTRY_IMAGE_BUILD:-ligolang/ligo}:next
only:
- dev
@ -188,6 +190,13 @@ build-and-package-ubuntu-19-04:
only:
- dev
trigger-webide:
stage: ide
trigger:
include: tools/webide/webide-ci.yml
# Pages are deployed from dev, be careful not to override 'next'
# in case something gets merged into 'dev' while releasing.
pages:

4
gitlab-pages/docs/advanced/first-contract.md
View File

@ -33,7 +33,7 @@ Output of the `dry-run` is the return value of our entrypoint function, we can s
## Building a counter contract
Our counter contract will store a single `int` as it's storage, and will accept an `action` variant in order to re-route our single `main` entrypoint into two entrypoints for `addition` and `subtraction`.
Our counter contract will store a single `int` in its storage, and will accept an `action` variant in order to re-route our single `main` entrypoint into two entrypoints for `addition` and `subtraction`.
<!--DOCUSAURUS_CODE_TABS-->
<!--Pascaligo-->
@ -167,7 +167,7 @@ ligo compile-storage src/counter.ligo main 5
<!--END_DOCUSAURUS_CODE_TABS-->
In our case the LIGO storage value maps 1:1 to it's Michelson representation, however this will not be the case once the parameter is of a more complex data type, like a record.
In our case the LIGO storage value maps 1:1 to its Michelson representation, however this will not be the case once the parameter is of a more complex data type, like a record.
## Invoking a LIGO contract

2
gitlab-pages/docs/advanced/timestamps-addresses.md
View File

@ -9,7 +9,7 @@ Timestamps in LIGO, or in Michelson in general are available in smart contracts,
### Current time
You can obtain the current time using the built-in syntax specific expression, please be aware that it's up to the baker to set the current timestamp value.
You can obtain the current time using the built-in syntax specific expression, please be aware that it is up to the baker to set the current timestamp value.
<!--DOCUSAURUS_CODE_TABS-->

4
gitlab-pages/docs/contributors/getting-started.md
View File

@ -23,9 +23,9 @@ The first issues will most likely be:
>Tests are **really** important, we don’t have lots of them, and mostly regression ones. This can’t be stressed enough. Some features are missing not because we can’t add them, but because we don’t know as no tests tell us they are missing.
## How
Issues will be added to Gitlab tagged with `On-boarding and Front-End` / `Middle-End` / `Back-End` / `Everything`.
Issues will be added to GitLab tagged with `On-boarding and Front-End` / `Middle-End` / `Back-End` / `Everything`.
If you try to tackle an issue and you have **any** problem, please tell us by creating a new Gitlab issue, contacting us on Riot, on Discord, or even by mail!
If you try to tackle an issue and you have **any** problem, please tell us by creating a new GitLab issue, contacting us on Riot, on Discord, or even by mail!
Problems might include:
* Installing the repository or the tools needed to work on it

2
gitlab-pages/docs/contributors/ligo_test_guide.md
View File

@ -111,4 +111,4 @@ What if we want to write a test of our own? If the test is in the integration te
1. Write a test contract which uses the new syntax or feature in [src/test/contracts](https://gitlab.com/ligolang/ligo/tree/dev/src/test/contracts).
2. Write an integration test in [src/test/integration_tests.ml](https://gitlab.com/ligolang/ligo/blob/dev/src/test/integration_tests.ml) in the vein of existing tests, make sure you add it to the test runner that is currently located at the bottom of the file.
3. Write the feature, assuming it doesn't already exist. Build the resulting version of LIGO without errors.
4. Run the test suite, see if your test(s) pass. If they do, you're probably done. If not it's time to go debugging.
4. Run the test suite, see if your test(s) pass. If they do, you're probably done. If not, it's time to go debugging.

4
gitlab-pages/docs/contributors/origin.md
View File

@ -3,8 +3,8 @@ id: origin
title: Origin
---
LIGO is a programming language that aims to provide developers with an uncomplicated and safe way to implement smart-contracts. Since it is being implemented for the Tezos blockchain LIGO compiles to Michelson—the native smart-contract language of Tezos.
LIGO is a programming language that aims to provide developers with an uncomplicated and safe way to implement smart contracts. Since it is being implemented for the Tezos blockchain LIGO compiles to Michelson—the native smart contract language of Tezos.
> Smart-contracts are programs that run within a blockchain network.
> Smart contracts are programs that run within a blockchain network.
LIGO was meant to be a language for developing Marigold on top of a hacky framework called Meta-Michelson. However, due to the attention received by the Tezos community, LIGO is now a standalone language being developed to support Tezos directly.

4
gitlab-pages/docs/contributors/philosophy.md
View File

@ -6,7 +6,7 @@ title: Philosophy
To understand LIGO’s design choices it’s important to understand its philosophy. We have two main concerns in mind while building LIGO.
## Safety
Once a smart-contract is deployed, it will likely be impossible to change it. You must get it right on the first try, and LIGO should help as much as possible. There are multiple ways to make LIGO a safer language for smart-contracts.
Once a smart contract is deployed, it will likely be impossible to change it. You must get it right on the first try, and LIGO should help as much as possible. There are multiple ways to make LIGO a safer language for smart contracts.
### Automated Testing
Automated Testing is the process through which a program runs another program, and checks that this other program behaves correctly.
@ -18,7 +18,7 @@ Static analysis is the process of having a program analyze another one.
For instance, type systems are a kind of static analysis through which it is possible to find lots of bugs. LIGO already has a simple type system, and we plan to make it much stronger.
### Conciseness
Writing less code gives you less room to introduce errors. That's why LIGO encourages writing lean rather than chunky smart-contracts.
Writing less code gives you less room to introduce errors. That's why LIGO encourages writing lean rather than chunky smart contracts.
---

4
gitlab-pages/docs/intro/installation.md
View File

@ -15,12 +15,12 @@ executable (see below). This manages the Docker bits for you.
* Use the Docker image available at [Docker Hub](https://hub.docker.com/r/ligolang/ligo).
This lets you run multiple versions and keep your installation(s) self contained, but requires more familiarity with Docker.
Sources for the image can be found on [Gitlab](https://gitlab.com/ligolang/ligo/blob/master/docker/Dockerfile).
Sources for the image can be found on [GitLab](https://gitlab.com/ligolang/ligo/blob/master/docker/Dockerfile).
If this is your first time using Docker, you probably want to set up a global LIGO executable as shown below.
### Setting up a globally available `ligo` executable
> You can install additional ligo versions by replacing `next` with the required version number
> You can install additional ligo versions by replacing `next` with the desired version number
Download the latest binaries here: https://gitlab.com/ligolang/ligo/pipelines/85536879/builds or get the latest pre-release:

6
gitlab-pages/docs/intro/what-and-why.md
View File

@ -64,7 +64,7 @@ Unfortunately (???), we **can't run Javascript on the Tezos blockchain** at the
## C-like smart contracts instead of Michelson
Let's take a look at a similar LIGO program. Don't worry if it's a little confusing at first; we'll explain all the syntax in the upcoming sections of the documentation.
Let's take a look at a similar LIGO program. Don't worry if it is a little confusing at first; we'll explain all the syntax in the upcoming sections of the documentation.
<!--DOCUSAURUS_CODE_TABS-->
<!--Pascaligo-->
@ -132,7 +132,7 @@ The LIGO contract behaves exactly* like the Michelson contract we've saw first,
## 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).
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:
@ -141,7 +141,7 @@ For example **code snippets** for the *Types* subsection of this doc, can be fou
### Exercises
Solutions to exercises can be found e.g. here: `gitlab-pages/docs/language-basics/exercises/types/**/solutions/**`
### Running snippets / excercise 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

4
gitlab-pages/docs/language-basics/boolean-if-else.md
View File

@ -155,7 +155,7 @@ let min_age: nat = 16n
(**
This function is really obnoxious, but it showcases
how the if statement and it's syntax can be used.
how the if statement and its syntax can be used.
Normally, you'd use `with (age > min_age)` instead.
@ -170,7 +170,7 @@ let min_age: nat = 16n;
(**
This function is really obnoxious, but it showcases
how the if statement and it's syntax can be used.
how the if statement and its syntax can be used.
Normally, you'd use `with (age > min_age)` instead.

2
gitlab-pages/docs/language-basics/tezos-specific.md
View File

@ -42,7 +42,7 @@ let id_string = (p: string) : option(string) => {
## Hashing Keys
It's often desirable to hash a public key. In Michelson, certain data structures
It is often desirable to hash a public key. In Michelson, certain data structures
such as maps will not allow the use of the `key` type. Even if this weren't the case
hashes are much smaller than keys, and storage on blockchains comes at a cost premium.
You can hash keys with the `key_hash` type and associated built in function.

2
gitlab-pages/docs/language-basics/variables-and-constants.md
View File

@ -88,7 +88,7 @@ with a new value being bound in place of the old one.
```cameligo
let add (a: int) (b: int) : int =
let add (a,b: int * int): int =
let c : int = a + b in c
```

79
gitlab-pages/docs/reference/string.md Normal file
View File

@ -0,0 +1,79 @@
---
id: string-reference
title: String
---
## String.size(s: string) : nat
Get the size of a string. [Michelson only supports ASCII strings](http://tezos.gitlab.io/whitedoc/michelson.html#constants)
so for now you can assume that each character takes one byte of storage.
<!--DOCUSAURUS_CODE_TABS-->
<!--PascaLIGO-->
```pascaligo
function string_size (const s: string) : nat is size(s)
```
<!--CameLIGO-->
```cameligo
let size_op (s: string) : nat = String.size s
```
<!--ReasonLIGO-->
```reasonligo
let size_op = (s: string): nat => String.size(s);
```
<!--END_DOCUSAURUS_CODE_TABS-->
## String.length(s: string) : nat
Alias for `String.size`.
## String.slice(pos1: nat, pos2: nat, s: string) : string
Get the substring of `s` between `pos1` inclusive and `pos2` inclusive. For example
the string "tata" given to the function below would return "at".
<!--DOCUSAURUS_CODE_TABS-->
<!--PascaLIGO-->
```pascaligo
function slice_op (const s : string) : string is string_slice(1n , 2n , s)
```
<!--CameLIGO-->
```cameligo
let slice_op (s: string) : string = String.slice 1n 2n s
```
<!--ReasonLIGO-->
```reasonligo
let slice_op = (s: string): string => String.slice(1n, 2n, s);
```
<!--END_DOCUSAURUS_CODE_TABS-->
## String.sub(pos1: nat, pos2: nat, s: string) : string
Alias for `String.slice`.
## String.concat(s1: string, s2: string) : string
Concatenate two strings and return the result.
<!--DOCUSAURUS_CODE_TABS-->
<!--PascaLIGO-->
```pascaligo
function concat_op (const s : string) : string is s ^ "toto"
```
<!--CameLIGO-->
```cameligo
let concat_syntax (s: string) = s ^ "test_literal"
```
<!--ReasonLIGO-->
```reasonligo
let concat_syntax = (s: string) => s ++ "test_literal";
```
<!--END_DOCUSAURUS_CODE_TABS-->

12
gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-smart-contract.md
View File

@ -1,13 +1,13 @@
---
id: tezos-taco-shop-smart-contract
title: Taco shop smart-contract
title: Taco shop smart contract
---
<div>
Meet **Pedro**, our *artisan taco chef* who has decided to open a Taco shop on the Tezos blockchain, using a smart-contract. He sells two different kinds of tacos, the **el clásico** and the **especial del chef**.
Meet **Pedro**, our *artisan taco chef* who has decided to open a Taco shop on the Tezos blockchain, using a smart contract. He sells two different kinds of tacos, the **el clásico** and the **especial del chef**.
To help Pedro open his dream taco shop, we'll implement a smart-contract, that will manage supply, pricing & sales of his tacos to the consumers.
To help Pedro open his dream taco shop, we'll implement a smart contract, that will manage supply, pricing & sales of his tacos to the consumers.
<br/>
<img src="/img/tutorials/get-started/tezos-taco-shop-smart-contract/taco-stand.svg" width="50%" />
@ -68,7 +68,7 @@ The best way to install the dockerized LIGO is as a **global executable** throug
> From now on we'll get a bit more technical. If you run into something we have not covered yet - please try checking out the [LIGO cheat sheet](api/cheat-sheet.md) for some extra tips & tricks.
To begin implementing our smart contract, we need an entry point. We'll call it `main` and it'll specify our contract's storage (`int`) and input parameter (`int`). Of course this is not the final storage/parameter of our contract, but it's something to get us started and test our LIGO installation as well.
To begin implementing our smart contract, we need an entry point. We'll call it `main` and it'll specify our contract's storage (`int`) and input parameter (`int`). Of course this is not the final storage/parameter of our contract, but it is something to get us started and test our LIGO installation as well.
### `taco-shop.ligo`
```pascaligo group=a
@ -138,7 +138,7 @@ end
type taco_shop_storage is map(nat, taco_supply);
```
Next step is to update the `main` entry point to include `taco_shop_storage` as its storage - while doing that let's set the `parameter` to `unit` as well to clear things up.
Next step is to update the `main` entry point to include `taco_shop_storage` in its storage - while doing that let's set the `parameter` to `unit` as well to clear things up.
**`taco-shop.ligo`**
```pascaligo group=b+
@ -154,7 +154,7 @@ function main (const parameter: unit ; const taco_shop_storage : taco_shop_stora
### Populating our storage in a dry-run
When dry-running a contract, it's crucial to provide a correct initial storage value - in our case the storage is type-checked as `taco_shop_storage`. Reflecting [Pedro's daily offer](tutorials/get-started/tezos-taco-shop-smart-contract.md#daily-offer), our storage's value will be defined as following:
When dry-running a contract, it is crucial to provide a correct initial storage value - in our case the storage is type-checked as `taco_shop_storage`. Reflecting [Pedro's daily offer](tutorials/get-started/tezos-taco-shop-smart-contract.md#daily-offer), our storage's value will be defined as following:
**Storage value**
```zsh

4
gitlab-pages/website/blog/2019-06-13-public-launch-of-ligo.md
View File

@ -8,7 +8,7 @@ author: Gabriel Alfour
---
## A Refresher: What is LIGO?
LIGO is a statically typed high-level smart-contract language that compiles down to Michelson. It seeks to be easy to use, extensible and safe.
LIGO is a statically typed high-level smart contract language that compiles down to Michelson. It seeks to be easy to use, extensible and safe.
The core language is being developed by The Marigold Project. George Dupéron and Christian Rinderknecht of Nomadic Labs help on the core language, and tooling for LIGO is being developed by Stove Labs (Granary, docs and infrastructure) and Brice Aldrich (syntax highlighting).
@ -95,7 +95,7 @@ We are looking to develop a Super Type System that has the following features:
The current version explicitly excludes non-essential features which can produce unexpected explosions in gas costs. To alleviate this constraint, we plan to integrate gas benchmarks on all top-level declarations with some fuzzing. This will allow developers and users to estimate the cost of their contracts in real time.
## Getting Started and Contact
Come visit [our website](https://ligolang.org)! You can also join our [Discord](https://discord.gg/9rhYaEt), Riot (*#ligo-public:matrix.org*) or Telegram Chat (Ligo Public channel).
Come visit [our website](https://ligolang.org)! You can also join our [Discord](https://discord.gg/9rhYaEt), Riot (*#ligo-public:matrix.org*) or [Telegram Chat](https://t.me/LigoLang).

6
gitlab-pages/website/blog/2019-07-11-ligo-update.md
View File

@ -7,7 +7,7 @@ author: Gabriel Alfour
---
It's been a few weeks since our last update. Since then, we've onboarded new collaborators to both LIGO and Marigold, rewritten much of the codebase, and we've begun some exciting new projects. Let's tell you all about it!
It has been a few weeks since our last update. Since then, we've onboarded new collaborators to both LIGO and Marigold, rewritten much of the codebase, and we've begun some exciting new projects. Let's tell you all about it!
# LIGO
@ -41,7 +41,7 @@ The most brittle part of our code base is about to become its strongest part. We
Concretely:
- Running LIGO-in-Browser will become much easier. Instead of having to dry-run it remotely or to rewrite a Michelson interpreter, we'll be able to **directly interpret** the LIGO program.
- It will be possible to prove the properties of Smart-Contracts written in LIGO directly, instead of having to prove the Michelson they produce.
- It will be possible to prove the properties of smart contracts written in LIGO directly, instead of having to prove the Michelson they produce.
- Fewer tests will ned to be written and testing will instead focus mostly on the developer-facing layers of the compiler (i.e. syntax, typing), rather than on the actual compiling part.
# Marigold
@ -56,4 +56,4 @@ It is thus hard for newcomers (even CS researchers!) to dive into Plasma in a co
# Contact
If you have any question, feel free to visit [our website](ligolang.org) and to contact us :)
If you have any question, feel free to visit [our website](https://ligolang.org) and to contact us :)

4
gitlab-pages/website/pages/en/contact.js
View File

@ -47,8 +47,8 @@ const TEAM = [
const COMMUNICATION_CHANNELS = [
{
link: 'https://discord.gg/9rhYaEt',
icon: 'img/discord.svg',
link: 'https://t.me/LigoLang',
icon: 'img/telegram.svg',
description: "We're hear to help. Ask us anything"
},
{

2
gitlab-pages/website/pages/en/index.js
View File

@ -77,7 +77,7 @@ module.exports = props => {
</ul>
</div>
<div id="preview">
<h1>A friendly smart-contract language for Tezos</h1>
<h1>A friendly smart contract language for Tezos</h1>
<p>Michelson was never so easy</p>
<CodeExamples MarkdownBlock={MarkdownBlock}></CodeExamples>
</div>

2
gitlab-pages/website/pages/en/versions.js
View File

@ -102,7 +102,7 @@ function Versions(props) {
</table>
<p>
You can find past versions of this project on{' '}
<a href={repoUrl}>Gitlab</a>.
<a href={repoUrl}>GitLab</a>.
</p>
</div>
</Container>

18
gitlab-pages/website/siteConfig.js
View File

@ -4,7 +4,7 @@ let reasonHighlightJs = require('reason-highlightjs');
const siteConfig = {
title: 'LIGO', // Title for your website.
tagline: 'LIGO is a friendly smart-contract language for Tezos',
tagline: 'LIGO is a friendly smart contract language for Tezos',
taglineSub: 'Michelson was never so easy',
url: 'https://ligolang.org', // Your website URL
baseUrl: '/', // Base URL for your project */
@ -29,7 +29,7 @@ const siteConfig = {
label: 'Tutorials'
},
{ blog: true, label: 'Blog' },
// TODO: { href: "/odoc", label: "Api" },
// TODO: { href: "/odoc", label: "API" },
// { doc: 'contributors/origin', label: 'Contribute' },
{ href: '/contact', label: 'Ask Questions' },
{ search: true }
@ -40,14 +40,24 @@ const siteConfig = {
{ doc: 'intro/installation', label: 'Install' },
{ doc: 'api/cli-commands', label: 'CLI Commands' },
{ doc: 'contributors/origin', label: 'Contribute' },
{ href: '/odoc', label: 'Api Documentation' }
{ href: '/odoc', label: 'API Documentation' }
],
community: [
{
href: 'https://forum.tezosagora.org/tag/ligo',
label: 'Tezos Agora Forum',
blankTarget: true
},
{
href: 'https://tezos.stackexchange.com/questions/tagged/ligo',
label: 'Tezos Stack Exchange',
blankTarget: true
},
{
href: 'https://t.me/LigoLang',
label: 'Telegram',
blankTarget: true
},
{
href: 'https://discord.gg/9rhYaEt',
label: 'Discord',
@ -59,7 +69,7 @@ const siteConfig = {
doc: 'tutorials/get-started/tezos-taco-shop-smart-contract',
label: 'Tutorials'
},
{ href: repoUrl, label: 'Gitlab' }
{ href: repoUrl, label: 'GitLab' }
]
},

18
gitlab-pages/website/static/img/telegram.svg Normal file
View File

@ -0,0 +1,18 @@
<svg xmlns="http://www.w3.org/2000/svg" width="50" height="50" viewBox="0 0 50 50">
<defs>
<linearGradient id="telegram-a" x1="66.7%" x2="41.7%" y1="16.7%" y2="75%">
<stop offset="0%" stop-color="#37AEE2"/>
<stop offset="100%" stop-color="#1E96C8"/>
</linearGradient>
<linearGradient id="telegram-b" x1="66%" x2="85.1%" y1="43.065%" y2="83.244%">
<stop offset="0%" stop-color="#EFF7FC"/>
<stop offset="100%" stop-color="#FFF"/>
</linearGradient>
</defs>
<g fill="none" transform="translate(1 1)">
<circle cx="23.5" cy="23.5" r="23.5" fill="url(#telegram-a)"/>
<path fill="#C8DAEA" d="M19.2727273,35 C18.4774545,35 18.6126591,34.7064 18.3383636,33.966 L16,26.4414 L34,16"/>
<path fill="#A9C9DD" d="M19,35 C19.6818182,35 19.9829545,34.7309188 20.3636364,34.4116301 L24,31.3603439 L19.4640909,29"/>
<path fill="url(#telegram-b)" d="M19.7939067,28.5186178 L29.058792,35.7003368 C30.1161307,36.312398 30.8790086,35.9954126 31.1424333,34.6705866 L34.9137167,16.0247303 C35.2997536,14.4006073 34.3236454,13.6637218 33.3120947,14.1455316 L11.1671796,23.1045396 C9.65560092,23.7407214 9.66460526,24.6255468 10.8916853,25.0197183 L16.5745698,26.8808265 L29.7310517,18.1722711 C30.3521592,17.7770947 30.922306,17.9893563 30.4544638,18.4251358"/>
</g>
</svg>
Side by Side

After

Width:  |  Height:  |  Size: 1.3 KiB

6
gitlab-pages/website/versioned_docs/version-next/contributors/origin.md
View File

@ -4,8 +4,8 @@ title: Origin
original_id: origin
---
LIGO is a programming language that aims to provide developers with an uncomplicated and safer way to implement smart-contracts. LIGO is currently being implemented for the Tezos blockchain and as a result, it compiles down to Michelson - the native smart-contract language of Tezos.
LIGO is a programming language that aims to provide developers with an uncomplicated and safe way to implement smart contracts. Since it is being implemented for the Tezos blockchain LIGO compiles to Michelson—the native smart contract language of Tezos.
> Smart-contracts are programs that run within a blockchain network.
> Smart contracts are programs that run within a blockchain network.
LIGO was initially meant to be a language for developing Marigold, on top of a hacky framework called Meta-Michelson. However, due to the attention received by the Tezos community, a decision has been put into action to develop LIGO as a standalone language that will support Tezos directly as well.
LIGO was meant to be a language for developing Marigold on top of a hacky framework called Meta-Michelson. However, due to the attention received by the Tezos community, LIGO is now a standalone language being developed to support Tezos directly.

13
gitlab-pages/website/versioned_docs/version-next/contributors/philosophy.md
View File

@ -4,23 +4,22 @@ title: Philosophy
original_id: philosophy
---
To understand LIGO’s design choices, it’s important to get its philosophy. There are two main concerns that we have in mind when building LIGO.
To understand LIGO’s design choices it’s important to understand its philosophy. We have two main concerns in mind while building LIGO.
## Safety
Once a smart-contract is deployed, it will likely be impossible to change it. You must get it right on the first try, and LIGO should help as much as possible. There are multiple ways to make LIGO a safer language for smart-contracts.
Once a smart contract is deployed, it will likely be impossible to change it. You must get it right on the first try, and LIGO should help as much as possible. There are multiple ways to make LIGO a safer language for smart contracts.
### Automated Testing
Automated Testing is the process through which a program will run some other program, and check that this other program behaves correctly.
Automated Testing is the process through which a program runs another program, and checks that this other program behaves correctly.
There already is a testing library for LIGO programs written in OCaml that is used to test LIGO itself. Making it accessible to users will greatly improve safety. A way to do so would be to make it accessible from within LIGO.
### Static Analysis
Static analysis is the process of having a program analyze another one.
For instance, type systems are a kind of static analysis through which it is possible to find lots of bugs. There is already a fairly simple type system in LIGO, and we plan to make it much stronger.
For instance, type systems are a kind of static analysis through which it is possible to find lots of bugs. LIGO already has a simple type system, and we plan to make it much stronger.
### Conciseness
Writing less code gives you less room to introduce errors and that's why LIGO encourages writing lean rather than chunky smart-contracts.
Writing less code gives you less room to introduce errors. That's why LIGO encourages writing lean rather than chunky smart contracts.
---

22
gitlab-pages/website/versioned_sidebars/version-next-sidebars.json
View File

@ -6,15 +6,27 @@
"version-next-intro/editor-support"
],
"Language Basics": [
"version-next-language-basics/cheat-sheet",
"version-next-language-basics/types",
"version-next-language-basics/variables",
"version-next-language-basics/constants-and-variables",
"version-next-language-basics/math-numbers-tez",
"version-next-language-basics/strings",
"version-next-language-basics/functions",
"version-next-language-basics/entrypoints",
"version-next-language-basics/operators"
"version-next-language-basics/boolean-if-else",
"version-next-language-basics/loops",
"version-next-language-basics/unit-option-pattern-matching",
"version-next-language-basics/maps-records",
"version-next-language-basics/sets-lists-tuples",
"version-next-language-basics/tezos-specific"
],
"Advanced": [
"version-next-advanced/timestamps-addresses",
"version-next-advanced/entrypoints-contracts",
"version-next-advanced/include",
"version-next-advanced/first-contract"
],
"API": [
"version-next-api-cli-commands"
"version-next-api/cli-commands",
"version-next-api/cheat-sheet"
]
},
"version-next-contributors-docs": {

2
scripts/distribution/generic/parameters.sh
View File

@ -1,4 +1,4 @@
# This script accepts three arguments, os family, os and it's version,
# This script accepts three arguments, os family, os and its version,
# which are subsequently used to fetch the respective docker
# image from the ocaml/infrastructure project.
#

2
scripts/test_cli.sh
View File

@ -7,7 +7,7 @@ dry_run_output=$(./scripts/ligo_ci.sh dry-run src/test/contracts/website2.ligo m
expected_compiled_parameter="(Right 1)";
expected_compiled_storage=1;
expected_dry_run_output="( [] , 2 )";
expected_dry_run_output="( list[] , 2 )";
if [ "$compiled_storage" != "$expected_compiled_storage" ]; then
echo "Expected $expected_compiled_storage as compile-storage output, got $compiled_storage instead";

17
src/bin/cli.ml
View File

@ -259,7 +259,7 @@ let interpret =
let%bind failstring = Run.failwith_to_string fail_res in
ok @@ Format.asprintf "%s" failstring
| Success value' ->
let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_annotation value' in
let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_expression value' in
ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
in
let term =
@ -268,6 +268,19 @@ let interpret =
let doc = "Subcommand: Interpret the expression in the context initialized by the provided source file." in
(Term.ret term , Term.info ~doc cmdname)
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 res = Compile.Of_typed.some_interpret typed in
ok @@ Format.asprintf "%s\n" res
in
let term =
Term.(const f $ source_file 0 $ syntax $ display_format ) in
let cmdname = "ligo-interpret" in
let doc = "Subcommand: (temporary / dev only) uses LIGO interpret." in
(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 =
@ -342,6 +355,7 @@ let run_function =
let env = Ast_typed.program_environment typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind simplified_param = Compile.Of_source.compile_expression v_syntax parameter in
let%bind app = Compile.Of_simplified.apply entry_point simplified_param in
let%bind (typed_app,_) = Compile.Of_simplified.compile_expression ~env ~state app in
@ -425,6 +439,7 @@ let list_declarations =
let run ?argv () =
Term.eval_choice ?argv main [
temp_ligo_interpreter ;
compile_file ;
measure_contract ;
compile_parameter ;

897
src/bin/expect_tests/contract_tests.ml
View File

File diff suppressed because it is too large Load Diff

36
src/bin/expect_tests/failwith_tests.ml Normal file
View File

@ -0,0 +1,36 @@
open Cli_expect
let contract basename =
"../../test/contracts/" ^ basename
let bad_contract basename =
"../../test/contracts/negative/" ^ basename
let%expect_test _ =
run_ligo_good [ "run-function" ; contract "failwith.ligo" ; "failer" ; "1" ] ;
[%expect {|
failwith("some_string") |}];
run_ligo_good [ "run-function" ; contract "failwith.ligo" ; "failer" ; "1" ; "--format=json" ] ;
[%expect {|
{"status":"ok","content":"failwith(\"some_string\")"} |}];
run_ligo_good [ "dry-run" ; contract "subtle_nontail_fail.mligo" ; "main" ; "()" ; "()" ] ;
[%expect {|
failwith("This contract always fails") |}];
run_ligo_good [ "interpret" ; "assert(1=1)" ; "--syntax=pascaligo" ] ;
[%expect {|
unit |}];
run_ligo_good [ "interpret" ; "assert(1=2)" ; "--syntax=pascaligo" ] ;
[%expect {|
failwith("failed assertion") |}];
run_ligo_good [ "interpret" ; "assert(1=1)" ; "--syntax=cameligo" ] ;
[%expect {|
unit |}];
run_ligo_good [ "interpret" ; "assert(1=2)" ; "--syntax=cameligo" ] ;
[%expect {|
failwith("failed assertion") |}];

6
src/bin/expect_tests/help_tests.ml
View File

@ -44,6 +44,9 @@ let%expect_test _ =
Subcommand: Interpret the expression in the context initialized by
the provided source file.
ligo-interpret
Subcommand: (temporary / dev only) uses LIGO interpret.
list-declarations
Subcommand: List all the top-level declarations.
@ -120,6 +123,9 @@ let%expect_test _ =
Subcommand: Interpret the expression in the context initialized by
the provided source file.
ligo-interpret
Subcommand: (temporary / dev only) uses LIGO interpret.
list-declarations
Subcommand: List all the top-level declarations.

56
src/bin/expect_tests/ligo_interpreter_tests.ml Normal file
View File

@ -0,0 +1,56 @@
open Cli_expect
let contract basename =
"../../test/contracts/" ^ basename
let%expect_test _ =
run_ligo_good [ "ligo-interpret" ; contract "interpret_test.mligo" ] ;
[%expect {|
val lambda_call = 16 : int
val higher_order1 = 5 : int
val higher_order2 = 5 : int
val higher_order3 = 5 : int
val higher_order4 = 5 : int
val concats = 0x7070 : bytes
val record_concat = "ab" : string
val record_patch = { ; a = ("a" : string) ; b = ("c" : string) }
val record_lambda = 5 : int
val variant_exp = { ; 0 = (Foo(unit)) ; 1 = (Bar(1 : int)) ; 2 = (Baz("b" : string)) }
val variant_match = 2 : int
val bool_match = 1 : int
val list_match = [ ; 1 : int ; 1 : int ; 2 : int ; 3 : int ; 4 : int]
val tuple_proj = true
val list_const = [ ; 0 : int ; 1 : int ; 2 : int ; 3 : int ; 4 : int]
val options_match_some = 0 : int
val options_match_none = 0 : int
val is_nat_nat = { ; 0 = (Some(1 : nat)) ; 1 = (None(unit)) }
val abs_int = 5 : int
val nat_int = 5 : int
val map_list = [ ; 2 : int ; 3 : int ; 4 : int ; 5 : int]
val fail_alone = "you failed" : failure
val iter_list_fail = "you failed" : failure
val fold_list = 10 : int
val comparison_int = { ; 0 = (false) ; 1 = (true) ; 2 = (false) ; 3 = (true) }
val comparison_string = { ; 0 = (false) ; 1 = (true) }
val divs = { ; 0 = (0 : int) ; 1 = (0 : nat) ; 2 = (500000 : mutez) ; 3 = (0 : nat) }
val var_neg = -2 : int
val sizes = { ; 0 = (5 : nat) ; 1 = (5 : nat) ; 2 = (5 : nat) ; 3 = (3 : nat) ; 4 = (2 : nat) }
val modi = 1 : nat
val fold_while = { ; 0 = (20 : int) ; 1 = (10 : int) }
val assertion_pass = unit
val assertion_fail = "failed assertion" : failure
val lit_address = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" : address
val map_finds = Some(2 : int)
val map_finds_fail = "failed map find" : failure
val map_empty = { ; 0 = ([]) ; 1 = ([]) }
val m = [ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int]
val map_fold = 4 : int
val map_iter = unit
val map_map = [ ; "one" : string -> 4 : int ; "two" : string -> 5 : int ; "three" : string -> 8 : int]
val map_mem = { ; 0 = (true) ; 1 = (false) }
val map_remove = { ; 0 = ([ ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) ; 1 = ([ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) }
val map_update = { ; 0 = ([ ; "one" : string -> 1 : int]) ; 1 = ([]) ; 2 = ([]) ; 3 = ([ ; "one" : string -> 1 : int]) }
val s = { ; 1 : int ; 2 : int ; 3 : int}
val set_add = { ; 0 = ({ ; 1 : int ; 2 : int ; 3 : int}) ; 1 = ({ ; 1 : int ; 2 : int ; 3 : int ; 4 : int}) ; 2 = ({ ; 1 : int}) }
val set_iter_fail = "set_iter_fail" : failure
val set_mem = { ; 0 = (true) ; 1 = (false) ; 2 = (false) } |}] ;

4
src/bin/expect_tests/literals.ml
View File

@ -2,12 +2,12 @@ open Cli_expect
let%expect_test _ =
run_ligo_good ["interpret" ; "(\"edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7\":signature)" ; "--syntax=pascaligo"] ;
[%expect {| signature edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7 |}]
[%expect {| Signature edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7 |}]
let%expect_test _ =
run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
[%expect {|
ligo: in file "", line 0, characters 1-32. Badly formatted literal: signature thisisnotasignature {"location":"in file \"\", line 0, characters 1-32"}
ligo: in file "", line 0, characters 1-32. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 1-32"}
If you're not sure how to fix this error, you can

2
src/bin/expect_tests/misc_cli_commands.ml
View File

@ -4,7 +4,7 @@ open Cli_expect
let%expect_test _ =
run_ligo_good [ "evaluate-value" ; "../../test/contracts/evaluation_tests.ligo" ; "a" ] ;
[%expect {|
{foo = +0 , bar = "bar"} |} ];
record[bar -> "bar" , foo -> +0] |} ];
run_ligo_good [ "evaluate-value" ; "../../test/contracts/evaluation_tests.ligo" ; "b" ] ;
[%expect {|

8
src/bin/expect_tests/typer_error_tests.ml
View File

@ -41,7 +41,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "main" ] ;
[%expect {|
ligo: in file "error_typer_3.mligo", line 3, characters 34-53. different number of arguments to type constructors: Expected these two n-ary type constructors to be the same, but they have different numbers of arguments (both use the TC_tuple type constructor, but they have 3 and 2 arguments, respectively) {"a":"(TO_tuple[int , string , bool])","b":"(TO_tuple[int , string])","op":"TC_tuple","len_a":"3","len_b":"2"}
ligo: in file "error_typer_3.mligo", line 3, characters 34-53. tuples have different sizes: Expected these two types to be the same, but they're different (both are tuples, but with a different number of arguments) {"a":"( int * string * bool )","b":"( int * string )"}
If you're not sure how to fix this error, you can
@ -54,7 +54,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "main" ] ;
[%expect {|
ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in record: {"key_a":"d","key_b":"c"}
ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in records: {"key_a":"c","key_b":"b","a":"record[a -> int , c -> bool , d -> string]","b":"record[a -> int , b -> string , c -> bool]"}
If you're not sure how to fix this error, you can
@ -93,7 +93,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_7.mligo" ; "main" ] ;
[%expect {|
ligo: in file "error_typer_7.mligo", line 4, characters 18-48. records have different sizes: Expected these two types to be the same, but they're different (both are records, but with a different number of arguments) {"a":"record[b -> string , a -> int]","b":"record[c -> bool , b -> string , a -> int]"}
ligo: in file "error_typer_7.mligo", line 4, characters 18-48. records have different sizes: Expected these two types to be the same, but they're different (both are records, but with a different number of arguments) {"a":"record[a -> int , b -> string]","b":"record[a -> int , b -> string , c -> bool]"}
If you're not sure how to fix this error, you can
@ -106,7 +106,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ;
[%expect {|
ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[profile -> bytes , owner -> address , controller -> address]
ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address , owner -> address , profile -> bytes]
If you're not sure how to fix this error, you can
do one of the following:

1
src/main/compile/dune
View File

@ -6,6 +6,7 @@
tezos-utils
parser
simplify
interpreter
ast_simplified
self_ast_simplified
typer_new

6
src/main/compile/of_simplified.ml
View File

@ -6,17 +6,17 @@ let compile (program : Ast_simplified.program) : (Ast_typed.program * Typer.Solv
ok @@ (prog_typed, state)
let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression)
: (Ast_typed.value * Typer.Solver.state) result =
: (Ast_typed.expression * Typer.Solver.state) result =
let () = Typer.Solver.discard_state state in
Typer.type_expression_subst env state ae
let apply (entry_point : string) (param : Ast_simplified.expression) : Ast_simplified.expression result =
let name = Var.of_name entry_point in
let entry_point_var : Ast_simplified.expression =
{ expression = Ast_simplified.E_variable name ;
{ expression_content = Ast_simplified.E_variable name ;
location = Virtual "generated entry-point variable" } in
let applied : Ast_simplified.expression =
{ expression = Ast_simplified.E_application (entry_point_var, param) ;
{ expression_content = Ast_simplified.E_application {expr1=entry_point_var; expr2=param} ;
location = Virtual "generated application" } in
ok applied

20
src/main/compile/of_typed.ml
View File

@ -4,20 +4,22 @@ open Ast_typed
let compile : Ast_typed.program -> Mini_c.program result = fun p ->
Transpiler.transpile_program p
let compile_expression : annotated_expression -> Mini_c.expression result = fun e ->
let compile_expression : expression -> Mini_c.expression result = fun e ->
Transpiler.transpile_annotated_expression e
type check_type = Check_parameter | Check_storage
let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.value -> unit result =
let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.expression -> unit result =
fun c entry contract param -> Trace.trace (simple_info "Check argument type against contract type") (
let%bind entry_point = Ast_typed.get_entry contract entry in
match entry_point.type_annotation.type_value' with
| T_arrow (args,_) -> (
match args.type_value' with
| T_operator (TC_tuple [param_exp;storage_exp]) -> (
match entry_point.type_expression.type_content with
| T_arrow {type1=args} -> (
match args.type_content with
| T_record m when LMap.cardinal m = 2 -> (
let param_exp = LMap.find (Label "0") m in
let storage_exp = LMap.find (Label "1") m in
match c with
| Check_parameter -> assert_type_value_eq (param_exp, param.type_annotation)
| Check_storage -> assert_type_value_eq (storage_exp, param.type_annotation)
| Check_parameter -> assert_type_expression_eq (param_exp, param.type_expression)
| Check_storage -> assert_type_expression_eq (storage_exp, param.type_expression)
)
| _ -> dummy_fail
)
@ -25,3 +27,5 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As
let pretty_print ppf program =
Ast_typed.PP.program ppf program
let some_interpret = Interpreter.dummy

12
src/main/compile/wrapper.ml Normal file
View File

@ -0,0 +1,12 @@
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

4
src/main/uncompile/uncompile.ml
View File

@ -4,9 +4,9 @@ type ret_type = Function | Expression
let uncompile_value func_or_expr program entry ex_ty_value =
let%bind entry_expression = Ast_typed.get_entry program entry in
let%bind output_type = match func_or_expr with
| Expression -> ok entry_expression.type_annotation
| Expression -> ok entry_expression.type_expression
| Function ->
let%bind (_,output_type) = Ast_typed.get_t_function entry_expression.type_annotation in
let%bind (_,output_type) = Ast_typed.get_t_function entry_expression.type_expression in
ok output_type in
let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in
let%bind typed = Transpiler.untranspile mini_c output_type in

3
src/passes/1-parser/pascaligo/AST.ml
View File

@ -789,3 +789,6 @@ let rhs_to_region = expr_to_region
let selection_to_region = function
FieldName {region; _}
| Component {region; _} -> region
let map_ne_injection f ne_injection =
{ ne_injection with ne_elements = nsepseq_map f ne_injection.ne_elements }

2
src/passes/1-parser/pascaligo/Scoping.ml
View File

@ -158,10 +158,12 @@ let check_variants variants =
let check_parameters params =
let add acc = function
ParamConst {value; _} ->
check_reserved_name value.var;
if VarSet.mem value.var acc then
raise (Error (Duplicate_parameter value.var))
else VarSet.add value.var acc
| ParamVar {value; _} ->
check_reserved_name value.var;
if VarSet.mem value.var acc then
raise (Error (Duplicate_parameter value.var))
else VarSet.add value.var acc in

42
src/passes/2-simplify/cameligo.ml
View File

@ -194,13 +194,13 @@ let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te
| Error _ -> ok @@ make_t @@ T_variable (Var.of_name v.value)
)
| TFun x -> (
let%bind (a , b) =
let%bind (type1 , type2) =
let (a , _ , b) = x.value in
let%bind a = simpl_type_expression a in
let%bind b = simpl_type_expression b in
ok (a , b)
in
ok @@ make_t @@ T_arrow (a , b)
ok @@ make_t @@ T_arrow {type1;type2}
)
| TApp x -> (
let (name, tuple) = x.value in
@ -247,7 +247,7 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
| [hd] -> simpl_type_expression hd
| lst ->
let%bind lst = bind_map_list simpl_type_expression lst in
ok @@ make_t @@ T_operator (TC_tuple lst)
ok @@ t_tuple lst
let rec simpl_expression :
Raw.expr -> expr result = fun t ->
@ -261,13 +261,13 @@ let rec simpl_expression :
let path' =
let aux (s:Raw.selection) =
match s with
FieldName property -> Access_record property.value
| Component index -> Access_tuple (Z.to_int (snd index.value))
FieldName property -> property.value
| Component index -> Z.to_string (snd index.value)
in
List.map aux @@ npseq_to_list path in
return @@ e_accessor ~loc var path'
return @@ List.fold_left (e_accessor ~loc ) var path'
in
let simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
let simpl_path : Raw.path -> string * label list = fun p ->
match p with
| Raw.Name v -> (v.value , [])
| Raw.Path p -> (
@ -277,8 +277,8 @@ let rec simpl_expression :
let path' =
let aux (s:Raw.selection) =
match s with
| FieldName property -> Access_record property.value
| Component index -> Access_tuple (Z.to_int (snd index.value))
| FieldName property -> Label property.value
| Component index -> Label (Z.to_string (snd index.value))
in
List.map aux @@ npseq_to_list path in
(var , path')
@ -289,7 +289,9 @@ let rec simpl_expression :
let (name, path) = simpl_path u.record in
let record = match path with
| [] -> e_variable (Var.of_name name)
| _ -> e_accessor (e_variable (Var.of_name name)) path in
| _ ->
let aux expr (Label l) = e_accessor expr l in
List.fold_left aux (e_variable (Var.of_name name)) path in
let updates = u.updates.value.ne_elements in
let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) =
@ -304,7 +306,7 @@ let rec simpl_expression :
| [] -> failwith "error in parsing"
| hd :: [] -> ok @@ e_update ~loc record hd expr
| hd :: tl ->
let%bind expr = (aux (e_accessor ~loc record [Access_record hd]) tl) in
let%bind expr = (aux (e_accessor ~loc record hd) tl) in
ok @@ e_update ~loc record hd expr
in
aux ur path in
@ -352,19 +354,20 @@ let rec simpl_expression :
match variables with
| hd :: [] ->
if (List.length prep_vars = 1)
then e_let_in hd inline rhs_b_expr body
else e_let_in hd inline (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - 1)]) body
then e_let_in hd false inline rhs_b_expr body
else e_let_in hd false inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body
| hd :: tl ->
e_let_in hd
false
inline
(e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)])
(e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - (List.length tl) - 1)))
(chain_let_in tl body)
| [] -> body (* Precluded by corner case assertion above *)
in
if List.length prep_vars = 1
then ok (chain_let_in prep_vars body)
(* Bind the right hand side so we only evaluate it once *)
else ok (e_let_in (rhs_b, ty_opt) inline rhs' (chain_let_in prep_vars body))
else ok (e_let_in (rhs_b, ty_opt) false inline rhs' (chain_let_in prep_vars body))
(* let f p1 ps... = rhs in body *)
| (f, p1 :: ps) ->
@ -413,8 +416,7 @@ let rec simpl_expression :
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v))
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ npseq_to_list r.ne_elements in
let map = SMap.of_list fields in
return @@ e_record ~loc map
return @@ e_record_ez ~loc fields
| EProj p -> simpl_projection p
| EUpdate u -> simpl_update u
| EConstr (ESomeApp a) ->
@ -501,7 +503,7 @@ let rec simpl_expression :
| Raw.PVar y ->
let var_name = Var.of_name y.value in
let%bind type_expr = simpl_type_expression x'.type_expr in
return @@ e_let_in (var_name , Some type_expr) false e rhs
return @@ e_let_in (var_name , Some type_expr) false false e rhs
| _ -> default_action ()
)
| _ -> default_action ()
@ -810,7 +812,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , None , inline, rhs'))]
)
and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result =
and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result =
fun t ->
let open Raw in
let rec get_var (t:Raw.pattern) =
@ -931,5 +933,5 @@ and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result =
in bind_or (as_option () , as_variant ())
let simpl_program : Raw.ast -> program result = fun t ->
let%bind decls = bind_list (List.map simpl_declaration @@ nseq_to_list t.decl) in
let%bind decls = bind_map_list simpl_declaration @@ nseq_to_list t.decl in
ok @@ List.concat @@ decls

662
src/passes/2-simplify/pascaligo.ml
View File

@ -16,17 +16,17 @@ let pseq_to_list = function
let get_value : 'a Raw.reg -> 'a = fun x -> x.value
let is_compiler_generated name = String.contains (Var.to_name name) '#'
let detect_local_declarations (for_body : expression) =
let _detect_local_declarations (for_body : expression) =
let%bind aux = Self_ast_simplified.fold_expression
(fun (nlist, cur_loop : expression_variable list * bool) (ass_exp : expression) ->
if cur_loop then
match ass_exp.expression with
| E_let_in {binder;rhs = _;result = _} ->
let (name,_) = binder in
match ass_exp.expression_content with
| E_let_in {let_binder;mut=false;rhs = _;let_result = _} ->
let (name,_) = let_binder in
ok (name::nlist, cur_loop)
| E_constant (C_MAP_FOLD, _)
| E_constant (C_SET_FOLD, _)
| E_constant (C_LIST_FOLD, _) -> ok @@ (nlist, false)
| E_constant {cons_name=C_MAP_FOLD;arguments= _}
| E_constant {cons_name=C_SET_FOLD;arguments= _}
| E_constant {cons_name=C_LIST_FOLD;arguments= _} -> ok @@ (nlist, false)
| _ -> ok (nlist, cur_loop)
else
ok @@ (nlist, cur_loop)
@ -35,17 +35,14 @@ let detect_local_declarations (for_body : expression) =
for_body in
ok @@ fst aux
let detect_free_variables (for_body : expression) (local_decl_names : expression_variable list) =
let _detect_free_variables (for_body : expression) (local_decl_names : expression_variable list) =
let%bind captured_names = Self_ast_simplified.fold_expression
(fun (prev : expression_variable list) (ass_exp : expression) ->
match ass_exp.expression with
| E_assign ( name , _ , _ ) ->
if is_compiler_generated name then ok prev
else ok (name::prev)
| E_constant (n, [a;b])
match ass_exp.expression_content with
| E_constant {cons_name=n;arguments=[a;b]}
when n=C_OR || n=C_AND || n=C_LT || n=C_GT ||
n=C_LE || n=C_GE || n=C_EQ || n=C_NEQ -> (
match (a.expression,b.expression) with
match (a.expression_content,b.expression_content) with
| E_variable na , E_variable nb ->
let ret = [] in
let ret = if not (is_compiler_generated na) then
@ -66,6 +63,92 @@ let detect_free_variables (for_body : expression) (local_decl_names : expression
ok @@ SSet.elements
@@ SSet.diff (SSet.of_list captured_names) (SSet.of_list local_decl_names)
and repair_mutable_variable (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
let%bind captured_names = Self_ast_simplified.fold_map_expression
(* TODO : these should use Variables sets *)
(fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) ->
match ass_exp.expression_content with
| E_let_in {let_binder;mut=false;rhs;let_result} ->
let (name,_) = let_binder in
ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result)
| E_let_in {let_binder;mut=true; rhs;let_result} ->
let (name,_) = let_binder in
if List.mem name decl_var then
ok (true,(decl_var, free_var), e_let_in let_binder false false rhs let_result)
else(
let free_var = if (List.mem name free_var) then free_var else name::free_var in
let expr = e_let_in (env,None) false false (e_update (e_variable env) (Var.show name) (e_variable name)) let_result in
ok (true,(decl_var, free_var), e_let_in let_binder false false rhs expr)
)
| E_variable name ->
if List.mem name decl_var || List.mem name free_var || Var.equal name env then
ok (true,(decl_var, free_var), e_variable name)
else
ok (true, (decl_var, name::free_var), e_variable name)
| E_constant {cons_name=C_MAP_FOLD;arguments= _}
| E_constant {cons_name=C_SET_FOLD;arguments= _}
| E_constant {cons_name=C_LIST_FOLD;arguments= _}
| E_matching _ -> ok @@ (false, (decl_var,free_var),ass_exp)
| _ -> ok (true, (decl_var, free_var),ass_exp)
)
(element_names,[])
for_body in
ok @@ captured_names
and repair_mutable_variable_for_collect (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
let%bind captured_names = Self_ast_simplified.fold_map_expression
(* TODO : these should use Variables sets *)
(fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) ->
match ass_exp.expression_content with
| E_let_in {let_binder;mut=false;rhs;let_result} ->
let (name,_) = let_binder in
ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result)
| E_let_in {let_binder;mut=true; rhs;let_result} ->
let (name,_) = let_binder in
if List.mem name decl_var then
ok (true,(decl_var, free_var), e_let_in let_binder false false rhs let_result)
else(
let free_var = if (List.mem name free_var) then free_var else name::free_var in
let expr = e_let_in (env,None) false false (
e_update (e_variable env) ("0")
(e_update (e_accessor (e_variable env) "0") (Var.show name) (e_variable name))
)
let_result in
ok (true,(decl_var, free_var), e_let_in let_binder false false rhs expr)
)
| E_variable name ->
if List.mem name decl_var || List.mem name free_var || Var.equal name env then
ok (true,(decl_var, free_var), e_variable name)
else
ok (true,(decl_var, name::free_var), e_variable name)
| E_constant {cons_name=C_MAP_FOLD;arguments= _}
| E_constant {cons_name=C_SET_FOLD;arguments= _}
| E_constant {cons_name=C_LIST_FOLD;arguments= _}
| E_matching _ -> ok @@ (false,(decl_var,free_var),ass_exp)
| _ -> ok (true,(decl_var, free_var),ass_exp)
)
(element_names,[])
for_body in
ok @@ captured_names
and store_mutable_variable (free_vars : expression_variable list) =
if (List.length free_vars == 0) then
e_unit ()
else
let aux var = (Var.show var, e_variable var) in
e_record_ez (List.map aux free_vars)
and restore_mutable_variable (expr : expression) (free_vars : expression_variable list) (env :expression_variable) =
let aux (f:expression -> expression) (ev:expression_variable) =
ok @@ fun expr -> f (e_let_in (ev,None) true false (e_accessor (e_variable env) (Var.show ev)) expr)
in
let%bind ef = bind_fold_list aux (fun e -> e) free_vars in
ok @@ fun expr'_opt -> match expr'_opt with
| None -> ok @@ e_let_in (env,None) false false expr (ef (e_skip ()))
| Some expr' -> ok @@ e_let_in (env,None) false false expr (ef expr')
module Errors = struct
let unsupported_cst_constr p =
let title () = "" in
@ -78,18 +161,6 @@ module Errors = struct
] in
error ~data title message
let corner_case ~loc message =
let title () = "\nCorner case" in
let content () = "We do not have a good error message for this case. \
We are striving find ways to better report them and \
find the use-cases that generate them. \
Please report this to the developers.\n" in
let data = [
("location" , fun () -> loc) ;
("message" , fun () -> message) ;
] in
error ~data title content
let unknown_predefined_type name =
let title () = "\nType constants" in
let message () =
@ -196,16 +267,17 @@ let r_split = Location.r_split
[return_statement] is used for non-let-in statements.
*)
let return_let_in ?loc binder inline rhs = ok @@ fun expr'_opt ->
let return_let_in ?loc binder mut inline rhs = ok @@ fun expr'_opt ->
match expr'_opt with
| None -> fail @@ corner_case ~loc:__LOC__ "missing return"
| Some expr' -> ok @@ e_let_in ?loc binder inline rhs expr'
| None -> ok @@ e_let_in ?loc binder mut inline rhs (e_skip ())
| Some expr' -> ok @@ e_let_in ?loc binder mut inline rhs expr'
let return_statement expr = ok @@ fun expr'_opt ->
match expr'_opt with
| None -> ok @@ expr
| Some expr' -> ok @@ e_sequence expr expr'
let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
match t with
TPar x -> simpl_type_expression x.value.inside
@ -218,7 +290,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
let%bind (a , b) =
let (a , _ , b) = x.value in
bind_map_pair simpl_type_expression (a , b) in
ok @@ make_t @@ T_arrow (a , b)
ok @@ make_t @@ T_arrow {type1=a;type2=b}
)
| TApp x ->
let (name, tuple) = x.value in
@ -268,7 +340,7 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
| [hd] -> simpl_type_expression hd
| lst ->
let%bind lst = bind_list @@ List.map simpl_type_expression lst in
ok @@ make_t @@ T_operator (TC_tuple lst)
ok @@ t_tuple lst
let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
let (p' , loc) = r_split p in
@ -279,11 +351,11 @@ let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
let path' =
let aux (s:Raw.selection) =
match s with
| FieldName property -> Access_record property.value
| Component index -> Access_tuple (Z.to_int (snd index.value))
| FieldName property -> property.value
| Component index -> (Z.to_string (snd index.value))
in
List.map aux @@ npseq_to_list path in
ok @@ e_accessor ~loc var path'
ok @@ List.fold_left (e_accessor ~loc) var path'
let rec simpl_expression (t:Raw.expr) : expr result =
@ -409,7 +481,11 @@ let rec simpl_expression (t:Raw.expr) : expr result =
let%bind expr = simpl_expression c.test in
let%bind match_true = simpl_expression c.ifso in
let%bind match_false = simpl_expression c.ifnot in
return @@ e_matching expr ~loc (Match_bool {match_true; match_false})
let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in
let env = Var.fresh () in
let%bind (_, match_expr) = repair_mutable_variable match_expr [] env in
return @@ match_expr
| ECase c -> (
let (c , loc) = r_split c in
let%bind e = simpl_expression c.expr in
@ -422,7 +498,10 @@ let rec simpl_expression (t:Raw.expr) : expr result =
@@ List.map get_value
@@ npseq_to_list c.cases.value in
let%bind cases = simpl_cases lst in
return @@ e_matching ~loc e cases
let match_expr = e_matching ~loc e cases in
let env = Var.fresh () in
let%bind (_, match_expr) = repair_mutable_variable match_expr [] env in
return @@ match_expr
)
| EMap (MapInj mi) -> (
let (mi , loc) = r_split mi in
@ -471,7 +550,7 @@ and simpl_update = fun (u:Raw.update Region.reg) ->
let (name, path) = simpl_path u.record in
let record = match path with
| [] -> e_variable (Var.of_name name)
| _ -> e_accessor (e_variable (Var.of_name name)) path in
| _ -> e_accessor_list (e_variable (Var.of_name name)) path in
let updates = u.updates.value.ne_elements in
let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) =
@ -486,7 +565,7 @@ and simpl_update = fun (u:Raw.update Region.reg) ->
| [] -> failwith "error in parsing"
| hd :: [] -> ok @@ e_update ~loc record hd expr
| hd :: tl ->
let%bind expr = (aux (e_accessor ~loc record [Access_record hd]) tl) in
let%bind expr = (aux (e_accessor ~loc record hd) tl) in
ok @@ e_update ~loc record hd expr
in
aux ur path in
@ -584,7 +663,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
let name = x.name.value in
let%bind t = simpl_type_expression x.var_type in
let%bind expression = simpl_expression x.init in
return_let_in ~loc (Var.of_name name, Some t) false expression
return_let_in ~loc (Var.of_name name, Some t) false false expression
| LocalConst x ->
let (x , loc) = r_split x in
let name = x.name.value in
@ -596,7 +675,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
| Some {value; _} ->
npseq_to_list value.ne_elements
|> List.exists (fun Region.{value; _} -> value = "\"inline\"")
in return_let_in ~loc (Var.of_name name, Some t) inline expression
in return_let_in ~loc (Var.of_name name, Some t) false inline expression
| LocalFun f ->
let (f , loc) = r_split f in
let%bind (binder, expr) = simpl_fun_decl ~loc f in
@ -606,22 +685,22 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
| Some {value; _} ->
npseq_to_list value.ne_elements
|> List.exists (fun Region.{value; _} -> value = "\"inline\"")
in return_let_in ~loc binder inline expr
in return_let_in ~loc binder false inline expr
and simpl_param :
Raw.param_decl -> (expression_variable * type_expression) result =
Raw.param_decl -> (string * type_expression) result =
fun t ->
match t with
| ParamConst c ->
let c = c.value in
let type_name = Var.of_name c.var.value in
let param_name = c.var.value in
let%bind type_expression = simpl_type_expression c.param_type in
ok (type_name , type_expression)
ok (param_name , type_expression)
| ParamVar v ->
let c = v.value in
let type_name = Var.of_name c.var.value in
let param_name = c.var.value in
let%bind type_expression = simpl_type_expression c.param_type in
ok (type_name , type_expression)
ok (param_name , type_expression)
and simpl_fun_decl :
loc:_ -> Raw.fun_decl ->
@ -652,10 +731,10 @@ and simpl_fun_decl :
let%bind result =
let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in
let expression : expression = e_lambda ~loc binder (Some input_type)
let expression : expression = e_lambda ~loc (Var.of_name binder) (Some input_type)
(Some output_type) result in
let type_annotation =
Some (make_t @@ T_arrow (input_type, output_type)) in
Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
ok ((Var.of_name fun_name.value, type_annotation), expression)
)
| lst -> (
@ -667,11 +746,11 @@ and simpl_fun_decl :
let type_expression = t_tuple (List.map snd params) in
(arguments_name , type_expression) in
let%bind tpl_declarations =
let aux = fun i x ->
let aux = fun i (param, type_expr) ->
let expr =
e_accessor (e_variable arguments_name) [Access_tuple i] in
let type_variable = Some (snd x) in
let ass = return_let_in (fst x , type_variable) inline expr in
e_accessor (e_variable arguments_name) (string_of_int i) in
let type_variable = Some type_expr in
let ass = return_let_in (Var.of_name param , type_variable) false inline expr in
ass
in
bind_list @@ List.mapi aux params in
@ -683,8 +762,8 @@ and simpl_fun_decl :
let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in
let expression =
e_lambda ~loc binder (Some input_type) (Some output_type) result in
let type_annotation = Some (make_t @@ T_arrow (input_type, output_type)) in
e_lambda ~loc binder (Some (input_type)) (Some output_type) result in
let type_annotation = Some (make_t @@ T_arrow {type1=input_type; type2=output_type}) in
ok ((Var.of_name fun_name.value, type_annotation), expression)
)
)
@ -706,11 +785,10 @@ and simpl_fun_expression :
let%bind result =
let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in
let expression : expression = e_lambda ~loc binder (Some input_type)
let expression : expression = e_lambda ~loc (Var.of_name binder) (Some input_type)
(Some output_type) result in
let type_annotation =
Some (make_t @@ T_arrow (input_type, output_type)) in
ok (type_annotation, expression)
let type_annotation = Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
ok (type_annotation , expression)
)
| lst -> (
let lst = npseq_to_list lst in
@ -721,11 +799,10 @@ and simpl_fun_expression :
let type_expression = t_tuple (List.map snd params) in
(arguments_name , type_expression) in
let%bind tpl_declarations =
let aux = fun i x ->
let expr =
e_accessor (e_variable arguments_name) [Access_tuple i] in
let type_variable = Some (snd x) in
let ass = return_let_in (fst x , type_variable) false expr in
let aux = fun i (param, param_type) ->
let expr = e_accessor (e_variable arguments_name) (string_of_int i) in
let type_variable = Some param_type in
let ass = return_let_in (Var.of_name param , type_variable) false false expr in
ass
in
bind_list @@ List.mapi aux params in
@ -738,8 +815,8 @@ and simpl_fun_expression :
bind_fold_right_list aux result body in
let expression =
e_lambda ~loc binder (Some (input_type)) (Some output_type) result in
let type_annotation = Some (make_t @@ T_arrow (input_type, output_type)) in
ok (type_annotation, expression)
let type_annotation = Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
ok (type_annotation , expression)
)
)
@ -770,6 +847,35 @@ and simpl_statement_list statements =
hook (simpl_data_declaration d :: acc) statements
in bind_list @@ hook [] (List.rev statements)
and get_case_variables (t:Raw.pattern) : expression_variable list result =
match t with
| PConstr PFalse _
| PConstr PTrue _
| PConstr PNone _ -> ok @@ []
| PConstr PSomeApp v -> (let (_,v) = v.value in get_case_variables (v.value.inside))
| PConstr PConstrApp v -> (
match v.value with
| constr, None -> ok @@ [ Var.of_name constr.value]
| constr, pat_opt ->
let%bind pat =
trace_option (unsupported_cst_constr t) @@
pat_opt in
let pat = npseq_to_list pat.value.inside in
let%bind var = bind_map_list get_case_variables pat in
ok @@ [Var.of_name constr.value ] @ (List.concat var)
)
| PList PNil _ -> ok @@ []
| PList PCons c -> (
match c.value with
| a, [(_, b)] ->
let%bind a = get_case_variables a in
let%bind b = get_case_variables b in
ok @@ a@b
| _ -> fail @@ unsupported_deep_list_patterns c
)
| PVar v -> ok @@ [Var.of_name v.value]
| p -> fail @@ unsupported_cst_constr p
and simpl_single_instruction : Raw.instruction -> (_ -> expression result) result =
fun t ->
match t with
@ -799,19 +905,14 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
return_statement @@ e_skip ~loc ()
)
| Loop (While l) ->
let l = l.value in
let%bind cond = simpl_expression l.cond in
let%bind body = simpl_block l.block.value in
let%bind body = body None in
return_statement @@ e_loop cond body
| Loop (For (ForInt fi)) ->
simpl_while_loop l.value
| Loop (For (ForInt fi)) -> (
let%bind loop = simpl_for_int fi.value in
let%bind loop = loop None in
return_statement @@ loop
ok loop
)
| Loop (For (ForCollect fc)) ->
let%bind loop = simpl_for_collect fc.value in
let%bind loop = loop None in
return_statement @@ loop
ok loop
| Cond c -> (
let (c , loc) = r_split c in
let%bind expr = simpl_expression c.test in
@ -833,9 +934,22 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
simpl_block value
| ShortBlock {value; _} ->
simpl_statements @@ fst value.inside in
let%bind match_true = match_true None in
let%bind match_false = match_false None in
return_statement @@ e_matching expr ~loc (Match_bool {match_true; match_false})
let env = Var.fresh () in
let%bind match_true' = match_true None in
let%bind match_false' = match_false None in
let%bind match_true = match_true @@ Some (e_variable env) in
let%bind match_false = match_false @@ Some (e_variable env) in
let%bind ((_,free_vars_true), match_true) = repair_mutable_variable match_true [] env in
let%bind ((_,free_vars_false), match_false) = repair_mutable_variable match_false [] env in
let free_vars = free_vars_true @ free_vars_false in
if (List.length free_vars != 0) then
let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in
let return_expr = e_let_in (env,None) false false (store_mutable_variable free_vars) match_expr in
restore_mutable_variable return_expr free_vars env
else
return_statement @@ e_matching expr ~loc (Match_bool {match_true=match_true'; match_false=match_false'})
)
| Assign a -> (
let (a , loc) = r_split a in
@ -843,7 +957,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
match a.lhs with
| Path path -> (
let (name , path') = simpl_path path in
return_statement @@ e_assign ~loc name path' value_expr
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in
return_let_in let_binder mut inline rhs
)
| MapPath v -> (
let v' = v.value in
@ -856,14 +971,16 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
in
let%bind key_expr = simpl_expression v'.index.value.inside in
let expr' = e_map_add key_expr value_expr map in
return_statement @@ e_assign ~loc varname path expr'
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in
return_let_in let_binder mut inline rhs
)
)
| CaseInstr c -> (
let (c , loc) = r_split c in
let%bind expr = simpl_expression c.expr in
let%bind cases =
let aux (x : Raw.if_clause Raw.case_clause Raw.reg) =
let env = Var.fresh () in
let%bind (fv,cases) =
let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) =
let%bind case_clause =
match x.value.rhs with
ClauseInstr i ->
@ -874,42 +991,43 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
simpl_block value
| ShortBlock {value; _} ->
simpl_statements @@ fst value.inside in
let%bind case_clause = case_clause None in
ok (x.value.pattern, case_clause) in
bind_list
@@ List.map aux
@@ npseq_to_list c.cases.value in
let%bind case_clause'= case_clause @@ None in
let%bind case_clause = case_clause @@ Some(e_variable env) in
let%bind case_vars = get_case_variables x.value.pattern in
let%bind ((_,free_vars), case_clause) = repair_mutable_variable case_clause case_vars env in
ok (free_vars::fv,(x.value.pattern, case_clause, case_clause')) in
bind_fold_map_list aux [] (npseq_to_list c.cases.value) in
let free_vars = List.concat fv in
if (List.length free_vars == 0) then (
let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
let%bind m = simpl_cases cases in
return_statement @@ e_matching ~loc expr m
) else (
let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in
let%bind m = simpl_cases cases in
let match_expr = e_matching ~loc expr m in
let return_expr = e_let_in (env,None) false false (store_mutable_variable free_vars) match_expr in
restore_mutable_variable return_expr free_vars env
)
)
| RecordPatch r -> (
let r = r.value in
let (name , access_path) = simpl_path r.path in
let head, tail = r.record_inj.value.ne_elements in
let%bind tail' = bind_list
@@ List.map (fun (x: Raw.field_assign Region.reg) ->
let (x , loc) = r_split x in
let%bind e = simpl_expression x.field_expr
in ok (x.field_name.value, e , loc)
)
@@ List.map snd tail in
let%bind head' =
let (x , loc) = r_split head in
let%bind e = simpl_expression x.field_expr
in ok (x.field_name.value, e , loc) in
let%bind expr =
let aux = fun (access , v , loc) ->
e_assign ~loc name (access_path @ [Access_record access]) v in
let hd, tl = aux head', List.map aux tail' in
let aux acc cur = e_sequence acc cur in
ok @@ List.fold_left aux hd tl
let reg = r.region in
let (r,loc) = r_split r in
let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg=
{value = {field_path = (fa.value.field_name, []); equal=fa.value.equal; field_expr = fa.value.field_expr};
region = fa.region}
in
return_statement @@ expr
let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = {
value = Raw.map_ne_injection aux r.record_inj.value;
region=r.record_inj.region
} in
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
let%bind expr = simpl_update {value=u;region=reg} in
let (name , access_path) = simpl_path r.path in
let loc = Some loc in
let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in
return_let_in binder mut inline rhs
)
| MapPatch patch -> (
let (map_p, loc) = r_split patch in
@ -923,16 +1041,16 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
in ok @@ (key', value')
)
@@ npseq_to_list map_p.map_inj.value.ne_elements in
let expr =
match inj with
| [] -> e_skip ~loc ()
| [] -> return_statement @@ e_skip ~loc ()
| _ :: _ ->
let assigns = List.fold_right
(fun (key, value) map -> (e_map_add key value map))
inj
(e_accessor ~loc (e_variable (Var.of_name name)) access_path)
in e_assign ~loc name access_path assigns
in return_statement @@ expr
(e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
return_let_in binder mut inline rhs
)
| SetPatch patch -> (
let (setp, loc) = r_split patch in
@ -941,15 +1059,14 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
bind_list @@
List.map simpl_expression @@
npseq_to_list setp.set_inj.value.ne_elements in
let expr =
match inj with
| [] -> e_skip ~loc ()
| [] -> return_statement @@ e_skip ~loc ()
| _ :: _ ->
let assigns = List.fold_right
(fun hd s -> e_constant C_SET_ADD [hd ; s])
inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
e_assign ~loc name access_path assigns in
return_statement @@ expr
inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
return_let_in binder mut inline rhs
)
| MapRemove r -> (
let (v , loc) = r_split r in
@ -963,7 +1080,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
in
let%bind key' = simpl_expression key in
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
return_statement @@ e_assign ~loc varname path expr
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
return_let_in binder mut inline rhs
)
| SetRemove r -> (
let (set_rm, loc) = r_split r in
@ -976,10 +1094,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
in
let%bind removed' = simpl_expression set_rm.element in
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
return_statement @@ e_assign ~loc varname path expr
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
return_let_in binder mut inline rhs
)
and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
and simpl_path : Raw.path -> string * string list = fun p ->
match p with
| Raw.Name v -> (v.value , [])
| Raw.Path p -> (
@ -989,14 +1108,14 @@ and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
let path' =
let aux (s:Raw.selection) =
match s with
| FieldName property -> Access_record property.value
| Component index -> Access_tuple (Z.to_int (snd index.value))
| FieldName property -> property.value
| Component index -> (Z.to_string (snd index.value))
in
List.map aux @@ npseq_to_list path in
(var , path')
)
and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result = fun t ->
and simpl_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
let open Raw in
let get_var (t:Raw.pattern) =
match t with
@ -1105,223 +1224,108 @@ and simpl_statements : Raw.statements -> (_ -> expression result) result =
and simpl_block : Raw.block -> (_ -> expression result) result =
fun t -> simpl_statements t.statements
and simpl_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl ->
let env_rec = Var.fresh () in
let binder = Var.fresh () in
let%bind cond = simpl_expression wl.cond in
let%bind for_body = simpl_block wl.block.value in
let ctrl =
(e_variable binder)
in
let%bind for_body = for_body @@ Some( ctrl ) in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable for_body [] binder in
let aux name expr=
e_let_in (name,None) false false (e_accessor (e_variable binder) (Var.to_name name)) expr
in
let init_rec = store_mutable_variable @@ captured_name_list in
let restore = fun expr -> List.fold_right aux captured_name_list expr in
let continue_expr = e_constant C_CONTINUE [for_body] in
let stop_expr = e_constant C_STOP [e_variable binder] in
let aux_func = e_cond cond continue_expr (stop_expr) in
let aux_func = (restore (aux_func)) in
let aux_func = e_lambda binder None None @@ aux_func in
let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in
let return_expr = e_let_in (env_rec,None) false false init_rec (loop) in
restore_mutable_variable return_expr captured_name_list env_rec
and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
(* cond part *)
let var = e_variable (Var.of_name fi.assign.value.name.value) in
let env_rec = Var.fresh () in
let binder = Var.fresh () in
let name = fi.assign.value.name.value in
let it = Var.of_name name in
let var = e_variable it in
(*Make the cond and the step *)
let%bind value = simpl_expression fi.assign.value.expr in
let%bind bound = simpl_expression fi.bound in
let comp = e_annotation (e_constant C_LE [var ; bound]) t_bool
in
(* body part *)
let%bind body = simpl_block fi.block.value in
let%bind body = body None in
let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in
let step = e_int 1 in
let ctrl = e_assign
fi.assign.value.name.value [] (e_constant C_ADD [ var ; step ]) in
let rec add_to_seq expr = match expr.expression with
| E_sequence (_,a) -> add_to_seq a
| _ -> e_sequence body ctrl in
let body' = add_to_seq body in
let loop = e_loop comp body' in
return_statement @@ e_let_in (Var.of_name fi.assign.value.name.value, Some t_int) false value loop
let ctrl =
e_let_in (it,Some t_int) false false (e_constant C_ADD [ var ; step ])
(e_let_in (binder, None) false false (e_update (e_variable binder) name var)
(e_variable binder))
in
(* Modify the body loop*)
let%bind for_body = simpl_block fi.block.value in
let%bind for_body = for_body @@ Some( ctrl ) in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable for_body [it] binder in
(** simpl_for_collect
For loops over collections, like
let aux name expr=
e_let_in (name,None) false false (e_accessor (e_variable binder) (Var.to_name name)) expr
in
``` concrete syntax :
for x : int in set myset
begin
myint := myint + x ;
myst := myst ^ "to" ;
end
```
(* restores the initial value of the free_var*)
let restore = fun expr -> List.fold_right aux captured_name_list expr in
are implemented using a MAP_FOLD, LIST_FOLD or SET_FOLD:
(*Prep the lambda for the fold*)
let continue_expr = e_constant C_CONTINUE [for_body] in
let stop_expr = e_constant C_STOP [e_variable binder] in
let aux_func = e_cond cond continue_expr (stop_expr) in
let aux_func = e_let_in (it,Some t_int) false false (e_accessor (e_variable binder) name) (restore (aux_func)) in
let aux_func = e_lambda binder None None @@ aux_func in
``` pseudo Ast_simplified
let #COMPILER#folded_record = list_fold( mylist ,
record st = st; acc = acc; end;
lamby = fun arguments -> (
let #COMPILER#acc = arguments.0 in
let #COMPILER#elt_x = arguments.1 in
#COMPILER#acc.myint := #COMPILER#acc.myint + #COMPILER#elt_x ;
#COMPILER#acc.myst := #COMPILER#acc.myst ^ "to" ;
#COMPILER#acc
)
) in
{
myst := #COMPILER#folded_record.myst ;
myint := #COMPILER#folded_record.myint ;
}
```
(* Make the fold_while en precharge the vakye *)
let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in
let init_rec = store_mutable_variable @@ it::captured_name_list in
let return_expr = e_let_in (env_rec,None) false false init_rec (loop) in
let return_expr = e_let_in (it, Some t_int) false false value @@ return_expr in
restore_mutable_variable return_expr captured_name_list env_rec
We are performing the following steps:
1) Simplifying the for body using ̀simpl_block`
2) Detect the free variables and build a list of their names
(myint and myst in the previous example)
Free variables are simply variables being assigned but not defined
locally.
Note: In the case of a nested loops, assignements to a compiler
generated value (#COMPILER#acc) correspond to variables
that were already renamed in the inner loop.
e.g :
```
#COMPILER#acc.myint := #COMPILER#acc.myint + #COMPILER#elt_x ;
#COMPILER#acc.myst := #COMPILER#acc.myst ^ "to" ;
```
They must not be considered as free variables
3) Build the initial record (later passed as 2nd argument of
`MAP/SET/LIST_FOLD`) capturing the environment using the
free variables list of (2)
4) In the filtered body of (1), replace occurences:
- free variable of name X as rhs ==> accessor `#COMPILER#acc.X`
- free variable of name X as lhs ==> accessor `#COMPILER#acc.X`
And, in the case of a map:
- references to the iterated key ==> variable `#COMPILER#elt_K`
- references to the iterated value ==> variable `#COMPILER#elt_V`
in the case of a set/list:
- references to the iterated value ==> variable `#COMPILER#elt_X`
Note: In the case of an inner loop capturing variable from an outer loop
the free variable name can be `#COMPILER#acc.Y` and because we do not
capture the accumulator record in the inner loop, we do not want to
generate `#COMPILER#acc.#COMPILER#acc.Y` but `#COMPILER#acc.Y`
5) Append the return value to the body
6) Prepend the declaration of the lambda arguments to the body which
is a serie of `let .. in`'s
Note that the parameter of the lambda ̀arguments` is a tree of
tuple holding:
* In the case of `list` or ̀set`:
( folding record , current list/set element ) as
( #COMPILER#acc , #COMPILER#elt_X )
* In the case of `map`:
( folding record , current map key , current map value ) as
( #COMPILER#acc , #COMPILER#elt_K , #COMPILER#elt_V )
Note: X , K and V above have to be replaced with their given name
7) Build the lambda using the final body of (6)
8) Build a sequence of assignments for all the captured variables
to their new value, namely an access to the folded record
(#COMPILER#folded_record)
9) Attach the sequence of 8 to the ̀let .. in` declaration
of #COMPILER#folded_record
**)
and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc ->
let elt_name = "#COMPILER#elt_"^fc.var.value in
let elt_v_name = match fc.bind_to with
| Some v -> "#COMPILER#elt_"^(snd v).value
| None -> "#COMPILER#elt_unused" in
let element_names = ok @@ match fc.bind_to with
let _elt_name = fc.var.value in
let binder = Var.of_name "arguments" in
let%bind element_names = ok @@ match fc.bind_to with
| Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value]
| None -> [Var.of_name fc.var.value] in
(* STEP 1 *)
let env = Var.fresh () in
let%bind for_body = simpl_block fc.block.value in
let%bind for_body = for_body None in
(* STEP 2 *)
let%bind local_decl_name_list = bind_concat (detect_local_declarations for_body) element_names in
let%bind captured_name_list = detect_free_variables for_body local_decl_name_list in
(* STEP 3 *)
let add_to_record (prev: expression SMap.t) (captured_name: string) =
SMap.add captured_name (e_variable (Var.of_name captured_name)) prev in
let init_record = e_record (List.fold_left add_to_record SMap.empty captured_name_list) in
(* STEP 4 *)
let replace exp =
match exp.expression with
(* replace references to fold accumulator as lhs *)
| E_assign ( name , path , expr ) -> (
if (List.mem name local_decl_name_list ) then
ok @@ exp
else
let name = Var.to_name name in
let path' = List.filter
( fun el ->
match el with
| Access_record name -> not @@ is_compiler_generated (Var.of_name name)
| _ -> true )
((Access_record name)::path) in
ok @@ e_assign "#COMPILER#acc" path' expr )
| E_variable name -> (
let name = Var.to_name name in
if (List.mem name captured_name_list) then
(* replace references to fold accumulator as rhs *)
ok @@ e_accessor (e_variable (Var.of_name "#COMPILER#acc")) [Access_record name] (* TODO fresh *)
else match fc.collection with
(* loop on map *)
| Map _ ->
let k' = e_variable (Var.of_name elt_name) in
if ( name = fc.var.value ) then
ok @@ k' (* replace references to the the key *)
else (
match fc.bind_to with
| Some (_,v) ->
let v' = e_variable (Var.of_name elt_v_name) in
if ( name = v.value ) then
ok @@ v' (* replace references to the the value *)
else ok @@ exp
| None -> ok @@ exp
)
(* loop on set or list *)
| (Set _ | List _) ->
if (name = fc.var.value ) then
(* replace references to the collection element *)
ok @@ (e_variable (Var.of_name elt_name))
else ok @@ exp
)
| _ -> ok @@ exp in
let%bind for_body = Self_ast_simplified.map_expression replace for_body in
(* STEP 5 *)
let rec add_return (expr : expression) = match expr.expression with
| E_sequence (a,b) -> e_sequence a (add_return b)
| _ -> (* TODO fresh *)
e_sequence expr (e_variable (Var.of_name "#COMPILER#acc")) in
let for_body = add_return for_body in
(* STEP 6 *)
let for_body =
let ( arg_access: Types.access_path -> expression ) =
e_accessor (e_variable (Var.of_name "arguments")) in (* TODO fresh *)
( match fc.collection with
| Map _ ->
let acc = arg_access [Access_tuple 0 ] in
let collec_elt_v = arg_access [Access_tuple 1 ; Access_tuple 0] in
let collec_elt_k = arg_access [Access_tuple 1 ; Access_tuple 1] in
e_let_in (Var.of_name "#COMPILER#acc", None) false acc @@ (* TODO fresh *)
e_let_in (Var.of_name elt_name, None) false collec_elt_v @@
e_let_in (Var.of_name elt_v_name, None) false collec_elt_k (for_body)
| _ ->
let acc = arg_access [Access_tuple 0] in
let collec_elt = arg_access [Access_tuple 1] in
e_let_in (Var.of_name "#COMPILER#acc", None) false acc @@ (* TODO fresh *)
e_let_in (Var.of_name elt_name, None) false collec_elt (for_body)
) in
(* STEP 7 *)
let%bind _for_body' = for_body None in
let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in
let%bind ((_,free_vars), for_body) = repair_mutable_variable_for_collect for_body element_names binder in
let init_record = store_mutable_variable free_vars in
let%bind collect = simpl_expression fc.expr in
let lambda = e_lambda (Var.of_name "arguments") None None for_body in
let aux name expr=
e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr
in
let restore = fun expr -> List.fold_right aux free_vars expr in
let restore = match fc.collection with
| Map _ -> (match fc.bind_to with
| Some v -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0")
(e_let_in (Var.of_name (snd v).value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "1") expr))
| None -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0") expr)
)
| _ -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_variable binder) "1") expr)
in
let lambda = e_lambda binder None None (restore for_body) in
let op_name = match fc.collection with
| Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in
let fold = e_constant op_name [lambda; collect ; init_record] in
(* STEP 8 *)
let assign_back (prev : expression option) (captured_varname : string) : expression option =
let access = (* TODO fresh *)
e_accessor (e_variable (Var.of_name "#COMPILER#folded_record"))
[Access_record captured_varname] in
let assign = e_assign captured_varname [] access in
match prev with
| None -> Some assign
| Some p -> Some (e_sequence p assign) in
let reassign_sequence = List.fold_left assign_back None captured_name_list in
(* STEP 9 *)
let final_sequence = match reassign_sequence with
(* None case means that no variables were captured *)
| None -> e_skip ()
| Some seq -> e_let_in (Var.of_name "#COMPILER#folded_record", None) false fold seq in (* TODO fresh *)
return_statement @@ final_sequence
restore_mutable_variable fold free_vars env
and simpl_declaration_list declarations :
Ast_simplified.declaration Location.wrap list result =

215
src/passes/3-self_ast_simplified/helpers.ml
View File

@ -1,13 +1,14 @@
open Ast_simplified
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 with
match e.expression_content with
| E_literal _ | E_variable _ | E_skip -> ok init'
| E_list lst | E_set lst | E_tuple lst | E_constant (_ , lst) -> (
| E_list lst | E_set lst | E_constant {arguments=lst} -> (
let%bind res = bind_fold_list self init' lst in
ok res
)
@ -15,20 +16,24 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
ok res
)
| E_look_up ab | E_sequence ab | E_loop ab | E_application ab -> (
| 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
ok res
)
| E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e }
| E_ascription (e , _) | E_constructor (_ , e) -> (
| E_ascription {anno_expr=e; _} | E_constructor {element=e} -> (
let%bind res = self init' e in
ok res
)
| E_assign (_ , _path , e) | E_accessor (e , _path) -> (
let%bind res = self init' e in
ok res
)
| E_matching (e , cases) -> (
| E_matching {matchee=e; cases} -> (
let%bind res = self init' e in
let%bind res = fold_cases f res cases in
ok res
@ -41,14 +46,18 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = bind_fold_lmap aux (ok init') m in
ok res
)
| E_update {record;update=(_,expr)} -> (
| E_record_update {record;update} -> (
let%bind res = self init' record in
let%bind res = fold_expression self res expr in
let%bind res = fold_expression self res update in
ok res
)
| E_let_in { binder = _ ; rhs ; result } -> (
| 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 result in
let%bind res = self res let_result in
ok res
)
@ -85,8 +94,8 @@ 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 = ok { e' with expression } in
match e'.expression with
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'
@ -103,68 +112,58 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind lst' = bind_map_list (bind_map_pair self) lst in
return @@ E_big_map lst'
)
| E_sequence ab -> (
let%bind ab' = bind_map_pair self ab in
return @@ E_sequence ab'
)
| E_look_up ab -> (
let%bind ab' = bind_map_pair self ab in
return @@ E_look_up ab'
)
| E_loop ab -> (
let%bind ab' = bind_map_pair self ab in
return @@ E_loop 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 (e , t) -> (
let%bind e' = self e in
return @@ E_ascription (e' , t)
| E_ascription ascr -> (
let%bind e' = self ascr.anno_expr in
return @@ E_ascription {ascr with anno_expr=e'}
)
| E_assign (name , path , e) -> (
let%bind e' = self e in
return @@ E_assign (name , path , e')
)
| E_matching (e , cases) -> (
| E_matching {matchee=e;cases} -> (
let%bind e' = self e in
let%bind cases' = map_cases f cases in
return @@ E_matching (e' , cases')
return @@ E_matching {matchee=e';cases=cases'}
)
| E_accessor (e , path) -> (
let%bind e' = self e in
return @@ E_accessor (e' , path)
| 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_update {record; update=(l,expr)} -> (
| E_record_update {record; path; update} -> (
let%bind record = self record in
let%bind expr = self expr in
return @@ E_update {record;update=(l,expr)}
let%bind update = self update in
return @@ E_record_update {record;path;update}
)
| E_constructor (name , e) -> (
let%bind e' = self e in
return @@ E_constructor (name , e')
| E_constructor c -> (
let%bind e' = self c.element in
return @@ E_constructor {c with element = e'}
)
| E_tuple lst -> (
let%bind lst' = bind_map_list self lst in
return @@ E_tuple lst'
| 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_application ab -> (
let%bind ab' = bind_map_pair self ab in
return @@ E_application ab'
)
| E_let_in { binder ; rhs ; result; inline } -> (
| E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
let%bind rhs = self rhs in
let%bind result = self result in
return @@ E_let_in { binder ; rhs ; result; inline }
let%bind let_result = self let_result in
return @@ E_let_in { let_binder ; mut; rhs ; let_result; inline }
)
| E_lambda { binder ; input_type ; output_type ; result } -> (
let%bind result = self result in
return @@ E_lambda { binder ; input_type ; output_type ; result }
)
| E_constant (name , lst) -> (
let%bind lst' = bind_map_list self lst in
return @@ E_constant (name , lst')
| E_constant c -> (
let%bind args = bind_map_list self c.arguments in
return @@ E_constant {c with arguments=args}
)
| E_literal _ | E_variable _ | E_skip as e' -> return e'
@ -209,3 +208,113 @@ and map_program : mapper -> program -> program result = fun m p ->
| Declaration_type _ -> ok x
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_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'})
)
| 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 ; mut; 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 ; mut; rhs ; let_result ; inline })
)
| E_lambda { binder ; input_type ; output_type ; result } -> (
let%bind (res,result) = self init' result in
ok ( res, return @@ E_lambda { binder ; input_type ; output_type ; 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 _ | E_skip 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, _) } -> (
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, ()) })
)
| Match_option { match_none ; match_some = (name , some, _) } -> (
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, ()) })
)
| Match_tuple ((names , e), _) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_tuple ((names , e'), []))
)
| Match_variant (lst, _) -> (
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', ()))
)

31
src/passes/3-self_ast_simplified/literals.ml
View File

@ -52,8 +52,8 @@ end
open Errors
let peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in
match e.expression with
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_literal (Literal_key_hash s) as l -> (
let open Tezos_crypto in
let%bind (_pkh:Crypto.Signature.public_key_hash) =
@ -82,18 +82,18 @@ let peephole_expression : expression -> expression result = fun e ->
Signature.Public_key.of_b58check s in
return l
)
| E_constant (C_BIG_MAP_LITERAL as cst, lst) -> (
| E_constant {cons_name=C_BIG_MAP_LITERAL as cst; arguments=lst} -> (
let%bind elt =
trace_option (bad_single_arity cst e.location) @@
List.to_singleton lst
in
let%bind lst =
trace_strong (bad_map_param_type cst e.location) @@
get_e_list elt.expression
get_e_list elt.expression_content
in
let aux = fun (e' : expression) ->
let aux = fun (e : expression) ->
trace_strong (bad_map_param_type cst e.location) @@
let%bind tpl = get_e_tuple e'.expression in
let%bind tpl = get_e_tuple e.expression_content in
let%bind (a , b) =
trace_option (simple_error "of pairs") @@
List.to_pair tpl
@ -103,18 +103,18 @@ let peephole_expression : expression -> expression result = fun e ->
let%bind pairs = bind_map_list aux lst in
return @@ E_big_map pairs
)
| E_constant (C_MAP_LITERAL as cst, lst) -> (
| E_constant {cons_name=C_MAP_LITERAL as cst; arguments=lst} -> (
let%bind elt =
trace_option (bad_single_arity cst e.location) @@
List.to_singleton lst
in
let%bind lst =
trace_strong (bad_map_param_type cst e.location) @@
get_e_list elt.expression
get_e_list elt.expression_content
in
let aux = fun (e' : expression) ->
let aux = fun (e : expression) ->
trace_strong (bad_map_param_type cst e.location) @@
let%bind tpl = get_e_tuple e'.expression in
let%bind tpl = get_e_tuple e.expression_content in
let%bind (a , b) =
trace_option (simple_error "of pairs") @@
List.to_pair tpl
@ -124,32 +124,33 @@ let peephole_expression : expression -> expression result = fun e ->
let%bind pairs = bind_map_list aux lst in
return @@ E_map pairs
)
| E_constant (C_BIG_MAP_EMPTY as cst, lst) -> (
| E_constant {cons_name=C_BIG_MAP_EMPTY as cst; arguments=lst} -> (
let%bind () =
trace_strong (bad_empty_arity cst e.location) @@
Assert.assert_list_empty lst
in
return @@ E_big_map []
)
| E_constant (C_MAP_EMPTY as cst, lst) -> (
| E_constant {cons_name=C_MAP_EMPTY as cst; arguments=lst} -> (
let%bind () =
trace_strong (bad_empty_arity cst e.location) @@
Assert.assert_list_empty lst
in
return @@ E_map []
)
| E_constant (C_SET_LITERAL as cst, lst) -> (
| E_constant {cons_name=C_SET_LITERAL as cst; arguments=lst} -> (
let%bind elt =
trace_option (bad_single_arity cst e.location) @@
List.to_singleton lst
in
let%bind lst =
trace_strong (bad_set_param_type cst e.location) @@
get_e_list elt.expression
get_e_list elt.expression_content
in
return @@ E_set lst
)
| E_constant (C_SET_EMPTY as cst, lst) -> (
| E_constant {cons_name=C_SET_EMPTY as cst; arguments=lst} -> (
let%bind () =
trace_strong (bad_empty_arity cst e.location) @@
Assert.assert_list_empty lst

8
src/passes/3-self_ast_simplified/none_variant.ml
View File

@ -2,8 +2,8 @@ open Ast_simplified
open Trace
let peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in
match e.expression with
| E_constructor (Constructor "Some" , e) -> return @@ E_constant (C_SOME , [ e ])
| E_constructor (Constructor "None" , _) -> return @@ E_constant (C_NONE , [ ])
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_constructor {constructor=Constructor "Some";element=e} -> return @@ E_constant {cons_name=C_SOME;arguments=[ e ]}
| E_constructor {constructor=Constructor "None"; _} -> return @@ E_constant {cons_name=C_NONE ; arguments=[]}
| e -> return e

2
src/passes/3-self_ast_simplified/self_ast_simplified.ml
View File

@ -17,3 +17,5 @@ let all_expression =
let map_expression = Helpers.map_expression
let fold_expression = Helpers.fold_expression
let fold_map_expression = Helpers.fold_map_expression

8
src/passes/3-self_ast_simplified/tezos_type_annotation.ml
View File

@ -13,10 +13,10 @@ end
open Errors
let peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in
match e.expression with
| E_ascription (e' , t) as e -> (
match (e'.expression , t.type_expression') with
let return expression_content = ok { e with expression_content } in
match e.expression_content with
| E_ascription {anno_expr=e'; type_annotation=t} as e -> (
match (e'.expression_content , t.type_content) with
| (E_literal (Literal_string s) , T_constant (TC_key_hash)) -> return @@ E_literal (Literal_key_hash s)
| (E_literal (Literal_string s) , T_constant (TC_signature)) -> return @@ E_literal (Literal_signature s)
| (E_literal (Literal_string s) , T_constant (TC_key)) -> return @@ E_literal (Literal_key s)

1
src/passes/4-typer-new/PP.ml
View File

@ -7,7 +7,6 @@ let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf ->
let ct = match c_tag with
| Solver.Core.C_arrow -> "arrow"
| Solver.Core.C_option -> "option"
| Solver.Core.C_tuple -> "tuple"
| Solver.Core.C_record -> failwith "record"
| Solver.Core.C_variant -> failwith "variant"
| Solver.Core.C_map -> "map"

352
src/passes/4-typer-new/solver.ml
View File

@ -9,13 +9,13 @@ module Wrap = struct
module Errors = struct
let unknown_type_constructor (ctor : string) (te : T.type_value) () =
let unknown_type_constructor (ctor : string) (te : T.type_expression) () =
let title = (thunk "unknown type constructor") in
(* TODO: sanitize the "ctor" argument before displaying it. *)
let message () = ctor in
let data = [
("ctor" , fun () -> ctor) ;
("expression" , fun () -> Format.asprintf "%a" T.PP.type_value te) ;
("expression" , fun () -> Format.asprintf "%a" T.PP.type_expression te) ;
(* ("location" , fun () -> Format.asprintf "%a" Location.pp te.location) *) (* TODO *)
] in
error ~data title message ()
@ -32,16 +32,17 @@ module Wrap = struct
(* let%bind state' = add_type state t in *)
(* return expr state' in *)
let rec type_expression_to_type_value : T.type_value -> O.type_value = fun te ->
match te.type_value' with
let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun te ->
match te.type_content with
| T_sum kvmap ->
let () = failwith "fixme: don't use to_list, it drops the variant keys, rows have a differnt kind than argument lists for now!" in
P_constant (C_variant, T.CMap.to_list @@ T.CMap.map type_expression_to_type_value kvmap)
| T_record kvmap ->
let () = failwith "fixme: don't use to_list, it drops the record keys, rows have a differnt kind than argument lists for now!" in
P_constant (C_record, T.LMap.to_list @@ T.LMap.map type_expression_to_type_value kvmap)
| T_arrow (arg , ret) ->
P_constant (C_arrow, List.map type_expression_to_type_value [ arg ; ret ])
| T_arrow {type1;type2} ->
P_constant (C_arrow, List.map type_expression_to_type_value [ type1 ; type2 ])
| T_variable (type_name) -> P_variable type_name
| T_constant (type_name) ->
let csttag = Core.(match type_name with
@ -58,7 +59,8 @@ module Wrap = struct
| TC_key -> C_key
| TC_signature -> C_signature
| TC_operation -> C_operation
| TC_chain_id -> C_unit (* TODO : replace with chain_id*)
| TC_chain_id -> C_unit (* TODO : replace with chain_id *)
| TC_void -> C_unit (* TODO : replace with void *)
)
in
P_constant (csttag, [])
@ -68,25 +70,24 @@ module Wrap = struct
| TC_set s -> (C_set, [s])
| TC_map ( k , v ) -> (C_map, [k;v])
| TC_big_map ( k , v) -> (C_big_map, [k;v])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
| TC_list l -> (C_list, [l])
| TC_contract c -> (C_contract, [c])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
| TC_tuple lst -> (C_tuple, lst)
)
in
P_constant (csttag, List.map type_expression_to_type_value args)
let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_value = fun te ->
match te.type_expression' with
match te.type_content with
| T_sum kvmap ->
let () = failwith "fixme: don't use to_list, it drops the variant keys, rows have a differnt kind than argument lists for now!" in
P_constant (C_variant, I.CMap.to_list @@ I.CMap.map type_expression_to_type_value_copypasted kvmap)
| T_record kvmap ->
let () = failwith "fixme: don't use to_list, it drops the record keys, rows have a differnt kind than argument lists for now!" in
P_constant (C_record, I.LMap.to_list @@ I.LMap.map type_expression_to_type_value_copypasted kvmap)
| T_arrow (arg , ret) ->
P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ arg ; ret ])
| T_variable type_name -> P_variable type_name
| T_arrow {type1;type2} ->
P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ type1 ; type2 ])
| T_variable type_name -> P_variable (type_name) (* eird stuff*)
| T_constant (type_name) ->
let csttag = Core.(match type_name with
| TC_unit -> C_unit
@ -104,7 +105,6 @@ module Wrap = struct
| TC_big_map ( k , v ) -> (C_big_map, [k;v])
| TC_contract c -> (C_contract, [c])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
| TC_tuple lst -> (C_tuple, lst)
)
in
P_constant (csttag, List.map type_expression_to_type_value_copypasted args)
@ -113,12 +113,12 @@ module Wrap = struct
let type_name = Core.fresh_type_variable () in
[] , type_name
let variable : I.expression_variable -> T.type_value -> (constraints * T.type_variable) = fun _name expr ->
let variable : I.expression_variable -> T.type_expression -> (constraints * T.type_variable) = fun _name expr ->
let pattern = type_expression_to_type_value expr in
let type_name = Core.fresh_type_variable () in
[C_equation (P_variable (type_name) , pattern)] , type_name
let literal : T.type_value -> (constraints * T.type_variable) = fun t ->
let literal : T.type_expression -> (constraints * T.type_variable) = fun t ->
let pattern = type_expression_to_type_value t in
let type_name = Core.fresh_type_variable () in
[C_equation (P_variable (type_name) , pattern)] , type_name
@ -135,9 +135,9 @@ module Wrap = struct
[C_equation (P_variable (type_name) , pattern)] , type_name
*)
let tuple : T.type_value list -> (constraints * T.type_variable) = fun tys ->
let tuple : T.type_expression list -> (constraints * T.type_variable) = fun tys ->
let patterns = List.map type_expression_to_type_value tys in
let pattern = O.(P_constant (C_tuple , patterns)) in
let pattern = O.(P_constant (C_record , patterns)) in
let type_name = Core.fresh_type_variable () in
[C_equation (P_variable (type_name) , pattern)] , type_name
@ -165,16 +165,13 @@ module Wrap = struct
end
(* TODO: I think we should take an I.expression for the base+label *)
let access_label ~(base : T.type_value) ~(label : O.accessor) : (constraints * T.type_variable) =
let access_label ~(base : T.type_expression) ~(label : O.accessor) : (constraints * T.type_variable) =
let base' = type_expression_to_type_value base in
let expr_type = Core.fresh_type_variable () in
[O.C_access_label (base' , label , expr_type)] , expr_type
let access_int ~base ~index = access_label ~base ~label:(L_int index)
let access_string ~base ~property = access_label ~base ~label:(L_string property)
let constructor
: T.type_value -> T.type_value -> T.type_value -> (constraints * T.type_variable)
: T.type_expression -> T.type_expression -> T.type_expression -> (constraints * T.type_variable)
= fun t_arg c_arg sum ->
let t_arg = type_expression_to_type_value t_arg in
let c_arg = type_expression_to_type_value c_arg in
@ -185,12 +182,12 @@ module Wrap = struct
C_equation (t_arg , c_arg)
] , whole_expr
let record : T.type_value I.label_map -> (constraints * T.type_variable) = fun fields ->
let record : T.type_expression T.label_map -> (constraints * T.type_variable) = fun fields ->
let record_type = type_expression_to_type_value (T.t_record fields ()) in
let whole_expr = Core.fresh_type_variable () in
[C_equation (P_variable whole_expr , record_type)] , whole_expr
let collection : O.constant_tag -> T.type_value list -> (constraints * T.type_variable) =
let collection : O.constant_tag -> T.type_expression list -> (constraints * T.type_variable) =
fun ctor element_tys ->
let elttype = O.P_variable (Core.fresh_type_variable ()) in
let aux elt =
@ -205,7 +202,7 @@ module Wrap = struct
let list = collection O.C_list
let set = collection O.C_set
let map : (T.type_value * T.type_value) list -> (constraints * T.type_variable) =
let map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) =
fun kv_tys ->
let k_type = O.P_variable (Core.fresh_type_variable ()) in
let v_type = O.P_variable (Core.fresh_type_variable ()) in
@ -222,7 +219,7 @@ module Wrap = struct
C_equation (P_variable whole_expr , O.P_constant (C_map , [k_type ; v_type]))
] @ equations_k @ equations_v , whole_expr
let big_map : (T.type_value * T.type_value) list -> (constraints * T.type_variable) =
let big_map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) =
fun kv_tys ->
let k_type = O.P_variable (Core.fresh_type_variable ()) in
let v_type = O.P_variable (Core.fresh_type_variable ()) in
@ -241,7 +238,7 @@ module Wrap = struct
C_equation (P_variable whole_expr , O.P_constant (C_big_map , [k_type ; v_type]))
] @ equations_k @ equations_v , whole_expr
let application : T.type_value -> T.type_value -> (constraints * T.type_variable) =
let application : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
fun f arg ->
let whole_expr = Core.fresh_type_variable () in
let f' = type_expression_to_type_value f in
@ -250,7 +247,7 @@ module Wrap = struct
C_equation (f' , P_constant (C_arrow , [arg' ; P_variable whole_expr]))
] , whole_expr
let look_up : T.type_value -> T.type_value -> (constraints * T.type_variable) =
let look_up : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
fun ds ind ->
let ds' = type_expression_to_type_value ds in
let ind' = type_expression_to_type_value ind in
@ -261,7 +258,7 @@ module Wrap = struct
C_equation (P_variable whole_expr , P_constant (C_option , [P_variable v]))
] , whole_expr
let sequence : T.type_value -> T.type_value -> (constraints * T.type_variable) =
let sequence : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
fun a b ->
let a' = type_expression_to_type_value a in
let b' = type_expression_to_type_value b in
@ -271,7 +268,7 @@ module Wrap = struct
C_equation (b' , P_variable whole_expr)
] , whole_expr
let loop : T.type_value -> T.type_value -> (constraints * T.type_variable) =
let loop : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
fun expr body ->
let expr' = type_expression_to_type_value expr in
let body' = type_expression_to_type_value body in
@ -282,7 +279,7 @@ module Wrap = struct
C_equation (P_variable whole_expr , P_constant (C_unit , []))
] , whole_expr
let let_in : T.type_value -> T.type_value option -> T.type_value -> (constraints * T.type_variable) =
let let_in : T.type_expression -> T.type_expression option -> T.type_expression -> (constraints * T.type_variable) =
fun rhs rhs_tv_opt result ->
let rhs' = type_expression_to_type_value rhs in
let result' = type_expression_to_type_value result in
@ -294,7 +291,7 @@ module Wrap = struct
C_equation (result' , P_variable whole_expr)
] @ rhs_tv_opt', whole_expr
let assign : T.type_value -> T.type_value -> (constraints * T.type_variable) =
let assign : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
fun v e ->
let v' = type_expression_to_type_value v in
let e' = type_expression_to_type_value e in
@ -304,7 +301,7 @@ module Wrap = struct
C_equation (P_variable whole_expr , P_constant (C_unit , []))
] , whole_expr
let annotation : T.type_value -> T.type_value -> (constraints * T.type_variable) =
let annotation : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
fun e annot ->
let e' = type_expression_to_type_value e in
let annot' = type_expression_to_type_value annot in
@ -314,20 +311,20 @@ module Wrap = struct
C_equation (e' , P_variable whole_expr)
] , whole_expr
let matching : T.type_value list -> (constraints * T.type_variable) =
let matching : T.type_expression list -> (constraints * T.type_variable) =
fun es ->
let whole_expr = Core.fresh_type_variable () in
let type_values = (List.map type_expression_to_type_value es) in
let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_values
let type_expressions = (List.map type_expression_to_type_value es) in
let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_expressions
in cs, whole_expr
let fresh_binder () =
Core.fresh_type_variable ()
let lambda
: T.type_value ->
T.type_value option ->
T.type_value option ->
: T.type_expression ->
T.type_expression option ->
T.type_expression option ->
(constraints * T.type_variable) =
fun fresh arg body ->
let whole_expr = Core.fresh_type_variable () in
@ -346,6 +343,16 @@ module Wrap = struct
P_variable unification_body]))
] @ arg' @ body' , whole_expr
(* This is pretty much a wrapper for an n-ary function. *)
let constant : O.type_value -> T.type_expression list -> (constraints * T.type_variable) =
fun f args ->
let whole_expr = Core.fresh_type_variable () in
let args' = List.map type_expression_to_type_value args in
let args_tuple = O.P_constant (C_record , args') in
O.[
C_equation (f , P_constant (C_arrow , [args_tuple ; P_variable whole_expr]))
] , whole_expr
end
(* begin unionfind *)
@ -431,8 +438,8 @@ and c_constructor_simpl = {
tv_list : type_variable list;
}
(* copy-pasted from core.ml *)
and c_const = (type_variable * type_value)
and c_equation = (type_value * type_value)
and c_const = (type_variable * type_expression)
and c_equation = (type_expression * type_expression)
and c_typeclass_simpl = {
tc : typeclass ;
args : type_variable list ;
@ -727,6 +734,136 @@ let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector =
| SC_Poly _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *)
| SC_Typeclass _ -> WasNotSelected
(* TODO: move this to a more appropriate place and/or auto-generate it. *)
let compare_simple_c_constant = function
| C_arrow -> (function
(* N/A -> 1 *)
| C_arrow -> 0
| C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_option -> (function
| C_arrow -> 1
| C_option -> 0
| C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_record -> (function
| C_arrow | C_option -> 1
| C_record -> 0
| C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_variant -> (function
| C_arrow | C_option | C_record -> 1
| C_variant -> 0
| C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_map -> (function
| C_arrow | C_option | C_record | C_variant -> 1
| C_map -> 0
| C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_big_map -> (function
| C_arrow | C_option | C_record | C_variant | C_map -> 1
| C_big_map -> 0
| C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_list -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map -> 1
| C_list -> 0
| C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_set -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list -> 1
| C_set -> 0
| C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_unit -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
| C_unit -> 0
| C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_bool -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1
| C_bool -> 0
| C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_string -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1
| C_string -> 0
| C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_nat -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1
| C_nat -> 0
| C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_mutez -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1
| C_mutez -> 0
| C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_timestamp -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez -> 1
| C_timestamp -> 0
| C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_int -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp -> 1
| C_int -> 0
| C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_address -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1
| C_address -> 0
| C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_bytes -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1
| C_bytes -> 0
| C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key_hash -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1
| C_key_hash -> 0
| C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1
| C_key -> 0
| C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_signature -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1
| C_signature -> 0
| C_operation | C_contract | C_chain_id -> -1)
| C_operation -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1
| C_operation -> 0
| C_contract | C_chain_id -> -1)
| C_contract -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1
| C_contract -> 0
| C_chain_id -> -1)
| C_chain_id -> (function
| C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1
| C_chain_id -> 0
(* N/A -> -1 *)
)
(* Using a pretty-printer from the PP.ml module creates a dependency
loop, so the one that we need temporarily for debugging purposes
has been copied here. *)
let debug_pp_constant : _ -> constant_tag -> unit = fun ppf c_tag ->
let ct = match c_tag with
| Core.C_arrow -> "arrow"
| Core.C_option -> "option"
| Core.C_record -> failwith "record"
| Core.C_variant -> failwith "variant"
| Core.C_map -> "map"
| Core.C_big_map -> "big_map"
| Core.C_list -> "list"
| Core.C_set -> "set"
| Core.C_unit -> "unit"
| Core.C_bool -> "bool"
| Core.C_string -> "string"
| Core.C_nat -> "nat"
| Core.C_mutez -> "mutez"
| Core.C_timestamp -> "timestamp"
| Core.C_int -> "int"
| Core.C_address -> "address"
| Core.C_bytes -> "bytes"
| Core.C_key_hash -> "key_hash"
| Core.C_key -> "key"
| Core.C_signature -> "signature"
| Core.C_operation -> "operation"
| Core.C_contract -> "contract"
| Core.C_chain_id -> "chain_id"
in
Format.fprintf ppf "%s" ct
let debug_pp_c_constructor_simpl ppf { tv; c_tag; tv_list } =
Format.fprintf ppf "CTOR %a %a(%a)" Var.pp tv debug_pp_constant c_tag PP_helpers.(list_sep Var.pp (const " , ")) tv_list
let propagator_break_ctor : output_break_ctor propagator =
fun selected dbs ->
let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *)
@ -737,8 +874,8 @@ let propagator_break_ctor : output_break_ctor propagator =
(* a.tv = b.tv *)
let eq1 = C_equation (P_variable a.tv, P_variable b.tv) in
(* a.c_tag = b.c_tag *)
if a.c_tag <> b.c_tag then
failwith "type error: incompatible types, not same ctor"
if (compare_simple_c_constant a.c_tag b.c_tag) <> 0 then
failwith (Format.asprintf "type error: incompatible types, not same ctor %a vs. %a (compare returns %d)" debug_pp_c_constructor_simpl a debug_pp_c_constructor_simpl b (compare_simple_c_constant a.c_tag b.c_tag))
else
(* a.tv_list = b.tv_list *)
if List.length a.tv_list <> List.length b.tv_list then
@ -765,114 +902,17 @@ let rec compare_list f = function
| [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *)
let compare_type_variable a b =
Var.compare a b
let compare_label = function
| L_int a -> (function L_int b -> Int.compare a b | L_string _ -> -1)
| L_string a -> (function L_int _ -> 1 | L_string b -> String.compare a b)
let compare_simple_c_constant = function
| C_arrow -> (function
(* N/A -> 1 *)
| C_arrow -> 0
| C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_option -> (function
| C_arrow -> 1
| C_option -> 0
| C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_tuple -> (function
| C_arrow | C_option -> 1
| C_tuple -> 0
| C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_record -> (function
| C_arrow | C_option | C_tuple -> 1
| C_record -> 0
| C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_variant -> (function
| C_arrow | C_option | C_tuple | C_record -> 1
| C_variant -> 0
| C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant -> 1
| C_map -> 0
| C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_big_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1
| C_big_map -> 0
| C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_list -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1
| C_list -> 0
| C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_set -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1
| C_set -> 0
| C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_unit -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
| C_unit -> 0
| C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_bool -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1
| C_bool -> 0
| C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_string -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1
| C_string -> 0
| C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_nat -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1
| C_nat -> 0
| C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_mutez -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1
| C_mutez -> 0
| C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_timestamp -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez -> 1
| C_timestamp -> 0
| C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_int -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp -> 1
| C_int -> 0
| C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_address -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1
| C_address -> 0
| C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_bytes -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1
| C_bytes -> 0
| C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key_hash -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1
| C_key_hash -> 0
| C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1
| C_key -> 0
| C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_signature -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1
| C_signature -> 0
| C_operation | C_contract | C_chain_id -> -1)
| C_operation -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1
| C_operation -> 0
| C_contract | C_chain_id -> -1)
| C_contract -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1
| C_contract -> 0
| C_chain_id -> -1)
| C_chain_id -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1
| C_chain_id -> 0
(* N/A -> -1 *)
)
let rec compare_typeclass a b = compare_list (compare_list compare_type_value) a b
and compare_type_value = function
let compare_label (a:accessor) (b:accessor) =
let Label a = a in
let Label b = b in
String.compare a b
let rec compare_typeclass a b = compare_list (compare_list compare_type_expression) a b
and compare_type_expression = function
| P_forall { binder=a1; constraints=a2; body=a3 } -> (function
| P_forall { binder=b1; constraints=b2; body=b3 } ->
compare_type_variable a1 b1 <? fun () ->
compare_list compare_type_constraint a2 b2 <? fun () ->
compare_type_value a3 b3
compare_type_expression a3 b3
| P_variable _ -> -1
| P_constant _ -> -1
| P_apply _ -> -1)
@ -884,33 +924,33 @@ and compare_type_value = function
| P_constant (a1, a2) -> (function
| P_forall _ -> 1
| P_variable _ -> 1
| P_constant (b1, b2) -> compare_simple_c_constant a1 b1 <? fun () -> compare_list compare_type_value a2 b2
| P_constant (b1, b2) -> compare_simple_c_constant a1 b1 <? fun () -> compare_list compare_type_expression a2 b2
| P_apply _ -> -1)
| P_apply (a1, a2) -> (function
| P_forall _ -> 1
| P_variable _ -> 1
| P_constant _ -> 1
| P_apply (b1, b2) -> compare_type_value a1 b1 <? fun () -> compare_type_value a2 b2)
| P_apply (b1, b2) -> compare_type_expression a1 b1 <? fun () -> compare_type_expression a2 b2)
and compare_type_constraint = function
| C_equation (a1, a2) -> (function
| C_equation (b1, b2) -> compare_type_value a1 b1 <? fun () -> compare_type_value a2 b2
| C_equation (b1, b2) -> compare_type_expression a1 b1 <? fun () -> compare_type_expression a2 b2
| C_typeclass _ -> -1
| C_access_label _ -> -1)
| C_typeclass (a1, a2) -> (function
| C_equation _ -> 1
| C_typeclass (b1, b2) -> compare_list compare_type_value a1 b1 <? fun () -> compare_typeclass a2 b2
| C_typeclass (b1, b2) -> compare_list compare_type_expression a1 b1 <? fun () -> compare_typeclass a2 b2
| C_access_label _ -> -1)
| C_access_label (a1, a2, a3) -> (function
| C_equation _ -> 1
| C_typeclass _ -> 1
| C_access_label (b1, b2, b3) -> compare_type_value a1 b1 <? fun () -> compare_label a2 b2 <? fun () -> compare_type_variable a3 b3)
| C_access_label (b1, b2, b3) -> compare_type_expression a1 b1 <? fun () -> compare_label a2 b2 <? fun () -> compare_type_variable a3 b3)
let compare_type_constraint_list = compare_list compare_type_constraint
let compare_p_forall
{ binder = a1; constraints = a2; body = a3 }
{ binder = b1; constraints = b2; body = b3 } =
compare_type_variable a1 b1 <? fun () ->
compare_type_constraint_list a2 b2 <? fun () ->
compare_type_value a3 b3
compare_type_expression a3 b3
let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } =
compare_type_variable a1 b1 <? fun () ->
compare_p_forall a2 b2
@ -1063,7 +1103,7 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s
* unification_vars : unionfind ;
*
* (\* assigns a value to the representant in the unionfind *\)
* assignments : type_value TypeVariableMap.t ;
* assignments : type_expression TypeVariableMap.t ;
*
* (\* constraints related to a type variable *\)
* constraints : constraints TypeVariableMap.t ;
@ -1104,7 +1144,7 @@ let initial_state : state = (* {
let discard_state (_ : state) = ()
(* let replace_var_in_state = fun (v : type_variable) (state : state) -> *)
(* let aux_tv : type_value -> _ = function *)
(* let aux_tv : type_expression -> _ = function *)
(* | P_forall (w , cs , tval) -> failwith "TODO" *)
(* | P_variable (w) -> *)
(* if w = v then *)

382
src/passes/4-typer-new/typer.ml
View File

@ -15,7 +15,7 @@ module Errors = struct
let title = (thunk "unbound type variable") in
let message () = "" in
let data = [
("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.type_variable tv) ;
("variable" , fun () -> Format.asprintf "%a" I.PP.type_variable tv) ;
(* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
@ -23,7 +23,7 @@ module Errors = struct
error ~data title message ()
let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () =
let name () = Format.asprintf "%a" Stage_common.PP.name n in
let name () = Format.asprintf "%a" I.PP.expression_variable n in
let title = (thunk ("unbound variable "^(name ()))) in
let message () = "" in
let data = [
@ -33,7 +33,7 @@ module Errors = struct
] in
error ~data title message ()
let match_empty_variant : type a . (a,unit) I.matching -> Location.t -> unit -> _ =
let match_empty_variant : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "match with no cases") in
let message () = "" in
@ -43,7 +43,7 @@ module Errors = struct
] in
error ~data title message ()
let match_missing_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
let match_missing_case : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "missing case in match") in
let message () = "" in
@ -53,7 +53,7 @@ module Errors = struct
] in
error ~data title message ()
let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
let match_redundant_case : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "redundant case in match") in
let message () = "" in
@ -63,11 +63,11 @@ module Errors = struct
] in
error ~data title message ()
let unbound_constructor (e:environment) (c:I.constructor) (loc:Location.t) () =
let unbound_constructor (e:environment) (c:I.constructor') (loc:Location.t) () =
let title = (thunk "unbound constructor") in
let message () = "" in
let data = [
("constructor" , fun () -> Format.asprintf "%a" Stage_common.PP.constructor c) ;
("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c) ;
("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
@ -103,27 +103,27 @@ module Errors = struct
] in
error ~data title message ()
let constant_declaration_error (name: I.expression_variable) (ae:I.expr) (expected: O.type_value option) () =
let constant_declaration_error (name: I.expression_variable) (ae:I.expr) (expected: O.type_expression option) () =
let title = (thunk "typing constant declaration") in
let message () = "" in
let data = [
("constant" , fun () -> Format.asprintf "%a" Stage_common.PP.name name) ; (* Todo : remove Stage_common*)
("constant" , fun () -> Format.asprintf "%a" I.PP.expression_variable name) ; (* Todo : remove Stage_common*)
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () ->
match expected with
None -> "(no annotation for the expected type)"
| Some expected -> Format.asprintf "%a" O.PP.type_value expected) ;
| Some expected -> Format.asprintf "%a" O.PP.type_expression expected) ;
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in
error ~data title message ()
let match_error : type a . ?msg:string -> expected: (a, unit) I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
let match_error : ?msg:string -> expected: I.matching_expr -> actual: O.type_expression -> Location.t -> unit -> _ =
fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ;
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
@ -148,39 +148,17 @@ module Errors = struct
* ] in
* error ~data title message () *)
let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () =
let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
let title = (thunk "type error") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%a" O.PP.type_value expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual);
("expected" , fun () -> Format.asprintf "%a" O.PP.type_expression expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
let title = (thunk "invalid tuple index") in
let message () = "" in
let data = [
("index" , fun () -> Format.asprintf "%d" index) ;
("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
let title = (thunk "invalid record field") in
let message () = "" in
let data = [
("field" , fun () -> Format.asprintf "%s" field) ;
("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] 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
@ -216,7 +194,7 @@ let rec type_program (p:I.program) : O.program result =
let rec type_declaration env state : I.declaration -> (environment * Solver.state * O.declaration option) result = function
| Declaration_type (type_name , type_expression) ->
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type type_name tv env in
let env' = Environment.add_type (type_name) tv env in
ok (env', state , None)
| Declaration_constant (name , tv_opt , inline, expression) -> (
(*
@ -227,10 +205,10 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat
trace (constant_declaration_error name expression tv'_opt) @@
type_expression env state expression in
let env' = Environment.add_ez_ae name ae' env in
ok (env', state' , Some (O.Declaration_constant ((make_n_e name ae') , inline, (env , env'))))
ok (env', state' , Some (O.Declaration_constant (name, ae', inline, env') ))
)
and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.matching -> I.expression -> Location.t -> ((O.value, O.type_value) O.matching * Solver.state) result =
and type_match : environment -> Solver.state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * Solver.state) result =
fun e state t i ae loc -> match i with
| Match_bool {match_true ; match_false} ->
let%bind _ =
@ -285,7 +263,7 @@ and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.mat
~expression:ae
loc
) @@
Ast_typed.assert_type_value_eq (variant , variant') >>? fun () ->
Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
ok (Some variant)
) in
ok acc in
@ -327,13 +305,13 @@ and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.mat
Recursively search the type_expression and return a result containing the
type_value at the leaves
*)
and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
let return tv' = ok (make_t tv' (Some t)) in
match t.type_expression' with
| T_arrow (a, b) ->
let%bind a' = evaluate_type e a in
let%bind b' = evaluate_type e b in
return (T_arrow (a', b'))
match t.type_content with
| T_arrow {type1;type2} ->
let%bind type1 = evaluate_type e type1 in
let%bind type2 = evaluate_type e type2 in
return (T_arrow {type1;type2})
| T_sum m ->
let aux k v prev =
let%bind prev' = prev in
@ -353,7 +331,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
| T_variable name ->
let%bind tv =
trace_option (unbound_type_variable e name)
@@ Environment.get_type_opt name e in
@@ Environment.get_type_opt (name) e in
ok tv
| T_constant cst ->
return (T_constant cst)
@ -383,13 +361,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
let%bind arg' = evaluate_type e arg in
let%bind ret' = evaluate_type e ret in
ok @@ O.TC_arrow ( arg' , ret' )
| TC_tuple lst ->
let%bind lst' = bind_map_list (evaluate_type e) lst in
ok @@ O.TC_tuple lst'
in
return (T_operator (opt))
and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result = fun e state ?tv_opt ae ->
and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result = fun e state ?tv_opt ae ->
let () = ignore tv_opt in (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
let open Solver in
let module L = Logger.Stateful() in
@ -410,7 +385,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
] in
error ~data title content in
trace main_error @@
match ae.expression with
match ae.expression_content with
(* TODO: this file should take care only of the order in which program fragments
are translated by Wrap.xyz
@ -426,11 +401,12 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
* return expr'' state' constraints expr_type
* ) *)
| E_variable name -> (
let name'= name in
let%bind (tv' : Environment.element) =
trace_option (unbound_variable e name ae.location)
@@ Environment.get_opt name e in
@@ Environment.get_opt name' e in
let (constraints , expr_type) = Wrap.variable name tv'.type_value in
let expr' = e_variable name in
let expr' = e_variable name' in
return expr' state constraints expr_type
)
| E_literal (Literal_bool b) -> (
@ -475,6 +451,9 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
| E_literal (Literal_unit) -> (
return_wrapped (e_unit ()) state @@ Wrap.literal (t_unit ())
)
| E_literal (Literal_void) -> (
failwith "TODO: missing implementation for literal void"
)
| E_skip -> (
(* E_skip just returns unit *)
return_wrapped (e_unit ()) state @@ Wrap.literal (t_unit ())
@ -485,44 +464,29 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
* | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ())
* | _ -> return (E_literal (Literal_string s)) (t_string ())
* ) *)
(* Tuple *)
| E_tuple lst -> (
let aux state hd = type_expression e state hd >>? swap in
let%bind (state', lst') = bind_fold_map_list aux state lst in
let tv_lst = List.map get_type_annotation lst' in
return_wrapped (e_tuple lst') state' @@ Wrap.tuple tv_lst
)
| E_accessor (base , [Access_tuple index]) -> (
let%bind (base' , state') = type_expression e state base in
let wrapped = Wrap.access_int ~base:base'.type_annotation ~index in
return_wrapped (E_tuple_accessor (base' , index)) state' wrapped
)
| E_accessor (base , [Access_record property]) -> (
let%bind (base' , state') = type_expression e state base in
let wrapped = Wrap.access_string ~base:base'.type_annotation ~property in
return_wrapped (E_record_accessor (base' , Label property)) state' wrapped
)
| E_accessor (_base , []) | E_accessor (_base , _ :: _ :: _) -> (
failwith
"The simplifier should produce E_accessor with only a single path element, not a list of path elements."
| E_record_accessor {expr;label} -> (
let%bind (base' , state') = type_expression e state expr in
let wrapped = Wrap.access_label ~base:base'.type_expression ~label in
return_wrapped (E_record_accessor {expr=base';label}) state' wrapped
)
(* Sum *)
| E_constructor (c, expr) ->
| E_constructor {constructor;element} ->
let%bind (c_tv, sum_tv) =
let error =
let title () = "no such constructor" in
let content () =
Format.asprintf "%a in:\n%a\n"
Stage_common.PP.constructor c
Stage_common.PP.constructor constructor
O.Environment.PP.full_environment e
in
error title content in
trace_option error @@
Environment.get_constructor c e in
let%bind (expr' , state') = type_expression e state expr in
let wrapped = Wrap.constructor expr'.type_annotation c_tv sum_tv in
return_wrapped (E_constructor (c , expr')) state' wrapped
Environment.get_constructor constructor e in
let%bind (expr' , state') = type_expression e state element in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
let wrapped = Wrap.constructor expr'.type_expression c_tv sum_tv in
return_wrapped (E_constructor {constructor; element=expr'}) state' wrapped
(* Record *)
| E_record m ->
@ -530,25 +494,25 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let%bind (expr' , state') = type_expression e state expr in
ok (I.LMap.add k expr' acc , state')
in
let%bind (m' , state') = I.bind_fold_lmap aux (ok (I.LMap.empty , state)) m in
let wrapped = Wrap.record (I.LMap.map get_type_annotation m') in
let%bind (m' , state') = Stage_common.Helpers.bind_fold_lmap aux (ok (I.LMap.empty , state)) m in
let wrapped = Wrap.record (I.LMap.map get_type_expression m') in
return_wrapped (E_record m') state' wrapped
| E_update {record; update=(k,expr)} ->
| E_record_update {record; path; update} ->
let%bind (record, state) = type_expression e state record in
let%bind (expr,state) = type_expression e state expr in
let wrapped = get_type_annotation record in
let%bind (update,state) = type_expression e state update in
let wrapped = get_type_expression record in
let%bind (wrapped,tv) =
match wrapped.type_value' with
match wrapped.type_content with
| T_record record -> (
let field_op = I.LMap.find_opt k record in
let field_op = I.LMap.find_opt path record in
match field_op with
| Some tv -> ok (record,tv)
| None -> failwith @@ Format.asprintf "field %a is not part of record" Stage_common.PP.label k
| None -> failwith @@ Format.asprintf "field %a is not part of record" Stage_common.PP.label path
)
| _ -> failwith "Update an expression which is not a record"
in
let%bind () = O.assert_type_value_eq (tv, get_type_annotation expr) in
return_wrapped (E_record_update (record, (k,expr))) state (Wrap.record wrapped)
let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
(* Data-structure *)
(*
@ -629,20 +593,20 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
| E_list lst ->
let%bind (state', lst') =
bind_fold_map_list (fun state' elt -> type_expression e state' elt >>? swap) state lst in
let wrapped = Wrap.list (List.map (fun x -> O.(x.type_annotation)) lst') in
let wrapped = Wrap.list (List.map (fun x -> O.(x.type_expression)) lst') in
return_wrapped (E_list lst') state' wrapped
| E_set set ->
let aux = fun state' elt -> type_expression e state' elt >>? swap in
let%bind (state', set') =
bind_fold_map_list aux state set in
let wrapped = Wrap.set (List.map (fun x -> O.(x.type_annotation)) set') in
let wrapped = Wrap.set (List.map (fun x -> O.(x.type_expression)) set') in
return_wrapped (E_set set') state' wrapped
| E_map map ->
let aux' state' elt = type_expression e state' elt >>? swap in
let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in
let%bind (state', map') =
bind_fold_map_list aux state map in
let aux (x, y) = O.(x.type_annotation , y.type_annotation) in
let aux (x, y) = O.(x.type_expression , y.type_expression) in
let wrapped = Wrap.map (List.map aux map') in
return_wrapped (E_map map') state' wrapped
@ -681,7 +645,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in
let%bind (state', big_map') =
bind_fold_map_list aux state big_map in
let aux (x, y) = O.(x.type_annotation , y.type_annotation) in
let aux (x, y) = O.(x.type_expression , y.type_expression) in
let wrapped = Wrap.big_map (List.map aux big_map') in
return_wrapped (E_big_map big_map') state' wrapped
@ -727,11 +691,11 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
* let%bind (name', tv) =
* type_constant name tv_lst tv_opt ae.location in
* return (E_constant (name' , lst')) tv *)
| E_application (f, arg) ->
let%bind (f' , state') = type_expression e state f in
let%bind (arg , state'') = type_expression e state' arg in
let wrapped = Wrap.application f'.type_annotation arg.type_annotation in
return_wrapped (E_application (f' , arg)) state'' wrapped
| E_application {expr1;expr2} ->
let%bind (f' , state') = type_expression e state expr1 in
let%bind (arg , state'') = type_expression e state' expr2 in
let wrapped = Wrap.application f'.type_expression arg.type_expression in
return_wrapped (E_application {expr1=f';expr2=arg}) state'' wrapped
(* | E_look_up dsi ->
* let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in
@ -742,7 +706,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
| E_look_up dsi ->
let aux' state' elt = type_expression e state' elt >>? swap in
let%bind (state'' , (ds , ind)) = bind_fold_map_pair aux' state dsi in
let wrapped = Wrap.look_up ds.type_annotation ind.type_annotation in
let wrapped = Wrap.look_up ds.type_expression ind.type_expression in
return_wrapped (E_look_up (ds , ind)) state'' wrapped
(* Advanced *)
@ -770,82 +734,52 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
* tv_opt in
* return (O.E_matching (ex', m')) tv
* ) *)
| E_sequence (a , b) ->
let%bind (a' , state') = type_expression e state a in
let%bind (b' , state'') = type_expression e state' b in
let wrapped = Wrap.sequence a'.type_annotation b'.type_annotation in
return_wrapped (O.E_sequence (a' , b')) state'' wrapped
| E_loop (expr , body) ->
let%bind (expr' , state') = type_expression e state expr in
| 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_annotation body'.type_annotation in
return_wrapped (O.E_loop (expr' , body')) state'' wrapped
| E_let_in {binder ; rhs ; result ; inline} ->
let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) 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 *)
let%bind (rhs , state') = type_expression e state rhs in
let e' = Environment.add_ez_declaration (fst binder) rhs e in
let%bind (result , state'') = type_expression e' state' result in
let let_binder = fst let_binder in
let e' = Environment.add_ez_declaration (let_binder) rhs e in
let%bind (let_result , state'') = type_expression e' state' let_result in
let wrapped =
Wrap.let_in rhs.type_annotation rhs_tv_opt result.type_annotation in
return_wrapped (E_let_in {binder = fst binder; rhs; result; inline}) state'' wrapped
| E_assign (name , path , expr) ->
let%bind typed_name =
let%bind ele = Environment.get_trace name e in
ok @@ make_n_t name ele.type_value in
let%bind (assign_tv , path') =
let aux : ((_ * O.access_path) as 'a) -> I.access -> 'a result = fun (prec_tv , prec_path) cur_path ->
match cur_path with
| Access_tuple index -> (
let%bind tpl = get_t_tuple prec_tv in
let%bind tv' =
trace_option (bad_tuple_index index ae prec_tv ae.location) @@
List.nth_opt tpl index in
ok (tv' , prec_path @ [O.Access_tuple index])
)
| Access_record property -> (
let%bind m = get_t_record prec_tv in
let%bind tv' =
trace_option (bad_record_access property ae prec_tv ae.location) @@
I.LMap.find_opt (Label property) m in
ok (tv' , prec_path @ [O.Access_record property])
)
in
bind_fold_list aux (typed_name.type_value , []) path in
let%bind (expr' , state') = type_expression e state expr in
let wrapped = Wrap.assign assign_tv expr'.type_annotation in
return_wrapped (O.E_assign (typed_name , path' , expr')) state' wrapped
| E_ascription (expr , te) ->
let%bind tv = evaluate_type e te in
let%bind (expr' , state') = type_expression e state expr in
let wrapped = Wrap.annotation expr'.type_annotation tv
Wrap.let_in rhs.type_expression rhs_tv_opt let_result.type_expression in
return_wrapped (E_let_in {let_binder; rhs; let_result; inline}) state'' wrapped
| E_ascription {anno_expr;type_annotation} ->
let%bind tv = evaluate_type e type_annotation in
let%bind (expr' , state') = type_expression e state anno_expr in
let wrapped = Wrap.annotation expr'.type_expression tv
(* TODO: we're probably discarding too much by using expr'.expression.
Previously: {expr' with type_annotation = the_explicit_type_annotation}
but then this case is not like the others and doesn't call return_wrapped,
which might do some necessary work *)
in return_wrapped expr'.expression state' wrapped
in return_wrapped expr'.expression_content state' wrapped
| E_matching (ex, m) -> (
let%bind (ex' , state') = type_expression e state ex in
let%bind (m' , state'') = type_match e state' ex'.type_annotation m ae ae.location in
| E_matching {matchee;cases} -> (
let%bind (ex' , state') = type_expression e state matchee in
let%bind (m' , state'') = type_match e state' ex'.type_expression cases ae ae.location in
let tvs =
let aux (cur:(O.value, O.type_value) O.matching) =
let aux (cur:(O.expression, O.type_expression) O.matching_content) =
match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ]
| Match_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in
List.map get_type_annotation @@ aux m' in
List.map get_type_expression @@ aux m' in
let%bind () = match tvs with
[] -> fail @@ match_empty_variant m ae.location
[] -> fail @@ match_empty_variant cases ae.location
| _ -> ok () in
(* constraints:
all the items of tvs should be equal to the first one
result = first item of tvs
*)
let wrapped = Wrap.matching tvs in
return_wrapped (O.E_matching (ex', m')) state'' wrapped
return_wrapped (O.E_matching {matchee=ex';cases=m'}) state'' wrapped
)
(* match m with *)
@ -885,20 +819,31 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let%bind input_type' = bind_map_option (evaluate_type e) input_type in
let%bind output_type' = bind_map_option (evaluate_type e) output_type in
let fresh : O.type_value = t_variable (Wrap.fresh_binder ()) () in
let e' = Environment.add_ez_binder (fst binder) fresh e in
let fresh : O.type_expression = t_variable (Wrap.fresh_binder ()) () in
let binder = fst binder in
let e' = Environment.add_ez_binder (binder) fresh e in
let%bind (result , state') = type_expression e' state result in
let () = Printf.printf "this does not make use of the typed body, this code sounds buggy." in
let wrapped = Wrap.lambda fresh input_type' output_type' in
return_wrapped
(E_lambda {binder = fst binder; body=result}) (* TODO: is the type of the entire lambda enough to access the input_type=fresh; ? *)
(E_lambda {binder = binder; result}) (* TODO: is the type of the entire lambda enough to access the input_type=fresh; ? *)
state' wrapped
)
| E_constant (name, lst) ->
| E_constant {cons_name=name; arguments=lst} ->
let () = ignore (name , lst) in
let _t = Operators.Typer.Operators_types.constant_type name in
Pervasives.failwith (Format.asprintf "TODO: E_constant (%a(%a))" Stage_common.PP.constant name (Format.pp_print_list Ast_simplified.PP.expression) lst)
let%bind t = Operators.Typer.Operators_types.constant_type name in
let aux acc expr =
let (lst , state) = acc in
let%bind (expr, state') = type_expression e state expr in
ok (expr::lst , state') in
let%bind (lst , state') = bind_fold_list aux ([], state) lst in
let lst_annot = List.map (fun (x : O.expression) -> x.type_expression) lst in
let wrapped = Wrap.constant t lst_annot in
return_wrapped
(E_constant {cons_name=name;arguments=lst})
state' wrapped
(*
let%bind lst' = bind_list @@ List.map (type_expression e) lst in
let tv_lst = List.map get_type_annotation lst' in
@ -909,13 +854,13 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
(* Advanced *)
and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result =
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
let%bind typer = Operators.Typer.constant_typers name in
let%bind tv = typer lst tv_opt in
ok(name, tv)
let untype_type_value (t:O.type_value) : (I.type_expression) result =
match t.simplified with
let untype_type_value (t:O.type_expression) : (I.type_expression) result =
match t.type_meta with
| Some s -> ok s
| _ -> fail @@ internal_assertion_failure "trying to untype generated type"
(* let type_statement : environment -> I.declaration -> Solver.state -> (environment * O.declaration * Solver.state) result = fun env declaration state -> *)
@ -968,7 +913,7 @@ let type_and_subst_xyz (env_state_node : environment * Solver.state * 'a) (apply
(Solver.TypeVariableMap.find_opt root assignments) in
let Solver.{ tv ; c_tag ; tv_list } = assignment in
let () = ignore tv (* I think there is an issue where the tv is stored twice (as a key and in the element itself) *) in
let%bind (expr : O.type_value') = Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.{ type_value' = T_variable s ; simplified = None }) tv_list)) in
let%bind (expr : O.type_content) = Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.{ type_content = T_variable s ; type_meta = None }) tv_list)) in
ok @@ expr
in
let p = apply_substs ~substs program in
@ -982,14 +927,14 @@ let type_program (p : I.program) : (O.program * Solver.state) result =
let empty_state = Solver.initial_state in
type_and_subst_xyz (empty_env , empty_state , p) Typesystem.Misc.Substitution.Pattern.s_program type_program_returns_state
let type_expression_returns_state : (environment * Solver.state * I.expression) -> (environment * Solver.state * O.annotated_expression) Trace.result =
let type_expression_returns_state : (environment * Solver.state * I.expression) -> (environment * Solver.state * O.expression) Trace.result =
fun (env, state, e) ->
let%bind (e , state) = type_expression env state e in
ok (env, state, e)
let type_expression_subst (env : environment) (state : Solver.state) ?(tv_opt : O.type_value option) (e : I.expression) : (O.annotated_expression * Solver.state) result =
let type_expression_subst (env : environment) (state : Solver.state) ?(tv_opt : O.type_expression option) (e : I.expression) : (O.expression * Solver.state) result =
let () = ignore tv_opt in (* For compatibility with the old typer's API, this argument can be removed once the new typer is used. *)
type_and_subst_xyz (env , state , e) Typesystem.Misc.Substitution.Pattern.s_annotated_expression type_expression_returns_state
type_and_subst_xyz (env , state , e) Typesystem.Misc.Substitution.Pattern.s_expression type_expression_returns_state
(*
TODO: Similar to type_program but use a fold_map_list and List.fold_left and add element to the left or the list which gives a better complexity
@ -1015,22 +960,22 @@ let type_program' : I.program -> O.program result = fun p ->
(*
Tranform a Ast_typed type_expression into an ast_simplified type_expression
*)
let rec untype_type_expression (t:O.type_value) : (I.type_expression) result =
let rec untype_type_expression (t:O.type_expression) : (I.type_expression) result =
(* TODO: or should we use t.simplified if present? *)
let%bind t = match t.type_value' with
let%bind t = match t.type_content with
| O.T_sum x ->
let%bind x' = I.bind_map_cmap untype_type_expression x in
let%bind x' = Stage_common.Helpers.bind_map_cmap untype_type_expression x in
ok @@ I.T_sum x'
| O.T_record x ->
let%bind x' = I.bind_map_lmap untype_type_expression x in
let%bind x' = Stage_common.Helpers.bind_map_lmap untype_type_expression x in
ok @@ I.T_record x'
| O.T_constant (tag) ->
ok @@ I.T_constant (tag)
| O.T_variable (name) -> ok @@ I.T_variable name (* TODO: is this the right conversion? *)
| O.T_arrow (a , b) ->
let%bind a' = untype_type_expression a in
let%bind b' = untype_type_expression b in
ok @@ I.T_arrow (a' , b')
| O.T_variable (name) -> ok @@ I.T_variable (name) (* TODO: is this the right conversion? *)
| O.T_arrow {type1;type2} ->
let%bind type1 = untype_type_expression type1 in
let%bind type2 = untype_type_expression type2 in
ok @@ I.T_arrow {type1;type2}
| O.T_operator (type_name) ->
let%bind type_name = match type_name with
| O.TC_option t ->
@ -1050,16 +995,13 @@ let rec untype_type_expression (t:O.type_value) : (I.type_expression) result =
let%bind k = untype_type_expression k in
let%bind v = untype_type_expression v in
ok @@ I.TC_big_map (k,v)
| O.TC_contract c->
let%bind c = untype_type_expression c in
ok @@ I.TC_contract c
| O.TC_arrow ( arg , ret ) ->
let%bind arg' = untype_type_expression arg in
let%bind ret' = untype_type_expression ret in
ok @@ I.TC_arrow ( arg' , ret' )
| O.TC_tuple lst ->
let%bind lst' = bind_map_list untype_type_expression lst in
ok @@ I.TC_tuple lst'
| O.TC_contract c->
let%bind c = untype_type_expression c in
ok @@ I.TC_contract c
in
ok @@ I.T_operator (type_name)
in
@ -1077,6 +1019,7 @@ let untype_literal (l:O.literal) : I.literal result =
let open I in
match l with
| Literal_unit -> ok Literal_unit
| Literal_void -> ok Literal_void
| Literal_bool b -> ok (Literal_bool b)
| Literal_nat n -> ok (Literal_nat n)
| Literal_timestamp n -> ok (Literal_timestamp n)
@ -1094,51 +1037,46 @@ let untype_literal (l:O.literal) : I.literal result =
(*
Tranform a Ast_typed expression into an ast_simplified matching
*)
let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
let rec untype_expression (e:O.expression) : (I.expression) result =
let open I in
let return e = ok e in
match e.expression with
match e.expression_content with
| E_literal l ->
let%bind l = untype_literal l in
return (e_literal l)
| E_constant (const, lst) ->
let%bind lst' = bind_map_list untype_expression lst in
return (e_constant const lst')
| E_constant {cons_name;arguments} ->
let%bind lst' = bind_map_list untype_expression arguments in
return (e_constant cons_name lst')
| E_variable (n) ->
return (e_variable n)
| E_application (f, arg) ->
let%bind f' = untype_expression f in
let%bind arg' = untype_expression arg in
return (e_variable (n))
| E_application {expr1;expr2} ->
let%bind f' = untype_expression expr1 in
let%bind arg' = untype_expression expr2 in
return (e_application f' arg')
| E_lambda {binder; body} -> (
let%bind io = get_t_function e.type_annotation in
| E_lambda {binder; result} -> (
let%bind io = get_t_function e.type_expression in
let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
let%bind result = untype_expression body in
return (e_lambda binder (Some input_type) (Some output_type) result)
let%bind result = untype_expression result in
return (e_lambda (binder) (Some input_type) (Some output_type) result)
)
| E_tuple lst ->
let%bind lst' = bind_list
@@ List.map untype_expression lst in
return (e_tuple lst')
| E_tuple_accessor (tpl, ind) ->
let%bind tpl' = untype_expression tpl in
return (e_accessor tpl' [Access_tuple ind])
| E_constructor (Constructor c, p) ->
let%bind p' = untype_expression p in
return (e_constructor c p')
| E_constructor {constructor; element} ->
let%bind p' = untype_expression element in
let Constructor n = constructor in
return (e_constructor n p')
| E_record r ->
let aux ( Label k ,v) = (k, v) in
let r = Map.String.of_list @@ List.map aux (LMap.to_kv_list r) in
let%bind r' = bind_smap
@@ Map.String.map untype_expression r in
return (e_record r')
| E_record_accessor (r, Label s) ->
let%bind r' = untype_expression r in
return (e_accessor r' [Access_record s])
| E_record_update (r, (l,e)) ->
let%bind r' = untype_expression r in
let%bind e = untype_expression e in
let Label l = l in
| E_record_accessor {expr; label} ->
let%bind r' = untype_expression expr in
let Label s = label in
return (e_accessor r' s)
| E_record_update {record; path; update} ->
let%bind r' = untype_expression record in
let%bind e = untype_expression update in
let Label l = path in
return (e_update r' l e)
| E_map m ->
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
@ -1155,26 +1093,24 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_look_up dsi ->
let%bind (a , b) = bind_map_pair untype_expression dsi in
return (e_look_up a b)
| E_matching (ae, m) ->
let%bind ae' = untype_expression ae in
let%bind m' = untype_matching untype_expression m in
| E_matching {matchee;cases} ->
let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression cases in
return (e_matching ae' m')
(* | E_failwith ae ->
* 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; inline} ->
let%bind tv = untype_type_value rhs.type_annotation in
| 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
let%bind result = untype_expression result in
return (e_let_in (binder , (Some tv)) inline rhs result)
let%bind result = untype_expression let_result in
return (e_let_in (let_binder , (Some tv)) false inline rhs result)
(*
Tranform a Ast_typed matching into an ast_simplified matching
*)
and untype_matching : type o i . (o -> i result) -> (o,O.type_value) O.matching -> ((i,unit) I.matching) result = fun f m ->
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
let open I in
match m with
| Match_bool {match_true ; match_false} ->

12
src/passes/4-typer-new/typer.mli
View File

@ -42,16 +42,16 @@ val type_program : I.program -> (O.program * Solver.state) result
val type_program' : I.program -> (O.program) result (* TODO: merge with type_program *)
val type_declaration : environment -> Solver.state -> I.declaration -> (environment * Solver.state * O.declaration option) result
(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
val evaluate_type : environment -> I.type_expression -> O.type_value result
val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
val type_expression_subst : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
val type_constant : I.constant -> O.type_value list -> O.type_value option -> (O.constant * O.type_value) result
val evaluate_type : environment -> I.type_expression -> O.type_expression result
val type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
val type_expression_subst : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression) result
(*
val untype_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal result
*)
val untype_type_expression : O.type_value -> I.type_expression result
val untype_expression : O.annotated_expression -> I.expression result
val untype_type_expression : O.type_expression -> I.type_expression result
val untype_expression : O.expression -> I.expression result
(*
val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result
*)

464
src/passes/4-typer-old/typer.ml
View File

@ -21,7 +21,7 @@ module Errors = struct
let title = (thunk "unbound type variable") in
let message () = "" in
let data = [
("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.type_variable tv) ;
("variable" , fun () -> Format.asprintf "%a" I.PP.type_variable tv) ;
(* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
@ -30,7 +30,7 @@ module Errors = struct
error ~data title message ()
let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () =
let name () = Format.asprintf "%a" Stage_common.PP.name n in
let name () = Format.asprintf "%a" I.PP.expression_variable n in
let title = (thunk ("unbound variable "^(name ()))) in
let message () = "" in
let data = [
@ -40,7 +40,7 @@ module Errors = struct
] in
error ~data title message ()
let match_empty_variant : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
let match_empty_variant : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "match with no cases") in
let message () = "" in
@ -50,7 +50,7 @@ module Errors = struct
] in
error ~data title message ()
let match_missing_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
let match_missing_case : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "missing case in match") in
let message () = "" in
@ -60,7 +60,7 @@ module Errors = struct
] in
error ~data title message ()
let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ =
let match_redundant_case : I.matching_expr -> Location.t -> unit -> _ =
fun matching loc () ->
let title = (thunk "redundant case in match") in
let message () = "" in
@ -70,11 +70,11 @@ module Errors = struct
] in
error ~data title message ()
let unbound_constructor (e:environment) (c:I.constructor) (loc:Location.t) () =
let unbound_constructor (e:environment) (c:I.constructor') (loc:Location.t) () =
let title = (thunk "unbound constructor") in
let message () = "" in
let data = [
("constructor" , fun () -> Format.asprintf "%a" Stage_common.PP.constructor c);
("constructor" , fun () -> Format.asprintf "%a" I.PP.constructor c);
("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
@ -91,6 +91,7 @@ module Errors = struct
] in
error ~data title message ()
let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () =
let title () = "matching tuple of different size" in
let message () = "" in
@ -110,27 +111,27 @@ module Errors = struct
] in
error ~data title message ()
let constant_declaration_error (name:I.expression_variable) (ae:I.expr) (expected: O.type_value option) () =
let constant_declaration_error (name:I.expression_variable) (ae:I.expr) (expected: O.type_expression option) () =
let title = (thunk "typing constant declaration") in
let message () = "" in
let data = [
("constant" , fun () -> Format.asprintf "%a" Stage_common.PP.name name) ;
("constant" , fun () -> Format.asprintf "%a" I.PP.expression_variable name) ;
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () ->
match expected with
None -> "(no annotation for the expected type)"
| Some expected -> Format.asprintf "%a" O.PP.type_value expected) ;
| Some expected -> Format.asprintf "%a" O.PP.type_expression expected) ;
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in
error ~data title message ()
let match_error : type a . ?msg:string -> expected: (a, unit) I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
let match_error : ?msg:string -> expected: I.matching_expr -> actual: O.type_expression -> Location.t -> unit -> _ =
fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ;
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
@ -144,46 +145,35 @@ module Errors = struct
] in
error ~data title message ()
let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () =
let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
let title = (thunk "type error") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%s" expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : I.expression) (loc:Location.t) () =
let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () =
let title = (thunk "type error") in
let message () = msg in
let data = [
("expected" , fun () -> Format.asprintf "%a" O.PP.type_value expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual);
("expected" , fun () -> Format.asprintf "%a" O.PP.type_expression expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_expression actual);
("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
let title = (thunk "invalid tuple index") in
let message () = "" in
let data = [
("index" , fun () -> Format.asprintf "%d" index) ;
("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
let bad_record_access (field : I.label) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
let bad_record_access (field : I.label) (ae : I.expression) (t : O.type_expression) (loc:Location.t) () =
let title = (thunk "invalid record field") in
let message () = "" in
let data = [
("field" , fun () -> Format.asprintf "%a" Stage_common.PP.label field) ;
("field" , fun () -> Format.asprintf "%a" I.PP.label field) ;
("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_expression t) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in
error ~data title message ()
@ -216,7 +206,7 @@ let rec type_program (p:I.program) : (O.program * Solver.state) result =
and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) : I.declaration -> (environment * Solver.state * O.declaration option) result = function
| Declaration_type (type_name , type_expression) ->
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type type_name tv env in
let env' = Environment.add_type (type_name) tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None)
| Declaration_constant (name , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
@ -224,10 +214,10 @@ and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) :
trace (constant_declaration_error name expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in
let env' = Environment.add_ez_ae name ae' env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant ((make_n_e name ae') , inline, (env , env'))))
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant (name,ae', inline, env')))
)
and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> (i, unit) I.matching -> I.expression -> Location.t -> (o, O.type_value) O.matching result =
and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result =
fun f e t i ae loc -> match i with
| Match_bool {match_true ; match_false} ->
let%bind _ =
@ -282,7 +272,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
~expression:ae
loc
) @@
Ast_typed.assert_type_value_eq (variant , variant') >>? fun () ->
Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
ok (Some variant)
) in
ok acc in
@ -320,13 +310,13 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
bind_map_list aux lst in
ok (O.Match_variant (lst' , variant))
and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
let return tv' = ok (make_t tv' (Some t)) in
match t.type_expression' with
| T_arrow (a, b) ->
let%bind a' = evaluate_type e a in
let%bind b' = evaluate_type e b in
return (T_arrow (a', b'))
match t.type_content with
| T_arrow {type1;type2} ->
let%bind type1 = evaluate_type e type1 in
let%bind type2 = evaluate_type e type2 in
return (T_arrow {type1;type2})
| T_sum m ->
let aux k v prev =
let%bind prev' = prev in
@ -346,7 +336,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
| T_variable name ->
let%bind tv =
trace_option (unbound_type_variable e name)
@@ Environment.get_type_opt name e in
@@ Environment.get_type_opt (name) e in
ok tv
| T_constant cst ->
return (T_constant cst)
@ -369,30 +359,27 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_big_map (k,v)
| TC_contract c ->
let%bind c = evaluate_type e c in
ok @@ I.TC_contract c
| TC_arrow ( arg , ret ) ->
let%bind arg' = evaluate_type e arg in
let%bind ret' = evaluate_type e ret in
ok @@ I.TC_arrow ( arg' , ret' )
| TC_tuple lst ->
let%bind lst' = bind_map_list (evaluate_type e) lst in
ok @@ I.TC_tuple lst'
ok @@ O.TC_arrow ( arg' , ret' )
| TC_contract c ->
let%bind c = evaluate_type e c in
ok @@ O.TC_contract c
in
return (T_operator (opt))
and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
= fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
let%bind res = type_expression' e ?tv_opt ae in
ok (res, (Solver.placeholder_for_state_of_new_typer ()))
and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.annotated_expression result = fun e ?tv_opt ae ->
and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> O.expression result = fun e ?tv_opt ae ->
let module L = Logger.Stateful() in
let return expr tv =
let%bind () =
match tv_opt with
| None -> ok ()
| Some tv' -> O.assert_type_value_eq (tv' , tv) in
| Some tv' -> O.assert_type_expression_eq (tv' , tv) in
let location = ae.location in
ok @@ make_a_e ~location expr tv e in
let main_error =
@ -405,7 +392,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
] in
error ~data title content in
trace main_error @@
match ae.expression with
match ae.expression_content with
(* Basic *)
| E_variable name ->
let%bind tv' =
@ -416,6 +403,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
return (E_literal (Literal_bool b)) (t_bool ())
| E_literal Literal_unit | E_skip ->
return (E_literal (Literal_unit)) (t_unit ())
| E_literal Literal_void -> return (E_literal (Literal_void)) (t_unit ()) (* TODO : IS this really a t_unit ?*)
| E_literal (Literal_string s) ->
return (E_literal (Literal_string s)) (t_string ())
| E_literal (Literal_key s) ->
@ -440,82 +428,66 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
return (e_address s) (t_address ())
| E_literal (Literal_operation op) ->
return (e_operation op) (t_operation ())
(* Tuple *)
| E_tuple lst ->
let%bind lst' = bind_list @@ List.map (type_expression' e) lst in
let tv_lst = List.map get_type_annotation lst' in
return (E_tuple lst') (t_tuple tv_lst ())
| E_accessor (ae', path) ->
let%bind e' = type_expression' e ae' in
let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result =
match a with
| Access_tuple index -> (
let%bind tpl_tv = get_t_tuple prev.type_annotation in
| E_record_accessor {expr;label} ->
let%bind e' = type_expression' e expr in
let aux (prev:O.expression) (a:I.label) : O.expression result =
let property = a in
let%bind r_tv = get_t_record prev.type_expression in
let%bind tv =
generic_try (bad_tuple_index index ae' prev.type_annotation ae.location)
@@ (fun () -> List.nth tpl_tv index) in
let location = ae.location in
ok @@ make_a_e ~location (E_tuple_accessor(prev , index)) tv e
)
| Access_record property -> (
let property = I.Label property in
let%bind r_tv = get_t_record prev.type_annotation in
let%bind tv =
generic_try (bad_record_access property ae' prev.type_annotation ae.location)
generic_try (bad_record_access property ae prev.type_expression ae.location)
@@ (fun () -> I.LMap.find property r_tv) in
let location = ae.location in
ok @@ make_a_e ~location (E_record_accessor (prev , property)) tv e
)
ok @@ make_a_e ~location (E_record_accessor {expr=prev; label=property}) tv e
in
let%bind ae =
trace (simple_info "accessing") @@
bind_fold_list aux e' path in
trace (simple_info "accessing") @@ aux e' label in
(* check type annotation of the final accessed element *)
let%bind () =
match tv_opt with
| None -> ok ()
| Some tv' -> O.assert_type_value_eq (tv' , ae.type_annotation) in
| Some tv' -> O.assert_type_expression_eq (tv' , ae.type_expression) in
ok(ae)
(* Sum *)
| E_constructor (c, expr) ->
| E_constructor {constructor; element} ->
let%bind (c_tv, sum_tv) =
let error =
let title () = "no such constructor" in
let content () =
Format.asprintf "%a in:\n%a\n"
Stage_common.PP.constructor c
Stage_common.PP.constructor constructor
O.Environment.PP.full_environment e
in
error title content in
trace_option error @@
Environment.get_constructor c e in
let%bind expr' = type_expression' e expr in
let%bind _assert = O.assert_type_value_eq (expr'.type_annotation, c_tv) in
return (E_constructor (c , expr')) sum_tv
Environment.get_constructor constructor e in
let%bind expr' = type_expression' e element in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
return (E_constructor {constructor; element=expr'}) sum_tv
(* Record *)
| E_record m ->
let aux prev k expr =
let%bind expr' = type_expression' e expr in
ok (I.LMap.add k expr' prev)
in
let%bind m' = I.bind_fold_lmap aux (ok I.LMap.empty) m in
return (E_record m') (t_record (I.LMap.map get_type_annotation m') ())
| E_update {record; update =(l,expr)} ->
let%bind m' = Stage_common.Helpers.bind_fold_lmap aux (ok I.LMap.empty) m in
return (E_record m') (t_record (I.LMap.map get_type_expression m') ())
| E_record_update {record; path; update} ->
let%bind record = type_expression' e record in
let%bind expr' = type_expression' e expr in
let wrapped = get_type_annotation record in
let%bind update = type_expression' e update in
let wrapped = get_type_expression record in
let%bind tv =
match wrapped.type_value' with
match wrapped.type_content with
| T_record record -> (
let field_op = I.LMap.find_opt l record in
let field_op = I.LMap.find_opt path record in
match field_op with
| Some tv -> ok (tv)
| None -> failwith @@ Format.asprintf "field %a is not part of record %a" Stage_common.PP.label l O.PP.type_value wrapped
| None -> failwith @@ Format.asprintf "field %a is not part of record %a" Stage_common.PP.label path O.PP.type_expression wrapped
)
| _ -> failwith "Update an expression which is not a record"
in
let%bind () = O.assert_type_value_eq (tv, get_type_annotation expr') in
return (E_record_update (record, (l,expr'))) wrapped
let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
return (E_record_update {record; path; update}) wrapped
(* Data-structure *)
| E_list lst ->
let%bind lst' = bind_map_list (type_expression' e) lst in
@ -524,7 +496,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
match opt with
| None -> ok (Some c)
| Some c' ->
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
ok (Some c') in
let%bind init = match tv_opt with
| None -> ok None
@ -533,7 +505,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
ok (Some ty') in
let%bind ty =
let%bind opt = bind_fold_list aux init
@@ List.map get_type_annotation lst' in
@@ List.map get_type_expression lst' in
trace_option (needs_annotation ae "empty list") opt in
ok (t_list ty ())
in
@ -545,7 +517,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
match opt with
| None -> ok (Some c)
| Some c' ->
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
ok (Some c') in
let%bind init = match tv_opt with
| None -> ok None
@ -554,7 +526,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
ok (Some ty') in
let%bind ty =
let%bind opt = bind_fold_list aux init
@@ List.map get_type_annotation lst' in
@@ List.map get_type_expression lst' in
trace_option (needs_annotation ae "empty set") opt in
ok (t_set ty ())
in
@ -566,12 +538,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
match opt with
| None -> ok (Some c)
| Some c' ->
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
ok (Some c') in
let%bind key_type =
let%bind sub =
bind_fold_list aux None
@@ List.map get_type_annotation
@@ List.map get_type_expression
@@ List.map fst lst' in
let%bind annot = bind_map_option get_t_map_key tv_opt in
trace (simple_info "empty map expression without a type annotation") @@
@ -580,7 +552,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
let%bind value_type =
let%bind sub =
bind_fold_list aux None
@@ List.map get_type_annotation
@@ List.map get_type_expression
@@ List.map snd lst' in
let%bind annot = bind_map_option get_t_map_value tv_opt in
trace (simple_info "empty map expression without a type annotation") @@
@ -596,12 +568,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
match opt with
| None -> ok (Some c)
| Some c' ->
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
ok (Some c') in
let%bind key_type =
let%bind sub =
bind_fold_list aux None
@@ List.map get_type_annotation
@@ List.map get_type_expression
@@ List.map fst lst' in
let%bind annot = bind_map_option get_t_big_map_key tv_opt in
trace (simple_info "empty map expression without a type annotation") @@
@ -610,7 +582,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
let%bind value_type =
let%bind sub =
bind_fold_list aux None
@@ List.map get_type_annotation
@@ List.map get_type_expression
@@ List.map snd lst' in
let%bind annot = bind_map_option get_t_big_map_value tv_opt in
trace (simple_info "empty map expression without a type annotation") @@
@ -632,11 +604,11 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
match input_type with
| Some ty -> ok ty
| None -> (
match result.expression with
match result.expression_content with
| I.E_let_in li -> (
match li.rhs.expression with
match li.rhs.expression_content with
| I.E_variable name when name = (fst binder) -> (
match snd li.binder with
match snd li.let_binder with
| Some ty -> ok ty
| None -> default_action li.rhs ()
)
@ -649,119 +621,133 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
let%bind output_type =
bind_map_option (evaluate_type e) output_type
in
let e' = Environment.add_ez_binder (fst binder) input_type e in
let binder = fst binder in
let e' = Environment.add_ez_binder binder input_type e in
let%bind body = type_expression' ?tv_opt:output_type e' result in
let output_type = body.type_annotation in
return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ())
let output_type = body.type_expression in
return (E_lambda {binder; result=body}) (t_function input_type output_type ())
)
| E_constant ( ( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ,
[
( { expression = (I.E_lambda { binder = (lname, None) ;
| E_constant {cons_name=( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ;
arguments=[
( { expression_content = (I.E_lambda { binder = (lname, None) ;
input_type = None ;
output_type = None ;
result }) ;
location = _ }) as _lambda ;
collect ;
init_record ;
] ) ->
]} ->
(* this special case is here force annotation of the untyped lambda
generated by pascaligo's for_collect loop *)
let%bind (v_col , v_initr ) = bind_map_pair (type_expression' e) (collect , init_record ) in
let tv_col = get_type_annotation v_col in (* this is the type of the collection *)
let tv_out = get_type_annotation v_initr in (* this is the output type of the lambda*)
let%bind input_type = match tv_col.type_value' with
| O.T_operator ( TC_list t | TC_set t) -> ok @@ t_tuple (tv_out::[t]) ()
| O.T_operator ( TC_map (k,v)| TC_big_map (k,v)) -> ok @@ t_tuple (tv_out::[(t_tuple [k;v] ())]) ()
let tv_col = get_type_expression v_col in (* this is the type of the collection *)
let tv_out = get_type_expression v_initr in (* this is the output type of the lambda*)
let%bind input_type = match tv_col.type_content with
| O.T_operator ( TC_list t | TC_set t) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",t)])
| O.T_operator ( TC_map (k,v)| TC_big_map (k,v)) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",make_t_ez_record [("0",k);("1",v)])])
| _ ->
let wtype = Format.asprintf
"Loops over collections expect lists, sets or maps, got type %a" O.PP.type_value tv_col in
"Loops over collections expect lists, sets or maps, got type %a" O.PP.type_expression tv_col in
fail @@ simple_error wtype in
let lname = lname in
let e' = Environment.add_ez_binder lname input_type e in
let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
let output_type = body.type_annotation in
let lambda' = make_a_e (E_lambda {binder = lname ; body}) (t_function input_type output_type ()) e in
let output_type = body.type_expression in
let lambda' = make_a_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in
let lst' = [lambda'; v_col; v_initr] in
let tv_lst = List.map get_type_annotation lst' in
let tv_lst = List.map get_type_expression lst' in
let%bind (opname', tv) =
type_constant opname tv_lst tv_opt in
return (E_constant (opname' , lst')) tv
| E_constant (name, lst) ->
let%bind lst' = bind_list @@ List.map (type_expression' e) lst in
let tv_lst = List.map get_type_annotation lst' in
return (E_constant {cons_name=opname';arguments=lst'}) tv
| E_constant {cons_name=C_FOLD_WHILE as opname;
arguments = [
( { expression_content = (I.E_lambda { binder = (lname, None) ;
input_type = None ;
output_type = None ;
result }) ;
location = _ }) as _lambda ;
init_record ;
]} ->
Format.printf "typing foldwhile \n %!";
let%bind v_initr = type_expression' e init_record in
let tv_out = get_type_expression v_initr in
let input_type = tv_out in
let e' = Environment.add_ez_binder lname input_type e in
Format.printf "typing foldwhile %a\n %a\n %!" Ast_typed.PP.type_expression tv_out I.PP.expression result;
let%bind body = type_expression' e' result in
Format.printf "typing foldwhile %a\n %!" O.PP.expression body;
let output_type = body.type_expression in
let lambda' = make_a_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in
let lst' = [lambda';v_initr] in
let tv_lst = List.map get_type_expression lst' in
Format.printf "Typing constant : %a \n%!" (Ast_typed.PP.list_sep_d Ast_typed.PP.type_expression) tv_lst;
let%bind (opname',tv) = type_constant opname tv_lst tv_opt in
Format.printf "Typed constant : %a \n%!" O.PP.type_expression tv;
return (E_constant {cons_name=opname';arguments=lst'}) tv
| E_constant {cons_name;arguments} ->
let%bind lst' = bind_list @@ List.map (type_expression' e) arguments in
let tv_lst = List.map get_type_expression lst' in
let%bind (name', tv) =
type_constant name tv_lst tv_opt in
return (E_constant (name' , lst')) tv
| E_application (f, arg) ->
let%bind f' = type_expression' e f in
let%bind arg = type_expression' e arg in
let%bind tv = match f'.type_annotation.type_value' with
| T_arrow (param, result) ->
let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in
ok result
type_constant cons_name tv_lst tv_opt in
return (E_constant {cons_name=name';arguments=lst'}) tv
| E_application {expr1;expr2} ->
let%bind expr1' = type_expression' e expr1 in
let%bind expr2 = type_expression' e expr2 in
let%bind tv = match expr1'.type_expression.type_content with
| T_arrow {type1;type2} ->
let%bind _ = O.assert_type_expression_eq (type1, expr2.type_expression) in
ok type2
| _ ->
fail @@ type_error_approximate
~expected:"should be a function type"
~expression:f
~actual:f'.type_annotation
f'.location
~expression:expr1
~actual:expr1'.type_expression
expr1'.location
in
return (E_application (f' , arg)) tv
return (E_application {expr1=expr1';expr2}) tv
| E_look_up dsi ->
let%bind (ds, ind) = bind_map_pair (type_expression' e) dsi in
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in
let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_expression in
let%bind _ = O.assert_type_expression_eq (ind.type_expression, src) in
return (E_look_up (ds , ind)) (t_option dst ())
(* Advanced *)
| E_matching (ex, m) -> (
let%bind ex' = type_expression' e ex in
let%bind m' = type_match (type_expression' ?tv_opt:None) e ex'.type_annotation m ae ae.location in
| E_matching {matchee;cases} -> (
let%bind ex' = type_expression' e matchee in
let%bind m' = type_match (type_expression' ?tv_opt:None) e ex'.type_expression cases ae ae.location in
let tvs =
let aux (cur:(O.value, O.type_value) O.matching) =
let aux (cur:O.matching_expr) =
match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ]
| Match_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in
List.map get_type_annotation @@ aux m' in
List.map get_type_expression @@ aux m' in
let aux prec cur =
let%bind () =
match prec with
| None -> ok ()
| Some cur' -> Ast_typed.assert_type_value_eq (cur , cur') in
| Some cur' -> Ast_typed.assert_type_expression_eq (cur , cur') in
ok (Some cur) in
let%bind tv_opt = bind_fold_list aux None tvs in
let%bind tv =
trace_option (match_empty_variant m ae.location) @@
trace_option (match_empty_variant cases ae.location) @@
tv_opt in
return (O.E_matching (ex', m')) tv
return (O.E_matching {matchee=ex'; cases=m'}) tv
)
| E_sequence (a , b) ->
let%bind a' = type_expression' e a in
let%bind b' = type_expression' e b in
let a'_type_annot = get_type_annotation a' in
let%bind () =
trace_strong (type_error
~msg:"first part of the sequence should be of unit type"
~expected:(O.t_unit ())
~actual:a'_type_annot
~expression:a
a'.location) @@
Ast_typed.assert_type_value_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
| 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_annotation expr' 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:expr
~expression:condition
expr'.location) @@
Ast_typed.assert_type_value_eq (t_bool () , t_expr') in
let t_body' = get_type_annotation body' in
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"
@ -769,71 +755,38 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
~actual:t_body'
~expression:body
body'.location) @@
Ast_typed.assert_type_value_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
ok @@ make_n_t name ele.type_value in
let%bind (assign_tv , path') =
let aux : ((_ * O.access_path) as 'a) -> I.access -> 'a result = fun (prec_tv , prec_path) cur_path ->
match cur_path with
| Access_tuple index -> (
let%bind tpl = get_t_tuple prec_tv in
let%bind tv' =
trace_option (bad_tuple_index index ae prec_tv ae.location) @@
List.nth_opt tpl index in
ok (tv' , prec_path @ [O.Access_tuple index])
)
| Access_record property -> (
let%bind m = get_t_record prec_tv in
let%bind tv' =
trace_option (bad_record_access (Label property) ae prec_tv ae.location) @@
I.LMap.find_opt (Label property) m in
ok (tv' , prec_path @ [O.Access_record property])
)
in
bind_fold_list aux (typed_name.type_value , []) path in
let%bind expr' = type_expression' e ~tv_opt:assign_tv expr in
let t_expr' = get_type_annotation expr' in
let%bind () =
trace_strong (type_error
~msg:"type of the expression to assign doesn't match left-hand-side"
~expected:assign_tv
~actual:t_expr'
~expression:expr
expr'.location) @@
Ast_typed.assert_type_value_eq (assign_tv , t_expr') in
return (O.E_assign (typed_name , path' , expr')) (t_unit ())
| E_let_in {binder ; rhs ; result; inline} ->
let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in
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
let e' = Environment.add_ez_declaration (fst binder) rhs e in
let%bind result = type_expression' e' result in
return (E_let_in {binder = fst binder; rhs; result; inline}) result.type_annotation
| E_ascription (expr , te) ->
let%bind tv = evaluate_type e te in
let%bind expr' = type_expression' ~tv_opt:tv e expr in
let let_binder = fst let_binder in
let e' = Environment.add_ez_declaration (let_binder) rhs e in
let%bind let_result = type_expression' e' let_result in
return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression
| E_ascription {anno_expr; type_annotation} ->
let%bind tv = evaluate_type e type_annotation in
let%bind expr' = type_expression' ~tv_opt:tv e anno_expr in
let%bind type_annotation =
O.merge_annotation
(Some tv)
(Some expr'.type_annotation)
(Some expr'.type_expression)
(internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in
(* check type annotation of the expression as a whole (e.g. let x : t = (v : t') ) *)
let%bind () =
match tv_opt with
| None -> ok ()
| Some tv' -> O.assert_type_value_eq (tv' , type_annotation) in
ok @@ {expr' with type_annotation}
| Some tv' -> O.assert_type_expression_eq (tv' , type_annotation) in
ok {expr' with type_expression=type_annotation}
and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result =
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
let%bind typer = Operators.Typer.constant_typers name in
let%bind tv = typer lst tv_opt in
ok(name, tv)
let untype_type_value (t:O.type_value) : (I.type_expression) result =
match t.simplified with
let untype_type_expression (t:O.type_expression) : (I.type_expression) result =
match t.type_meta with
| Some s -> ok s
| _ -> fail @@ internal_assertion_failure "trying to untype generated type"
@ -841,6 +794,7 @@ let untype_literal (l:O.literal) : I.literal result =
let open I in
match l with
| Literal_unit -> ok Literal_unit
| Literal_void -> ok Literal_void
| Literal_bool b -> ok (Literal_bool b)
| Literal_nat n -> ok (Literal_nat n)
| Literal_timestamp n -> ok (Literal_timestamp n)
@ -849,43 +803,38 @@ let untype_literal (l:O.literal) : I.literal result =
| Literal_string s -> ok (Literal_string s)
| Literal_signature s -> ok (Literal_signature s)
| Literal_key s -> ok (Literal_key s)
| Literal_key_hash s -> ok (Literal_key_hash s)
| Literal_chain_id s -> ok (Literal_chain_id s)
| Literal_bytes b -> ok (Literal_bytes b)
| Literal_address s -> ok (Literal_address s)
| Literal_operation s -> ok (Literal_operation s)
let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
let rec untype_expression (e:O.expression) : (I.expression) result =
let open I in
let return e = ok e in
match e.expression with
match e.expression_content with
| E_literal l ->
let%bind l = untype_literal l in
return (e_literal l)
| E_constant (const, lst) ->
let%bind lst' = bind_map_list untype_expression lst in
return (e_constant const lst')
| E_constant {cons_name;arguments} ->
let%bind lst' = bind_map_list untype_expression arguments in
return (e_constant cons_name lst')
| E_variable n ->
return (e_variable n)
| E_application (f, arg) ->
let%bind f' = untype_expression f in
let%bind arg' = untype_expression arg in
return (e_variable (n))
| E_application {expr1;expr2} ->
let%bind f' = untype_expression expr1 in
let%bind arg' = untype_expression expr2 in
return (e_application f' arg')
| E_lambda {binder ; body} -> (
let%bind io = get_t_function e.type_annotation in
let%bind (input_type , output_type) = bind_map_pair untype_type_value io in
let%bind result = untype_expression body in
return (e_lambda binder (Some input_type) (Some output_type) result)
| E_lambda {binder ; result} -> (
let%bind io = get_t_function e.type_expression in
let%bind (input_type , output_type) = bind_map_pair untype_type_expression io in
let%bind result = untype_expression result in
return (e_lambda (binder) (Some input_type) (Some output_type) result)
)
| E_tuple lst ->
let%bind lst' = bind_list
@@ List.map untype_expression lst in
return (e_tuple lst')
| E_tuple_accessor (tpl, ind) ->
let%bind tpl' = untype_expression tpl in
return (e_accessor tpl' [Access_tuple ind])
| E_constructor ( Constructor n, p) ->
let%bind p' = untype_expression p in
| E_constructor {constructor; element} ->
let%bind p' = untype_expression element in
let Constructor n = constructor in
return (e_constructor n p')
| E_record r ->
let aux ( Label k ,v) = (k, v) in
@ -893,10 +842,11 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
let%bind r' = bind_smap
@@ Map.String.map untype_expression r in
return (e_record r')
| E_record_accessor (r, Label s) ->
let%bind r' = untype_expression r in
return (e_accessor r' [Access_record s])
| E_record_update (r, (l,e)) ->
| E_record_accessor {expr; label} ->
let%bind r' = untype_expression expr in
let Label s = label in
return (e_accessor r' s)
| E_record_update {record=r; path=l; update=e} ->
let%bind r' = untype_expression r in
let%bind e = untype_expression e in
let Label l = l in
@ -916,20 +866,18 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_look_up dsi ->
let%bind (a , b) = bind_map_pair untype_expression dsi in
return (e_look_up a b)
| E_matching (ae, m) ->
let%bind ae' = untype_expression ae in
let%bind m' = untype_matching untype_expression m in
| E_matching {matchee;cases} ->
let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression cases in
return (e_matching ae' m')
| 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; inline} ->
let%bind tv = untype_type_value rhs.type_annotation in
| 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
let%bind result = untype_expression result in
return (e_let_in (binder , (Some tv)) inline rhs result)
let%bind result = untype_expression let_result in
return (I.e_let_in (let_binder , (Some tv)) false inline rhs result)
and untype_matching : type o i . (o -> i result) -> (o,O.type_value) O.matching -> ((i,unit) I.matching) result = fun f m ->
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
let open I in
match m with
| Match_bool {match_true ; match_false} ->

8
src/passes/4-typer-old/typer.mli
View File

@ -41,14 +41,14 @@ end
val type_program : I.program -> (O.program * Solver.state) result
val type_declaration : environment -> Solver.state -> I.declaration -> (environment * Solver.state * O.declaration option) result
(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
val evaluate_type : environment -> I.type_expression -> O.type_value result
val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
val type_constant : I.constant -> O.type_value list -> O.type_value option -> (O.constant * O.type_value) result
val evaluate_type : environment -> I.type_expression -> O.type_expression result
val type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
val type_constant : I.constant' -> O.type_expression list -> O.type_expression option -> (O.constant' * O.type_expression) result
(*
val untype_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal result
*)
val untype_expression : O.annotated_expression -> I.expression result
val untype_expression : O.expression -> I.expression result
(*
val untype_matching : ('o -> 'i result) -> 'o O.matching -> ('i I.matching) result
*)

4
src/passes/4-typer/typer.mli
View File

@ -12,5 +12,5 @@ module Solver = Typer_new.Solver
type environment = Environment.t
val type_program : I.program -> (O.program * Solver.state) result
val type_expression_subst : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) result
val untype_expression : O.annotated_expression -> I.expression result
val type_expression_subst : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
val untype_expression : O.expression -> I.expression result

14
src/passes/6-interpreter/dune Normal file
View File

@ -0,0 +1,14 @@
(library
(name interpreter)
(public_name ligo.interpreter)
(libraries
simple-utils
tezos-utils
ast_typed
ligo_interpreter
)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
)

395
src/passes/6-interpreter/interpreter.ml Normal file
View File

@ -0,0 +1,395 @@
open Trace
open Ligo_interpreter.Types
open Ligo_interpreter.Combinators
include Stage_common.Types
module Env = Ligo_interpreter.Environment
let apply_comparison : Ast_typed.constant' -> value list -> value result =
fun c operands -> match (c,operands) with
| ( comp , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] )
| ( comp , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] )
| ( comp , [ V_Ct (C_mutez a' ) ; V_Ct (C_mutez b' ) ] )
| ( comp , [ V_Ct (C_timestamp a') ; V_Ct (C_timestamp b') ] ) ->
let f_op = match comp with
| C_EQ -> Int.equal
| C_NEQ -> fun a b -> not (Int.equal a b)
| C_LT -> (<)
| C_LE -> (<=)
| C_GT -> (>)
| C_GE -> (>=)
| _ -> failwith "apply compare must be called with a comparative constant" in
ok @@ v_bool (f_op a' b')
| ( comp , [ V_Ct (C_string a' ) ; V_Ct (C_string b' ) ] )
| ( comp , [ V_Ct (C_address a' ) ; V_Ct (C_address b' ) ] )
| ( comp , [ V_Ct (C_key_hash a') ; V_Ct (C_key_hash b') ] ) ->
let f_op = match comp with
| C_EQ -> fun a b -> (String.compare a b = 0)
| C_NEQ -> fun a b -> (String.compare a b != 0)
(* the above might not be alligned with Michelson interpreter. Do we care ? *)
| C_LT -> fun a b -> (String.compare a b < 0)
| C_LE -> fun a b -> (String.compare a b <= 0)
| C_GT -> fun a b -> (String.compare a b > 0)
| C_GE -> fun a b -> (String.compare a b >= 0)
| _ -> failwith "apply compare must be called with a comparative constant" in
ok @@ v_bool (f_op a' b')
| ( comp , [ V_Ct (C_bytes a' ) ; V_Ct (C_bytes b' ) ] ) ->
let f_op = match comp with
| C_EQ -> fun a b -> (Bytes.compare a b = 0)
| C_NEQ -> fun a b -> (Bytes.compare a b != 0)
(* the above might not be alligned with Michelson interpreter. Do we care ? *)
| C_LT -> fun a b -> (Bytes.compare a b < 0)
| C_LE -> fun a b -> (Bytes.compare a b <= 0)
| C_GT -> fun a b -> (Bytes.compare a b > 0)
| C_GE -> fun a b -> (Bytes.compare a b >= 0)
| _ -> failwith "apply compare must be called with a comparative constant" in
ok @@ v_bool (f_op a' b')
| _ ->
let () = List.iter (fun el -> Format.printf "%s" (Ligo_interpreter.PP.pp_value el)) operands in
simple_fail "unsupported comparison"
(* applying those operators does not involve extending the environment *)
let rec apply_operator : Ast_typed.constant' -> value list -> value result =
fun c operands ->
let return_ct v = ok @@ V_Ct v in
let return_none () = ok @@ v_none () in
let return_some v = ok @@ v_some v in
( match (c,operands) with
(* nullary *)
| ( C_NONE , [] ) -> return_none ()
| ( C_UNIT , [] ) -> ok @@ V_Ct C_unit
| ( C_NIL , [] ) -> ok @@ V_List []
(* unary *)
| ( C_FAILWITH , [ V_Ct (C_string a') ] ) ->
(*TODO This raise is here until we properly implement effects*)
raise (Temporary_hack a')
(*TODO This raise is here until we properly implement effects*)
| ( C_SIZE , [(V_Set l | V_List l)] ) -> return_ct @@ C_nat (List.length l)
| ( C_SIZE , [ V_Map l ] ) -> return_ct @@ C_nat (List.length l)
| ( C_SIZE , [ V_Ct (C_string s ) ] ) -> return_ct @@ C_nat (String.length s)
| ( C_SIZE , [ V_Ct (C_bytes b ) ] ) -> return_ct @@ C_nat (Bytes.length b)
| ( C_NOT , [ V_Ct (C_bool a' ) ] ) -> return_ct @@ C_bool (not a')
| ( C_INT , [ V_Ct (C_nat a') ] ) -> return_ct @@ C_int a'
| ( C_ABS , [ V_Ct (C_int a') ] ) -> return_ct @@ C_int (abs a')
| ( C_NEG , [ V_Ct (C_int a') ] ) -> return_ct @@ C_int (-a')
| ( C_SOME , [ v ] ) -> return_some v
| ( C_IS_NAT , [ V_Ct (C_int a') ] ) ->
if a' > 0 then return_some @@ V_Ct (C_nat a')
else return_none ()
| ( C_CONTINUE , [ v ] ) -> ok @@ v_pair (v_bool true , v)
| ( C_STOP , [ v ] ) -> ok @@ v_pair (v_bool false , v)
| ( C_ASSERTION , [ v ] ) ->
let%bind pass = is_true v in
if pass then return_ct @@ C_unit
else raise (Temporary_hack "failed assertion")
| C_MAP_FIND_OPT , [ k ; V_Map l ] -> ( match List.assoc_opt k l with
| Some v -> ok @@ v_some v
| None -> ok @@ v_none ()
)
| C_MAP_FIND , [ k ; V_Map l ] -> ( match List.assoc_opt k l with
| Some v -> ok @@ v
| None -> raise (Temporary_hack "failed map find")
)
(* binary *)
| ( (C_EQ | C_NEQ | C_LT | C_LE | C_GT | C_GE) , _ ) -> apply_comparison c operands
| ( C_SUB , [ V_Ct (C_int a' | C_nat a') ; V_Ct (C_int b' | C_nat b') ] ) -> return_ct @@ C_int (a' - b')
| ( C_CONS , [ v ; V_List vl ] ) -> ok @@ V_List (v::vl)
| ( C_ADD , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' + b')
| ( C_ADD , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' + b')
| ( C_ADD , [ V_Ct (C_nat a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' + b')
| ( C_ADD , [ V_Ct (C_int a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_int (a' + b')
| ( C_MUL , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' * b')
| ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' * b')
| ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b')
| ( C_MUL , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b')
| ( C_DIV , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' / b')
| ( C_DIV , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' / b')
| ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_mutez (a' / b')
| ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_nat (a' / b')
| ( C_MOD , [ V_Ct (C_int a') ; V_Ct (C_int b') ] ) -> return_ct @@ C_nat (a' mod b')
| ( C_MOD , [ V_Ct (C_nat a') ; V_Ct (C_nat b') ] ) -> return_ct @@ C_nat (a' mod b')
| ( C_MOD , [ V_Ct (C_nat a') ; V_Ct (C_int b') ] ) -> return_ct @@ C_nat (a' mod b')
| ( C_MOD , [ V_Ct (C_int a') ; V_Ct (C_nat b') ] ) -> return_ct @@ C_nat (a' mod b')
| ( C_CONCAT , [ V_Ct (C_string a') ; V_Ct (C_string b') ] ) -> return_ct @@ C_string (a' ^ b')
| ( C_CONCAT , [ V_Ct (C_bytes a' ) ; V_Ct (C_bytes b' ) ] ) -> return_ct @@ C_bytes (Bytes.cat a' b')
| ( C_OR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' || b')
| ( C_AND , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' && b')
| ( C_XOR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool ( (a' || b') && (not (a' && b')) )
| ( C_LIST_MAP , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) ->
let%bind elts' = bind_map_list
(fun elt ->
let env' = Env.extend env (arg_name,elt) in
eval body env')
elts in
ok @@ V_List elts'
| ( C_MAP_MAP , [ V_Func_val (arg_name, body, env) ; V_Map (elts) ] ) ->
let%bind elts' = bind_map_list
(fun (k,v) ->
let env' = Env.extend env (arg_name,v_pair (k,v)) in
let%bind v' = eval body env' in
ok @@ (k,v')
)
elts in
ok @@ V_Map elts'
| ( C_LIST_ITER , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) ->
bind_fold_list
(fun _ elt ->
let env' = Env.extend env (arg_name,elt) in
eval body env'
)
(V_Ct C_unit) elts
| ( C_MAP_ITER , [ V_Func_val (arg_name, body, env) ; V_Map (elts) ] ) ->
bind_fold_list
(fun _ kv ->
let env' = Env.extend env (arg_name,v_pair kv) in
eval body env'
)
(V_Ct C_unit) elts
| ( C_FOLD_WHILE , [ V_Func_val (arg_name, body, env) ; init ] ) ->
let rec aux el =
let%bind (b,folded_val) = extract_pair el in
let env' = Env.extend env (arg_name, folded_val) in
let%bind res = eval body env' in
let%bind continue = is_true b in
if continue then aux res else ok folded_val in
aux @@ v_pair (v_bool true,init)
(* tertiary *)
| ( C_SLICE , [ V_Ct (C_nat st) ; V_Ct (C_nat ed) ; V_Ct (C_string s) ] ) ->
generic_try (simple_error "bad slice") @@ (fun () ->
V_Ct (C_string (String.sub s st ed))
)
| ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List elts ; init ] ) ->
bind_fold_list
(fun prev elt ->
let fold_args = v_pair (prev,elt) in
let env' = Env.extend env (arg_name, fold_args) in
eval body env'
)
init elts
| ( C_MAP_FOLD , [ V_Func_val (arg_name, body, env) ; V_Map kvs ; init ] ) ->
bind_fold_list
(fun prev kv ->
let fold_args = v_pair (prev, v_pair kv) in
let env' = Env.extend env (arg_name, fold_args) in
eval body env'
)
init kvs
| ( C_MAP_MEM , [ k ; V_Map kvs ] ) -> ok @@ v_bool (List.mem_assoc k kvs)
| ( C_MAP_ADD , [ k ; v ; V_Map kvs as vmap] ) ->
if (List.mem_assoc k kvs) then ok vmap
else ok (V_Map ((k,v)::kvs))
| ( C_MAP_REMOVE , [ k ; V_Map kvs] ) -> ok @@ V_Map (List.remove_assoc k kvs)
| ( C_MAP_UPDATE , [ k ; V_Construct (option,v) ; V_Map kvs] ) -> (match option with
| "Some" -> ok @@ V_Map ((k,v)::(List.remove_assoc k kvs))
| "None" -> ok @@ V_Map (List.remove_assoc k kvs)
| _ -> simple_fail "update without an option"
)
| ( C_SET_ADD , [ v ; V_Set l ] ) -> ok @@ V_Set (List.sort_uniq compare (v::l))
| ( C_SET_FOLD , [ V_Func_val (arg_name, body, env) ; V_Set elts ; init ] ) ->
bind_fold_list
(fun prev elt ->
let fold_args = v_pair (prev,elt) in
let env' = Env.extend env (arg_name, fold_args) in
eval body env'
)
init elts
| ( C_SET_ITER , [ V_Func_val (arg_name, body, env) ; V_Set (elts) ] ) ->
bind_fold_list
(fun _ elt ->
let env' = Env.extend env (arg_name,elt) in
eval body env'
)
(V_Ct C_unit) elts
| ( C_SET_MEM , [ v ; V_Set (elts) ] ) -> ok @@ v_bool (List.mem v elts)
| ( C_SET_REMOVE , [ v ; V_Set (elts) ] ) -> ok @@ V_Set (List.filter (fun el -> not (el = v)) elts)
| _ ->
let () = Format.printf "%a\n" Stage_common.PP.constant c in
let () = List.iter ( fun e -> Format.printf "%s\n" (Ligo_interpreter.PP.pp_value e)) operands in
simple_fail "Unsupported constant op"
)
(* TODO
hash on bytes
C_BLAKE2b
C_SHA256
C_SHA512
hash on key
C_HASH_KEY
need exts
C_AMOUNT
C_BALANCE
C_CHAIN_ID
C_CONTRACT_ENTRYPOINT_OPT
C_CONTRACT_OPT
C_CONTRACT
C_CONTRACT_ENTRYPOINT
C_SELF_ADDRESS
C_SOURCE
C_SENDER
C_NOW
C_IMPLICIT_ACCOUNT
C_CALL
C_SET_DELEGATE
C_BYTES_PACK
C_BYTES_UNPACK
C_CHECK_SIGNATURE
C_ADDRESS
WONT DO:
C_STEPS_TO_QUOTA
*)
(*interpreter*)
and eval_literal : Ast_typed.literal -> value result = function
| Literal_unit -> ok @@ V_Ct (C_unit)
| Literal_bool b -> ok @@ V_Ct (C_bool b)
| Literal_int i -> ok @@ V_Ct (C_int i)
| Literal_nat n -> ok @@ V_Ct (C_nat n)
| Literal_timestamp i -> ok @@ V_Ct (C_timestamp i)
| Literal_string s -> ok @@ V_Ct (C_string s)
| Literal_bytes s -> ok @@ V_Ct (C_bytes s)
| Literal_mutez t -> ok @@ V_Ct (C_mutez t)
| Literal_address s -> ok @@ V_Ct (C_address s)
| Literal_signature s -> ok @@ V_Ct (C_signature s)
| Literal_key s -> ok @@ V_Ct (C_key s)
| Literal_key_hash s -> ok @@ V_Ct (C_key_hash s)
| Literal_chain_id s -> ok @@ V_Ct (C_key_hash s)
| Literal_operation o -> ok @@ V_Ct (C_operation o)
| Literal_void -> simple_fail "iguess ?"
and eval : Ast_typed.expression -> env -> value result
= fun term env ->
match term.expression_content with
| E_application ({expr1 = f; expr2 = args}) -> (
let%bind f' = eval f env in
match f' with
| V_Func_val (arg_names, body, f_env) ->
let%bind args' = eval args env in
let f_env' = Env.extend f_env (arg_names, args') in
eval body f_env'
| _ -> simple_fail "trying to apply on something that is not a function"
)
| E_lambda { binder; result;} ->
ok @@ V_Func_val (binder,result,env)
| E_let_in { let_binder; rhs; let_result; _} ->
let%bind rhs' = eval rhs env in
eval let_result (Env.extend env (let_binder,rhs'))
| E_map kvlist | E_big_map kvlist ->
let%bind kvlist' = bind_map_list
(fun kv -> bind_map_pair (fun (el:Ast_typed.expression) -> eval el env) kv)
kvlist in
ok @@ V_Map kvlist'
| E_list expl ->
let%bind expl' = bind_map_list
(fun (exp:Ast_typed.expression) -> eval exp env)
expl in
ok @@ V_List expl'
| E_set expl ->
let%bind expl' = bind_map_list
(fun (exp:Ast_typed.expression) -> eval exp env)
(List.sort_uniq compare expl)
in
ok @@ V_Set expl'
| E_literal l ->
eval_literal l
| E_variable var ->
Env.lookup env var
| E_record recmap ->
let%bind lv' = bind_map_list
(fun (label,(v:Ast_typed.expression)) ->
let%bind v' = eval v env in
ok (label,v'))
(LMap.to_kv_list recmap) in
ok @@ V_Record (LMap.of_list lv')
| E_record_accessor { expr ; label} -> (
let%bind record' = eval expr env in
match record' with
| V_Record recmap ->
let%bind a = trace_option (simple_error "unknown record field") @@
LMap.find_opt label recmap in
ok a
| _ -> simple_fail "trying to access a non-record"
)
| E_record_update {record ; path ; update} -> (
let%bind record' = eval record env in
match record' with
| V_Record recmap ->
if LMap.mem path recmap then
let%bind field' = eval update env in
ok @@ V_Record (LMap.add path field' recmap)
else
simple_fail "field l does not exist in record"
| _ -> simple_fail "this expression isn't a record"
)
| E_constant {cons_name ; arguments} -> (
let%bind operands' = bind_map_list
(fun (ae:Ast_typed.expression) -> eval ae env)
arguments in
apply_operator cons_name operands'
)
| E_constructor { constructor = Constructor c ; element } ->
let%bind v' = eval element env in
ok @@ V_Construct (c,v')
| E_matching { matchee ; cases} -> (
let%bind e' = eval matchee env in
match cases, e' with
| Match_list cases , V_List [] ->
eval cases.match_nil env
| Match_list cases , V_List (head::tail) ->
let (head_var,tail_var,body,_) = cases.match_cons in
let env' = Env.extend (Env.extend env (head_var,head)) (tail_var, V_List tail) in
eval body env'
| Match_variant (case_list , _) , V_Construct (matched_c , proj) ->
let ((_, var) , body) =
List.find
(fun case ->
let (Constructor c , _) = fst case in
String.equal matched_c c)
case_list in
let env' = Env.extend env (var, proj) in
eval body env'
| Match_bool cases , V_Ct (C_bool true) ->
eval cases.match_true env
| Match_bool cases , V_Ct (C_bool false) ->
eval cases.match_false env
| Match_option cases, V_Construct ("Some" , proj) ->
let (var,body,_) = cases.match_some in
let env' = Env.extend env (var,proj) in
eval body env'
| Match_option cases, V_Construct ("None" , V_Ct C_unit) ->
eval cases.match_none env
| _ -> simple_fail "not yet supported case"
(* ((ctor,name),body) *)
)
| E_look_up _ | E_loop _ ->
let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in
simple_fail serr
let dummy : Ast_typed.program -> string result =
fun prg ->
let%bind (res,_) = bind_fold_list
(fun (pp,top_env) el ->
let (Ast_typed.Declaration_constant (exp_name, exp , _ , _)) = Location.unwrap el in
let%bind v =
(*TODO This TRY-CATCH is here until we properly implement effects*)
try
eval exp top_env
with Temporary_hack s -> ok @@ V_Failure s
(*TODO This TRY-CATCH is here until we properly implement effects*)
in
let pp' = pp^"\n val "^(Var.to_name exp_name)^" = "^(Ligo_interpreter.PP.pp_value v) in
let top_env' = Env.extend top_env (exp_name, v) in
ok @@ (pp',top_env')
)
("",Env.empty_env) prg in
ok @@ res

3
src/passes/6-interpreter/interpreter.mli Normal file
View File

@ -0,0 +1,3 @@
open Trace
val dummy : Ast_typed.program -> string result

10
src/passes/6-transpiler/helpers.ml
View File

@ -21,9 +21,9 @@ let map_of_kv_list lst =
let open Map.String in
List.fold_left (fun prev (k, v) -> add k v prev) empty lst
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_expression) result =
let open Append_tree in
let rec aux tv : (string * value * AST.type_value) result=
let rec aux tv : (string * value * AST.type_expression) result=
match tv with
| Leaf (Constructor k, t), v -> ok (k, v, t)
| Node {a}, D_left v -> aux (a, v)
@ -33,9 +33,9 @@ let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value
let%bind (s, v, t) = aux (tree, v) in
ok (s, v, t)
let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result =
let extract_tuple (v : value) (tree : AST.type_expression Append_tree.t') : ((value * AST.type_expression) list) result =
let open Append_tree in
let rec aux tv : ((value * AST.type_value) list) result =
let rec aux tv : ((value * AST.type_expression) list) result =
match tv with
| Leaf t, v -> ok @@ [v, t]
| Node {a;b}, D_pair (va, vb) ->
@ -48,7 +48,7 @@ let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value *
let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
let open Append_tree in
let rec aux tv : ((AST.label * (value * AST.type_value)) list) result =
let rec aux tv : ((AST.label * (value * AST.type_expression)) list) result =
match tv with
| Leaf (s, t), v -> ok @@ [s, (v, t)]
| Node {a;b}, D_pair (va, vb) ->

276
src/passes/6-transpiler/transpiler.ml
View File

@ -102,32 +102,27 @@ them. please report this to the developers." in
] in
error ~data title content
let not_found content =
let title () = "Not_found" in
let content () = content in
let data = [
] in
error ~data title content
end
open Errors
let rec transpile_type (t:AST.type_value) : type_value result =
match t.type_value' with
let rec transpile_type (t:AST.type_expression) : type_value result =
match t.type_content with
| T_variable (name) -> fail @@ no_type_variable @@ name
| T_constant (TC_bool) -> ok (T_base Base_bool)
| T_constant (TC_int) -> ok (T_base Base_int)
| T_constant (TC_nat) -> ok (T_base Base_nat)
| T_constant (TC_mutez) -> ok (T_base Base_mutez)
| T_constant (TC_string) -> ok (T_base Base_string)
| T_constant (TC_bytes) -> ok (T_base Base_bytes)
| T_constant (TC_address) -> ok (T_base Base_address)
| T_constant (TC_timestamp) -> ok (T_base Base_timestamp)
| T_constant (TC_unit) -> ok (T_base Base_unit)
| T_constant (TC_operation) -> ok (T_base Base_operation)
| T_constant (TC_signature) -> ok (T_base Base_signature)
| T_constant (TC_key) -> ok (T_base Base_key)
| T_constant (TC_key_hash) -> ok (T_base Base_key_hash)
| T_constant (TC_chain_id) -> ok (T_base Base_chain_id)
| T_constant (TC_bool) -> ok (T_base TC_bool)
| T_constant (TC_int) -> ok (T_base TC_int)
| T_constant (TC_nat) -> ok (T_base TC_nat)
| T_constant (TC_mutez) -> ok (T_base TC_mutez)
| T_constant (TC_string) -> ok (T_base TC_string)
| T_constant (TC_bytes) -> ok (T_base TC_bytes)
| T_constant (TC_address) -> ok (T_base TC_address)
| T_constant (TC_timestamp) -> ok (T_base TC_timestamp)
| T_constant (TC_unit) -> ok (T_base TC_unit)
| T_constant (TC_operation) -> ok (T_base TC_operation)
| T_constant (TC_signature) -> ok (T_base TC_signature)
| T_constant (TC_key) -> ok (T_base TC_key)
| T_constant (TC_key_hash) -> ok (T_base TC_key_hash)
| T_constant (TC_chain_id) -> ok (T_base TC_chain_id)
| T_constant (TC_void) -> ok (T_base TC_void)
| T_operator (TC_contract x) ->
let%bind x' = transpile_type x in
ok (T_contract x')
@ -160,7 +155,7 @@ let rec transpile_type (t:AST.type_value) : type_value result =
ok (None, T_or (a, b))
in
let%bind m' = Append_tree.fold_ne
(fun (Constructor ann, a) ->
(fun (Stage_common.Types.Constructor ann, a) ->
let%bind a = transpile_type a in
ok (Some (String.uncapitalize_ascii ann), a))
aux node in
@ -173,49 +168,22 @@ let rec transpile_type (t:AST.type_value) : type_value result =
ok (None, T_pair (a, b))
in
let%bind m' = Append_tree.fold_ne
(fun (Label ann, a) ->
(fun (Stage_common.Types.Label ann, a) ->
let%bind a = transpile_type a in
ok (Some ann, a))
aux node in
ok @@ snd m'
| T_operator (TC_tuple lst) ->
let node = Append_tree.of_list lst in
let aux a b : type_value result =
let%bind a = a in
let%bind b = b in
ok (T_pair ((None, a), (None, b)))
in
Append_tree.fold_ne transpile_type aux node
| T_arrow (param, result) -> (
let%bind param' = transpile_type param in
let%bind result' = transpile_type result in
ok (T_function (param', result'))
| T_arrow {type1;type2} -> (
let%bind param' = transpile_type type1 in
let%bind result' = transpile_type type2 in
ok (T_function (param',result'))
)
let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [`Left | `Right]) list result = fun ty tys ind ->
let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (i, a)) tys in
let%bind path =
let aux (i , _) = i = ind in
trace_option (corner_case ~loc:__LOC__ "tuple access leaf") @@
Append_tree.exists_path aux node_tv in
let lr_path = List.map (fun b -> if b then `Right else `Left) path in
let%bind (_ , lst) =
let aux = fun (ty' , acc) cur ->
let%bind (a , b) =
trace_strong (corner_case ~loc:__LOC__ "tuple access pair") @@
Mini_c.get_t_pair ty' in
match cur with
| `Left -> ok (a , acc @ [(a , `Left)])
| `Right -> ok (b , acc @ [(b , `Right)])
in
bind_fold_list aux (ty , []) lr_path in
ok lst
let record_access_to_lr : type_value -> type_value AST.label_map -> label -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
let tys = kv_list_of_lmap tym in
let node_tv = Append_tree.of_list tys in
let%bind path =
let aux (Label i , _) = let Label ind = ind in i = ind in
let aux (i , _) = i = ind in
trace_option (corner_case ~loc:__LOC__ "record access leaf") @@
Append_tree.exists_path aux node_tv in
let lr_path = List.map (fun b -> if b then `Right else `Left) path in
@ -245,16 +213,17 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
| Literal_chain_id s -> D_string s
| Literal_operation op -> D_operation op
| Literal_unit -> D_unit
| Literal_void -> D_none
and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele ->
transpile_type ele.type_value
and tree_of_sum : AST.type_value -> (constructor * AST.type_value) Append_tree.t result = fun t ->
and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t ->
let%bind map_tv = get_t_sum t in
ok @@ Append_tree.of_list @@ kv_list_of_cmap map_tv
and transpile_annotated_expression (ae:AST.annotated_expression) : expression result =
let%bind tv = transpile_type ae.type_annotation in
and transpile_annotated_expression (ae:AST.expression) : expression result =
let%bind tv = transpile_type ae.type_expression in
let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
let f = transpile_annotated_expression in
let info =
@ -262,11 +231,11 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let content () = Format.asprintf "%a" Location.pp ae.location in
info title content in
trace info @@
match ae.expression with
| E_let_in {binder; rhs; result; inline} ->
match ae.expression_content with
| E_let_in {let_binder; rhs; let_result; inline} ->
let%bind rhs' = transpile_annotated_expression rhs in
let%bind result' = transpile_annotated_expression result in
return (E_let_in ((binder, rhs'.type_value), inline, rhs', result'))
let%bind result' = transpile_annotated_expression let_result in
return (E_let_in ((let_binder, rhs'.type_value), inline, rhs', result'))
| E_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> (
let%bind ele =
@ -275,21 +244,21 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind tv = transpile_environment_element_type ele in
return ~tv @@ E_variable (name)
)
| E_application (a, b) ->
let%bind a = transpile_annotated_expression a in
let%bind b = transpile_annotated_expression b in
| E_application {expr1;expr2} ->
let%bind a = transpile_annotated_expression expr1 in
let%bind b = transpile_annotated_expression expr2 in
return @@ E_application (a, b)
| E_constructor (m, param) -> (
let%bind param' = transpile_annotated_expression param in
| E_constructor {constructor;element} -> (
let%bind param' = transpile_annotated_expression element in
let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in
let%bind node_tv =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
tree_of_sum ae.type_annotation in
tree_of_sum ae.type_expression in
let leaf (k, tv) : (expression' option * type_value) result =
if k = m then (
if k = constructor then (
let%bind _ =
trace_strong (corner_case ~loc:__LOC__ "wrong type for constructor parameter")
@@ AST.assert_type_value_eq (tv, param.type_annotation) in
@@ AST.assert_type_expression_eq (tv, element.type_expression) in
ok (Some (param'_expr), param'_tv)
) else (
let%bind tv = transpile_type tv in
@ -301,8 +270,8 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
match (a, b) with
| (None, a), (None, b) -> ok (None, T_or ((None, a), (None, b)))
| (Some _, _), (Some _, _) -> fail @@ corner_case ~loc:__LOC__ "multiple identical constructors in the same variant"
| (Some v, a), (None, b) -> ok (Some (E_constant (C_LEFT, [Combinators.Expression.make_tpl (v, a)])), T_or ((None, a), (None, b)))
| (None, a), (Some v, b) -> ok (Some (E_constant (C_RIGHT, [Combinators.Expression.make_tpl (v, b)])), T_or ((None, a), (None, b)))
| (Some v, a), (None, b) -> ok (Some (E_constant {cons_name=C_LEFT ;arguments= [Combinators.Expression.make_tpl (v, a)]}), T_or ((None, a), (None, b)))
| (None, a), (Some v, b) -> ok (Some (E_constant {cons_name=C_RIGHT;arguments= [Combinators.Expression.make_tpl (v, b)]}), T_or ((None, a), (None, b)))
in
let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
let%bind ae =
@ -310,36 +279,6 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
ae_opt in
return ~tv ae
)
| E_tuple lst -> (
let node = Append_tree.of_list lst in
let aux (a:expression result) (b:expression result) : expression result =
let%bind a = a in
let%bind b = b in
let a_ty = Combinators.Expression.get_type a in
let b_ty = Combinators.Expression.get_type b in
let tv = T_pair ((None, a_ty) , (None, b_ty)) in
return ~tv @@ E_constant (C_PAIR, [a; b])
in
Append_tree.fold_ne (transpile_annotated_expression) aux node
)
| E_tuple_accessor (tpl, ind) -> (
let%bind ty' = transpile_type tpl.type_annotation in
let%bind ty_lst =
trace_strong (corner_case ~loc:__LOC__ "transpiler: E_tuple_accessor: not a tuple") @@
get_t_tuple tpl.type_annotation in
let%bind ty'_lst = bind_map_list transpile_type ty_lst in
let%bind path =
trace_strong (corner_case ~loc:__LOC__ "tuple access") @@
tuple_access_to_lr ty' ty'_lst ind in
let aux = fun pred (ty, lr) ->
let c = match lr with
| `Left -> C_CAR
| `Right -> C_CDR in
Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
let%bind tpl' = transpile_annotated_expression tpl in
let expr = List.fold_left aux tpl' path in
ok expr
)
| E_record m -> (
let node = Append_tree.of_list @@ list_of_lmap m in
let aux a b : expression result =
@ -348,51 +287,51 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let a_ty = Combinators.Expression.get_type a in
let b_ty = Combinators.Expression.get_type b in
let tv = T_pair ((None, a_ty) , (None, b_ty)) in
return ~tv @@ E_constant (C_PAIR, [a; b])
return ~tv @@ E_constant {cons_name=C_PAIR;arguments=[a; b]}
in
trace_strong (corner_case ~loc:__LOC__ "record build") @@
Append_tree.fold_ne (transpile_annotated_expression) aux node
)
| E_record_accessor (record, property) ->
let%bind ty' = transpile_type (get_type_annotation record) in
| E_record_accessor {expr; label} ->
let%bind ty' = transpile_type (get_type_expression expr) in
let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_annotation record) in
let%bind ty'_lmap = AST.bind_map_lmap transpile_type ty_lmap in
get_t_record (get_type_expression expr) in
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_lmap property in
record_access_to_lr ty' ty'_lmap label in
let aux = fun pred (ty, lr) ->
let c = match lr with
| `Left -> C_CAR
| `Right -> C_CDR in
Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
let%bind record' = transpile_annotated_expression record in
Combinators.Expression.make_tpl (E_constant {cons_name=c;arguments=[pred]} , ty) in
let%bind record' = transpile_annotated_expression expr in
let expr = List.fold_left aux record' path in
ok expr
| E_record_update (record, (l,expr)) ->
let%bind ty' = transpile_type (get_type_annotation record) in
| E_record_update {record; path; update} ->
let%bind ty' = transpile_type (get_type_expression record) in
let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_annotation record) in
let%bind ty'_lmap = AST.bind_map_lmap transpile_type ty_lmap in
get_t_record (get_type_expression record) in
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_lmap l in
let path' = List.map snd path in
let%bind expr' = transpile_annotated_expression expr in
record_access_to_lr ty' ty'_lmap path in
let path = List.map snd path in
let%bind update = transpile_annotated_expression update in
let%bind record = transpile_annotated_expression record in
return @@ E_update (record, (path',expr'))
| E_constant (name , lst) -> (
return @@ E_record_update (record, path, update)
| E_constant {cons_name=name; arguments=lst} -> (
let iterator_generator iterator_name =
let lambda_to_iterator_body (f : AST.annotated_expression) (l : AST.lambda) =
let%bind body' = transpile_annotated_expression l.body in
let%bind (input , _) = AST.get_t_function f.type_annotation in
let lambda_to_iterator_body (f : AST.expression) (l : AST.lambda) =
let%bind body' = transpile_annotated_expression l.result in
let%bind (input , _) = AST.get_t_function f.type_expression in
let%bind input' = transpile_type input in
ok ((l.binder , input') , body')
in
let expression_to_iterator_body (f : AST.annotated_expression) =
match f.expression with
let expression_to_iterator_body (f : AST.expression) =
match f.expression_content with
| E_lambda l -> lambda_to_iterator_body f l
| E_variable v -> (
let%bind elt =
@ -400,7 +339,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
AST.Environment.get_opt v f.environment in
match elt.definition with
| ED_declaration (f , _) -> (
match f.expression with
match f.expression_content with
| E_lambda l -> lambda_to_iterator_body f l
| _ -> fail @@ unsupported_iterator f.location
)
@ -408,7 +347,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
)
| _ -> fail @@ unsupported_iterator f.location
in
fun (lst : AST.annotated_expression list) -> match (lst , iterator_name) with
fun (lst : AST.expression list) -> match (lst , iterator_name) with
| [f ; i] , C_ITER | [f ; i] , C_MAP -> (
let%bind f' = expression_to_iterator_body f in
let%bind i' = transpile_annotated_expression i in
@ -434,11 +373,11 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
| (C_MAP_FOLD , lst) -> fold lst
| _ -> (
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
return @@ E_constant (name , lst')
return @@ E_constant {cons_name=name;arguments=lst'}
)
)
| E_lambda l ->
let%bind io = AST.get_t_function ae.type_annotation in
let%bind io = AST.get_t_function ae.type_expression in
transpile_lambda l io
| E_list lst -> (
let%bind t =
@ -446,7 +385,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
get_t_list tv in
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur ->
return @@ E_constant (C_CONS, [cur ; prev]) in
return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in
let%bind (init : expression) = return @@ E_make_empty_list t in
bind_fold_right_list aux init lst'
)
@ -456,7 +395,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
get_t_set tv in
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur ->
return @@ E_constant (C_SET_ADD, [cur ; prev]) in
return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in
let%bind (init : expression) = return @@ E_make_empty_set t in
bind_fold_list aux init lst'
)
@ -464,12 +403,12 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind (src, dst) =
trace_strong (corner_case ~loc:__LOC__ "not a map") @@
Mini_c.Combinators.get_t_map tv in
let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) ->
let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) ->
let%bind prev' = prev in
let%bind (k', v') =
let v' = e_a_some v ae.environment in
bind_map_pair (transpile_annotated_expression) (k , v') in
return @@ E_constant (C_UPDATE, [k' ; v' ; prev'])
return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']}
in
let init = return @@ E_make_empty_map (src, dst) in
List.fold_left aux init m
@ -478,63 +417,26 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind (src, dst) =
trace_strong (corner_case ~loc:__LOC__ "not a map") @@
Mini_c.Combinators.get_t_big_map tv in
let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) ->
let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) ->
let%bind prev' = prev in
let%bind (k', v') =
let v' = e_a_some v ae.environment in
bind_map_pair (transpile_annotated_expression) (k , v') in
return @@ E_constant (C_UPDATE, [k' ; v' ; prev'])
return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']}
in
let init = return @@ E_make_empty_big_map (src, dst) in
List.fold_left aux init m
)
| E_look_up dsi -> (
let%bind (ds', i') = bind_map_pair f dsi in
return @@ E_constant (C_MAP_GET, [i' ; ds'])
return @@ E_constant {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']}
)
| E_sequence (a , b) -> (
let%bind a' = transpile_annotated_expression a in
let%bind b' = transpile_annotated_expression b in
return @@ E_sequence (a' , b')
)
| E_loop (expr , body) -> (
let%bind expr' = transpile_annotated_expression expr in
| 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_assign (typed_name , path , expr) -> (
let ty = typed_name.type_value in
let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result =
fun (prev, acc) cur ->
let%bind ty' = transpile_type prev in
match cur with
| Access_tuple ind -> (
let%bind ty_lst =
trace_strong (corner_case ~loc:__LOC__ "transpiler: E_assign: Access_tuple: not a tuple") @@
AST.Combinators.get_t_tuple prev in
let%bind ty'_lst = bind_map_list transpile_type ty_lst in
let%bind path = tuple_access_to_lr ty' ty'_lst ind in
let path' = List.map snd path in
ok (List.nth ty_lst ind, acc @ path')
)
| Access_record prop -> (
let%bind ty_map =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
AST.Combinators.get_t_record prev in
let%bind ty'_map = bind_map_lmap transpile_type ty_map in
let%bind path = record_access_to_lr ty' ty'_map (Label prop) in
let path' = List.map snd path in
let%bind prop_in_ty_map = trace_option
(Errors.not_found "acessing prop in ty_map [TODO: better error message]")
(AST.LMap.find_opt (Label prop) ty_map) in
ok (prop_in_ty_map, acc @ path')
)
in
let%bind (_, path) = bind_fold_list aux (ty, []) path in
let%bind expr' = transpile_annotated_expression expr in
return (E_assignment (typed_name.type_name, path, expr'))
)
| E_matching (expr, m) -> (
| E_matching {matchee=expr; cases=m} -> (
let%bind expr' = transpile_annotated_expression expr in
match m with
| Match_bool {match_true ; match_false} ->
@ -612,18 +514,20 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
)
and transpile_lambda l (input_type , output_type) =
let { binder ; body } : AST.lambda = l in
let%bind result' = transpile_annotated_expression body in
let { binder ; result } : AST.lambda = l in
let%bind result' = transpile_annotated_expression result in
let%bind input = transpile_type input_type in
let%bind output = transpile_type output_type in
let tv = Combinators.t_function input output in
let binder = binder in
let closure = E_closure { binder; body = result'} in
ok @@ Combinators.Expression.make_tpl (closure , tv)
let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
match d with
| Declaration_constant ({name;annotated_expression} , inline , _) ->
let%bind expression = transpile_annotated_expression annotated_expression in
| Declaration_constant (name,expression, inline, _) ->
let name = name in
let%bind expression = transpile_annotated_expression expression in
let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (name, tv) env in
ok @@ ((name, inline, expression), environment_wrap env env')
@ -658,9 +562,9 @@ let check_storage f ty loc : (anon_function * _) result =
if aux (snd storage) false then ok (f, ty) else fail @@ bad_big_map loc
| _ -> ok (f, ty)
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_expression) result =
let open Append_tree in
let rec aux tv : (string * value * AST.type_value) result=
let rec aux tv : (string * value * AST.type_expression) result=
match tv with
| Leaf (k, t), v -> ok (k, v, t)
| Node {a}, D_left v -> aux (a, v)
@ -670,9 +574,9 @@ let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value
let%bind (s, v, t) = aux (tree, v) in
ok (s, v, t)
let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result =
let extract_tuple (v : value) (tree : AST.type_expression Append_tree.t') : ((value * AST.type_expression) list) result =
let open Append_tree in
let rec aux tv : ((value * AST.type_value) list) result =
let rec aux tv : ((value * AST.type_expression) list) result =
match tv with
| Leaf t, v -> ok @@ [v, t]
| Node {a;b}, D_pair (va, vb) ->
@ -685,7 +589,7 @@ let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value *
let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
let open Append_tree in
let rec aux tv : ((string * (value * AST.type_value)) list) result =
let rec aux tv : ((string * (value * AST.type_expression)) list) result =
match tv with
| Leaf (s, t), v -> ok @@ [s, (v, t)]
| Node {a;b}, D_pair (va, vb) ->

10
src/passes/6-transpiler/transpiler.mli
View File

@ -35,7 +35,7 @@ val translate_literal : AST.literal -> value
val transpile_environment_element_type : AST.environment_element -> type_value result
val tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t result
*)
val transpile_annotated_expression : AST.annotated_expression -> expression result
val transpile_annotated_expression : AST.expression -> expression result
(*
val transpile_lambda : AST.lambda -> expression result
val transpile_declaration : environment -> AST.declaration -> toplevel_statement result
@ -49,7 +49,7 @@ val translate_main : AST.lambda -> Location.t ->( anon_function * ( type_value *
(* From an expression [expr], build the expression [fun () -> expr] *)
val translate_entry : AST.program -> string -> ( anon_function * ( type_value * type_value )) result
*)
val extract_constructor : value -> ( string * AST.type_value ) Append_tree.t' -> (string * value * AST.type_value) result
val extract_tuple : value -> AST.type_value Append_tree.t' -> (value * AST.type_value) list result
val extract_record : value -> ( string * AST.type_value ) Append_tree.t' -> ( string * ( value * AST.type_value )) list result
val untranspile : value -> AST.type_value -> AST.annotated_expression result
val extract_constructor : value -> ( string * AST.type_expression ) Append_tree.t' -> (string * value * AST.type_expression) result
val extract_tuple : value -> AST.type_expression Append_tree.t' -> (value * AST.type_expression) list result
val extract_record : value -> ( string * AST.type_expression ) Append_tree.t' -> ( string * ( value * AST.type_expression)) list result
val untranspile : value -> AST.type_expression -> AST.expression result

35
src/passes/6-transpiler/untranspiler.ml
View File

@ -40,10 +40,10 @@ end
open Errors
let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result =
let rec untranspile (v : value) (t : AST.type_expression) : AST.expression result =
let open! AST in
let return e = ok (make_a_e_empty e t) in
match t.type_value' with
match t.type_content with
| T_constant type_constant -> (
match type_constant with
| TC_unit -> (
@ -95,6 +95,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
return (E_literal (Literal_bytes n))
)
| TC_address -> (
let%bind n =
trace_strong (wrong_mini_c_value "address" v) @@
get_string v in
@ -124,6 +125,12 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
get_string v in
return (E_literal (Literal_chain_id n))
)
| TC_void -> (
let%bind () =
trace_strong (wrong_mini_c_value "void" v) @@
get_unit v in
return (E_literal (Literal_void))
)
| TC_signature -> (
let%bind n =
trace_strong (wrong_mini_c_value "signature" v) @@
@ -176,6 +183,12 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
bind_map_list aux lst in
return (E_list lst')
)
| TC_arrow _ -> (
let%bind n =
trace_strong (wrong_mini_c_value "lambda as string" v) @@
get_string v in
return (E_literal (Literal_string n))
)
| TC_set ty -> (
let%bind lst =
trace_strong (wrong_mini_c_value "set" v) @@
@ -187,22 +200,6 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
)
| TC_contract _ ->
fail @@ bad_untranspile "contract" v
| TC_arrow _ -> (
let%bind n =
trace_strong (wrong_mini_c_value "lambda as string" v) @@
get_string v in
return (E_literal (Literal_string n))
)
| TC_tuple lst ->
let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple"
| Full t -> ok t in
let%bind tpl =
trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@
extract_tuple v node in
let%bind tpl' = bind_list
@@ List.map (fun (x, y) -> untranspile x y) tpl in
return (E_tuple tpl')
)
| T_sum m ->
let lst = kv_list_of_cmap m in
@ -214,7 +211,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
extract_constructor v node in
let%bind sub = untranspile v tv in
return (E_constructor (Constructor name, sub))
return (E_constructor {constructor=Constructor name;element=sub})
| T_record m ->
let lst = kv_list_of_lmap m in
let%bind node = match Append_tree.of_list lst with

16
src/passes/7-self_mini_c/helpers.ml
View File

@ -32,8 +32,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok init'
)
| E_literal _ -> ok init'
| E_constant (_, lst) -> (
let%bind res = bind_fold_list self init' lst in
| E_constant (c) -> (
let%bind res = bind_fold_list self init' c.arguments in
ok res
)
| E_closure af -> (
@ -84,7 +84,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = self init' exp in
ok res
)
| E_update (r, (_,e)) -> (
| E_record_update (r, _, e) -> (
let%bind res = self init' r in
let%bind res = self res e in
ok res
@ -102,9 +102,9 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
| E_make_empty_big_map _
| E_make_empty_list _
| E_make_empty_set _ as em -> return em
| E_constant (name, lst) -> (
let%bind lst' = bind_map_list self lst in
return @@ E_constant (name,lst')
| E_constant (c) -> (
let%bind lst = bind_map_list self c.arguments in
return @@ E_constant {cons_name = c.cons_name; arguments = lst}
)
| E_closure af -> (
let%bind body = self af.body in
@ -154,10 +154,10 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind exp' = self exp in
return @@ E_assignment (s, lrl, exp')
)
| E_update (r, (l,e)) -> (
| E_record_update (r, l, e) -> (
let%bind r = self r in
let%bind e = self e in
return @@ E_update(r,(l,e))
return @@ E_record_update(r, l, e)
)
let map_sub_level_expression : mapper -> expression -> expression result = fun f e ->

2
src/passes/7-self_mini_c/michelson_restrictions.ml
View File

@ -19,7 +19,7 @@ let self_in_lambdas : expression -> expression result =
| E_closure {binder=_ ; body} ->
let%bind _self_in_lambdas = Helpers.map_expression
(fun e -> match e.content with
| E_constant (C_SELF_ADDRESS, _) as c -> fail (bad_self_address c)
| E_constant {cons_name=C_SELF_ADDRESS; _} as c -> fail (bad_self_address c)
| _ -> ok e)
body in
ok e

25
src/passes/7-self_mini_c/self_mini_c.ml
View File

@ -15,7 +15,7 @@ let map_expression :
(* true if the name names a pure constant -- i.e. if uses will be pure
assuming arguments are pure *)
let is_pure_constant : constant -> bool =
let is_pure_constant : constant' -> bool =
function
| C_UNIT
| C_CAR | C_CDR | C_PAIR
@ -23,7 +23,7 @@ let is_pure_constant : constant -> bool =
| C_NEG | C_OR | C_AND | C_XOR | C_NOT
| C_EQ | C_NEQ | C_LT | C_LE | C_GT | C_GE
| C_SOME
| C_UPDATE | C_MAP_GET | C_MAP_FIND_OPT | C_MAP_ADD | C_MAP_UPDATE
| C_UPDATE | C_MAP_FIND_OPT | C_MAP_ADD | C_MAP_UPDATE
| C_INT | C_ABS | C_IS_NAT
| C_BALANCE | C_AMOUNT | C_ADDRESS | C_NOW | C_SOURCE | C_SENDER | C_CHAIN_ID
| C_SET_MEM | C_SET_ADD | C_SET_REMOVE | C_SLICE
@ -31,10 +31,10 @@ let is_pure_constant : constant -> bool =
| C_HASH_KEY | C_BYTES_PACK | C_CONCAT
-> true
(* unfortunately impure: *)
| C_ADD | C_SUB |C_MUL|C_DIV|C_MOD
| C_ADD | C_SUB |C_MUL|C_DIV|C_MOD | C_LSL | C_LSR
(* impure: *)
| C_ASSERTION | C_ASSERT_INFERRED
| C_MAP_GET_FORCE | C_MAP_FIND
| C_MAP_FIND
| C_FOLD_WHILE
| C_CALL
(* TODO... *)
@ -64,10 +64,10 @@ let rec is_pure : expression -> bool = fun e ->
| E_sequence (e1, e2)
-> List.for_all is_pure [ e1 ; e2 ]
| E_constant (c, args)
-> is_pure_constant c && List.for_all is_pure args
| E_update (r, (_,e))
-> is_pure r && is_pure e
| E_constant (c)
-> is_pure_constant c.cons_name && List.for_all is_pure c.arguments
| E_record_update (e, _,up)
-> is_pure e && is_pure up
(* I'm not sure about these. Maybe can be tested better? *)
| E_application _
@ -79,6 +79,7 @@ let rec is_pure : expression -> bool = fun e ->
is near... *)
| E_while _ -> false
(* definitely not pure *)
| E_assignment _ -> false
@ -111,14 +112,14 @@ let rec is_assigned : ignore_lambdas:bool -> expression_variable -> expression -
match e.content with
| E_assignment (x, _, e) ->
it x || self e
| E_update (r, (_,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 (_, args) ->
selfs args
| E_constant (c) ->
selfs c.arguments
| E_application (f, arg) ->
selfs [ f ; arg ]
| E_iterator (_, ((x, _), e1), e2) ->
@ -236,7 +237,7 @@ let beta : bool ref -> expression -> expression =
else e
(* also do CAR (PAIR x y) ↦ x, or CDR (PAIR x y) ↦ y, only if x and y are pure *)
| E_constant (C_CAR| C_CDR as const, [ { content = E_constant (C_PAIR, [ e1 ; e2 ]) ; type_value = _ } ]) ->
| E_constant {cons_name = C_CAR| C_CDR as const; arguments = [ { content = E_constant {cons_name = C_PAIR; arguments = [ e1 ; e2 ]} ; type_value = _ } ]} ->
if is_pure e1 && is_pure e2
then (changed := true ;
match const with

24
src/passes/7-self_mini_c/subst.ml
View File

@ -31,9 +31,9 @@ let rec replace : expression -> var_name -> var_name -> expression =
let binder = replace_var binder in
return @@ E_closure { binder ; body }
| E_skip -> e
| E_constant (c, args) ->
let args = List.map replace args in
return @@ E_constant (c, args)
| E_constant (c) ->
let args = List.map replace c.arguments in
return @@ E_constant {cons_name = c.cons_name; arguments = args}
| E_application (f, x) ->
let (f, x) = Tuple.map2 replace (f, x) in
return @@ E_application (f, x)
@ -94,10 +94,10 @@ let rec replace : expression -> var_name -> var_name -> expression =
let v = replace_var v in
let e = replace e in
return @@ E_assignment (v, path, e)
| E_update (r, (p,e)) ->
| E_record_update (r, p, e) ->
let r = replace r in
let e = replace e in
return @@ E_update (r, (p,e))
return @@ E_record_update (r, p, e)
| E_while (cond, body) ->
let cond = replace cond in
let body = replace body in
@ -126,7 +126,7 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
(* hack to avoid reimplementing subst_binder for 2-ary binder in E_if_cons:
intuitively, we substitute in \hd tl. expr' as if it were \hd. \tl. expr *)
let subst_binder2 y z expr' =
let dummy = T_base Base_unit in
let dummy = T_base TC_unit in
let hack = { content = E_closure { binder = z ; body = expr' } ;
type_value = dummy } in
match subst_binder y hack with
@ -184,9 +184,9 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
| E_make_empty_big_map _
| E_make_empty_list _
| E_make_empty_set _ as em -> return em
| E_constant (name, lst) -> (
let lst' = List.map self lst in
return @@ E_constant (name,lst')
| E_constant (c) -> (
let lst = List.map self c.arguments in
return @@ E_constant {cons_name = c.cons_name; arguments = lst }
)
| E_application farg -> (
let farg' = Tuple.map2 self farg in
@ -209,14 +209,14 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
if Var.equal s x then raise Bad_argument ;
return @@ E_assignment (s, lrl, exp')
)
| E_update (r, (p,e)) -> (
| E_record_update (r, p, e) -> (
let r' = self r in
let e' = self e in
return @@ E_update(r', (p,e'))
return @@ E_record_update(r', p, e')
)
let%expect_test _ =
let dummy_type = T_base Base_unit in
let dummy_type = T_base TC_unit in
let wrap e = { content = e ; type_value = dummy_type } in
let show_subst ~body ~x ~expr =

2
src/passes/8-compiler/compiler_environment.ml
View File

@ -10,7 +10,7 @@ let get : environment -> expression_variable -> michelson result = fun e s ->
let error =
let title () = "Environment.get" in
let content () = Format.asprintf "%a in %a"
Stage_common.PP.name s
Var.pp s
PP.environment e in
error title content in
generic_try error @@

14
src/passes/8-compiler/compiler_program.ml
View File

@ -27,7 +27,7 @@ end
open Errors
(* This does not makes sense to me *)
let get_operator : constant -> type_value -> expression list -> predicate result = fun s ty lst ->
let get_operator : constant' -> type_value -> expression list -> predicate result = fun s ty lst ->
match Operators.Compiler.get_operators s with
| Ok (x,_) -> ok x
| Error _ -> (
@ -114,7 +114,7 @@ let get_operator : constant -> type_value -> expression list -> predicate result
i_drop ; (* drop the entrypoint... *)
prim ~annot:[entry] ~children:[r_ty] I_CONTRACT ;
]
| x -> simple_fail (Format.asprintf "predicate \"%a\" doesn't exist" Stage_common.PP.constant x)
| x -> simple_fail (Format.asprintf "predicate \"%a\" doesn't exist" PP.constant x)
)
let rec translate_value (v:value) ty : michelson result = match v with
@ -220,7 +220,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
b' ;
]
)
| E_constant(str, lst) ->
| E_constant{cons_name=str;arguments= lst} ->
let module L = Logger.Stateful() in
let%bind pre_code =
let aux code expr =
@ -249,7 +249,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
pre_code ;
f ;
]
| _ -> simple_fail (Format.asprintf "bad arity for %a" Stage_common.PP.constant str)
| _ -> simple_fail (Format.asprintf "bad arity for %a" PP.constant str)
in
let error =
let title () = "error compiling constant" in
@ -347,7 +347,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
]) in
return code
)
| E_iterator (name , (v , body) , expr) -> (
| E_iterator (name,(v , body) , expr) -> (
let%bind expr' = translate_expression expr env in
let%bind body' = translate_expression body (Environment.add v env) in
match name with
@ -367,7 +367,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
return code
)
| s -> (
let iter = Format.asprintf "iter %a" Stage_common.PP.constant s in
let iter = Format.asprintf "iter %a" PP.constant s in
let error = error (thunk "bad iterator") (thunk iter) in
fail error
)
@ -422,7 +422,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
i_push_unit ;
]
)
| E_update (record, (path, expr)) -> (
| E_record_update (record, path, expr) -> (
let%bind record' = translate_expression record env in
let record_var = Var.fresh () in

2
src/passes/8-compiler/compiler_program.mli
View File

@ -14,7 +14,7 @@ type compiled_expression = {
expr : michelson ;
}
val get_operator : constant -> type_value -> expression list -> predicate result
val get_operator : constant' -> type_value -> expression list -> predicate result
val translate_expression : expression -> environment -> michelson result
val translate_function_body : anon_function -> environment_element list -> type_value -> michelson result
val translate_value : value -> type_value -> michelson result

98
src/passes/8-compiler/compiler_type.ml
View File

@ -15,7 +15,7 @@ module Ty = struct
let tez_k = Mutez_key None
let int_k = Int_key None
let string_k = String_key None
let key_hash_k = Key_hash_key None
let _key_hash_k = Key_hash_key None
let address_k = Address_key None
let timestamp_k = Timestamp_key None
let bytes_k = Bytes_key None
@ -57,24 +57,24 @@ module Ty = struct
let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) ()
let comparable_type_base : type_base -> ex_comparable_ty result = fun tb ->
let comparable_type_base : type_constant -> ex_comparable_ty result = fun tb ->
let return x = ok @@ Ex_comparable_ty x in
match tb with
| Base_unit -> fail (not_comparable "unit")
| Base_void -> fail (not_comparable "void")
| Base_bool -> fail (not_comparable "bool")
| Base_nat -> return nat_k
| Base_mutez -> return tez_k
| Base_int -> return int_k
| Base_string -> return string_k
| Base_address -> return address_k
| Base_timestamp -> return timestamp_k
| Base_bytes -> return bytes_k
| Base_operation -> fail (not_comparable "operation")
| Base_signature -> fail (not_comparable "signature")
| Base_key -> fail (not_comparable "key")
| Base_key_hash -> return key_hash_k
| Base_chain_id -> fail (not_comparable "chain_id")
| TC_unit -> fail (not_comparable "unit")
| TC_void -> fail (not_comparable "void")
| TC_bool -> fail (not_comparable "bool")
| TC_nat -> return nat_k
| TC_mutez -> return tez_k
| TC_int -> return int_k
| TC_string -> return string_k
| TC_address -> return address_k
| TC_timestamp -> return timestamp_k
| TC_bytes -> return bytes_k
| TC_operation -> fail (not_comparable "operation")
| TC_signature -> fail (not_comparable "signature")
| TC_key -> fail (not_comparable "key")
| TC_key_hash -> fail (not_comparable "key_hash")
| TC_chain_id -> fail (not_comparable "chain_id")
let comparable_type : type_value -> ex_comparable_ty result = fun tv ->
match tv with
@ -89,24 +89,24 @@ module Ty = struct
| T_option _ -> fail (not_comparable "option")
| T_contract _ -> fail (not_comparable "contract")
let base_type : type_base -> ex_ty result = fun b ->
let base_type : type_constant -> ex_ty result = fun b ->
let return x = ok @@ Ex_ty x in
match b with
| Base_unit -> return unit
| Base_void -> fail (not_compilable_type "void")
| Base_bool -> return bool
| Base_int -> return int
| Base_nat -> return nat
| Base_mutez -> return tez
| Base_string -> return string
| Base_address -> return address
| Base_timestamp -> return timestamp
| Base_bytes -> return bytes
| Base_operation -> return operation
| Base_signature -> return signature
| Base_key -> return key
| Base_key_hash -> return key_hash
| Base_chain_id -> return chain_id
| TC_unit -> return unit
| TC_void -> fail (not_compilable_type "void")
| TC_bool -> return bool
| TC_int -> return int
| TC_nat -> return nat
| TC_mutez -> return tez
| TC_string -> return string
| TC_address -> return address
| TC_timestamp -> return timestamp
| TC_bytes -> return bytes
| TC_operation -> return operation
| TC_signature -> return signature
| TC_key -> return key
| TC_key_hash -> return key_hash
| TC_chain_id -> return chain_id
let rec type_ : type_value -> ex_ty result =
function
@ -175,23 +175,23 @@ module Ty = struct
end
let base_type : type_base -> O.michelson result =
let base_type : type_constant -> O.michelson result =
function
| Base_unit -> ok @@ O.prim T_unit
| Base_void -> fail (Ty.not_compilable_type "void")
| Base_bool -> ok @@ O.prim T_bool
| Base_int -> ok @@ O.prim T_int
| Base_nat -> ok @@ O.prim T_nat
| Base_mutez -> ok @@ O.prim T_mutez
| Base_string -> ok @@ O.prim T_string
| Base_address -> ok @@ O.prim T_address
| Base_timestamp -> ok @@ O.prim T_timestamp
| Base_bytes -> ok @@ O.prim T_bytes
| Base_operation -> ok @@ O.prim T_operation
| Base_signature -> ok @@ O.prim T_signature
| Base_key -> ok @@ O.prim T_key
| Base_key_hash -> ok @@ O.prim T_key_hash
| Base_chain_id -> ok @@ O.prim T_chain_id
| TC_unit -> ok @@ O.prim T_unit
| TC_void -> fail (Ty.not_compilable_type "void")
| TC_bool -> ok @@ O.prim T_bool
| TC_int -> ok @@ O.prim T_int
| TC_nat -> ok @@ O.prim T_nat
| TC_mutez -> ok @@ O.prim T_mutez
| TC_string -> ok @@ O.prim T_string
| TC_address -> ok @@ O.prim T_address
| TC_timestamp -> ok @@ O.prim T_timestamp
| TC_bytes -> ok @@ O.prim T_bytes
| TC_operation -> ok @@ O.prim T_operation
| TC_signature -> ok @@ O.prim T_signature
| TC_key -> ok @@ O.prim T_key
| TC_key_hash -> ok @@ O.prim T_key_hash
| TC_chain_id -> ok @@ O.prim T_chain_id
let rec type_ : type_value -> O.michelson result =
function

36
src/passes/operators/helpers.ml
View File

@ -14,17 +14,17 @@ module Typer = struct
let title () = "these types are not comparable" in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_value b )
("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_expression b )
] in
error ~data title message ()
end
open Errors
type type_result = type_value
type typer = type_value list -> type_value option -> type_result result
type type_result = type_expression
type typer = type_expression list -> type_expression option -> type_result result
let typer_0 : string -> (type_value option -> type_value result) -> typer = fun s f lst tv_opt ->
let typer_0 : string -> (type_expression option -> type_expression result) -> typer = fun s f lst tv_opt ->
match lst with
| [] -> (
let%bind tv' = f tv_opt in
@ -32,7 +32,7 @@ module Typer = struct
)
| _ -> fail @@ wrong_param_number s 0 lst
let typer_1 : string -> (type_value -> type_value result) -> typer = fun s f lst _ ->
let typer_1 : string -> (type_expression -> type_expression result) -> typer = fun s f lst _ ->
match lst with
| [ a ] -> (
let%bind tv' = f a in
@ -40,7 +40,7 @@ module Typer = struct
)
| _ -> fail @@ wrong_param_number s 1 lst
let typer_1_opt : string -> (type_value -> type_value option -> type_value result) -> typer = fun s f lst tv_opt ->
let typer_1_opt : string -> (type_expression -> type_expression option -> type_expression result) -> typer = fun s f lst tv_opt ->
match lst with
| [ a ] -> (
let%bind tv' = f a tv_opt in
@ -48,7 +48,7 @@ module Typer = struct
)
| _ -> fail @@ wrong_param_number s 1 lst
let typer_2 : string -> (type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
let typer_2 : string -> (type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ] -> (
let%bind tv' = f a b in
@ -56,7 +56,7 @@ module Typer = struct
)
| _ -> fail @@ wrong_param_number s 2 lst
let typer_2_opt : string -> (type_value -> type_value -> type_value option -> type_value result) -> typer = fun s f lst tv_opt ->
let typer_2_opt : string -> (type_expression -> type_expression -> type_expression option -> type_expression result) -> typer = fun s f lst tv_opt ->
match lst with
| [ a ; b ] -> (
let%bind tv' = f a b tv_opt in
@ -64,7 +64,7 @@ module Typer = struct
)
| _ -> fail @@ wrong_param_number s 2 lst
let typer_3 : string -> (type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
let typer_3 : string -> (type_expression -> type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ] -> (
let%bind tv' = f a b c in
@ -72,7 +72,7 @@ module Typer = struct
)
| _ -> fail @@ wrong_param_number s 3 lst
let typer_4 : string -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
let typer_4 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ; d ] -> (
let%bind tv' = f a b c d in
@ -80,7 +80,7 @@ module Typer = struct
)
| _ -> fail @@ wrong_param_number s 4 lst
let typer_5 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
let typer_5 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ; d ; e ] -> (
let%bind tv' = f a b c d e in
@ -88,7 +88,7 @@ module Typer = struct
)
| _ -> fail @@ wrong_param_number s 5 lst
let typer_6 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer = fun s f lst _ ->
let typer_6 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer = fun s f lst _ ->
match lst with
| [ a ; b ; c ; d ; e ; f_ ] -> (
let%bind tv' = f a b c d e f_ in
@ -96,12 +96,12 @@ module Typer = struct
)
| _ -> fail @@ wrong_param_number s 6 lst
let constant name cst = typer_0 name (fun _ -> ok cst)
let constant' name cst = typer_0 name (fun _ -> ok cst)
open Combinators
let eq_1 a cst = type_value_eq (a , cst)
let eq_2 (a , b) cst = type_value_eq (a , cst) && type_value_eq (b , cst)
let eq_1 a cst = type_expression_eq (a , cst)
let eq_2 (a , b) cst = type_expression_eq (a , cst) && type_expression_eq (b , cst)
let assert_eq_1 ?msg a b = Assert.assert_true ?msg (eq_1 a b)
@ -125,11 +125,11 @@ module Typer = struct
let%bind () =
trace_strong (simple_error "A isn't of type bool") @@
Assert.assert_true @@
type_value_eq (t_bool () , a) in
type_expression_eq (t_bool () , a) in
let%bind () =
trace_strong (simple_error "B isn't of type bool") @@
Assert.assert_true @@
type_value_eq (t_bool () , b) in
type_expression_eq (t_bool () , b) in
ok @@ t_bool ()
end

48
src/passes/operators/helpers.mli
View File

@ -4,51 +4,51 @@ module Typer : sig
module Errors : sig
val wrong_param_number : string -> int -> 'a list -> unit -> error
val error_uncomparable_types : type_value -> type_value -> unit -> error
val error_uncomparable_types : type_expression -> type_expression -> unit -> error
end
type type_result = type_value
type typer = type_value list -> type_value option -> type_result result
type type_result = type_expression
type typer = type_expression list -> type_expression option -> type_result result
(*
val typer'_0 : name -> (type_value option -> type_value result) -> typer'
val typer'_0 : name -> (type_expression option -> type_expression result) -> typer'
*)
val typer_0 : string -> ( type_value option -> type_value result ) -> typer
val typer_0 : string -> ( type_expression option -> type_expression result ) -> typer
(*
val typer'_1 : name -> (type_value -> type_value result) -> typer'
val typer'_1 : name -> (type_expression -> type_expression result) -> typer'
*)
val typer_1 : string -> (type_value -> type_value result) -> typer
val typer_1 : string -> (type_expression -> type_expression result) -> typer
(*
val typer'_1_opt : name -> (type_value -> type_value option -> type_value result) -> typer'
val typer'_1_opt : name -> (type_expression -> type_expression option -> type_expression result) -> typer'
*)
val typer_1_opt : string -> (type_value -> type_value option -> type_value result) -> typer
val typer_1_opt : string -> (type_expression -> type_expression option -> type_expression result) -> typer
(*
val typer'_2 : name -> (type_value -> type_value -> type_value result) -> typer'
val typer'_2 : name -> (type_expression -> type_expression -> type_expression result) -> typer'
*)
val typer_2 : string -> (type_value -> type_value -> type_value result) -> typer
val typer_2_opt : string -> (type_value -> type_value -> type_value option -> type_value result) -> typer
val typer_2 : string -> (type_expression -> type_expression -> type_expression result) -> typer
val typer_2_opt : string -> (type_expression -> type_expression -> type_expression option -> type_expression result) -> typer
(*
val typer'_3 : name -> (type_value -> type_value -> type_value -> type_value result) -> typer'
val typer'_3 : name -> (type_expression -> type_expression -> type_expression -> type_expression result) -> typer'
*)
val typer_3 : string -> (type_value -> type_value -> type_value -> type_value result) -> typer
val typer_3 : string -> (type_expression -> type_expression -> type_expression -> type_expression result) -> typer
(*
val typer'_4 : name -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer'
val typer'_4 : name -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer'
*)
val typer_4 : string -> (type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
val typer_4 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer
(*
val typer'_5 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer'
val typer'_5 : name -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer'
*)
val typer_5 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
val typer_5 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer
(*
val typer'_6 : name -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer'
val typer'_6 : name -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer'
*)
val typer_6 : string -> (type_value -> type_value -> type_value -> type_value -> type_value -> type_value -> type_value result) -> typer
val typer_6 : string -> (type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression -> type_expression result) -> typer
val constant : string -> type_value -> typer
val constant' : string -> type_expression -> typer
val eq_1 : type_value -> type_value -> bool
val eq_2 : ( type_value * type_value ) -> type_value -> bool
val assert_eq_1 : ?msg:string -> type_value -> type_value -> unit result
val eq_1 : type_expression -> type_expression -> bool
val eq_2 : ( type_expression * type_expression ) -> type_expression -> bool
val assert_eq_1 : ?msg:string -> type_expression -> type_expression -> unit result
val comparator : string -> typer
val boolean_operator_2 : string -> typer

208
src/passes/operators/operators.ml
View File

@ -66,7 +66,7 @@ module Simplify = struct
module Pascaligo = struct
let constants = function
| "get_force" -> ok C_MAP_GET_FORCE
| "assert" -> ok C_ASSERTION
| "get_chain_id" -> ok C_CHAIN_ID
| "transaction" -> ok C_CALL
| "get_contract" -> ok C_CONTRACT
@ -87,6 +87,8 @@ module Simplify = struct
| "bitwise_or" -> ok C_OR
| "bitwise_and" -> ok C_AND
| "bitwise_xor" -> ok C_XOR
| "bitwise_lsl" -> ok C_LSL
| "bitwise_lsr" -> ok C_LSR
| "string_concat" -> ok C_CONCAT
| "string_slice" -> ok C_SLICE
| "crypto_check" -> ok C_CHECK_SIGNATURE
@ -104,12 +106,13 @@ module Simplify = struct
| "list_iter" -> ok C_LIST_ITER
| "list_fold" -> ok C_LIST_FOLD
| "list_map" -> ok C_LIST_MAP
| "get_force" -> ok C_MAP_FIND
| "map_iter" -> ok C_MAP_ITER
| "map_map" -> ok C_MAP_MAP
| "map_fold" -> ok C_MAP_FOLD
| "map_remove" -> ok C_MAP_REMOVE
| "map_update" -> ok C_MAP_UPDATE
| "map_get" -> ok C_MAP_GET
| "map_get" -> ok C_MAP_FIND_OPT
| "map_mem" -> ok C_MAP_MEM
| "sha_256" -> ok C_SHA256
| "sha_512" -> ok C_SHA512
@ -163,7 +166,6 @@ module Simplify = struct
| "Current.failwith" -> ok C_FAILWITH
| "failwith" -> ok C_FAILWITH
| "Crypto.hash" -> ok C_HASH
| "Crypto.blake2b" -> ok C_BLAKE2b
| "Crypto.sha256" -> ok C_SHA256
| "Crypto.sha512" -> ok C_SHA512
@ -179,6 +181,7 @@ module Simplify = struct
| "Bytes.sub" -> ok C_SLICE
| "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
@ -210,6 +213,8 @@ module Simplify = struct
| "Bitwise.lor" -> ok C_OR
| "Bitwise.land" -> ok C_AND
| "Bitwise.lxor" -> ok C_XOR
| "Bitwise.shift_left" -> ok C_LSL
| "Bitwise.shift_right" -> ok C_LSR
| "String.length" -> ok C_SIZE
| "String.size" -> ok C_SIZE
@ -268,8 +273,8 @@ module Typer = struct
let type_error msg expected_type actual_type () =
let message () =
Format.asprintf "Expected an expression of type %a but got an expression of type %a"
Ast_typed.PP.type_value expected_type
Ast_typed.PP.type_value actual_type in
Ast_typed.PP.type_expression expected_type
Ast_typed.PP.type_expression actual_type in
error (thunk msg) message
open PP_helpers
@ -281,8 +286,8 @@ module Typer = struct
let typeclass_error msg f expected_types actual_types () =
let message () =
Format.asprintf "Expected arguments with one of the following combinations of types: %a but got this combination instead: %a"
(list_sep (print_f_args f Ast_typed.PP.type_value) (const " or ")) expected_types
(print_f_args f Ast_typed.PP.type_value) actual_types in
(list_sep (print_f_args f Ast_typed.PP.type_expression) (const " or ")) expected_types
(print_f_args f Ast_typed.PP.type_expression) actual_types in
error (thunk msg) message
end
(*
@ -324,53 +329,55 @@ module Typer = struct
let tc_addargs a b c = tc [a;b;c] [ (*TODO…*) ]
let t_none = forall "a" @@ fun a -> option a
let t_sub = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_subarg a b c] => a --> b --> c (* TYPECLASS *)
let t_sub = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_subarg a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_some = forall "a" @@ fun a -> a --> option a
let t_map_remove = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> map src dst
let t_map_add = forall2 "src" "dst" @@ fun src dst -> src --> dst --> map src dst --> map src dst
let t_map_update = forall2 "src" "dst" @@ fun src dst -> src --> option dst --> map src dst --> map src dst
let t_map_mem = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> bool
let t_map_find = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> dst
let t_map_find_opt = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> option dst
let t_map_fold = forall3 "src" "dst" "acc" @@ fun src dst acc -> ( ( (src * dst) * acc ) --> acc ) --> map src dst --> acc --> acc
let t_map_map = forall3 "k" "v" "result" @@ fun k v result -> ((k * v) --> result) --> map k v --> map k result
let t_map_remove = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> map src dst
let t_map_add = forall2 "src" "dst" @@ fun src dst -> tuple3 src dst (map src dst) --> map src dst
let t_map_update = forall2 "src" "dst" @@ fun src dst -> tuple3 src (option dst) (map src dst) --> map src dst
let t_map_mem = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> bool
let t_map_find = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> dst
let t_map_find_opt = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> option dst
let t_map_fold = forall3 "src" "dst" "acc" @@ fun src dst acc -> tuple3 ( ( (src * dst) * acc ) --> acc ) (map src dst) acc --> acc
let t_map_map = forall3 "k" "v" "result" @@ fun k v result -> tuple2 ((k * v) --> result) (map k v) --> map k result
(* TODO: the type of map_map_fold might be wrong, check it. *)
let t_map_map_fold = forall4 "k" "v" "acc" "dst" @@ fun k v acc dst -> ( ((k * v) * acc) --> acc * dst ) --> map k v --> (k * v) --> (map k dst * acc)
let t_map_iter = forall2 "k" "v" @@ fun k v -> ( (k * v) --> unit ) --> map k v --> unit
let t_size = forall_tc "c" @@ fun c -> [tc_sizearg c] => c --> nat (* TYPECLASS *)
let t_slice = nat --> nat --> string --> string
let t_failwith = string --> unit
let t_get_force = forall2 "src" "dst" @@ fun src dst -> src --> map src dst --> dst
let t_int = nat --> int
let t_bytes_pack = forall_tc "a" @@ fun a -> [tc_packable a] => a --> bytes (* TYPECLASS *)
let t_bytes_unpack = forall_tc "a" @@ fun a -> [tc_packable a] => bytes --> a (* TYPECLASS *)
let t_hash256 = bytes --> bytes
let t_hash512 = bytes --> bytes
let t_blake2b = bytes --> bytes
let t_hash_key = key --> key_hash
let t_check_signature = key --> signature --> bytes --> bool
let t_sender = address
let t_source = address
let t_unit = unit
let t_amount = mutez
let t_address = address
let t_now = timestamp
let t_transaction = forall "a" @@ fun a -> a --> mutez --> contract a --> operation
let t_get_contract = forall "a" @@ fun a -> contract a
let t_abs = int --> nat
let t_cons = forall "a" @@ fun a -> a --> list a --> list a
let t_assertion = bool --> unit
let t_times = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_timargs a b c] => a --> b --> c (* TYPECLASS *)
let t_div = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_divargs a b c] => a --> b --> c (* TYPECLASS *)
let t_mod = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_modargs a b c] => a --> b --> c (* TYPECLASS *)
let t_add = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_addargs a b c] => a --> b --> c (* TYPECLASS *)
let t_set_mem = forall "a" @@ fun a -> a --> set a --> bool
let t_set_add = forall "a" @@ fun a -> a --> set a --> set a
let t_set_remove = forall "a" @@ fun a -> a --> set a --> set a
let t_not = bool --> bool
let t_map_map_fold = forall4 "k" "v" "acc" "dst" @@ fun k v acc dst -> tuple3 ( ((k * v) * acc) --> acc * dst ) (map k v) (k * v) --> (map k dst * acc)
let t_map_iter = forall2 "k" "v" @@ fun k v -> tuple2 ( (k * v) --> unit ) (map k v) --> unit
let t_size = forall_tc "c" @@ fun c -> [tc_sizearg c] => tuple1 c --> nat (* TYPECLASS *)
let t_slice = tuple3 nat nat string --> string
let t_failwith = tuple1 string --> unit
let t_get_force = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> dst
let t_int = tuple1 nat --> int
let t_bytes_pack = forall_tc "a" @@ fun a -> [tc_packable a] => tuple1 a --> bytes (* TYPECLASS *)
let t_bytes_unpack = forall_tc "a" @@ fun a -> [tc_packable a] => tuple1 bytes --> a (* TYPECLASS *)
let t_hash256 = tuple1 bytes --> bytes
let t_hash512 = tuple1 bytes --> bytes
let t_blake2b = tuple1 bytes --> bytes
let t_hash_key = tuple1 key --> key_hash
let t_check_signature = tuple3 key signature bytes --> bool
let t_chain_id = tuple0 --> chain_id
let t_sender = tuple0 --> address
let t_source = tuple0 --> address
let t_unit = tuple0 --> unit
let t_amount = tuple0 --> mutez
let t_address = tuple0 --> address
let t_now = tuple0 --> timestamp
let t_transaction = forall "a" @@ fun a -> tuple3 a mutez (contract a) --> operation
let t_get_contract = forall "a" @@ fun a -> tuple0 --> contract a
let t_abs = tuple1 int --> nat
let t_cons = forall "a" @@ fun a -> a --> tuple1 (list a) --> list a
let t_assertion = tuple1 bool --> unit
let t_times = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_timargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_div = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_divargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_mod = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_modargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_add = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_addargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_set_mem = forall "a" @@ fun a -> tuple2 a (set a) --> bool
let t_set_add = forall "a" @@ fun a -> tuple2 a (set a) --> set a
let t_set_remove = forall "a" @@ fun a -> tuple2 a (set a) --> set a
let t_not = tuple1 bool --> bool
let constant_type : constant -> Typesystem.Core.type_value result = function
let constant_type : constant' -> Typesystem.Core.type_value result = function
| C_INT -> ok @@ t_int ;
| C_UNIT -> ok @@ t_unit ;
| C_NOW -> ok @@ t_now ;
@ -396,6 +403,8 @@ module Typer = struct
| C_AND -> ok @@ failwith "t_and" ;
| C_OR -> ok @@ failwith "t_or" ;
| C_XOR -> ok @@ failwith "t_xor" ;
| C_LSL -> ok @@ failwith "t_lsl" ;
| C_LSR -> ok @@ failwith "t_lsr" ;
(* COMPARATOR *)
| C_EQ -> ok @@ failwith "t_comparator EQ" ;
| C_NEQ -> ok @@ failwith "t_comparator NEQ" ;
@ -424,8 +433,6 @@ module Typer = struct
| C_LIST_FOLD -> ok @@ failwith "t_list_fold" ;
| C_LIST_CONS -> ok @@ failwith "t_list_cons" ;
(* MAP *)
| C_MAP_GET -> ok @@ failwith "t_map_get" ;
| C_MAP_GET_FORCE -> ok @@ failwith "t_map_get_force" ;
| C_MAP_ADD -> ok @@ t_map_add ;
| C_MAP_REMOVE -> ok @@ t_map_remove ;
| C_MAP_UPDATE -> ok @@ t_map_update ;
@ -442,7 +449,7 @@ module Typer = struct
| C_BLAKE2b -> ok @@ t_blake2b ;
| C_HASH_KEY -> ok @@ t_hash_key ;
| C_CHECK_SIGNATURE -> ok @@ t_check_signature ;
| C_CHAIN_ID -> ok @@ failwith "t_chain_id" ;
| C_CHAIN_ID -> ok @@ t_chain_id ;
(*BLOCKCHAIN *)
| C_CONTRACT -> ok @@ t_get_contract ;
| C_CONTRACT_ENTRYPOINT -> ok @@ failwith "t_get_entrypoint" ;
@ -484,42 +491,42 @@ module Typer = struct
let list_cons : typer = typer_2 "CONS" @@ fun hd tl ->
let%bind tl' = get_t_list tl in
let%bind () = assert_type_value_eq (hd , tl') in
let%bind () = assert_type_expression_eq (hd , tl') in
ok tl
let map_remove : typer = typer_2 "MAP_REMOVE" @@ fun k m ->
let%bind (src , _) = bind_map_or (get_t_map , get_t_big_map) m in
let%bind () = assert_type_value_eq (src , k) in
let%bind () = assert_type_expression_eq (src , k) in
ok m
let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m ->
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
let%bind () = assert_type_value_eq (src, k) in
let%bind () = assert_type_value_eq (dst, v) in
let%bind () = assert_type_expression_eq (src, k) in
let%bind () = assert_type_expression_eq (dst, v) in
ok m
let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v m ->
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
let%bind () = assert_type_value_eq (src, k) in
let%bind () = assert_type_expression_eq (src, k) in
let%bind v' = get_t_option v in
let%bind () = assert_type_value_eq (dst, v') in
let%bind () = assert_type_expression_eq (dst, v') in
ok m
let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m ->
let%bind (src, _dst) = bind_map_or (get_t_map , get_t_big_map) m in
let%bind () = assert_type_value_eq (src, k) in
let%bind () = assert_type_expression_eq (src, k) in
ok @@ t_bool ()
let map_find : typer = typer_2 "MAP_FIND" @@ fun k m ->
let%bind (src, dst) =
trace_strong (simple_error "MAP_FIND: not map or bigmap") @@
bind_map_or (get_t_map , get_t_big_map) m in
let%bind () = assert_type_value_eq (src, k) in
let%bind () = assert_type_expression_eq (src, k) in
ok @@ dst
let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m ->
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
let%bind () = assert_type_value_eq (src, k) in
let%bind () = assert_type_expression_eq (src, k) in
ok @@ t_option dst ()
let map_iter : typer = typer_2 "MAP_ITER" @@ fun f m ->
@ -562,16 +569,6 @@ module Typer = struct
let default = t_unit () in
ok @@ Simple_utils.Option.unopt ~default opt
let map_get_force = typer_2 "MAP_GET_FORCE" @@ fun i m ->
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
let%bind _ = assert_type_value_eq (src, i) in
ok dst
let map_get = typer_2 "MAP_GET" @@ fun i m ->
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
let%bind _ = assert_type_value_eq (src, i) in
ok @@ t_option dst ()
let int : typer = typer_1 "INT" @@ fun t ->
let%bind () = assert_t_nat t in
ok @@ t_int ()
@ -606,17 +603,17 @@ module Typer = struct
let%bind () = assert_t_bytes b in
ok @@ t_bool ()
let sender = constant "SENDER" @@ t_address ()
let sender = constant' "SENDER" @@ t_address ()
let source = constant "SOURCE" @@ t_address ()
let source = constant' "SOURCE" @@ t_address ()
let unit = constant "UNIT" @@ t_unit ()
let unit = constant' "UNIT" @@ t_unit ()
let amount = constant "AMOUNT" @@ t_mutez ()
let amount = constant' "AMOUNT" @@ t_mutez ()
let balance = constant "BALANCE" @@ t_mutez ()
let balance = constant' "BALANCE" @@ t_mutez ()
let chain_id = constant "CHAIN_ID" @@ t_chain_id ()
let chain_id = constant' "CHAIN_ID" @@ t_chain_id ()
let address = typer_1 "ADDRESS" @@ fun contract ->
let%bind () = assert_t_contract contract in
@ -629,12 +626,12 @@ module Typer = struct
let%bind () = assert_t_key_hash key_hash in
ok @@ t_contract (t_unit () ) ()
let now = constant "NOW" @@ t_timestamp ()
let now = constant' "NOW" @@ t_timestamp ()
let transaction = typer_3 "CALL" @@ fun param amount contract ->
let%bind () = assert_t_mutez amount in
let%bind contract_param = get_t_contract contract in
let%bind () = assert_type_value_eq (param , contract_param) in
let%bind () = assert_type_expression_eq (param , contract_param) in
ok @@ t_operation ()
let originate = typer_6 "ORIGINATE" @@ fun manager delegate_opt spendable delegatable init_balance code ->
@ -651,8 +648,8 @@ module Typer = struct
ok @@ (t_pair (t_operation ()) (t_address ()) ())
let get_contract = typer_1_opt "CONTRACT" @@ fun addr_tv tv_opt ->
if not (type_value_eq (addr_tv, t_address ()))
then fail @@ simple_error (Format.asprintf "get_contract expects an address, got %a" PP.type_value addr_tv)
if not (type_expression_eq (addr_tv, t_address ()))
then fail @@ simple_error (Format.asprintf "get_contract expects an address, got %a" PP.type_expression addr_tv)
else
let%bind tv =
trace_option (simple_error "get_contract needs a type annotation") tv_opt in
@ -662,8 +659,8 @@ module Typer = struct
ok @@ t_contract tv' ()
let get_contract_opt = typer_1_opt "CONTRACT OPT" @@ fun addr_tv tv_opt ->
if not (type_value_eq (addr_tv, t_address ()))
then fail @@ simple_error (Format.asprintf "get_contract_opt expects an address, got %a" PP.type_value addr_tv)
if not (type_expression_eq (addr_tv, t_address ()))
then fail @@ simple_error (Format.asprintf "get_contract_opt expects an address, got %a" PP.type_expression addr_tv)
else
let%bind tv =
trace_option (simple_error "get_contract_opt needs a type annotation") tv_opt in
@ -676,11 +673,11 @@ module Typer = struct
ok @@ t_option (t_contract tv' ()) ()
let get_entrypoint = typer_2_opt "CONTRACT_ENTRYPOINT" @@ fun entry_tv addr_tv tv_opt ->
if not (type_value_eq (entry_tv, t_string ()))
then fail @@ simple_error (Format.asprintf "get_entrypoint expects a string entrypoint label for first argument, got %a" PP.type_value entry_tv)
if not (type_expression_eq (entry_tv, t_string ()))
then fail @@ simple_error (Format.asprintf "get_entrypoint expects a string entrypoint label for first argument, got %a" PP.type_expression entry_tv)
else
if not (type_value_eq (addr_tv, t_address ()))
then fail @@ simple_error (Format.asprintf "get_entrypoint expects an address for second argument, got %a" PP.type_value addr_tv)
if not (type_expression_eq (addr_tv, t_address ()))
then fail @@ simple_error (Format.asprintf "get_entrypoint expects an address for second argument, got %a" PP.type_expression addr_tv)
else
let%bind tv =
trace_option (simple_error "get_entrypoint needs a type annotation") tv_opt in
@ -690,11 +687,11 @@ module Typer = struct
ok @@ t_contract tv' ()
let get_entrypoint_opt = typer_2_opt "CONTRACT_ENTRYPOINT_OPT" @@ fun entry_tv addr_tv tv_opt ->
if not (type_value_eq (entry_tv, t_string ()))
then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects a string entrypoint label for first argument, got %a" PP.type_value entry_tv)
if not (type_expression_eq (entry_tv, t_string ()))
then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects a string entrypoint label for first argument, got %a" PP.type_expression entry_tv)
else
if not (type_value_eq (addr_tv, t_address ()))
then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects an address for second argument, got %a" PP.type_value addr_tv)
if not (type_expression_eq (addr_tv, t_address ()))
then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects an address for second argument, got %a" PP.type_expression addr_tv)
else
let%bind tv =
trace_option (simple_error "get_entrypoint_opt needs a type annotation") tv_opt in
@ -845,8 +842,8 @@ module Typer = struct
let%bind (prec , cur) = get_t_pair arg in
let%bind key = get_t_list lst in
let msg = Format.asprintf "%a vs %a"
Ast_typed.PP.type_value key
Ast_typed.PP.type_value arg
PP.type_expression key
PP.type_expression arg
in
trace (simple_error ("bad list fold:" ^ msg)) @@
let%bind () = assert_eq_1 ~msg:"key cur" key cur in
@ -859,8 +856,8 @@ module Typer = struct
let%bind (prec , cur) = get_t_pair arg in
let%bind key = get_t_set lst in
let msg = Format.asprintf "%a vs %a"
Ast_typed.PP.type_value key
Ast_typed.PP.type_value arg
PP.type_expression key
PP.type_expression arg
in
trace (simple_error ("bad set fold:" ^ msg)) @@
let%bind () = assert_eq_1 ~msg:"key cur" key cur in
@ -873,10 +870,10 @@ module Typer = struct
let%bind (prec , cur) = get_t_pair arg in
let%bind (key , value) = get_t_map map in
let msg = Format.asprintf "%a vs %a"
Ast_typed.PP.type_value key
Ast_typed.PP.type_value arg
PP.type_expression key
PP.type_expression arg
in
trace (simple_error ("bad list fold:" ^ msg)) @@
trace (simple_error ("bad map fold:" ^ msg)) @@
let%bind () = assert_eq_1 ~msg:"key cur" (t_pair key value ()) cur in
let%bind () = assert_eq_1 ~msg:"prec res" prec res in
let%bind () = assert_eq_1 ~msg:"res init" res init in
@ -1006,6 +1003,8 @@ module Typer = struct
| C_AND -> ok @@ and_ ;
| C_OR -> ok @@ or_ ;
| C_XOR -> ok @@ xor ;
| C_LSL -> ok @@ lsl_;
| C_LSR -> ok @@ lsr_;
(* COMPARATOR *)
| C_EQ -> ok @@ comparator "EQ" ;
| C_NEQ -> ok @@ comparator "NEQ" ;
@ -1034,8 +1033,6 @@ module Typer = struct
| C_LIST_FOLD -> ok @@ list_fold ;
| C_LIST_CONS -> ok @@ list_cons ;
(* MAP *)
| C_MAP_GET -> ok @@ map_get ;
| C_MAP_GET_FORCE -> ok @@ map_get_force ;
| C_MAP_ADD -> ok @@ map_add ;
| C_MAP_REMOVE -> ok @@ map_remove ;
| C_MAP_UPDATE -> ok @@ map_update ;
@ -1067,7 +1064,7 @@ module Typer = struct
| C_SELF_ADDRESS -> ok @@ self_address;
| C_IMPLICIT_ACCOUNT -> ok @@ implicit_account;
| C_SET_DELEGATE -> ok @@ set_delegate ;
| _ -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" Stage_common.PP.constant c
| _ -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" PP.constant c
@ -1103,6 +1100,8 @@ module Compiler = struct
| C_OR -> ok @@ simple_binary @@ prim I_OR
| C_AND -> ok @@ simple_binary @@ prim I_AND
| C_XOR -> ok @@ simple_binary @@ prim I_XOR
| C_LSL -> ok @@ simple_binary @@ prim I_LSL
| C_LSR -> ok @@ simple_binary @@ prim I_LSR
| C_NOT -> ok @@ simple_unary @@ prim I_NOT
| C_PAIR -> ok @@ simple_binary @@ prim I_PAIR
| C_CAR -> ok @@ simple_unary @@ prim I_CAR
@ -1115,9 +1114,7 @@ module Compiler = struct
| C_GE -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_GE]
| C_UPDATE -> ok @@ simple_ternary @@ prim I_UPDATE
| C_SOME -> ok @@ simple_unary @@ prim I_SOME
| C_MAP_GET_FORCE -> ok @@ simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]
| C_MAP_FIND -> ok @@ simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]
| C_MAP_GET -> ok @@ simple_binary @@ prim I_GET
| C_MAP_MEM -> ok @@ simple_binary @@ prim I_MEM
| C_MAP_FIND_OPT -> ok @@ simple_binary @@ prim I_GET
| C_MAP_ADD -> ok @@ simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]
@ -1128,7 +1125,7 @@ module Compiler = struct
| C_SIZE -> ok @@ simple_unary @@ prim I_SIZE
| C_FAILWITH -> ok @@ simple_unary @@ prim I_FAILWITH
| C_ASSERT_INFERRED -> ok @@ simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])
| C_ASSERTION -> ok @@ simple_unary @@ i_if (seq [i_push_unit]) (seq [i_push_unit ; i_failwith])
| C_ASSERTION -> ok @@ simple_unary @@ i_if (seq [i_push_unit]) (seq [i_push_string "failed assertion" ; i_failwith])
| C_INT -> ok @@ simple_unary @@ prim I_INT
| C_ABS -> ok @@ simple_unary @@ prim I_ABS
| C_IS_NAT -> ok @@ simple_unary @@ prim I_ISNAT
@ -1158,7 +1155,6 @@ module Compiler = struct
| C_CHAIN_ID -> ok @@ simple_constant @@ prim I_CHAIN_ID
| _ -> simple_fail @@ Format.asprintf "operator not implemented for %a" Stage_common.PP.constant c
(*
Some complex operators will need to be added in compiler/compiler_program.
All operators whose compilations involve a type are found there.

15
src/passes/operators/operators.mli
View File

@ -4,16 +4,15 @@ module Simplify : sig
open Trace
module Pascaligo : sig
val constants : string -> constant result
val constants : string -> constant' result
val type_constants : string -> type_constant result
val type_operators : string -> type_expression type_operator result
val type_operators : string -> type_operator result
end
module Cameligo : sig
val constants : string -> constant result
val constants : string -> constant' result
val type_constants : string -> type_constant result
val type_operators : string -> type_expression type_operator result
val type_operators : string -> type_operator result
end
end
@ -94,7 +93,7 @@ module Typer : sig
val t_set_add : Typesystem.Core.type_value
val t_set_remove : Typesystem.Core.type_value
val t_not : Typesystem.Core.type_value
val constant_type : constant -> Typesystem.Core.type_value Trace.result
val constant_type : constant' -> Typesystem.Core.type_value Trace.result
end
(*
@ -171,7 +170,7 @@ module Typer : sig
val concat : typer
*)
val cons : typer
val constant_typers : constant -> typer result
val constant_typers : constant' -> typer result
end
@ -191,7 +190,7 @@ module Compiler : sig
| Tetrary of michelson
| Pentary of michelson
| Hexary of michelson
val get_operators : constant -> predicate result
val get_operators : constant' -> predicate result
val simple_constant : t -> predicate
val simple_unary : t -> predicate
val simple_binary : t -> predicate

186
src/stages/ast_simplified/PP.ml
View File

@ -1,110 +1,93 @@
[@@@coverage exclude_file]
open Types
open PP_helpers
open Format
open PP_helpers
include Stage_common.PP
include Ast_PP_type(Ast_simplified_parameter)
let list_sep_d x ppf lst = match lst with
| [] -> ()
| _ -> fprintf ppf " @[<v>%a@] " (list_sep x (tag " ; ")) lst
let tuple_sep_d x ppf lst = match lst with
| [] -> ()
| _ -> fprintf ppf " @[<v>%a@] " (list_sep x (tag " , ")) lst
let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev
let rec te' ppf (te : type_expression type_expression') : unit =
type_expression' type_expression ppf te
and type_expression ppf (te: type_expression) : unit =
te' ppf te.type_expression'
let rec expression ppf (e : expression) =
match e.expression_content with
| E_literal l ->
literal ppf l
| E_variable n ->
fprintf ppf "%a" expression_variable n
| E_application app ->
fprintf ppf "(%a)@(%a)" expression app.expr1 expression app.expr2
| E_constructor c ->
fprintf ppf "%a(%a)" constructor c.constructor expression c.element
| E_constant c ->
fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression)
c.arguments
| E_record m ->
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
| E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.expr label ra.label
| E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
| E_map m ->
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
| E_big_map m ->
fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
| E_list lst ->
fprintf ppf "list[%a]" (list_sep_d expression) lst
| E_set lst ->
fprintf ppf "set[%a]" (list_sep_d expression) lst
| E_look_up (ds, ind) ->
fprintf ppf "(%a)[%a]" expression ds expression ind
| E_lambda {binder; input_type; output_type; result} ->
fprintf ppf "lambda (%a:%a) : %a return %a" option_type_name binder
(PP_helpers.option type_expression)
input_type
(PP_helpers.option type_expression)
output_type 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 ; 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 ->
fprintf ppf "skip"
| E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression
type_annotation
let rec expression ppf (e:expression) = match e.expression with
| E_literal l -> fprintf ppf "%a" literal l
| E_variable n -> fprintf ppf "%a" name n
| E_application (f, arg) -> fprintf ppf "(%a)@(%a)" expression f expression arg
| E_constructor (c, ae) -> fprintf ppf "%a(%a)" constructor c expression ae
| E_constant (b, lst) -> fprintf ppf "%a(%a)" constant b (list_sep_d expression) lst
| E_tuple lst -> fprintf ppf "(%a)" (tuple_sep_d expression) lst
| E_accessor (ae, p) -> fprintf ppf "%a.%a" expression ae access_path p
| E_record m -> fprintf ppf "{%a}" (lrecord_sep expression (const " , ")) m
| E_update {record; update=(path,expr)} -> fprintf ppf "%a with { %a = %a }" expression record Stage_common.PP.label path expression expr
| E_map m -> fprintf ppf "[%a]" (list_sep_d assoc_expression) m
| E_big_map m -> fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
| E_list lst -> fprintf ppf "[%a]" (list_sep_d expression) lst
| E_set lst -> fprintf ppf "{%a}" (list_sep_d expression) lst
| E_look_up (ds, ind) -> fprintf ppf "(%a)[%a]" expression ds expression ind
| E_lambda {binder;input_type;output_type;result} ->
fprintf ppf "lambda (%a:%a) : %a return %a"
option_type_name binder
(PP_helpers.option type_expression) input_type (PP_helpers.option type_expression) output_type
expression result
| E_matching (ae, m) ->
fprintf ppf "match %a with %a" expression ae (matching expression) m
| E_sequence (a , b) ->
fprintf ppf "%a ; %a"
expression a
expression b
| E_loop (expr , body) ->
fprintf ppf "%a ; %a"
expression expr
expression body
| E_assign (n , path , expr) ->
fprintf ppf "%a.%a := %a"
name n
PP_helpers.(list_sep access (const ".")) path
expression expr
| E_let_in { binder ; rhs ; result; inline } ->
fprintf ppf "let %a = %a%a in %a" option_type_name binder expression rhs option_inline inline expression result
| E_skip -> fprintf ppf "skip"
| E_ascription (expr , ty) -> fprintf ppf "%a : %a" expression expr type_expression ty
and option_type_name ppf ((n , ty_opt) : expression_variable * type_expression option) =
and option_type_name ppf
((n, ty_opt) : expression_variable * type_expression option) =
match ty_opt with
| None -> fprintf ppf "%a" name n
| Some ty -> fprintf ppf "%a : %a" name n type_expression ty
| None ->
fprintf ppf "%a" expression_variable n
| Some ty ->
fprintf ppf "%a : %a" expression_variable n type_expression ty
and option_inline ppf inline =
if inline then
fprintf ppf "[@inline]"
else
fprintf ppf ""
and assoc_expression ppf : expr * expr -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
and assoc_expression ppf : (expr * expr) -> unit = fun (a, b) ->
fprintf ppf "%a -> %a" expression a expression b
and single_record_patch ppf ((p, expr) : label * expr) =
fprintf ppf "%a <- %a" label p expression expr
and access ppf (a:access) =
match a with
| Access_tuple i -> fprintf ppf "%d" i
| Access_record l -> fprintf ppf "%s" l
and access_path ppf (p:access_path) =
fprintf ppf "%a" (list_sep access (const ".")) p
and type_annotation ppf (ta:type_expression option) = match ta with
| None -> fprintf ppf ""
| Some t -> type_expression ppf t
and single_record_patch ppf ((p, expr) : string * expr) =
fprintf ppf "%s <- %a" p expression expr
and single_tuple_patch ppf ((p, expr) : int * expr) =
fprintf ppf "%d <- %a" p expression expr
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor * expression_variable) * a -> unit =
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a -> %a" constructor c name n f a
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching -> unit =
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
fun f ppf m -> match m with
| Match_tuple ((lst, b), _) ->
fprintf ppf "let (%a) = %a" (list_sep_d name) lst f b
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil name hd name tl f match_cons
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none name some f match_some
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
(* Shows the type expected for the matched value *)
and matching_type ppf m = match m with
@ -120,13 +103,30 @@ and matching_type ppf m = match m with
fprintf ppf "option"
and matching_variant_case_type ppf ((c,n),_a) =
fprintf ppf "| %a %a" constructor c name n
fprintf ppf "| %a %a" constructor c expression_variable n
let declaration ppf (d:declaration) = match d with
| Declaration_type (type_name , te) ->
fprintf ppf "type %a = %a" type_variable (type_name) type_expression te
| Declaration_constant (name , ty_opt , inline, expr) ->
fprintf ppf "const %a = %a%a" option_type_name (name , ty_opt) expression expr option_inline inline
and option_mut ppf mut =
if mut then
fprintf ppf "[@mut]"
else
fprintf ppf ""
let program ppf (p:program) =
fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)
and option_inline ppf inline =
if inline then
fprintf ppf "[@inline]"
else
fprintf ppf ""
let declaration ppf (d : declaration) =
match d with
| Declaration_type (type_name, te) ->
fprintf ppf "type %a = %a" type_variable type_name type_expression te
| Declaration_constant (name, ty_opt, i, expr) ->
fprintf ppf "const %a = %a%a" option_type_name (name, ty_opt) expression
expr
option_inline i
let program ppf (p : program) =
fprintf ppf "@[<v>%a@]"
(list_sep declaration (tag "@;"))
(List.map Location.unwrap p)

47
src/stages/ast_simplified/PP.mli
View File

@ -1,47 +0,0 @@
(** Pretty printer for the Simplified Abstract Syntax Tree *)
open Types
open Format
(*
val list_sep_d : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
val smap_sep_d : (formatter -> 'a -> unit) -> formatter -> 'a Map.String.t -> unit
*)
val type_expression : formatter -> type_expression -> unit
val literal : formatter -> literal -> unit
val expression : formatter -> expression -> unit
(*
val option_type_name : formatter -> string * type_expression option -> unit
val assoc_expression : formatter -> (expr * expr) -> unit
val access : formatter -> access -> unit
val access_path : formatter -> access_path -> unit
*)
val type_annotation : formatter -> type_expression option -> unit
val single_record_patch : formatter -> string * expr -> unit
val single_tuple_patch : formatter -> int * expr -> unit
(*
val matching_variant_case : (formatter -> 'a -> unit) -> formatter -> (constructor_name * name) * 'a -> unit
val matching : (formatter -> 'a -> unit) -> formatter -> 'a matching -> unit
*)
(** Shows the type expected for the matched value *)
val matching_type : formatter -> ('a, 'var) matching -> unit
(*
val matching_variant_case_type : formatter -> ( ( constructor_name * name) * 'a) -> unit
val declaration : formatter -> declaration -> unit
*)
(** Pretty print a full program AST *)
val program : formatter -> program -> unit

4
src/stages/ast_simplified/ast_simplified.ml
View File

@ -1,8 +1,8 @@
include Types
(* include Misc *)
include Combinators
module Types = Types
module Misc = Misc
module PP = PP
module PP=PP
module Combinators = Combinators

148
src/stages/ast_simplified/combinators.ml
View File

@ -13,13 +13,19 @@ module Errors = struct
] in
error ~data title message
let bad_type_operator type_op =
let title () = Format.asprintf "bad type operator %a" (Stage_common.PP.type_operator PP.type_expression) type_op in
let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in
let message () = "" in
error title message
end
open Errors
let make_t type_expression' = {type_expression'}
let make_t type_content = {type_content; type_meta = ()}
let tuple_to_record lst =
let aux (i,acc) el = (i+1,(string_of_int i, el)::acc) in
let (_, lst ) = List.fold_left aux (0,[]) lst in
lst
let t_bool : type_expression = make_t @@ T_constant (TC_bool)
let t_string : type_expression = make_t @@ T_constant (TC_string)
@ -36,8 +42,6 @@ let t_key_hash : type_expression = make_t @@ T_constant (TC_key_hash)
let t_option o : type_expression = make_t @@ T_operator (TC_option o)
let t_list t : type_expression = make_t @@ T_operator (TC_list t)
let t_variable n : type_expression = make_t @@ T_variable (Var.of_name n)
let t_tuple lst : type_expression = make_t @@ T_operator (TC_tuple lst)
let t_pair (a , b) : type_expression = t_tuple [a ; b]
let t_record_ez lst =
let lst = List.map (fun (k, v) -> (Label k, v)) lst in
let m = LMap.of_list lst in
@ -46,6 +50,9 @@ let t_record m : type_expression =
let lst = Map.String.to_kv_list m in
t_record_ez lst
let t_pair (a , b) : type_expression = t_record_ez [("0",a) ; ("1",b)]
let t_tuple lst : type_expression = t_record_ez (tuple_to_record lst)
let ez_t_sum (lst:(string * type_expression) list) : type_expression =
let aux prev (k, v) = CMap.add (Constructor k) v prev in
let map = List.fold_left aux CMap.empty lst in
@ -54,7 +61,7 @@ let t_sum m : type_expression =
let lst = Map.String.to_kv_list m in
ez_t_sum lst
let t_function param result : type_expression = make_t @@ T_arrow (param, result)
let t_function type1 type2 : type_expression = make_t @@ T_arrow {type1; type2}
let t_map key value : type_expression = make_t @@ T_operator (TC_map (key, value))
let t_big_map key value : type_expression = make_t @@ T_operator (TC_big_map (key , value))
let t_set key : type_expression = make_t @@ T_operator (TC_set key)
@ -71,9 +78,9 @@ let t_operator op lst: type_expression result =
| TC_contract _ , [t] -> ok @@ t_contract t
| _ , _ -> fail @@ bad_type_operator op
let location_wrap ?(loc = Location.generated) expression =
let location_wrap ?(loc = Location.generated) expression_content =
let location = loc in
{ location ; expression }
{ expression_content; location }
let e_var ?loc (n: string) : expression = location_wrap ?loc @@ E_variable (Var.of_name n)
let e_literal ?loc l : expression = location_wrap ?loc @@ E_literal l
@ -89,7 +96,7 @@ let e_signature ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_s
let e_key ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = location_wrap ?loc @@ E_literal (Literal_chain_id s)
let e'_bytes b : expression' result =
let e'_bytes b : expression_content result =
let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in
ok @@ E_literal (Literal_bytes bytes)
let e_bytes_hex ?loc b : expression result =
@ -100,37 +107,51 @@ let e_bytes_raw ?loc (b: bytes) : expression =
let e_bytes_string ?loc (s: string) : expression =
location_wrap ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_big_map ?loc lst : expression = location_wrap ?loc @@ E_big_map lst
let e_record ?loc map : expression = location_wrap ?loc @@ E_record map
let e_tuple ?loc lst : expression = location_wrap ?loc @@ E_tuple lst
let e_some ?loc s : expression = location_wrap ?loc @@ E_constant (C_SOME, [s])
let e_none ?loc () : expression = location_wrap ?loc @@ E_constant (C_NONE, [])
let e_string_cat ?loc sl sr : expression = location_wrap ?loc @@ E_constant (C_CONCAT, [sl ; sr ])
let e_map_add ?loc k v old : expression = location_wrap ?loc @@ E_constant (C_MAP_ADD, [k ; v ; old])
let e_some ?loc s : expression = location_wrap ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = location_wrap ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc sl sr : expression = location_wrap ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc k v old : expression = location_wrap ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
let e_map ?loc lst : expression = location_wrap ?loc @@ E_map lst
let e_set ?loc lst : expression = location_wrap ?loc @@ E_set lst
let e_list ?loc lst : expression = location_wrap ?loc @@ E_list lst
let e_pair ?loc a b : expression = location_wrap ?loc @@ E_tuple [a; b]
let e_constructor ?loc s a : expression = location_wrap ?loc @@ E_constructor (Constructor s , a)
let e_matching ?loc a b : expression = location_wrap ?loc @@ E_matching (a , b)
let e_constructor ?loc s a : expression = location_wrap ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = location_wrap ?loc @@ E_matching {matchee=a;cases=b}
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = location_wrap ?loc @@ E_accessor (a , b)
let e_accessor_props ?loc a b = e_accessor ?loc a (List.map (fun x -> Access_record x) b)
let e_accessor ?loc a b = location_wrap ?loc @@ E_record_accessor {expr = a; label= Label b}
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 cond body = location_wrap ?loc @@ E_loop (cond , body)
let e_sequence ?loc a b = location_wrap ?loc @@ E_sequence (a , b)
let e_let_in ?loc (binder, ascr) inline rhs result = location_wrap ?loc @@ E_let_in { binder = (binder, ascr) ; rhs ; result ; inline }
let e_annotation ?loc expr ty = location_wrap ?loc @@ E_ascription (expr , ty)
let e_application ?loc a b = location_wrap ?loc @@ E_application (a , b)
let e_binop ?loc name a b = location_wrap ?loc @@ E_constant (name , [a ; b])
let e_constant ?loc name lst = location_wrap ?loc @@ E_constant (name , lst)
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}
let e_application ?loc a b = location_wrap ?loc @@ E_application {expr1=a ; expr2=b}
let e_binop ?loc name a b = location_wrap ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
let e_constant ?loc name lst = location_wrap ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_look_up ?loc x y = location_wrap ?loc @@ E_look_up (x , y)
let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c)
let e_sequence ?loc expr1 expr2 = e_let_in ?loc (Var.fresh (), Some t_unit) false false expr1 expr2
let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false})
(*
let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*)
*)
let ez_match_variant (lst : ((string * string) * 'a) list) =
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
Match_variant (lst,())
let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
e_matching ?loc a (ez_match_variant lst)
let e_record_ez ?loc (lst : (string * expr) list) : expression =
let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
location_wrap ?loc @@ E_record map
let e_record ?loc map =
let lst = Map.String.to_kv_list map in
e_record_ez ?loc lst
let e_update ?loc record path update =
let path = Label path in
location_wrap ?loc @@ E_record_update {record; path; update}
let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst)
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
let make_option_typed ?loc e t_opt =
match t_opt with
@ -138,12 +159,6 @@ let make_option_typed ?loc e t_opt =
| Some t -> e_annotation ?loc e t
let ez_e_record ?loc (lst : (string * expr) list) =
let aux prev (k, v) = LMap.add k v prev in
let lst = List.map (fun (k,v) -> (Label k, v)) lst in
let map = List.fold_left aux LMap.empty lst in
e_record ?loc map
let e_typed_none ?loc t_opt =
let type_annotation = t_option t_opt in
e_annotation ?loc (e_none ?loc ()) type_annotation
@ -156,6 +171,7 @@ let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map
let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
let e_lambda ?loc (binder : expression_variable)
(input_type : type_expression option)
(output_type : type_expression option)
@ -168,34 +184,41 @@ let e_lambda ?loc (binder : expression_variable)
result ;
}
let e_ez_record ?loc (lst : (string * expr) list) : expression =
let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
location_wrap ?loc @@ E_record map
let e_record ?loc map =
let lst = Map.String.to_kv_list map in
e_ez_record ?loc lst
let e_update ?loc record path expr =
let update = (Label path, expr) in
location_wrap ?loc @@ E_update {record; update}
let e_assign_with_let ?loc var access_path expr =
let var = Var.of_name (var) in
match access_path with
| [] -> (var, None), true, expr, false
| lst ->
let rec aux path record= match path with
| [] -> failwith "acces_path cannot be empty"
| [e] -> e_update ?loc record e expr
| elem::tail ->
let next_record = e_accessor record elem in
e_update ?loc record elem (aux tail next_record )
in
(var, None), true, (aux lst (e_variable var)), false
let get_e_accessor = fun t ->
match t with
| E_accessor (a , b) -> ok (a , b)
| E_record_accessor {expr; label} -> ok (expr , label)
| _ -> simple_fail "not an accessor"
let assert_e_accessor = fun t ->
let%bind _ = get_e_accessor t in
ok ()
let get_access_record : access -> string result = fun a ->
match a with
| Access_tuple _ -> simple_fail "not an access record"
| Access_record s -> ok s
let get_e_pair = fun t ->
match t with
| E_tuple [a ; b] -> ok (a , b)
| E_record r -> (
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> simple_fail "not a pair"
)
| _ -> simple_fail "not a pair"
let get_e_list = fun t ->
@ -203,27 +226,42 @@ let get_e_list = fun t ->
| E_list lst -> ok lst
| _ -> simple_fail "not a list"
let tuple_of_record (m: _ LMap.t) =
let aux i =
let opt = LMap.find_opt (Label (string_of_int i)) m in
Option.bind (fun opt -> Some (opt,i+1)) opt
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
let get_e_tuple = fun t ->
match t with
| E_tuple lst -> ok lst
| E_record r -> ok @@ tuple_of_record r
| _ -> simple_fail "ast_simplified: get_e_tuple: not a tuple"
(* Same as get_e_pair *)
let extract_pair : expression -> (expression * expression) result = fun e ->
match e.expression with
| E_tuple [ a ; b ] -> ok (a , b)
match e.expression_content with
| E_record r -> (
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> fail @@ bad_kind "pair" e.location
)
| _ -> fail @@ bad_kind "pair" e.location
let extract_list : expression -> (expression list) result = fun e ->
match e.expression with
match e.expression_content with
| E_list lst -> ok lst
| _ -> fail @@ bad_kind "list" e.location
let extract_record : expression -> (label * expression) list result = fun e ->
match e.expression with
match e.expression_content with
| E_record lst -> ok @@ LMap.to_kv_list lst
| _ -> fail @@ bad_kind "record" e.location
let extract_map : expression -> (expression * expression) list result = fun e ->
match e.expression with
match e.expression_content with
| E_map lst -> ok lst
| _ -> fail @@ bad_kind "map" e.location

40
src/stages/ast_simplified/combinators.mli
View File

@ -9,7 +9,7 @@ module Errors : sig
val bad_kind : name -> Location.t -> unit -> error
end
*)
val make_t : type_expression type_expression' -> type_expression
val make_t : type_content -> type_expression
val t_bool : type_expression
val t_string : type_expression
val t_bytes : type_expression
@ -27,11 +27,11 @@ val t_option : type_expression -> type_expression
*)
val t_list : type_expression -> type_expression
val t_variable : string -> type_expression
val t_tuple : type_expression list -> type_expression
(*
val t_record : te_map -> type_expression
*)
val t_pair : ( type_expression * type_expression ) -> type_expression
val t_tuple : type_expression list -> type_expression
val t_record : type_expression Map.String.t -> type_expression
val t_record_ez : (string * type_expression) list -> type_expression
@ -42,7 +42,7 @@ val ez_t_sum : ( string * type_expression ) list -> type_expression
val t_function : type_expression -> type_expression -> type_expression
val t_map : type_expression -> type_expression -> type_expression
val t_operator : type_expression type_operator -> type_expression list -> type_expression result
val t_operator : type_operator -> type_expression list -> type_expression result
val t_set : type_expression -> type_expression
val e_var : ?loc:Location.t -> string -> expression
@ -59,14 +59,13 @@ val e_key : ?loc:Location.t -> string -> expression
val e_key_hash : ?loc:Location.t -> string -> expression
val e_chain_id : ?loc:Location.t -> string -> expression
val e_mutez : ?loc:Location.t -> int -> expression
val e'_bytes : string -> expression' result
val e'_bytes : string -> expression_content result
val e_bytes_hex : ?loc:Location.t -> string -> expression result
val e_bytes_raw : ?loc:Location.t -> bytes -> expression
val e_bytes_string : ?loc:Location.t -> string -> expression
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
(*
val e_record : ?loc:Location.t -> ( expr * expr ) list -> expression
*)
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression
val e_tuple : ?loc:Location.t -> expression list -> expression
val e_some : ?loc:Location.t -> expression -> expression
val e_none : ?loc:Location.t -> unit -> expression
@ -79,24 +78,23 @@ val e_pair : ?loc:Location.t -> expression -> expression -> expression
val e_constructor : ?loc:Location.t -> string -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
val e_accessor : ?loc:Location.t -> expression -> access_path -> expression
val e_accessor_props : ?loc:Location.t -> expression -> string list -> expression
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_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> inline -> 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
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_binop : ?loc:Location.t -> constant -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> constant -> expression list -> expression
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val e_assign : ?loc:Location.t -> string -> access_path -> expression -> expression
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
val ez_e_record : ?loc:Location.t -> ( string * expression ) list -> expression
val e_typed_none : ?loc:Location.t -> type_expression -> expression
@ -110,20 +108,18 @@ val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expre
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
val e_update : ?loc:Location.t -> expression -> string -> expression -> expression
val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool)
val e_ez_record : ?loc:Location.t -> ( string * expr ) list -> expression
(*
val get_e_accessor : expression' -> ( expression * access_path ) result
*)
val assert_e_accessor : expression' -> unit result
val assert_e_accessor : expression_content -> unit result
val get_access_record : access -> string result
val get_e_pair : expression_content -> ( expression * expression ) result
val get_e_pair : expression' -> ( expression * expression ) result
val get_e_list : expression' -> ( expression list ) result
val get_e_tuple : expression' -> ( expression list ) result
val get_e_list : expression_content -> ( expression list ) result
val get_e_tuple : expression_content -> ( expression list ) result
(*
val get_e_failwith : expression -> expression result
val is_e_failwith : expression -> bool

47
src/stages/ast_simplified/misc.ml
View File

@ -1,8 +1,7 @@
open Trace
open Types
include Stage_common.Misc
open Stage_common.Helpers
module Errors = struct
let different_literals_because_different_types name a b () =
let title () = "literals have different types: " ^ name in
@ -56,6 +55,8 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
| Literal_bytes a, Literal_bytes b when a = b -> ok ()
| Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytess" a b
| Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b
| Literal_void, Literal_void -> ok ()
| Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b
| Literal_unit, Literal_unit -> ok ()
| Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b
| Literal_address a, Literal_address b when a = b -> ok ()
@ -77,19 +78,20 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
| Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b
let rec assert_value_eq (a, b: (expression * expression )) : unit result =
Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b;
let error_content () =
Format.asprintf "\n@[<v>- %a@;- %a]" PP.expression a PP.expression b
in
trace (fun () -> error (thunk "not equal") error_content ()) @@
match (a.expression , b.expression) with
match (a.expression_content , b.expression_content) with
| E_literal a , E_literal b ->
assert_literal_eq (a, b)
| E_literal _ , _ ->
simple_fail "comparing a literal with not a literal"
| E_constant (ca, lsta) , E_constant (cb, lstb) when ca = cb -> (
| E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> (
let%bind lst =
generic_try (simple_error "constants with different number of elements")
(fun () -> List.combine lsta lstb) in
(fun () -> List.combine ca.arguments cb.arguments) in
let%bind _all = bind_list @@ List.map assert_value_eq lst in
ok ()
)
@ -103,8 +105,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
in
fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ())
| E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> (
let%bind _eq = assert_value_eq (a, b) in
| E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> (
let%bind _eq = assert_value_eq (ca.element, cb.element) in
ok ()
)
| E_constructor _, E_constructor _ ->
@ -112,15 +114,6 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| E_constructor _, _ ->
simple_fail "comparing constructor with other expression"
| E_tuple lsta, E_tuple lstb -> (
let%bind lst =
generic_try (simple_error "tuples with different number of elements")
(fun () -> List.combine lsta lstb) in
let%bind _all = bind_list @@ List.map assert_value_eq lst in
ok ()
)
| E_tuple _, _ ->
simple_fail "comparing tuple with other expression"
| E_record sma, E_record smb -> (
let aux _ a b =
@ -134,17 +127,17 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| E_record _, _ ->
simple_fail "comparing record with other expression"
| E_update ura, E_update urb ->
| E_record_update ura, E_record_update urb ->
let _ =
generic_try (simple_error "Updating different record") @@
fun () -> assert_value_eq (ura.record, urb.record) in
let aux ((Label a,expra),(Label b, exprb))=
assert (String.equal a b);
assert_value_eq (expra,exprb)
let aux (Label a,Label b) =
assert (String.equal a b)
in
let%bind _all = aux (ura.update, urb.update) in
let () = aux (ura.path, urb.path) in
let%bind () = assert_value_eq (ura.update,urb.update) in
ok ()
| E_update _, _ ->
| E_record_update _, _ ->
simple_fail "comparing record update with other expression"
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
@ -185,13 +178,13 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| E_set _, _ ->
simple_fail "comparing set with other expression"
| (E_ascription (a , _) , _b') -> assert_value_eq (a , b)
| (_a' , E_ascription (b , _)) -> assert_value_eq (a , b)
| (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b)
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
| (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _)
| (E_accessor _, _)
| (E_look_up _, _) | (E_matching _, _) | (E_sequence _, _)
| (E_loop _, _) | (E_assign _, _) | (E_skip, _) -> simple_fail "comparing not a value"
| (E_record_accessor _, _)
| (E_look_up _, _) | (E_matching _, _)
| (E_loop _, _) | (E_skip, _) -> simple_fail "comparing not a value"
let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)

1
src/stages/ast_simplified/misc.mli
View File

@ -1,7 +1,6 @@
open Trace
open Types
include module type of Stage_common.Misc
(*

143
src/stages/ast_simplified/types.ml
View File

@ -1,14 +1,19 @@
[@@@warning "-30"]
module Location = Simple_utils.Location
module Ast_simplified_parameter = struct
type type_meta = unit
end
include Stage_common.Types
(*include Ast_generic_type(Ast_simplified_parameter)
*)
include Ast_generic_type (Ast_simplified_parameter)
type inline = bool
type program = declaration Location.wrap list
and inline = bool
and type_expression = {
type_expression' : type_expression type_expression'
}
and declaration =
| Declaration_type of (type_variable * type_expression)
@ -19,59 +24,91 @@ and declaration =
* an expression *)
| Declaration_constant of (expression_variable * type_expression option * inline * expression)
and expr = expression
(* | Macro_declaration of macro_declaration *)
and expression = {expression_content: expression_content; location: Location.t}
and lambda = {
binder : (expression_variable * type_expression option) ;
input_type : type_expression option ;
output_type : type_expression option ;
result : expr ;
}
and let_in = {
binder : (expression_variable * type_expression option) ;
rhs : expr ;
result : expr ;
inline : inline;
}
and expression' =
and expression_content =
(* Base *)
| E_literal of literal
| E_constant of (constant * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of expression_variable
| E_application of application
| E_lambda of lambda
| E_application of (expr * expr)
| E_let_in of let_in
(* E_Tuple *)
| E_tuple of expr list
(* Sum *)
| E_constructor of (constructor * expr) (* For user defined constructors *)
(* E_record *)
| E_record of expr label_map
(* TODO: Change it to (expr * access) *)
| E_accessor of (expr * access_path)
| E_update of update
(* Data Structures *)
| E_map of (expr * expr) list
| E_big_map of (expr * expr) list
| E_list of expr list
| E_set of expr list
| E_look_up of (expr * expr)
(* Matching *)
| E_matching of (expr * matching_expr)
(* Replace Statements *)
| E_sequence of (expr * expr)
| E_loop of (expr * expr)
| E_assign of (expression_variable * access_path * expr)
| E_skip
(* Annotate *)
| E_ascription of expr * type_expression
(* Variant *)
| E_constructor of constructor (* For user defined constructors *)
| E_matching of matching
(* Record *)
| E_record of expression label_map
| E_record_accessor of accessor
| E_record_update of update
(* Data Structures *)
(* TODO : move to constant*)
| E_map of (expression * expression) list (*move to operator *)
| E_big_map of (expression * expression) list (*move to operator *)
| 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 expression = {
expression : expression' ;
location : Location.t ;
}
and update = { record: expr; update: (label *expr) }
and constant =
{ cons_name: constant' (* this is at the end because it is huge *)
; arguments: expression list }
and matching_expr = (expr,unit) matching
and application = {expr1: expression; expr2: expression}
and lambda =
{ binder: expression_variable * type_expression option
; input_type: type_expression option
; output_type: type_expression option
; result: expression }
and let_in =
{ let_binder: expression_variable * type_expression option
; mut: bool
; rhs: expression
; let_result: expression
; inline: bool }
and constructor = {constructor: constructor'; element: expression}
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
; cases: matching_expr
}
and ascription = {anno_expr: expression; type_annotation: type_expression}
and environment_element_definition =
| ED_binder
| ED_declaration of (expression * free_variables)
and free_variables = expression_variable list
and environment_element =
{ type_value: type_expression
; source_environment: full_environment
; definition: environment_element_definition }
and environment = (expression_variable * environment_element) list
and type_environment = (type_variable * type_expression) list
(* SUBST ??? *)
and small_environment = environment * type_environment
and full_environment = small_environment List.Ne.t
and expr = expression
and texpr = type_expression

126
src/stages/ast_typed/PP.ml
View File

@ -2,26 +2,60 @@
open Types
open Format
open PP_helpers
include Stage_common.PP
include Ast_PP_type(Ast_typed_type_parameter)
let list_sep_d x = list_sep x (const " , ")
let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev
let rec type_value' ppf (tv':type_value type_expression') : unit =
type_expression' type_value ppf tv'
let rec expression ppf (e : expression) =
match e.expression_content with
| E_literal l ->
literal ppf l
| E_variable n ->
fprintf ppf "%a" expression_variable n
| E_application app ->
fprintf ppf "(%a)@(%a)" expression app.expr1 expression app.expr2
| E_constructor c ->
fprintf ppf "%a(%a)" constructor c.constructor expression c.element
| E_constant c ->
fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression)
c.arguments
| E_record m ->
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
| E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.expr label ra.label
| E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
| E_map m ->
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
| E_big_map m ->
fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
| E_list lst ->
fprintf ppf "list[%a]" (list_sep_d expression) lst
| E_set lst ->
fprintf ppf "set[%a]" (list_sep_d expression) lst
| E_look_up (ds, ind) ->
fprintf ppf "(%a)[%a]" expression ds expression ind
| E_lambda {binder; result} ->
fprintf ppf "lambda (%a) return %a" expression_variable binder
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
and type_value ppf (tv:type_value) : unit =
type_value' ppf tv.type_value'
and assoc_expression ppf : expr * expr -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
let rec annotated_expression ppf (ae:annotated_expression) : unit =
match ae.type_annotation.simplified with
| _ -> fprintf ppf "@[<v>%a:%a@]" expression ae.expression type_value ae.type_annotation
and single_record_patch ppf ((p, expr) : label * expr) =
fprintf ppf "%a <- %a" label p expression expr
and lambda ppf l =
let ({ binder ; body } : lambda) = l in
fprintf ppf "(lambda (%a) -> %a)"
name binder
annotated_expression body
and option_inline ppf inline =
if inline then
@ -29,68 +63,28 @@ and option_inline ppf inline =
else
fprintf ppf ""
and expression ppf (e:expression) : unit =
match e with
| E_literal l -> Stage_common.PP.literal ppf l
| E_constant (b, lst) -> fprintf ppf "(e_constant %a(%a))" constant b (list_sep_d annotated_expression) lst
| E_constructor (c, lst) -> fprintf ppf "(e_constructor %a(%a))" constructor c annotated_expression lst
| E_variable a -> fprintf ppf "(e_var %a)" name a
| E_application (f, arg) -> fprintf ppf "(%a) (%a)" annotated_expression f annotated_expression arg
| E_lambda l -> fprintf ppf "%a" lambda l
| E_tuple_accessor (ae, i) -> fprintf ppf "%a.%d" annotated_expression ae i
| E_record_accessor (ae, l) -> fprintf ppf "%a.%a" annotated_expression ae label l
| E_record_update (ae, (path,expr)) -> fprintf ppf "%a with record[%a=%a]" annotated_expression ae Stage_common.PP.label path annotated_expression expr
| E_tuple lst -> fprintf ppf "tuple[@; @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) lst
| E_record m -> fprintf ppf "record[%a]" (lmap_sep annotated_expression (const " , ")) m
| E_map m -> fprintf ppf "map[@; @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m
| E_big_map m -> fprintf ppf "big_map[@; @[<v>%a@]@;]" (list_sep assoc_annotated_expression (tag ",@;")) m
| E_list m -> fprintf ppf "list[@; @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) m
| E_set m -> fprintf ppf "set[@; @[<v>%a@]@;]" (list_sep annotated_expression (tag ",@;")) m
| E_look_up (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i
| E_matching (ae, m) ->
fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
| E_sequence (a , b) -> fprintf ppf "(e_seq %a ; %a)" annotated_expression a annotated_expression b
| E_loop (expr , body) -> fprintf ppf "while %a { %a }" annotated_expression expr annotated_expression body
| E_assign (name , path , expr) ->
fprintf ppf "%a.%a := %a"
Stage_common.PP.name name.type_name
PP_helpers.(list_sep pre_access (const ".")) path
annotated_expression expr
| E_let_in { binder; rhs; result; inline } ->
fprintf ppf "let %a = %a%a in %a" name binder annotated_expression rhs option_inline inline annotated_expression result
and value ppf v = annotated_expression ppf v
and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) ->
fprintf ppf "%a -> %a" annotated_expression a annotated_expression b
and single_record_patch ppf ((s, ae) : string * ae) =
fprintf ppf "%s <- %a" s annotated_expression ae
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor * expression_variable) * a -> unit =
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a -> %a" constructor c name n f a
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching -> unit = fun f ppf m -> match m with
and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching_content -> unit = fun f ppf m -> match m with
| Match_tuple ((lst, b),_) ->
fprintf ppf "let (%a) = %a" (list_sep_d Stage_common.PP.name) lst f b
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = (hd_name, tl_name, match_cons, _)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil Stage_common.PP.name hd_name Stage_common.PP.name tl_name f match_cons
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd_name expression_variable tl_name f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none name some f match_some
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
and pre_access ppf (a:access) = match a with
| Access_record n -> fprintf ppf ".%s" n
| Access_tuple i -> fprintf ppf ".%d" i
let declaration ppf (d:declaration) =
let declaration ppf (d : declaration) =
match d with
| Declaration_constant ({name ; annotated_expression = ae} , inline, _) ->
fprintf ppf "const %a = %a%a" Stage_common.PP.name name annotated_expression ae option_inline inline
| Declaration_constant (name, expr, inline,_) ->
fprintf ppf "const %a = %a%a" expression_variable name expression expr option_inline inline
let program ppf (p:program) =
fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p)
let program ppf (p : program) =
fprintf ppf "@[<v>%a@]"
(list_sep declaration (tag "@;"))
(List.map Location.unwrap p)

33
src/stages/ast_typed/PP.mli
View File

@ -1,33 +0,0 @@
open Types
open Format
val value : formatter -> annotated_expression -> unit
val type_value : formatter -> type_value -> unit
val single_record_patch : formatter -> ( string * ae ) -> unit
val program : formatter -> program -> unit
val expression : formatter -> expression -> unit
val literal : formatter -> literal -> unit
val annotated_expression : formatter -> annotated_expression -> unit
(*
val list_sep_d : ( formatter -> 'a -> unit ) -> formatter -> 'a list -> unit
val smap_sep_d : ( formatter -> 'a -> unit ) -> formatter -> 'a Map.String.t -> unit
val lambda : formatter -> lambda -> unit
val assoc_annotated_expression : formatter -> (ae * ae) -> unit
val matching_variant_case : ( formatter -> 'a -> unit ) -> formatter -> ( T.constructor_name * name ) * 'a -> unit
val matching : ( formatter -> 'a -> unit ) -> formatter -> 'a matching -> unit
val pre_access : formatter -> access -> unit
val declaration : formatter -> declaration -> unit
*)

258
src/stages/ast_typed/combinators.ml
View File

@ -13,7 +13,7 @@ module Errors = struct
let message () =
Format.asprintf "Expected the type %s but got the type %a"
expected_type
PP.type_value actual_type in
PP.type_expression actual_type in
error (thunk "Expected a different type") message
let declaration_not_found expected_declaration () =
@ -23,177 +23,182 @@ module Errors = struct
error (thunk "No declaration with the given name") message
end
let make_t type_value' simplified = { type_value' ; simplified }
let make_a_e ?(location = Location.generated) expression type_annotation environment = {
expression ;
type_annotation ;
let make_t type_content simplified = { type_content ; type_meta=simplified }
let make_a_e ?(location = Location.generated) expression_content type_expression environment = {
expression_content ;
type_expression ;
environment ;
location ;
}
let make_n_e name a_e = { name ; annotated_expression = a_e }
let make_n_t type_name type_value = { type_name ; type_value }
let t_signature ?s () : type_value = make_t (T_constant TC_signature) s
let t_chain_id ?s () : type_value = make_t (T_constant TC_chain_id) s
let t_bool ?s () : type_value = make_t (T_constant TC_bool) s
let t_string ?s () : type_value = make_t (T_constant TC_string) s
let t_bytes ?s () : type_value = make_t (T_constant TC_bytes) s
let t_key ?s () : type_value = make_t (T_constant TC_key) s
let t_key_hash ?s () : type_value = make_t (T_constant TC_key_hash) s
let t_int ?s () : type_value = make_t (T_constant TC_int) s
let t_address ?s () : type_value = make_t (T_constant TC_address) s
let t_operation ?s () : type_value = make_t (T_constant TC_operation) s
let t_nat ?s () : type_value = make_t (T_constant TC_nat) s
let t_mutez ?s () : type_value = make_t (T_constant TC_mutez) s
let t_timestamp ?s () : type_value = make_t (T_constant TC_timestamp) s
let t_unit ?s () : type_value = make_t (T_constant TC_unit) s
let t_option o ?s () : type_value = make_t (T_operator (TC_option o)) s
let t_tuple lst ?s () : type_value = make_t (T_operator (TC_tuple lst)) s
let t_variable t ?s () : type_value = make_t (T_variable t) s
let t_list t ?s () : type_value = make_t (T_operator (TC_list t)) s
let t_set t ?s () : type_value = make_t (T_operator (TC_set t)) s
let t_contract t ?s () : type_value = make_t (T_operator (TC_contract t)) s
let t_pair a b ?s () : type_value = t_tuple [a ; b] ?s ()
let t_signature ?s () : type_expression = make_t (T_constant TC_signature) s
let t_chain_id ?s () : type_expression = make_t (T_constant TC_chain_id) s
let t_bool ?s () : type_expression = make_t (T_constant TC_bool) s
let t_string ?s () : type_expression = make_t (T_constant TC_string) s
let t_bytes ?s () : type_expression = make_t (T_constant TC_bytes) s
let t_key ?s () : type_expression = make_t (T_constant TC_key) s
let t_key_hash ?s () : type_expression = make_t (T_constant TC_key_hash) s
let t_int ?s () : type_expression = make_t (T_constant TC_int) s
let t_address ?s () : type_expression = make_t (T_constant TC_address) s
let t_operation ?s () : type_expression = make_t (T_constant TC_operation) s
let t_nat ?s () : type_expression = make_t (T_constant TC_nat) s
let t_mutez ?s () : type_expression = make_t (T_constant TC_mutez) s
let t_timestamp ?s () : type_expression = make_t (T_constant TC_timestamp) s
let t_unit ?s () : type_expression = make_t (T_constant TC_unit) s
let t_option o ?s () : type_expression = make_t (T_operator (TC_option o)) s
let t_variable t ?s () : type_expression = make_t (T_variable t) s
let t_list t ?s () : type_expression = make_t (T_operator (TC_list t)) s
let t_set t ?s () : type_expression = make_t (T_operator (TC_set t)) s
let t_contract t ?s () : type_expression = make_t (T_operator (TC_contract t)) s
let t_record m ?s () : type_value = make_t (T_record m) s
let make_t_ez_record (lst:(label * type_value) list) : type_value =
let aux prev (k, v) = LMap.add k v prev in
let map = List.fold_left aux LMap.empty lst in
let t_record m ?s () : type_expression = make_t (T_record m) s
let make_t_ez_record (lst:(string * type_expression) list) : type_expression =
let lst = List.map (fun (x,y) -> (Label x, y) ) lst in
let map = LMap.of_list lst in
make_t (T_record map) None
let ez_t_record lst ?s () : type_value =
let ez_t_record lst ?s () : type_expression =
let m = LMap.of_list lst in
t_record m ?s ()
let t_pair a b ?s () : type_expression = ez_t_record [(Label "0",a) ; (Label "1",b)] ?s ()
let t_map key value ?s () = make_t (T_operator (TC_map (key , value))) s
let t_big_map key value ?s () = make_t (T_operator (TC_big_map (key , value))) s
let t_sum m ?s () : type_value = make_t (T_sum m) s
let make_t_ez_sum (lst:(constructor * type_value) list) : type_value =
let t_sum m ?s () : type_expression = make_t (T_sum m) s
let make_t_ez_sum (lst:(constructor' * type_expression) list) : type_expression =
let aux prev (k, v) = CMap.add k v prev in
let map = List.fold_left aux CMap.empty lst in
make_t (T_sum map) None
let t_function param result ?s () : type_value = make_t (T_arrow (param, result)) s
let t_shallow_closure param result ?s () : type_value = make_t (T_arrow (param, result)) s
let t_function param result ?s () : type_expression = make_t (T_arrow {type1=param; type2=result}) s
let t_shallow_closure param result ?s () : type_expression = make_t (T_arrow {type1=param; type2=result}) s
let get_type_annotation (x:annotated_expression) = x.type_annotation
let get_type' (x:type_value) = x.type_value'
let get_environment (x:annotated_expression) = x.environment
let get_expression (x:annotated_expression) = x.expression
let get_type_expression (x:expression) = x.type_expression
let get_type' (x:type_expression) = x.type_content
let get_environment (x:expression) = x.environment
let get_expression (x:expression) = x.expression_content
let get_lambda e : _ result = match e with
let get_lambda e : _ result = match e.expression_content with
| E_lambda l -> ok l
| _ -> fail @@ Errors.not_a_x_expression "lambda" e ()
let get_lambda_with_type e =
match (e.expression , e.type_annotation.type_value') with
| E_lambda l , T_arrow (i,o) -> ok (l , (i,o))
| _ -> fail @@ Errors.not_a_x_expression "lambda with functional type" e.expression ()
match (e.expression_content , e.type_expression.type_content) with
| E_lambda l , T_arrow {type1;type2} -> ok (l , (type1,type2))
| _ -> simple_fail "not a lambda with functional type"
let get_t_bool (t:type_value) : unit result = match t.type_value' with
let get_t_bool (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_bool) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "bool" t ()
let get_t_int (t:type_value) : unit result = match t.type_value' with
let get_t_int (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_int) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "int" t ()
let get_t_nat (t:type_value) : unit result = match t.type_value' with
let get_t_nat (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_nat) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "nat" t ()
let get_t_unit (t:type_value) : unit result = match t.type_value' with
let get_t_unit (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_unit) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "unit" t ()
let get_t_mutez (t:type_value) : unit result = match t.type_value' with
let get_t_mutez (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_mutez) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "tez" t ()
let get_t_bytes (t:type_value) : unit result = match t.type_value' with
let get_t_bytes (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_bytes) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "bytes" t ()
let get_t_string (t:type_value) : unit result = match t.type_value' with
let get_t_string (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_string) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "string" t ()
let get_t_contract (t:type_value) : type_value result = match t.type_value' with
let get_t_contract (t:type_expression) : type_expression result = match t.type_content with
| T_operator (TC_contract x) -> ok x
| _ -> fail @@ Errors.not_a_x_type "contract" t ()
let get_t_option (t:type_value) : type_value result = match t.type_value' with
let get_t_option (t:type_expression) : type_expression result = match t.type_content with
| T_operator (TC_option o) -> ok o
| _ -> fail @@ Errors.not_a_x_type "option" t ()
let get_t_list (t:type_value) : type_value result = match t.type_value' with
let get_t_list (t:type_expression) : type_expression result = match t.type_content with
| T_operator (TC_list l) -> ok l
| _ -> fail @@ Errors.not_a_x_type "list" t ()
let get_t_set (t:type_value) : type_value result = match t.type_value' with
let get_t_set (t:type_expression) : type_expression result = match t.type_content with
| T_operator (TC_set s) -> ok s
| _ -> fail @@ Errors.not_a_x_type "set" t ()
let get_t_key (t:type_value) : unit result = match t.type_value' with
let get_t_key (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_key) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "key" t ()
let get_t_signature (t:type_value) : unit result = match t.type_value' with
let get_t_signature (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_signature) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "signature" t ()
let get_t_key_hash (t:type_value) : unit result = match t.type_value' with
let get_t_key_hash (t:type_expression) : unit result = match t.type_content with
| T_constant (TC_key_hash) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "key_hash" t ()
let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with
| T_operator (TC_tuple lst) -> ok lst
let tuple_of_record (m: _ LMap.t) =
let aux i =
let opt = LMap.find_opt (Label (string_of_int i)) m in
Option.bind (fun opt -> Some (opt,i+1)) opt
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
let get_t_tuple (t:type_expression) : type_expression list result = match t.type_content with
| T_record lst -> ok @@ tuple_of_record lst
| _ -> fail @@ Errors.not_a_x_type "tuple" t ()
let get_t_pair (t:type_value) : (type_value * type_value) result = match t.type_value' with
| T_operator (TC_tuple lst) ->
let get_t_pair (t:type_expression) : (type_expression * type_expression) result = match t.type_content with
| T_record m ->
let lst = tuple_of_record m in
let%bind () =
trace_strong (Errors.not_a_x_type "pair (tuple with two elements)" t ()) @@
Assert.assert_list_size lst 2 in
ok List.(nth lst 0 , nth lst 1)
| _ -> fail @@ Errors.not_a_x_type "pair (tuple with two elements)" t ()
let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with
| T_arrow (a,r) -> ok (a,r)
| T_operator (TC_arrow (a , b)) -> ok (a , b)
| _ -> fail @@ Errors.not_a_x_type "function" t ()
let get_t_function (t:type_expression) : (type_expression * type_expression) result = match t.type_content with
| T_arrow {type1;type2} -> ok (type1,type2)
| _ -> simple_fail "not a function"
let get_t_sum (t:type_value) : type_value constructor_map result = match t.type_value' with
let get_t_sum (t:type_expression) : type_expression constructor_map result = match t.type_content with
| T_sum m -> ok m
| _ -> fail @@ Errors.not_a_x_type "sum" t ()
let get_t_record (t:type_value) : type_value label_map result = match t.type_value' with
let get_t_record (t:type_expression) : type_expression label_map result = match t.type_content with
| T_record m -> ok m
| _ -> fail @@ Errors.not_a_x_type "record" t ()
let get_t_map (t:type_value) : (type_value * type_value) result =
match t.type_value' with
let get_t_map (t:type_expression) : (type_expression * type_expression) result =
match t.type_content with
| T_operator (TC_map (k,v)) -> ok (k, v)
| _ -> fail @@ Errors.not_a_x_type "map" t ()
let get_t_big_map (t:type_value) : (type_value * type_value) result =
match t.type_value' with
let get_t_big_map (t:type_expression) : (type_expression * type_expression) result =
match t.type_content with
| T_operator (TC_big_map (k,v)) -> ok (k, v)
| _ -> fail @@ Errors.not_a_x_type "big_map" t ()
let get_t_map_key : type_value -> type_value result = fun t ->
let get_t_map_key : type_expression -> type_expression result = fun t ->
let%bind (key , _) = get_t_map t in
ok key
let get_t_map_value : type_value -> type_value result = fun t ->
let get_t_map_value : type_expression -> type_expression result = fun t ->
let%bind (_ , value) = get_t_map t in
ok value
let get_t_big_map_key : type_value -> type_value result = fun t ->
let get_t_big_map_key : type_expression -> type_expression result = fun t ->
let%bind (key , _) = get_t_big_map t in
ok key
let get_t_big_map_value : type_value -> type_value result = fun t ->
let get_t_big_map_value : type_expression -> type_expression result = fun t ->
let%bind (_ , value) = get_t_big_map t in
ok value
@ -204,12 +209,12 @@ let assert_t_map = fun t ->
let is_t_map = Function.compose to_bool get_t_map
let is_t_big_map = Function.compose to_bool get_t_big_map
let assert_t_mutez : type_value -> unit result = get_t_mutez
let assert_t_mutez : type_expression -> unit result = get_t_mutez
let assert_t_key = get_t_key
let assert_t_signature = get_t_signature
let assert_t_key_hash = get_t_key_hash
let assert_t_contract (t:type_value) : unit result = match t.type_value' with
let assert_t_contract (t:type_expression) : unit result = match t.type_content with
| T_operator (TC_contract _) -> ok ()
| _ -> simple_fail "not a contract"
@ -228,57 +233,56 @@ let assert_t_bytes = fun t ->
let%bind _ = get_t_bytes t in
ok ()
let assert_t_operation (t:type_value) : unit result =
match t.type_value' with
let assert_t_operation (t:type_expression) : unit result =
match t.type_content with
| T_constant (TC_operation) -> ok ()
| _ -> simple_fail "assert: not an operation"
let assert_t_list_operation (t : type_value) : unit result =
let assert_t_list_operation (t : type_expression) : unit result =
let%bind t' = get_t_list t in
assert_t_operation t'
let assert_t_int : type_value -> unit result = fun t -> match t.type_value' with
let assert_t_int : type_expression -> unit result = fun t -> match t.type_content with
| T_constant (TC_int) -> ok ()
| _ -> simple_fail "not an int"
let assert_t_nat : type_value -> unit result = fun t -> match t.type_value' with
let assert_t_nat : type_expression -> unit result = fun t -> match t.type_content with
| T_constant (TC_nat) -> ok ()
| _ -> simple_fail "not an nat"
let assert_t_bool : type_value -> unit result = fun v -> get_t_bool v
let assert_t_unit : type_value -> unit result = fun v -> get_t_unit v
let assert_t_bool : type_expression -> unit result = fun v -> get_t_bool v
let assert_t_unit : type_expression -> unit result = fun v -> get_t_unit v
let e_record map : expression = E_record map
let ez_e_record (lst : (label * ae) list) : expression =
let e_record map : expression_content = E_record map
let ez_e_record (lst : (label * expression) list) : expression_content =
let aux prev (k, v) = LMap.add k v prev in
let map = List.fold_left aux LMap.empty lst in
e_record map
let e_some s : expression = E_constant (C_SOME, [s])
let e_none () : expression = E_constant (C_NONE, [])
let e_some s : expression_content = E_constant {cons_name=C_SOME;arguments=[s]}
let e_none (): expression_content = E_constant {cons_name=C_NONE; arguments=[]}
let e_map lst : expression = E_map lst
let e_map lst : expression_content = E_map lst
let e_unit () : expression = E_literal (Literal_unit)
let e_int n : expression = E_literal (Literal_int n)
let e_nat n : expression = E_literal (Literal_nat n)
let e_mutez n : expression = E_literal (Literal_mutez n)
let e_bool b : expression = E_literal (Literal_bool b)
let e_string s : expression = E_literal (Literal_string s)
let e_bytes s : expression = E_literal (Literal_bytes s)
let e_timestamp s : expression = E_literal (Literal_timestamp s)
let e_address s : expression = E_literal (Literal_address s)
let e_signature s : expression = E_literal (Literal_signature s)
let e_key s : expression = E_literal (Literal_key s)
let e_key_hash s : expression = E_literal (Literal_key_hash s)
let e_chain_id s : expression = E_literal (Literal_chain_id s)
let e_operation s : expression = E_literal (Literal_operation s)
let e_lambda l : expression = E_lambda l
let e_pair a b : expression = E_tuple [a; b]
let e_application a b : expression = E_application (a , b)
let e_variable v : expression = E_variable v
let e_list lst : expression = E_list lst
let e_let_in binder inline rhs result = E_let_in { binder ; rhs ; result; inline }
let e_tuple lst : expression = E_tuple lst
let e_unit () : expression_content = E_literal (Literal_unit)
let e_int n : expression_content = E_literal (Literal_int n)
let e_nat n : expression_content = E_literal (Literal_nat n)
let e_mutez n : expression_content = E_literal (Literal_mutez n)
let e_bool b : expression_content = E_literal (Literal_bool b)
let e_string s : expression_content = E_literal (Literal_string s)
let e_bytes s : expression_content = E_literal (Literal_bytes s)
let e_timestamp s : expression_content = E_literal (Literal_timestamp s)
let e_address s : expression_content = E_literal (Literal_address s)
let e_signature s : expression_content = E_literal (Literal_signature s)
let e_key s : expression_content = E_literal (Literal_key s)
let e_key_hash s : expression_content = E_literal (Literal_key_hash s)
let e_chain_id s : expression_content = E_literal (Literal_chain_id s)
let e_operation s : expression_content = E_literal (Literal_operation s)
let e_lambda l : expression_content = E_lambda l
let e_pair a b : expression_content = ez_e_record [(Label "0",a);(Label "1", b)]
let e_application expr1 expr2 : expression_content = E_application {expr1;expr2}
let e_variable v : expression_content = E_variable v
let e_list lst : expression_content = E_list lst
let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; let_result; inline }
let e_a_unit = make_a_e (e_unit ()) (t_unit ())
let e_a_int n = make_a_e (e_int n) (t_int ())
@ -287,44 +291,44 @@ let e_a_mutez n = make_a_e (e_mutez n) (t_mutez ())
let e_a_bool b = make_a_e (e_bool b) (t_bool ())
let e_a_string s = make_a_e (e_string s) (t_string ())
let e_a_address s = make_a_e (e_address s) (t_address ())
let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_annotation b.type_annotation ())
let e_a_some s = make_a_e (e_some s) (t_option s.type_annotation ())
let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_expression b.type_expression ())
let e_a_some s = make_a_e (e_some s) (t_option s.type_expression ())
let e_a_lambda l in_ty out_ty = make_a_e (e_lambda l) (t_function in_ty out_ty ())
let e_a_none t = make_a_e (e_none ()) (t_option t ())
let e_a_tuple lst = make_a_e (E_tuple lst) (t_tuple (List.map get_type_annotation lst) ())
let e_a_record r = make_a_e (e_record r) (t_record (LMap.map get_type_annotation r) ())
let e_a_application a b = make_a_e (e_application a b) (get_type_annotation b)
let e_a_record r = make_a_e (e_record r) (t_record (LMap.map get_type_expression r) ())
let e_a_application a b = make_a_e (e_application a b) (get_type_expression b)
let e_a_variable v ty = make_a_e (e_variable v) ty
let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_annotation) r) ())
let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_expression) r) ())
let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ())
let e_a_list lst t = make_a_e (e_list lst) (t_list t ())
let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_annotation body)
let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_expression body)
let get_a_int (t:annotated_expression) =
match t.expression with
let get_a_int (t:expression) =
match t.expression_content with
| E_literal (Literal_int n) -> ok n
| _ -> simple_fail "not an int"
let get_a_unit (t:annotated_expression) =
match t.expression with
let get_a_unit (t:expression) =
match t.expression_content with
| E_literal (Literal_unit) -> ok ()
| _ -> simple_fail "not a unit"
let get_a_bool (t:annotated_expression) =
match t.expression with
let get_a_bool (t:expression) =
match t.expression_content with
| E_literal (Literal_bool b) -> ok b
| _ -> simple_fail "not a bool"
let get_a_record_accessor = fun t ->
match t.expression with
| E_record_accessor (a , b) -> ok (a , b)
match t.expression_content with
| E_record_accessor {expr ; label} -> ok (expr , label)
| _ -> simple_fail "not an accessor"
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration ->
match declaration with
| Declaration_constant (d , _, _) -> d.name = Var.of_name name
| Declaration_constant (d, _, _, _) -> d = Var.of_name name
in
trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p

267
src/stages/ast_typed/combinators.mli
View File

@ -1,162 +1,155 @@
open Trace
open Types
open Stage_common.Types
val make_n_e : expression_variable -> annotated_expression -> named_expression
val make_n_t : expression_variable -> type_value -> named_type_value
val make_t : type_value' -> S.type_expression option -> type_value
val make_a_e : ?location:Location.t -> expression -> type_value -> full_environment -> annotated_expression
val make_n_t : type_variable -> type_expression -> named_type_content
val make_t : type_content -> S.type_expression option -> type_expression
val make_a_e : ?location:Location.t -> expression_content -> type_expression -> full_environment -> expression
val t_bool : ?s:S.type_expression -> unit -> type_value
val t_string : ?s:S.type_expression -> unit -> type_value
val t_bytes : ?s:S.type_expression -> unit -> type_value
val t_key : ?s:S.type_expression -> unit -> type_value
val t_key_hash : ?s:S.type_expression -> unit -> type_value
val t_operation : ?s:S.type_expression -> unit -> type_value
val t_timestamp : ?s:S.type_expression -> unit -> type_value
val t_set : type_value -> ?s:S.type_expression -> unit -> type_value
val t_contract : type_value -> ?s:S.type_expression -> unit -> type_value
val t_int : ?s:S.type_expression -> unit -> type_value
val t_nat : ?s:S.type_expression -> unit -> type_value
val t_mutez : ?s:S.type_expression -> unit -> type_value
val t_address : ?s:S.type_expression -> unit -> type_value
val t_chain_id : ?s:S.type_expression -> unit -> type_value
val t_signature : ?s:S.type_expression -> unit -> type_value
val t_unit : ?s:S.type_expression -> unit -> type_value
val t_option : type_value -> ?s:S.type_expression -> unit -> type_value
val t_pair : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val t_list : type_value -> ?s:S.type_expression -> unit -> type_value
val t_tuple : type_value list -> ?s:S.type_expression -> unit -> type_value
val t_variable : type_variable -> ?s:S.type_expression -> unit -> type_value
val t_record : type_value label_map -> ?s:S.type_expression -> unit -> type_value
val make_t_ez_record : (label* type_value) list -> type_value
(*
val ez_t_record : ( string * type_value ) list -> ?s:S.type_expression -> unit -> type_value
*)
val t_bool : ?s:S.type_expression -> unit -> type_expression
val t_string : ?s:S.type_expression -> unit -> type_expression
val t_bytes : ?s:S.type_expression -> unit -> type_expression
val t_key : ?s:S.type_expression -> unit -> type_expression
val t_key_hash : ?s:S.type_expression -> unit -> type_expression
val t_operation : ?s:S.type_expression -> unit -> type_expression
val t_timestamp : ?s:S.type_expression -> unit -> type_expression
val t_set : type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_contract : type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_int : ?s:S.type_expression -> unit -> type_expression
val t_nat : ?s:S.type_expression -> unit -> type_expression
val t_mutez : ?s:S.type_expression -> unit -> type_expression
val t_address : ?s:S.type_expression -> unit -> type_expression
val t_chain_id : ?s:S.type_expression -> unit -> type_expression
val t_signature : ?s:S.type_expression -> unit -> type_expression
val t_unit : ?s:S.type_expression -> unit -> type_expression
val t_option : type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_pair : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_list : type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_variable : type_variable -> ?s:S.type_expression -> unit -> type_expression
val t_record : type_expression label_map -> ?s:S.type_expression -> unit -> type_expression
val make_t_ez_record : (string* type_expression) list -> type_expression
val ez_t_record : ( label * type_expression ) list -> ?s:S.type_expression -> unit -> type_expression
val t_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val t_big_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val t_sum : type_value constructor_map -> ?s:S.type_expression -> unit -> type_value
val make_t_ez_sum : ( constructor * type_value ) list -> type_value
val t_function : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val t_shallow_closure : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value
val get_type_annotation : annotated_expression -> type_value
val get_type' : type_value -> type_value'
val get_environment : annotated_expression -> full_environment
val get_expression : annotated_expression -> expression
val t_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_sum : type_expression constructor_map -> ?s:S.type_expression -> unit -> type_expression
val make_t_ez_sum : ( constructor' * type_expression ) list -> type_expression
val t_function : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_shallow_closure : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val get_type_expression : expression -> type_expression
val get_type' : type_expression -> type_content
val get_environment : expression -> full_environment
val get_expression : expression -> expression_content
val get_lambda : expression -> lambda result
val get_lambda_with_type : annotated_expression -> (lambda * ( type_value * type_value) ) result
val get_t_bool : type_value -> unit result
val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression) ) result
val get_t_bool : type_expression -> unit result
(*
val get_t_int : type_value -> unit result
val get_t_nat : type_value -> unit result
val get_t_unit : type_value -> unit result
val get_t_mutez : type_value -> unit result
val get_t_bytes : type_value -> unit result
val get_t_string : type_value -> unit result
val get_t_int : type_expression -> unit result
val get_t_nat : type_expression -> unit result
val get_t_unit : type_expression -> unit result
val get_t_mutez : type_expression -> unit result
val get_t_bytes : type_expression -> unit result
val get_t_string : type_expression -> unit result
*)
val get_t_contract : type_value -> type_value result
val get_t_option : type_value -> type_value result
val get_t_list : type_value -> type_value result
val get_t_set : type_value -> type_value result
val get_t_contract : type_expression -> type_expression result
val get_t_option : type_expression -> type_expression result
val get_t_list : type_expression -> type_expression result
val get_t_set : type_expression -> type_expression result
(*
val get_t_key : type_value -> unit result
val get_t_signature : type_value -> unit result
val get_t_key_hash : type_value -> unit result
val get_t_key : type_expression -> unit result
val get_t_signature : type_expression -> unit result
val get_t_key_hash : type_expression -> unit result
*)
val get_t_tuple : type_value -> type_value list result
val get_t_pair : type_value -> ( type_value * type_value ) result
val get_t_function : type_value -> ( type_value * type_value ) result
val get_t_sum : type_value -> type_value constructor_map result
val get_t_record : type_value -> type_value label_map result
val get_t_map : type_value -> ( type_value * type_value ) result
val get_t_big_map : type_value -> ( type_value * type_value ) result
val get_t_map_key : type_value -> type_value result
val get_t_map_value : type_value -> type_value result
val get_t_big_map_key : type_value -> type_value result
val get_t_big_map_value : type_value -> type_value result
val get_t_tuple : type_expression -> type_expression list result
val get_t_pair : type_expression -> ( type_expression * type_expression ) result
val get_t_function : type_expression -> ( type_expression * type_expression ) result
val get_t_sum : type_expression -> type_expression constructor_map result
val get_t_record : type_expression -> type_expression label_map result
val get_t_map : type_expression -> ( type_expression * type_expression ) result
val get_t_big_map : type_expression -> ( type_expression * type_expression ) result
val get_t_map_key : type_expression -> type_expression result
val get_t_map_value : type_expression -> type_expression result
val get_t_big_map_key : type_expression -> type_expression result
val get_t_big_map_value : type_expression -> type_expression result
val assert_t_map : type_value -> unit result
val assert_t_map : type_expression -> unit result
val is_t_map : type_value -> bool
val is_t_big_map : type_value -> bool
val is_t_map : type_expression -> bool
val is_t_big_map : type_expression -> bool
val assert_t_mutez : type_value -> unit result
val assert_t_key : type_value -> unit result
val assert_t_signature : type_value -> unit result
val assert_t_key_hash : type_value -> unit result
val assert_t_mutez : type_expression -> unit result
val assert_t_key : type_expression -> unit result
val assert_t_signature : type_expression -> unit result
val assert_t_key_hash : type_expression -> unit result
val assert_t_list : type_value -> unit result
val assert_t_list : type_expression -> unit result
val is_t_list : type_value -> bool
val is_t_set : type_value -> bool
val is_t_nat : type_value -> bool
val is_t_string : type_value -> bool
val is_t_bytes : type_value -> bool
val is_t_int : type_value -> bool
val is_t_list : type_expression -> bool
val is_t_set : type_expression -> bool
val is_t_nat : type_expression -> bool
val is_t_string : type_expression -> bool
val is_t_bytes : type_expression -> bool
val is_t_int : type_expression -> bool
val assert_t_bytes : type_value -> unit result
val assert_t_bytes : type_expression -> unit result
(*
val assert_t_operation : type_value -> unit result
val assert_t_operation : type_expression -> unit result
*)
val assert_t_list_operation : type_value -> unit result
val assert_t_int : type_value -> unit result
val assert_t_nat : type_value -> unit result
val assert_t_bool : type_value -> unit result
val assert_t_unit : type_value -> unit result
val assert_t_contract : type_value -> unit result
val assert_t_list_operation : type_expression -> unit result
val assert_t_int : type_expression -> unit result
val assert_t_nat : type_expression -> unit result
val assert_t_bool : type_expression -> unit result
val assert_t_unit : type_expression -> unit result
val assert_t_contract : type_expression -> unit result
(*
val e_record : ae_map -> expression
val ez_e_record : ( string * annotated_expression ) list -> expression
val ez_e_record : ( string * expression ) list -> expression
*)
val e_some : value -> expression
val e_none : unit -> expression
val e_map : ( value * value ) list -> expression
val e_unit : unit -> expression
val e_int : int -> expression
val e_nat : int -> expression
val e_mutez : int -> expression
val e_bool : bool -> expression
val e_string : string -> expression
val e_bytes : bytes -> expression
val e_timestamp : int -> expression
val e_address : string -> expression
val e_signature : string -> expression
val e_key : string -> expression
val e_key_hash : string -> expression
val e_chain_id : string -> expression
val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression
val e_lambda : lambda -> expression
val e_pair : value -> value -> expression
val e_application : value -> value -> expression
val e_variable : expression_variable -> expression
val e_list : value list -> expression
val e_let_in : expression_variable -> inline -> value -> value -> expression
val e_tuple : value list -> expression
val e_some : expression -> expression_content
val e_none : unit -> expression_content
val e_map : ( expression * expression ) list -> expression_content
val e_unit : unit -> expression_content
val e_int : int -> expression_content
val e_nat : int -> expression_content
val e_mutez : int -> expression_content
val e_bool : bool -> expression_content
val e_string : string -> expression_content
val e_bytes : bytes -> expression_content
val e_timestamp : int -> expression_content
val e_address : string -> expression_content
val e_signature : string -> expression_content
val e_key : string -> expression_content
val e_key_hash : string -> expression_content
val e_chain_id : string -> expression_content
val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression_content
val e_lambda : lambda -> expression_content
val e_pair : expression -> expression -> expression_content
val e_application : expression -> expr -> expression_content
val e_variable : expression_variable -> expression_content
val e_list : expression list -> expression_content
val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
val e_a_unit : full_environment -> annotated_expression
val e_a_int : int -> full_environment -> annotated_expression
val e_a_nat : int -> full_environment -> annotated_expression
val e_a_mutez : int -> full_environment -> annotated_expression
val e_a_bool : bool -> full_environment -> annotated_expression
val e_a_string : string -> full_environment -> annotated_expression
val e_a_address : string -> full_environment -> annotated_expression
val e_a_pair : annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val e_a_some : annotated_expression -> full_environment -> annotated_expression
val e_a_lambda : lambda -> type_value -> type_value -> full_environment -> annotated_expression
val e_a_none : type_value -> full_environment -> annotated_expression
val e_a_tuple : annotated_expression list -> full_environment -> annotated_expression
val e_a_record : annotated_expression label_map -> full_environment -> annotated_expression
val e_a_application : annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val e_a_variable : expression_variable -> type_value -> full_environment -> annotated_expression
val ez_e_a_record : ( label * annotated_expression ) list -> full_environment -> annotated_expression
val e_a_map : ( annotated_expression * annotated_expression ) list -> type_value -> type_value -> full_environment -> annotated_expression
val e_a_list : annotated_expression list -> type_value -> full_environment -> annotated_expression
val e_a_let_in : expression_variable -> inline -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val e_a_unit : full_environment -> expression
val e_a_int : int -> full_environment -> expression
val e_a_nat : int -> full_environment -> expression
val e_a_mutez : int -> full_environment -> expression
val e_a_bool : bool -> full_environment -> expression
val e_a_string : string -> full_environment -> expression
val e_a_address : string -> full_environment -> expression
val e_a_pair : expression -> expression -> full_environment -> expression
val e_a_some : expression -> full_environment -> expression
val e_a_lambda : lambda -> type_expression -> type_expression -> full_environment -> expression
val e_a_none : type_expression -> full_environment -> expression
val e_a_record : expression label_map -> full_environment -> expression
val e_a_application : expression -> expression -> full_environment -> expression
val e_a_variable : expression_variable -> type_expression -> full_environment -> expression
val ez_e_a_record : ( label * expression ) list -> full_environment -> expression
val e_a_map : ( expression * expression ) list -> type_expression -> type_expression -> full_environment -> expression
val e_a_list : expression list -> type_expression -> full_environment -> expression
val e_a_let_in : expression_variable -> bool -> expression -> expression -> full_environment -> expression
val get_a_int : annotated_expression -> int result
val get_a_unit : annotated_expression -> unit result
val get_a_bool : annotated_expression -> bool result
val get_a_record_accessor : annotated_expression -> (annotated_expression * label) result
val get_a_int : expression -> int result
val get_a_unit : expression -> unit result
val get_a_bool : expression -> bool result
val get_a_record_accessor : expression -> (expression * label) result
val get_declaration_by_name : program -> string -> declaration result

3
src/stages/ast_typed/combinators_environment.ml
View File

@ -13,7 +13,6 @@ let e_a_empty_address s = e_a_address s Environment.full_empty
let e_a_empty_pair a b = e_a_pair a b Environment.full_empty
let e_a_empty_some s = e_a_some s Environment.full_empty
let e_a_empty_none t = e_a_none t Environment.full_empty
let e_a_empty_tuple lst = e_a_tuple lst Environment.full_empty
let e_a_empty_record r = e_a_record r Environment.full_empty
let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty
let e_a_empty_list lst t = e_a_list lst t Environment.full_empty
@ -24,5 +23,5 @@ open Environment
let env_sum_type ?(env = full_empty)
?(type_name = Var.of_name "a_sum_type")
(lst : (constructor * type_value) list) =
(lst : (constructor' * type_expression) list) =
add_type type_name (make_t_ez_sum lst) env

35
src/stages/ast_typed/combinators_environment.mli
View File

@ -1,22 +1,21 @@
open Types
val make_a_e_empty : expression -> type_value -> annotated_expression
val make_a_e_empty : expression_content -> type_expression -> expression
val e_a_empty_unit : annotated_expression
val e_a_empty_int : int -> annotated_expression
val e_a_empty_nat : int -> annotated_expression
val e_a_empty_mutez : int -> annotated_expression
val e_a_empty_bool : bool -> annotated_expression
val e_a_empty_string : string -> annotated_expression
val e_a_empty_address : string -> annotated_expression
val e_a_empty_pair : annotated_expression -> annotated_expression -> annotated_expression
val e_a_empty_some : annotated_expression -> annotated_expression
val e_a_empty_none : type_value -> annotated_expression
val e_a_empty_tuple : annotated_expression list -> annotated_expression
val e_a_empty_record : annotated_expression label_map -> annotated_expression
val e_a_empty_map : (annotated_expression * annotated_expression ) list -> type_value -> type_value -> annotated_expression
val e_a_empty_list : annotated_expression list -> type_value -> annotated_expression
val ez_e_a_empty_record : ( label * annotated_expression ) list -> annotated_expression
val e_a_empty_lambda : lambda -> type_value -> type_value -> annotated_expression
val e_a_empty_unit : expression
val e_a_empty_int : int -> expression
val e_a_empty_nat : int -> expression
val e_a_empty_mutez : int -> expression
val e_a_empty_bool : bool -> expression
val e_a_empty_string : string -> expression
val e_a_empty_address : string -> expression
val e_a_empty_pair : expression -> expression -> expression
val e_a_empty_some : expression -> expression
val e_a_empty_none : type_expression -> expression
val e_a_empty_record : expression label_map -> expression
val e_a_empty_map : (expression * expression ) list -> type_expression -> type_expression -> expression
val e_a_empty_list : expression list -> type_expression -> expression
val ez_e_a_empty_record : ( label * expression ) list -> expression
val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression
val env_sum_type : ?env:full_environment -> ?type_name:type_variable -> (constructor * type_value) list -> full_environment
val env_sum_type : ?env:full_environment -> ?type_name:type_variable -> (constructor' * type_expression) list -> full_environment

32
src/stages/ast_typed/environment.ml
View File

@ -1,15 +1,14 @@
open Types
open Stage_common.Types
open Combinators
type element = environment_element
let make_element : type_value -> full_environment -> environment_element_definition -> element =
let make_element : type_expression -> full_environment -> environment_element_definition -> element =
fun type_value source_environment definition -> {type_value ; source_environment ; definition}
let make_element_binder = fun t s -> make_element t s ED_binder
let make_element_declaration = fun s (ae : annotated_expression) ->
let free_variables = Misc.Free_variables.(annotated_expression empty ae) in
make_element (get_type_annotation ae) s (ED_declaration (ae , free_variables))
let make_element_declaration = fun s (ae : expression) ->
let free_variables = Misc.Free_variables.(expression empty ae) in
make_element (get_type_expression ae) s (ED_declaration (ae , free_variables))
module Small = struct
type t = small_environment
@ -22,28 +21,28 @@ module Small = struct
let map_type_environment : _ -> t -> t = fun f (a , b) -> (a , f b)
let add : expression_variable -> element -> t -> t = fun k v -> map_environment (fun x -> (k , v) :: x)
let add_type : type_variable -> type_value -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x)
let add_type : type_variable -> type_expression -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x)
let get_opt : expression_variable -> t -> element option = fun k x -> List.assoc_opt k (get_environment x)
let get_type_opt : type_variable -> t -> type_value option = fun k x -> List.assoc_opt k (get_type_environment x)
let get_type_opt : type_variable -> t -> type_expression option = fun k x -> List.assoc_opt k (get_type_environment x)
end
type t = full_environment
let empty : environment = Small.(get_environment empty)
let full_empty : t = List.Ne.singleton Small.empty
let add : expression_variable -> element -> t -> t = fun k v -> List.Ne.hd_map (Small.add k v)
let add_ez_binder : expression_variable -> type_value -> t -> t = fun k v e ->
let add_ez_binder : expression_variable -> type_expression -> t -> t = fun k v e ->
List.Ne.hd_map (Small.add k (make_element_binder v e)) e
let add_ez_declaration : expression_variable -> annotated_expression -> t -> t = fun k ae e ->
let add_ez_declaration : expression_variable -> expression -> t -> t = fun k ae e ->
List.Ne.hd_map (Small.add k (make_element_declaration e ae)) e
let add_ez_ae = add_ez_declaration
let add_type : type_variable -> type_value -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v)
let add_type : type_variable -> type_expression -> t -> t = fun k v -> List.Ne.hd_map (Small.add_type k v)
let get_opt : expression_variable -> t -> element option = fun k x -> List.Ne.find_map (Small.get_opt k) x
let get_type_opt : type_variable -> t -> type_value option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x
let get_type_opt : type_variable -> t -> type_expression option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x
let get_constructor : constructor -> t -> (type_value * type_value) option = fun k x -> (* Left is the constructor, right is the sum type *)
let get_constructor : constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *)
let aux = fun x ->
let aux = fun (_type_name , x) ->
match x.type_value' with
match x.type_content with
| T_sum m ->
(match CMap.find_opt k m with
Some km -> Some (km , x)
@ -56,15 +55,16 @@ let get_constructor : constructor -> t -> (type_value * type_value) option = fun
module PP = struct
open Format
include PP
open PP_helpers
let list_sep_scope x = list_sep x (const " | ")
let environment_element = fun ppf (k , (ele : environment_element)) ->
fprintf ppf "%a -> %a" Stage_common.PP.name k PP.type_value ele.type_value
fprintf ppf "%a -> %a" PP.expression_variable k PP.type_expression ele.type_value
let type_environment_element = fun ppf (k , tv) ->
fprintf ppf "%a -> %a" Stage_common.PP.type_variable k PP.type_value tv
fprintf ppf "%a -> %a" PP.type_variable k PP.type_expression tv
let environment : _ -> environment -> unit = fun ppf lst ->
fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) lst
@ -87,6 +87,6 @@ open Trace
let get_trace : expression_variable -> t -> element result = fun s env ->
let error =
let title () = "missing var not in env" in
let content () = Format.asprintf "\nvar: %a\nenv: %a\n" Stage_common.PP.name s PP.full_environment env in
let content () = Format.asprintf "\nvar: %a\nenv: %a\n" PP. expression_variable s PP.full_environment env in
error title content in
trace_option error @@ get_opt s env

24
src/stages/ast_typed/environment.mli
View File

@ -8,13 +8,13 @@ val get_trace : expression_variable -> t -> element result
val empty : environment
val full_empty : t
val add : expression_variable -> element -> t -> t
val add_ez_binder : expression_variable -> type_value -> t -> t
val add_ez_declaration : expression_variable -> annotated_expression -> t -> t
val add_ez_ae : expression_variable -> annotated_expression -> t -> t
val add_type : type_variable -> type_value -> t -> t
val add_ez_binder : expression_variable -> type_expression -> t -> t
val add_ez_declaration : expression_variable -> expression -> t -> t
val add_ez_ae : expression_variable -> expression -> t -> t
val add_type : type_variable -> type_expression -> t -> t
val get_opt : expression_variable -> t -> element option
val get_type_opt : type_variable -> t -> type_value option
val get_constructor : constructor -> t -> (type_value * type_value) option
val get_type_opt : type_variable -> t -> type_expression option
val get_constructor : constructor' -> t -> (type_expression * type_expression) option
module Small : sig
type t = small_environment
@ -28,16 +28,16 @@ module Small : sig
val map_type_environment : ( type_environment -> type_environment ) -> t -> t
val add : string -> element -> t -> t
val add_type : string -> type_value -> t -> t
val add_type : string -> type_expression -> t -> t
val get_opt : string -> t -> element option
val get_type_opt : string -> t -> type_value option
val get_type_opt : string -> t -> type_expression option
*)
end
(*
val make_element : type_value -> full_environment -> environment_element_definition -> element
val make_element_binder : type_value -> full_environment -> element
val make_element_declaration : full_environment -> annotated_expression -> element
val make_element : type_expression -> full_environment -> environment_element_definition -> element
val make_element_binder : type_expression -> full_environment -> element
val make_element_declaration : full_environment -> expression -> element
*)
@ -50,7 +50,7 @@ module PP : sig
(*
val environment_element : formatter -> ( string * environment_element ) -> unit
val type_environment_element : formatter -> ( string * type_value ) -> unit
val type_environment_element : formatter -> ( string * type_expression ) -> unit
val environment : formatter -> environment -> unit

208
src/stages/ast_typed/misc.ml
View File

@ -1,15 +1,13 @@
open Trace
open Types
include Stage_common.Misc
module Errors = struct
let different_kinds a b () =
let title = (thunk "different kinds") in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_value b )
("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_expression b )
] in
error ~data title message ()
@ -17,16 +15,16 @@ module Errors = struct
let title = (thunk "different type constructors") in
let message () = "Expected these two constant type constructors to be the same, but they're different" in
let data = [
("a" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant a) ;
("b" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant b )
("a" , fun () -> Format.asprintf "%a" PP.type_constant a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_constant b )
] in
error ~data title message ()
let different_operators a b () =
let title = (thunk "different type constructors") in
let message () = "Expected these two n-ary type constructors to be the same, but they're different" in
let data = [
("a" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) a) ;
("b" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) b)
("a" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) a) ;
("b" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) b)
] in
error ~data title message ()
@ -37,44 +35,64 @@ module Errors = struct
"Expected these two n-ary type constructors to be the same, but they have different numbers of arguments (both use the %s type constructor, but they have %d and %d arguments, respectively)"
(type_operator_name opa) lena lenb in
let data = [
("a" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) opa) ;
("b" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) opb) ;
("a" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) opa) ;
("b" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) opb) ;
("op" , fun () -> type_operator_name opa) ;
("len_a" , fun () -> Format.asprintf "%d" lena) ;
("len_b" , fun () -> Format.asprintf "%d" lenb) ;
] in
error ~data title message ()
let different_size_type name a b () =
let title () = name ^ " have different sizes" in
let message () = "Expected these two types to be the same, but they're different (both are " ^ name ^ ", but with a different number of arguments)" in
let different_size_type names a b () =
let title () = names ^ " have different sizes" in
let message () = "Expected these two types to be the same, but they're different (both are " ^ names ^ ", but with a different number of arguments)" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_value b )
("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_expression b)
] in
error ~data title message ()
let different_props_in_record ka kb () =
let title () = "different keys in record" in
let different_props_in_record a b ra rb ka kb () =
let names () = if Stage_common.Helpers.is_tuple_lmap ra && Stage_common.Helpers.is_tuple_lmap rb then "tuples" else "records" in
let title () = "different keys in " ^ (names ()) in
let message () = "" in
let data = [
("key_a" , fun () -> Format.asprintf "%s" ka) ;
("key_b" , fun () -> Format.asprintf "%s" kb )
("key_b" , fun () -> Format.asprintf "%s" kb ) ;
("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_expression b ) ;
] in
error ~data title message ()
let different_kind_record_tuple a b ra rb () =
let name_a () = if Stage_common.Helpers.is_tuple_lmap ra then "tuple" else "record" in
let name_b () = if Stage_common.Helpers.is_tuple_lmap rb then "tuple" else "record" in
let title () = "different keys in " ^ (name_a ()) ^ " and " ^ (name_b ()) in
let message () = "Expected these two types to be the same, but they're different (one is a " ^ (name_a ()) ^ " and the other is a " ^ (name_b ()) ^ ")" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_expression b ) ;
] in
error ~data title message ()
let _different_size_constants = different_size_type "type constructors"
let different_size_sums = different_size_type "sums"
let different_size_records = different_size_type "records"
let different_size_records_tuples a b ra rb =
different_size_type
(if Stage_common.Helpers.is_tuple_lmap ra && Stage_common.Helpers.is_tuple_lmap rb
then "tuples"
else "records")
a b
let different_types name a b () =
let title () = name ^ " are different" in
let message () = "Expected these two types to be the same, but they're different" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_value a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_value b )
("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_expression b )
] in
error ~data title message ()
@ -91,8 +109,8 @@ module Errors = struct
let title () = name ^ " are different" in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.value a) ;
("b" , fun () -> Format.asprintf "%a" PP.value b )
("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.expression b )
] in
error ~data title message ()
@ -109,8 +127,8 @@ module Errors = struct
let title () = "values have different types: " ^ name in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.value a) ;
("b" , fun () -> Format.asprintf "%a" PP.value b )
("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.expression b)
] in
error ~data title message ()
@ -127,8 +145,8 @@ module Errors = struct
let title () = name ^ " are not comparable" in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.value a) ;
("b" , fun () -> Format.asprintf "%a" PP.value b )
("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.expression b )
] in
error ~data title message ()
@ -136,8 +154,8 @@ module Errors = struct
let title () = name in
let message () = "" in
let data = [
("a" , fun () -> Format.asprintf "%a" PP.value a) ;
("b" , fun () -> Format.asprintf "%a" PP.value b )
("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.expression b )
] in
error ~data title message ()
@ -177,49 +195,45 @@ module Free_variables = struct
let empty : bindings = []
let of_list : expression_variable list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings = fun b e ->
let self = annotated_expression b in
match e with
let rec expression_content : bindings -> expression_content -> bindings = fun b ec ->
let self = expression b in
match ec with
| E_lambda l -> lambda b l
| E_literal _ -> empty
| E_constant (_ , lst) -> unions @@ List.map self lst
| E_constant {arguments;_} -> unions @@ List.map self arguments
| E_variable name -> (
match mem name b with
| true -> empty
| false -> singleton name
)
| E_application (a, b) -> unions @@ List.map self [ a ; b ]
| E_tuple lst -> unions @@ List.map self lst
| E_constructor (_ , a) -> self a
| E_application {expr1;expr2} -> unions @@ List.map self [ expr1 ; expr2 ]
| E_constructor {element;_} -> self element
| E_record m -> unions @@ List.map self @@ LMap.to_list m
| E_record_accessor (a, _) -> self a
| E_record_update (r,(_,e)) -> union (self r) @@ self e
| E_tuple_accessor (a, _) -> self a
| E_record_accessor {expr;_} -> self expr
| E_record_update {record; update;_} -> union (self record) @@ self update
| E_list lst -> unions @@ List.map self lst
| E_set lst -> unions @@ List.map self lst
| (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 (a , cs) -> union (self a) (matching_expression b cs)
| E_sequence (a , b) -> unions @@ List.map self [ a ; b ]
| E_loop (expr , body) -> unions @@ List.map self [ expr ; body ]
| E_assign (_ , _ , expr) -> self expr
| E_let_in { binder; rhs; result; _ } ->
let b' = union (singleton binder) b in
| 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
(annotated_expression b' result)
(annotated_expression b rhs)
(expression b' let_result)
(self rhs)
and lambda : bindings -> lambda -> bindings = fun b l ->
let b' = union (singleton l.binder) b in
annotated_expression b' l.body
expression b' l.result
and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae ->
expression b ae.expression
and expression : bindings -> expression -> bindings = fun b e ->
expression_content b e.expression_content
and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor * expression_variable) * a) -> bindings = fun f b ((_,n),c) ->
and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor' * expression_variable) * a) -> bindings = fun f b ((_,n),c) ->
f (union (singleton n) b) c
and matching : type a . (bindings -> a -> bindings) -> bindings -> (a,'var) matching -> bindings = fun f b m ->
and matching : type a . (bindings -> a -> bindings) -> bindings -> (a,'var) matching_content -> bindings = fun f b m ->
match m with
| Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa)
| Match_list { match_nil = n ; match_cons = (hd, tl, c, _) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c)
@ -228,7 +242,7 @@ module Free_variables = struct
f (union (of_list lst) b) a
| Match_variant (lst,_) -> unions @@ List.map (matching_variant_case f b) lst
and matching_expression = fun x -> matching annotated_expression x
and matching_expression = fun x -> matching expression x
end
@ -314,7 +328,7 @@ end
open Errors
let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = match (a.type_value', b.type_value') with
let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) : unit result = match (a.type_content, b.type_content) with
| T_constant ca, T_constant cb -> (
trace_strong (different_constants ca cb)
@@ Assert.assert_true (ca = cb)
@ -328,16 +342,14 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
| TC_set la, TC_set lb -> ok @@ ([la], [lb])
| TC_map (ka,va), TC_map (kb,vb)
| TC_big_map (ka,va), TC_big_map (kb,vb) -> ok @@ ([ka;va] ,[kb;vb])
| TC_tuple lsta, TC_tuple lstb -> ok @@ (lsta , lstb)
| TC_arrow (froma , toa) , TC_arrow (fromb , tob) -> ok @@ ([froma;toa] , [fromb;tob])
| (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_tuple _ | TC_arrow _),
(TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_tuple _ | TC_arrow _) -> fail @@ different_operators opa opb
| (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _),
(TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _ ) -> fail @@ different_operators opa opb
in
if List.length lsta <> List.length lstb then
fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb)
else
trace (different_types "arguments to type operators" a b)
@@ bind_list_iter (fun (a,b) -> assert_type_value_eq (a,b) )(List.combine lsta lstb)
@@ bind_list_iter (fun (a,b) -> assert_type_expression_eq (a,b) )(List.combine lsta lstb)
)
| T_operator _, _ -> fail @@ different_kinds a b
| T_sum sa, T_sum sb -> (
@ -347,7 +359,7 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
let%bind _ =
Assert.assert_true ~msg:"different keys in sum types"
@@ (ka = kb) in
assert_type_value_eq (va, vb)
assert_type_expression_eq (va, vb)
in
let%bind _ =
trace_strong (different_size_sums a b)
@ -356,36 +368,41 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m
bind_list_iter aux (List.combine sa' sb')
)
| T_sum _, _ -> fail @@ different_kinds a b
| T_record ra, T_record rb
when Stage_common.Helpers.is_tuple_lmap ra <> Stage_common.Helpers.is_tuple_lmap rb -> (
fail @@ different_kind_record_tuple a b ra rb
)
| T_record ra, T_record rb -> (
let ra' = LMap.to_kv_list ra in
let rb' = LMap.to_kv_list rb in
let sort_lmap r' = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) r' in
let ra' = sort_lmap @@ LMap.to_kv_list ra in
let rb' = sort_lmap @@ LMap.to_kv_list rb in
let aux ((ka, va), (kb, vb)) =
let%bind _ =
trace (different_types "records" a b) @@
let Label ka = ka in
let Label kb = kb in
trace_strong (different_props_in_record ka kb) @@
trace_strong (different_props_in_record a b ra rb ka kb) @@
Assert.assert_true (ka = kb) in
assert_type_value_eq (va, vb)
assert_type_expression_eq (va, vb)
in
let%bind _ =
trace_strong (different_size_records a b)
trace_strong (different_size_records_tuples a b ra rb)
@@ Assert.assert_list_same_size ra' rb' in
trace (different_types "record type" a b)
@@ bind_list_iter aux (List.combine ra' rb')
)
| T_record _, _ -> fail @@ different_kinds a b
| T_arrow (param, result), T_arrow (param', result') ->
let%bind _ = assert_type_value_eq (param, param') in
let%bind _ = assert_type_value_eq (result, result') in
| T_arrow {type1;type2}, T_arrow {type1=type1';type2=type2'} ->
let%bind _ = assert_type_expression_eq (type1, type1') in
let%bind _ = assert_type_expression_eq (type2, type2') in
ok ()
| T_arrow _, _ -> fail @@ different_kinds a b
| T_variable x, T_variable y -> let _ = (x = y) in failwith "TODO : we must check that the two types were bound at the same location (even if they have the same name), i.e. use something like De Bruijn indices or a propper graph encoding"
| T_variable _, _ -> fail @@ different_kinds a b
(* No information about what made it fail *)
let type_value_eq ab = Trace.to_bool @@ assert_type_value_eq ab
let type_expression_eq ab = Trace.to_bool @@ assert_type_expression_eq ab
let assert_literal_eq (a, b : literal * literal) : unit result =
match (a, b) with
@ -410,6 +427,8 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
| Literal_bytes a, Literal_bytes b when a = b -> ok ()
| Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytes" a b
| Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b
| Literal_void, Literal_void -> ok ()
| Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b
| Literal_unit, Literal_unit -> ok ()
| Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b
| Literal_address a, Literal_address b when a = b -> ok ()
@ -431,15 +450,15 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
| Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b
let rec assert_value_eq (a, b: (value*value)) : unit result =
let rec assert_value_eq (a, b: (expression*expression)) : unit result =
let error_content () =
Format.asprintf "\n%a vs %a" PP.value a PP.value b
Format.asprintf "\n%a vs %a" PP.expression a PP.expression b
in
trace (fun () -> error (thunk "not equal") error_content ()) @@
match (a.expression, b.expression) with
match (a.expression_content, b.expression_content) with
| E_literal a, E_literal b ->
assert_literal_eq (a, b)
| E_constant (ca, lsta), E_constant (cb, lstb) when ca = cb -> (
| E_constant {cons_name=ca;arguments=lsta}, E_constant {cons_name=cb;arguments=lstb} when ca = cb -> (
let%bind lst =
generic_try (different_size_values "constants with different number of elements" a b)
(fun () -> List.combine lsta lstb) in
@ -451,12 +470,12 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
| E_constant _, _ ->
let error_content () =
Format.asprintf "%a vs %a"
PP.annotated_expression a
PP.annotated_expression b
PP.expression a
PP.expression b
in
fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ())
| E_constructor (ca, a), E_constructor (cb, b) when ca = cb -> (
| E_constructor {constructor=ca;element=a}, E_constructor {constructor=cb;element=b} when ca = cb -> (
let%bind _eq = assert_value_eq (a, b) in
ok ()
)
@ -464,24 +483,13 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
fail @@ different_values "constructors" a b
| E_constructor _, _ ->
fail @@ different_values_because_different_types "constructor vs. non-constructor" a b
| E_tuple lsta, E_tuple lstb -> (
let%bind lst =
generic_try (different_size_values "tuples with different number of elements" a b)
(fun () -> List.combine lsta lstb) in
let%bind _all = bind_list @@ List.map assert_value_eq lst in
ok ()
)
| E_tuple _, _ ->
fail @@ different_values_because_different_types "tuple vs. non-tuple" a b
| E_record sma, E_record smb -> (
let aux (Label k) a b =
match a, b with
| Some a, Some b -> Some (assert_value_eq (a, b))
| _ -> Some (fail @@ missing_key_in_record_value k)
in
let%bind _all = bind_lmap @@ LMap.merge aux sma smb in
let%bind _all = Stage_common.Helpers.bind_lmap @@ LMap.merge aux sma smb in
ok ()
)
| E_record _, _ ->
@ -522,30 +530,28 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
| E_set _, _ ->
fail @@ different_values_because_different_types "set vs. non-set" a b
| (E_literal _, _) | (E_variable _, _) | (E_application _, _)
| (E_lambda _, _) | (E_let_in _, _) | (E_tuple_accessor _, _)
| (E_record_update _,_)
| (E_record_accessor _, _)
| (E_lambda _, _) | (E_let_in _, _)
| (E_record_accessor _, _) | (E_record_update _,_)
| (E_look_up _, _) | (E_matching _, _)
| (E_assign _ , _)
| (E_sequence _, _) | (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
| (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
let merge_annotation (a:type_value option) (b:type_value option) err : type_value result =
let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result =
match a, b with
| None, None -> fail @@ err
| Some a, None -> ok a
| None, Some b -> ok b
| Some a, Some b ->
let%bind _ = assert_type_value_eq (a, b) in
match a.simplified, b.simplified with
let%bind _ = assert_type_expression_eq (a, b) in
match a.type_meta, b.type_meta with
| _, None -> ok a
| _, Some _ -> ok b
let get_entry (lst : program) (name : string) : annotated_expression result =
let get_entry (lst : program) (name : string) : expression result =
trace_option (Errors.missing_entry_point name) @@
let aux x =
let (Declaration_constant (an , _, _)) = Location.unwrap x in
if (an.name = Var.of_name name)
then Some an.annotated_expression
let (Declaration_constant (an , expr, _, _)) = Location.unwrap x in
if (an = Var.of_name name)
then Some expr
else None
in
List.find_map aux lst
@ -553,4 +559,4 @@ let get_entry (lst : program) (name : string) : annotated_expression result =
let program_environment (program : program) : full_environment =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , _, (_ , post_env)) -> post_env
| Declaration_constant (_ , _, _, post_env) -> post_env

28
src/stages/ast_typed/misc.mli
View File

@ -1,16 +1,14 @@
open Trace
open Types
include module type of Stage_common.Misc
val assert_value_eq : ( expression * expression ) -> unit result
val assert_value_eq : ( value * value ) -> unit result
val assert_type_expression_eq : ( type_expression * type_expression ) -> unit result
val assert_type_value_eq : ( type_value * type_value ) -> unit result
val merge_annotation : type_value option -> type_value option -> error_thunk -> type_value result
val merge_annotation : type_expression option -> type_expression option -> error_thunk -> type_expression result
(* No information about what made it fail *)
val type_value_eq : ( type_value * type_value ) -> bool
val type_expression_eq : ( type_expression * type_expression ) -> bool
module Free_variables : sig
type bindings = expression_variable list
@ -18,7 +16,7 @@ module Free_variables : sig
val matching_expression : bindings -> matching_expr -> bindings
val lambda : bindings -> lambda -> bindings
val annotated_expression : bindings -> annotated_expression -> bindings
val expression : bindings -> expression -> bindings
val empty : bindings
val singleton : expression_variable -> bindings
@ -40,14 +38,16 @@ end
module Errors : sig
(*
val different_kinds : type_value -> type_value -> unit -> error
val different_kinds : type_expression -> type_expression -> unit -> error
val different_constants : string -> string -> unit -> error
val different_size_type : name -> type_value -> type_value -> unit -> error
val different_size_type : name -> type_expression -> type_expression -> unit -> error
val different_props_in_record : string -> string -> unit -> error
val different_size_constants : type_value -> type_value -> unit -> error
val different_size_sums : type_value -> type_value -> unit -> error
val different_size_records : type_value -> type_value -> unit -> error
val different_types : name -> type_value -> type_value -> unit -> error
val different_size_constants : type_expression -> type_expression -> unit -> error
val different_size_tuples : type_expression -> type_expression -> unit -> error
val different_size_sums : type_expression -> type_expression -> unit -> error
val different_size_records : type_expression -> type_expression -> unit -> error
val different_size_tuples : type_expression -> type_expression -> unit -> error
val different_types : name -> type_expression -> type_expression -> unit -> error
val different_literals : name -> literal -> literal -> unit -> error
val different_values : name -> value -> value -> unit -> error
val different_literals_because_different_types : name -> literal -> literal -> unit -> error
@ -67,5 +67,5 @@ end
val assert_literal_eq : ( literal * literal ) -> unit result
*)
val get_entry : program -> string -> annotated_expression result
val get_entry : program -> string -> expression result
val program_environment : program -> full_environment

64
src/stages/ast_typed/misc_smart.ml
View File

@ -8,31 +8,31 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let%bind (main , input_type , _) =
let pred = fun d ->
match d with
| Declaration_constant (d , _, _) when d.name = Var.of_name s -> Some d.annotated_expression
| Declaration_constant (d , expr, _, _) when d = Var.of_name s -> Some expr
| Declaration_constant _ -> None
in
let%bind main =
trace_option (simple_error "no main with given name") @@
List.find_map (Function.compose pred Location.unwrap) p in
let%bind (input_ty , output_ty) =
match (get_type' @@ get_type_annotation main) with
| T_arrow (i , o) -> ok (i , o)
match (get_type' @@ get_type_expression main) with
| T_arrow {type1;type2} -> ok (type1 , type2)
| _ -> simple_fail "program main isn't a function" in
ok (main , input_ty , output_ty)
in
let env =
let aux = fun _ d ->
match d with
| Declaration_constant (_ , _, (_ , post_env)) -> post_env in
| Declaration_constant (_ , _, _, post_env) -> post_env in
List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
let binder = Var.of_name "@contract_input" in
let body =
let result =
let input_expr = e_a_variable binder input_type env in
let main_expr = e_a_variable (Var.of_name s) (get_type_annotation main) env in
let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) env in
e_a_application main_expr input_expr env in
ok {
binder ;
body ;
result ;
}
module Captured_variables = struct
@ -45,13 +45,13 @@ module Captured_variables = struct
let empty : bindings = []
let of_list : expression_variable list -> bindings = fun x -> x
let rec annotated_expression : bindings -> annotated_expression -> bindings result = fun b ae ->
let self = annotated_expression b in
match ae.expression with
let rec expression : bindings -> expression -> bindings result = fun b ae ->
let self = expression b in
match ae.expression_content with
| E_lambda l -> ok @@ Free_variables.lambda empty l
| E_literal _ -> ok empty
| E_constant (_ , lst) ->
let%bind lst' = bind_map_list self lst in
| E_constant {arguments;_} ->
let%bind lst' = bind_map_list self arguments in
ok @@ unions lst'
| E_variable name -> (
let%bind env_element =
@ -61,22 +61,18 @@ module Captured_variables = struct
| ED_binder -> ok empty
| ED_declaration (_ , _) -> simple_fail "todo"
)
| E_application (a, b) ->
let%bind lst' = bind_map_list self [ a ; b ] in
| E_application {expr1;expr2} ->
let%bind lst' = bind_map_list self [ expr1 ; expr2 ] in
ok @@ unions lst'
| E_tuple lst ->
let%bind lst' = bind_map_list self lst in
ok @@ unions lst'
| E_constructor (_ , a) -> self a
| E_constructor {element;_} -> self element
| E_record m ->
let%bind lst' = bind_map_list self @@ LMap.to_list m in
ok @@ unions lst'
| E_record_accessor (a, _) -> self a
| E_record_update (r,(_,e)) ->
let%bind r = self r in
let%bind e = self e in
| E_record_accessor {expr;_} -> self expr
| E_record_update {record;update;_} ->
let%bind r = self record in
let%bind e = self update in
ok @@ union r e
| E_tuple_accessor (a, _) -> self a
| E_list lst ->
let%bind lst' = bind_map_list self lst in
ok @@ unions lst'
@ -89,23 +85,21 @@ module Captured_variables = struct
| E_look_up (a , b) ->
let%bind lst' = bind_map_list self [ a ; b ] in
ok @@ unions lst'
| E_matching (a , cs) ->
let%bind a' = self a in
let%bind cs' = matching_expression b cs in
| E_matching {matchee;cases;_} ->
let%bind a' = self matchee in
let%bind cs' = matching_expression b cases in
ok @@ union a' cs'
| E_sequence (_ , b) -> self b
| E_loop (expr , body) ->
let%bind lst' = bind_map_list self [ expr ; body ] in
| E_loop {condition; body} ->
let%bind lst' = bind_map_list self [ condition ; body ] in
ok @@ unions lst'
| E_assign (_ , _ , expr) -> self expr
| E_let_in li ->
let b' = union (singleton li.binder) b in
annotated_expression b' li.result
let b' = union (singleton li.let_binder) b in
expression b' li.let_result
and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor * expression_variable) * a) -> bindings result = fun f b ((_,n),c) ->
and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor' * expression_variable) * a) -> bindings result = fun f b ((_,n),c) ->
f (union (singleton n) b) c
and matching : type a . (bindings -> a -> bindings result) -> bindings -> (a, 'tv) matching -> bindings result = fun f b m ->
and matching : type a . (bindings -> a -> bindings result) -> bindings -> (a, 'tv) matching_content -> bindings result = fun f b m ->
match m with
| Match_bool { match_true = t ; match_false = fa } ->
let%bind t' = f b t in
@ -125,6 +119,6 @@ module Captured_variables = struct
let%bind lst' = bind_map_list (matching_variant_case f b) lst in
ok @@ unions lst'
and matching_expression = fun x -> matching annotated_expression x
and matching_expression = fun x -> matching expression x
end

3
src/stages/ast_typed/misc_smart.mli
View File

@ -1,13 +1,12 @@
open Trace
open Types
open Stage_common.Types
val program_to_main : program -> string -> lambda result
module Captured_variables : sig
type bindings = expression_variable list
val matching : (bindings -> 'a -> bindings result) -> bindings -> ('a, type_value) matching -> bindings result
val matching : (bindings -> 'a -> bindings result) -> bindings -> ('a, type_expression) matching_content -> bindings result
val matching_expression : bindings -> matching_expr -> bindings result

193
src/stages/ast_typed/types.ml
View File

@ -3,6 +3,12 @@
module S = Ast_simplified
include Stage_common.Types
module Ast_typed_type_parameter = struct
type type_meta = S.type_expression option
end
include Ast_generic_type (Ast_typed_type_parameter)
type program = declaration Location.wrap list
and inline = bool
@ -13,105 +19,108 @@ and declaration =
* a boolean indicating whether it should be inlined
* the environment before the declaration (the original environment)
* the environment after the declaration (i.e. with that new declaration added to the original environment). *)
| Declaration_constant of (named_expression * inline * (full_environment * full_environment))
| Declaration_constant of (expression_variable * expression * inline * full_environment)
(*
| Declaration_type of (type_variable * type_expression)
| Declaration_constant of (named_expression * (full_environment * full_environment))
*)
(* | Macro_declaration of macro_declaration *)
and expression =
{ expression_content: expression_content
; location: Location.t
; type_expression: type_expression
; environment: full_environment }
and expression_content =
(* Base *)
| E_literal of literal
| E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of expression_variable
| E_application of application
| E_lambda of lambda
| E_let_in of let_in
(* Variant *)
| E_constructor of constructor (* For user defined constructors *)
| E_matching of matching
(* Record *)
| E_record of expression label_map
| E_record_accessor of accessor
| E_record_update of update
(* Data Structures *)
(* TODO : move to constant*)
| E_map of (expression * expression) list (*move to operator *)
| E_big_map of (expression * expression) list (*move to operator *)
| 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' (* this is at the end because it is huge *)
; arguments: expression list }
and application = {expr1: expression; expr2: expression}
and lambda =
{ binder: expression_variable
(* ; input_type: type_expression option
; output_type: type_expression option *)
; result: expression }
and let_in =
{ let_binder: expression_variable
; rhs: expression
; let_result: expression
; inline : inline }
and constructor = {constructor: constructor'; element: expression}
and accessor = {expr: expression; label: label}
and update = {record: expression; path: label ; update: expression}
and loop = {condition: expression; body: expression}
and matching_expr = (expression,type_expression) matching_content
and matching =
{ matchee: expression
; cases: matching_expr
}
and ascription = {anno_expr: expression; type_annotation: type_expression}
and environment_element_definition =
| ED_binder
| ED_declaration of (annotated_expression * free_variables)
| ED_declaration of (expression * free_variables)
and free_variables = expression_variable list
and environment_element = {
type_value : type_value ;
source_environment : full_environment ;
definition : environment_element_definition ;
}
and environment_element =
{ type_value: type_expression
; source_environment: full_environment
; definition: environment_element_definition }
and environment = (expression_variable * environment_element) list
and type_environment = (type_variable * type_value) list (* SUBST ??? *)
and small_environment = (environment * type_environment)
and type_environment = (type_variable * type_expression) list
(* SUBST ??? *)
and small_environment = environment * type_environment
and full_environment = small_environment List.Ne.t
and annotated_expression = {
expression : expression ;
type_annotation : type_value ; (* SUBST *)
environment : full_environment ;
location : Location.t ;
and expr = expression
and texpr = type_expression
and named_type_content = {
type_name : type_variable;
type_value : type_expression;
}
(* This seems to be used only for top-level declarations, and
represents the name of the top-level binding, and the expression
assigned to it. -- Suzanne.
TODO: if this is correct, then we should inline this in
"declaration" or at least move it close to it. *)
and named_expression = {
name: expression_variable ;
annotated_expression: ae ;
}
and ae = annotated_expression
and type_value' = type_value type_expression'
and type_value = {
type_value' : type_value';
simplified : S.type_expression option ; (* If we have the simplified this AST fragment comes from, it is stored here, for easier untyping. *)
}
(* This is used in E_assign of (named_type_value * access_path * ae).
In mini_c, we need the type associated with `x` in the assignment
expression `x.y.z := 42`, so it is stored here. *)
and named_type_value = {
type_name: expression_variable ;
type_value : type_value ;
}
(* E_lamba and other expressions are always wrapped as an annotated_expression. *)
and lambda = {
binder : expression_variable ;
(* input_type: tv ;
* output_type: tv ; *)
body : ae ;
}
and let_in = {
binder: expression_variable;
rhs: ae;
result: ae;
inline: inline;
}
and 'a expression' =
(* Base *)
| E_literal of literal
| E_constant of (constant * ('a) list) (* For language constants, like (Cons hd tl) or (plus i j) *)
| E_variable of expression_variable
| E_application of (('a) * ('a))
| E_lambda of lambda
| E_let_in of let_in
(* Tuple, TODO: remove tuples and use records with integer keys instead *)
| E_tuple of ('a) list
| E_tuple_accessor of (('a) * int) (* Access n'th tuple's element *)
(* Sum *)
| E_constructor of (constructor * ('a)) (* For user defined constructors *)
(* Record *)
| E_record of ('a) label_map
| E_record_accessor of (('a) * label)
| E_record_update of ('a * (label * 'a))
(* Data Structures *)
| E_map of (('a) * ('a)) list
| E_big_map of (('a) * ('a)) list
| E_list of ('a) list
| E_set of ('a) list
| E_look_up of (('a) * ('a))
(* Advanced *)
| E_matching of (('a) * matching_expr)
(* Replace Statements *)
| E_sequence of (('a) * ('a))
| E_loop of (('a) * ('a))
| E_assign of (named_type_value * access_path * ('a))
and expression = ae expression'
and value = annotated_expression (* todo (for refactoring) *)
and matching_expr = (ae,type_value) matching

218
src/stages/common/PP.ml
View File

@ -2,19 +2,45 @@ open Types
open Format
open PP_helpers
let name ppf (n:expression_variable) : unit =
fprintf ppf "%a" Var.pp n
let type_variable ppf (t:type_variable) : unit =
fprintf ppf "%a" Var.pp t
let constructor ppf (c:constructor) : unit =
let constructor ppf (c:constructor') : unit =
let Constructor c = c in fprintf ppf "%s" c
let label ppf (l:label) : unit =
let Label l = l in fprintf ppf "%s" l
let constant ppf : constant -> unit = function
let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let record_sep value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in
let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let tuple_sep value sep ppf m =
assert (Helpers.is_tuple_lmap m);
let lst = LMap.to_kv_list m in
let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
let new_pp ppf (_k, v) = fprintf ppf "%a" value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
(* Prints records which only contain the consecutive fields
0..(cardinal-1) as tuples *)
let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m =
if Helpers.is_tuple_lmap m then
fprintf ppf format_tuple (tuple_sep value (const sep_tuple)) m
else
fprintf ppf format_record (record_sep value (const sep_record)) m
let list_sep_d x = list_sep x (const " , ")
let cmap_sep_d x = cmap_sep x (const " , ")
let tuple_or_record_sep_expr value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " , "
let tuple_or_record_sep_type value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " * "
let constant ppf : constant' -> unit = function
| C_INT -> fprintf ppf "INT"
| C_UNIT -> fprintf ppf "UNIT"
| C_NIL -> fprintf ppf "NIL"
@ -45,6 +71,8 @@ let constant ppf : constant -> unit = function
| C_AND -> fprintf ppf "AND"
| C_OR -> fprintf ppf "OR"
| C_XOR -> fprintf ppf "XOR"
| C_LSL -> fprintf ppf "LSL"
| C_LSR -> fprintf ppf "LSR"
(* COMPARATOR *)
| C_EQ -> fprintf ppf "EQ"
| C_NEQ -> fprintf ppf "NEQ"
@ -121,85 +149,119 @@ let constant ppf : constant -> unit = function
| C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE"
| C_STEPS_TO_QUOTA -> fprintf ppf "STEPS_TO_QUOTA"
let cmap_sep value sep ppf m =
let lst = Types.CMap.to_kv_list m in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let literal ppf (l : literal) =
match l with
| Literal_unit ->
fprintf ppf "unit"
| Literal_void ->
fprintf ppf "void"
| Literal_bool b ->
fprintf ppf "%b" b
| Literal_int n ->
fprintf ppf "%d" n
| Literal_nat n ->
fprintf ppf "+%d" n
| Literal_timestamp n ->
fprintf ppf "+%d" n
| Literal_mutez n ->
fprintf ppf "%dmutez" n
| Literal_string s ->
fprintf ppf "%S" s
| Literal_bytes b ->
fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
| Literal_address s ->
fprintf ppf "@%S" s
| Literal_operation _ ->
fprintf ppf "Operation(...bytes)"
| Literal_key s ->
fprintf ppf "key %s" s
| Literal_key_hash s ->
fprintf ppf "key_hash %s" s
| Literal_signature s ->
fprintf ppf "Signature %s" s
| Literal_chain_id s ->
fprintf ppf "Chain_id %s" s
module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
module Agt=Ast_generic_type(PARAMETER)
open Agt
open Format
let lmap_sep value sep ppf m =
let lst = Types.LMap.to_kv_list m in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
let lrecord_sep value sep ppf m =
let lst = Types.LMap.to_kv_list m in
let new_pp ppf (k, v) = fprintf ppf "%a = %a" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let list_sep_d x = list_sep x (const " , ")
let cmap_sep_d x = cmap_sep x (const " , ")
let lmap_sep_d x = lmap_sep x (const " , ")
let rec type_expression' : type a . (formatter -> a -> unit) -> formatter -> a type_expression' -> unit =
let rec type_expression' :
(formatter -> type_expression -> unit)
-> formatter
-> type_expression
-> unit =
fun f ppf te ->
match te with
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "record[%a]" (lmap_sep_d f ) m
| T_arrow (a, b) -> fprintf ppf "%a -> %a" f a f b
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
match te.type_content with
| T_sum m ->
fprintf ppf "sum[%a]" (cmap_sep_d f) m
| T_record m ->
fprintf ppf "%a" (tuple_or_record_sep_type f) m
| T_arrow a ->
fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv ->
type_variable ppf tv
| T_constant tc ->
type_constant ppf tc
| T_operator to_ ->
type_operator f ppf to_
and type_constant ppf (tc:type_constant) : unit =
let s = match tc with
| TC_unit -> "unit"
| TC_string -> "string"
| TC_bytes -> "bytes"
| TC_nat -> "nat"
| TC_int -> "int"
| TC_mutez -> "mutez"
| TC_bool -> "bool"
| TC_operation -> "operation"
| TC_address -> "address"
| TC_key -> "key"
| TC_key_hash -> "key_hash"
| TC_signature -> "signature"
| TC_timestamp -> "timestamp"
| TC_chain_id -> "chain_id"
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_constant ppf (tc : type_constant) : unit =
let s =
match tc with
| TC_unit ->
"unit"
| TC_string ->
"string"
| TC_bytes ->
"bytes"
| TC_nat ->
"nat"
| TC_int ->
"int"
| TC_mutez ->
"mutez"
| TC_bool ->
"bool"
| TC_operation ->
"operation"
| TC_address ->
"address"
| TC_key ->
"key"
| TC_key_hash ->
"key_hash"
| TC_signature ->
"signatuer"
| TC_timestamp ->
"timestamp"
| TC_chain_id ->
"chain_id"
| TC_void ->
"void"
in
fprintf ppf "%s" s
and type_operator : type a . (formatter -> a -> unit) -> formatter -> a type_operator -> unit =
and type_operator :
(formatter -> type_expression -> unit)
-> formatter
-> type_operator
-> unit =
fun f ppf to_ ->
let s = match to_ with
| TC_option (tv) -> Format.asprintf "option(%a)" f tv
| TC_list (tv) -> Format.asprintf "list(%a)" f tv
| TC_set (tv) -> Format.asprintf "set(%a)" f tv
let s =
match to_ with
| TC_option te -> Format.asprintf "option(%a)" f te
| TC_list te -> Format.asprintf "list(%a)" f te
| TC_set te -> Format.asprintf "set(%a)" f te
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_contract (c) -> Format.asprintf "Contract (%a)" f c
| TC_arrow (a , b) -> Format.asprintf "TC_Arrow (%a,%a)" f a f b
| TC_tuple lst -> Format.asprintf "tuple[%a]" (list_sep_d f) lst
| TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te
in
fprintf ppf "(TO_%s)" s
let literal ppf (l:literal) = match l with
| Literal_unit -> fprintf ppf "Unit"
| Literal_bool b -> fprintf ppf "%b" b
| Literal_int n -> fprintf ppf "%d" n
| Literal_nat n -> fprintf ppf "+%d" n
| Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_mutez n -> fprintf ppf "%dmutez" n
| Literal_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
| Literal_address s -> fprintf ppf "address %S" s
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
| Literal_key s -> fprintf ppf "key %s" s
| Literal_key_hash s -> fprintf ppf "key_hash %s" s
| Literal_signature s -> fprintf ppf "signature %s" s
| Literal_chain_id s -> fprintf ppf "chain_id %s" s
let%expect_test _ =
Format.printf "%a" literal (Literal_bytes (Bytes.of_string "foo")) ;
[%expect{| 0x666f6f |}]
end

16
src/stages/common/PP.mli
View File

@ -1,16 +0,0 @@
open Types
open Format
val name : formatter -> expression_variable -> unit
val type_variable : formatter -> type_variable -> unit
val constructor : formatter -> constructor -> unit
val label : formatter -> label -> unit
val constant : formatter -> constant -> unit
val cmap_sep : (formatter -> 'a -> unit) -> (formatter -> unit -> unit) -> formatter -> 'a CMap.t -> unit
val lmap_sep : (formatter -> 'a -> unit) -> (formatter -> unit -> unit) -> formatter -> 'a LMap.t -> unit
val lrecord_sep : (formatter -> 'a -> unit) -> (formatter -> unit -> unit) -> formatter -> 'a LMap.t -> unit
val type_expression' : (formatter -> 'a -> unit) -> formatter -> 'a type_expression' -> unit
val type_operator : (formatter -> 'a -> unit) -> formatter -> 'a type_operator -> unit
val type_constant : formatter -> type_constant -> unit
val literal : formatter -> literal -> unit
val list_sep_d : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit

2
src/stages/common/ast_common.ml
View File

@ -1,3 +1,3 @@
module Types = Types
module PP = PP
module Misc = Misc
module Helpers = Helpers

40
src/stages/common/helpers.ml Normal file
View File

@ -0,0 +1,40 @@
open Types
let bind_lmap (l:_ label_map) =
let open Trace in
let open LMap in
let aux k v prev =
prev >>? fun prev' ->
v >>? fun v' ->
ok @@ add k v' prev' in
fold aux l (ok empty)
let bind_cmap (c:_ constructor_map) =
let open Trace in
let open CMap in
let aux k v prev =
prev >>? fun prev' ->
v >>? fun v' ->
ok @@ add k v' prev' in
fold aux c (ok empty)
let bind_fold_lmap f init (lmap:_ LMap.t) =
let open Trace in
let aux k v prev =
prev >>? fun prev' ->
f prev' k v
in
LMap.fold aux lmap init
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 range i j =
let rec aux i j acc = if i >= j then acc else aux i (j-1) (j-1 :: acc) in
aux i j []
let label_range i j =
List.map (fun i -> Label (string_of_int i)) @@ range i j
let is_tuple_lmap m =
List.for_all (fun i -> LMap.mem i m) @@ (label_range 0 (LMap.cardinal m))

Some files were not shown because too many files have changed in this diff Show More