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

Merge branch 'dev' of gitlab.com:ligolang/ligo into feature/doc-pascaligo-loop

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-02-10 19:22:52 +01:00
commit 61832354d9
130 changed files with 4493 additions and 3420 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 Version.ml
/_opam/ /_opam/
/*.pp.ligo /*.pp.ligo
/*.pp.mligo
/*.pp.religo
**/.DS_Store **/.DS_Store
.vscode/ .vscode/
/ligo.install /ligo.install

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

@ -180,7 +180,7 @@ ligo compile-storage src/counter.ligo main 5
<!--END_DOCUSAURUS_CODE_TABS--> <!--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 ## Invoking a LIGO contract

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. >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 ## 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: Problems might include:
* Installing the repository or the tools needed to work on it * 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). 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. 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. 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 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. 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. To understand LIGO’s design choices it’s important to understand its philosophy. We have two main concerns in mind while building LIGO.
## Safety ## 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
Automated Testing is the process through which a program runs another program, and checks 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.
@ -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. 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 ### 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). * 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. 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. 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 ### 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: Download the latest binaries here: https://gitlab.com/ligolang/ligo/pipelines/85536879/builds or get the latest pre-release:

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

@ -249,7 +249,7 @@ For example **code snippets** for the *Types* subsection of this doc, can be fou
### Exercises ### Exercises
Solutions to exercises can be found e.g. here: `gitlab-pages/docs/language-basics/exercises/types/**/solutions/**` 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: 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 ```shell

8
gitlab-pages/docs/language-basics/sets-lists-tuples.md
View File

@ -644,7 +644,7 @@ with the map data structure.
In PascaLIGO, the predefined functional iterator implementing the map In PascaLIGO, the predefined functional iterator implementing the map
operation over sets is called `set_map` and is used as follows: operation over sets is called `set_map` and is used as follows:
```pascaligo group=sets ```pascaligo skip
function increment (const i : int): int is i + 1 function increment (const i : int): int is i + 1
// Creates a new set with all elements incremented by 1 // Creates a new set with all elements incremented by 1
@ -656,24 +656,26 @@ const plus_one : set (int) = set_map (increment, larger_set)
In CameLIGO, the predefined functional iterator implementing the map In CameLIGO, the predefined functional iterator implementing the map
operation over sets is called `Set.map` and is used as follows: operation over sets is called `Set.map` and is used as follows:
```cameligo group=sets ```cameligo skip
let increment (i : int) : int = i + 1 let increment (i : int) : int = i + 1
// Creates a new set with all elements incremented by 1 // Creates a new set with all elements incremented by 1
let plus_one : int set = Set.map increment larger_set let plus_one : int set = Set.map increment larger_set
``` ```
<!--ReasonLIGO--> <!--ReasonLIGO-->
In ReasonLIGO, the predefined functional iterator implementing the map In ReasonLIGO, the predefined functional iterator implementing the map
operation over sets is called `Set.map` and is used as follows: operation over sets is called `Set.map` and is used as follows:
```reasonligo group=sets ```reasonligo skip
let increment = (i : int) : int => i + 1; let increment = (i : int) : int => i + 1;
// Creates a new set with all elements incremented by 1 // Creates a new set with all elements incremented by 1
let plus_one : set (int) = Set.map (increment, larger_set); let plus_one : set (int) = Set.map (increment, larger_set);
``` ```
<!--END_DOCUSAURUS_CODE_TABS--> <!--END_DOCUSAURUS_CODE_TABS-->
#### Fold Operation #### Fold Operation

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

@ -52,8 +52,8 @@ let id_string = (p : string) : option (string) => {
It is often desirable to hash a public key. In Michelson, certain data 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 structures such as maps will not allow the use of the `key` type. Even
if this were not the case, hashes are much smaller than keys, and if this were not the case, hashes are much smaller than keys, and
storage on blockchains comes at a cost premium. You can hash keys an storage on blockchains comes at a cost premium. You can hash keys with
predefined function returning a value of type `key_hash`. a predefined functions returning a value of type `key_hash`.
<!--DOCUSAURUS_CODE_TABS--> <!--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 id: tezos-taco-shop-smart-contract
title: Taco shop smart-contract title: Taco shop smart contract
--- ---
<div> <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/> <br/>
<img src="/img/tutorials/get-started/tezos-taco-shop-smart-contract/taco-stand.svg" width="50%" /> <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. > 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` ### `taco-shop.ligo`
```pascaligo group=a ```pascaligo group=a
@ -138,7 +138,7 @@ end
type taco_shop_storage is map(nat, taco_supply); 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`** **`taco-shop.ligo`**
```pascaligo group=b+ ```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 ### 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** **Storage value**
```zsh ```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? ## 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). 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. 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 ## 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 # LIGO
@ -41,7 +41,7 @@ The most brittle part of our code base is about to become its strongest part. We
Concretely: 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. - 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. - 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 # Marigold
@ -56,4 +56,4 @@ It is thus hard for newcomers (even CS researchers!) to dive into Plasma in a co
# Contact # 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 = [ const COMMUNICATION_CHANNELS = [
{ {
link: 'https://discord.gg/9rhYaEt', link: 'https://t.me/LigoLang',
icon: 'img/discord.svg', icon: 'img/telegram.svg',
description: "We're hear to help. Ask us anything" description: "We're hear to help. Ask us anything"
}, },
{ {

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

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

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

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

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

@ -4,8 +4,14 @@ title: Origin
original_id: origin original_id: 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. 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.

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

@ -4,42 +4,79 @@ title: Philosophy
original_id: philosophy original_id: philosophy
--- ---
To understand LIGO’s design choices it’s important to understand its philosophy. We have two main concerns in mind while building LIGO. To understand LIGO’s design choices it is important to understand its
philosophy. We have two main concerns in mind while building LIGO.
## Safety ## 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
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. 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
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. 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 ### 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 is why
LIGO encourages writing lean rather than chunky smart contracts.
--- ---
## Ergonomics ## Ergonomics
Having an ergonomic product is crucial on multiple levels:
Making features easily accessible ensures they’ll actually get used. Having an ergonomic product is crucial on multiple levels: Making
Not wasting users time on idiosyncrasies frees more time for making contracts safer or building apps. features easily accessible ensures they will actually get used. Not
Keeping users in a Flow state makes it possible to introduce more complex features in the language. wasting users time on idiosyncrasies frees more time for making
There are multiple ways to improve ergonomics. contracts safer or building apps. Keeping users in a Flow state makes
it possible to introduce more complex features in the language. There
are multiple ways to improve ergonomics.
### The Language ### The Language
LIGO should contain as few surprises as possible. This is usually known as the principle of least surprise.
Most programmers who will use LIGO have already spent a lot of time learning to develop in an existing language, with its own set of conventions and expectations. These expectations are often the most important to accommodate. This is why C-style syntaxes are especially popular (e.g. JavaScript), C-style is well known and new languages want to take advantage of that familiarity. Therefore as an extension of the principle of least surprise, LIGO supports more than one syntax. The least surprising language for a new developer is the one that they have already learned how to use. It’s probably not practical to replicate the syntax of every programming language, so LIGO takes the approach of replicating the structure used by languages from a particular paradigm. LIGO should contain as few surprises as possible. This is usually
known as the principle of least surprise.
It is packaged in a Docker container, so that no particular installation instructions are required. Most programmers who will use LIGO have already spent a lot of time
learning to develop in an existing language, with its own set of
conventions and expectations. These expectations are often the most
important to accommodate. This is why C-style syntaxes are especially
popular (e.g. JavaScript), C-style is well known and new languages
want to take advantage of that familiarity. Therefore as an extension
of the principle of least surprise, LIGO supports more than one
syntax. The least surprising language for a new developer is the one
that they have already learned how to use. It’s probably not practical
to replicate the syntax of every programming language, so LIGO takes
the approach of replicating the structure used by languages from a
particular paradigm.
It is packaged in a Docker container, so that no particular
installation instructions are required.
### Editor Support ### Editor Support
Without editor support, a lot of manipulations are very cumbersome. Checking for errors, testing, examining code, refactoring code, etc. This is why there is ongoing work on editor support, starting with highlighting and code-folding.
### Docs Without editor support, a lot of manipulations are very
Docs include documentation of the languages, tutorials, as well as examples and design patterns. cumbersome. Checking for errors, testing, examining code, refactoring
We’re a long way from there. But having extensive docs is part of our goals. code, etc. This is why there is ongoing work on editor support,
starting with highlighting and code-folding.
### Documentation
Documentation includes a reference of the languages, tutorials, as
well as examples and design patterns. We are a long way from
there. But having an extensive documentation is part of our goals.

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 # which are subsequently used to fetch the respective docker
# image from the ocaml/infrastructure project. # 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_parameter="(Right 1)";
expected_compiled_storage=1; expected_compiled_storage=1;
expected_dry_run_output="( [] , 2 )"; expected_dry_run_output="( list[] , 2 )";
if [ "$compiled_storage" != "$expected_compiled_storage" ]; then if [ "$compiled_storage" != "$expected_compiled_storage" ]; then
echo "Expected $expected_compiled_storage as compile-storage output, got $compiled_storage instead"; 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 let%bind failstring = Run.failwith_to_string fail_res in
ok @@ Format.asprintf "%s" failstring ok @@ Format.asprintf "%s" failstring
| Success value' -> | 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 ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output
in in
let term = let term =
@ -268,6 +268,19 @@ let interpret =
let doc = "Subcommand: Interpret the expression in the context initialized by the provided source file." in let doc = "Subcommand: Interpret the expression in the context initialized by the provided source file." in
(Term.ret term , Term.info ~doc cmdname) (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 compile_storage =
let f source_file entry_point expression syntax amount sender source predecessor_timestamp display_format michelson_format = let f source_file entry_point expression syntax amount 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 env = Ast_typed.program_environment typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile 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 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 app = Compile.Of_simplified.apply entry_point simplified_param in
let%bind (typed_app,_) = Compile.Of_simplified.compile_expression ~env ~state app in let%bind (typed_app,_) = Compile.Of_simplified.compile_expression ~env ~state app in
@ -425,6 +439,7 @@ let list_declarations =
let run ?argv () = let run ?argv () =
Term.eval_choice ?argv main [ Term.eval_choice ?argv main [
temp_ligo_interpreter ;
compile_file ; compile_file ;
measure_contract ; measure_contract ;
compile_parameter ; compile_parameter ;

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

File diff suppressed because it is too large Load Diff

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

@ -21,7 +21,7 @@ let%expect_test _ =
run_ligo_good [ "interpret" ; "assert(1=1)" ; "--syntax=pascaligo" ] ; run_ligo_good [ "interpret" ; "assert(1=1)" ; "--syntax=pascaligo" ] ;
[%expect {| [%expect {|
Unit |}]; unit |}];
run_ligo_good [ "interpret" ; "assert(1=2)" ; "--syntax=pascaligo" ] ; run_ligo_good [ "interpret" ; "assert(1=2)" ; "--syntax=pascaligo" ] ;
[%expect {| [%expect {|
@ -29,7 +29,7 @@ let%expect_test _ =
run_ligo_good [ "interpret" ; "assert(1=1)" ; "--syntax=cameligo" ] ; run_ligo_good [ "interpret" ; "assert(1=1)" ; "--syntax=cameligo" ] ;
[%expect {| [%expect {|
Unit |}]; unit |}];
run_ligo_good [ "interpret" ; "assert(1=2)" ; "--syntax=cameligo" ] ; run_ligo_good [ "interpret" ; "assert(1=2)" ; "--syntax=cameligo" ] ;
[%expect {| [%expect {|

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 Subcommand: Interpret the expression in the context initialized by
the provided source file. the provided source file.
ligo-interpret
Subcommand: (temporary / dev only) uses LIGO interpret.
list-declarations list-declarations
Subcommand: List all the top-level declarations. Subcommand: List all the top-level declarations.
@ -120,6 +123,9 @@ let%expect_test _ =
Subcommand: Interpret the expression in the context initialized by Subcommand: Interpret the expression in the context initialized by
the provided source file. the provided source file.
ligo-interpret
Subcommand: (temporary / dev only) uses LIGO interpret.
list-declarations list-declarations
Subcommand: List all the top-level 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 _ = let%expect_test _ =
run_ligo_good ["interpret" ; "(\"edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7\":signature)" ; "--syntax=pascaligo"] ; run_ligo_good ["interpret" ; "(\"edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7\":signature)" ; "--syntax=pascaligo"] ;
[%expect {| signature edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7 |}] [%expect {| Signature edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7 |}]
let%expect_test _ = let%expect_test _ =
run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ; run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
[%expect {| [%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 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 _ = let%expect_test _ =
run_ligo_good [ "evaluate-value" ; "../../test/contracts/evaluation_tests.ligo" ; "a" ] ; run_ligo_good [ "evaluate-value" ; "../../test/contracts/evaluation_tests.ligo" ; "a" ] ;
[%expect {| [%expect {|
{foo = +0 , bar = "bar"} |} ]; record[bar -> "bar" , foo -> +0] |} ];
run_ligo_good [ "evaluate-value" ; "../../test/contracts/evaluation_tests.ligo" ; "b" ] ; run_ligo_good [ "evaluate-value" ; "../../test/contracts/evaluation_tests.ligo" ; "b" ] ;
[%expect {| [%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" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "main" ] ;
[%expect {| [%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 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" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "main" ] ;
[%expect {| [%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 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" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_7.mligo" ; "main" ] ;
[%expect {| [%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 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" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ;
[%expect {| [%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 If you're not sure how to fix this error, you can
do one of the following: do one of the following:

1
src/main/compile/dune
View File

@ -6,6 +6,7 @@
tezos-utils tezos-utils
parser parser
simplify simplify
interpreter
ast_simplified ast_simplified
self_ast_simplified self_ast_simplified
typer_new 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) ok @@ (prog_typed, state)
let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression) 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 let () = Typer.Solver.discard_state state in
Typer.type_expression_subst env state ae Typer.type_expression_subst env state ae
let apply (entry_point : string) (param : Ast_simplified.expression) : Ast_simplified.expression result = let apply (entry_point : string) (param : Ast_simplified.expression) : Ast_simplified.expression result =
let name = Var.of_name entry_point in let name = Var.of_name entry_point in
let entry_point_var : Ast_simplified.expression = 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 location = Virtual "generated entry-point variable" } in
let applied : Ast_simplified.expression = 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 location = Virtual "generated application" } in
ok applied 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 -> let compile : Ast_typed.program -> Mini_c.program result = fun p ->
Transpiler.transpile_program 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 Transpiler.transpile_annotated_expression e
type check_type = Check_parameter | Check_storage 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") ( 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 let%bind entry_point = Ast_typed.get_entry contract entry in
match entry_point.type_annotation.type_value' with match entry_point.type_expression.type_content with
| T_arrow (args,_) -> ( | T_arrow {type1=args} -> (
match args.type_value' with match args.type_content with
| T_operator (TC_tuple [param_exp;storage_exp]) -> ( | 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 match c with
| Check_parameter -> assert_type_value_eq (param_exp, param.type_annotation) | Check_parameter -> assert_type_expression_eq (param_exp, param.type_expression)
| Check_storage -> assert_type_value_eq (storage_exp, param.type_annotation) | Check_storage -> assert_type_expression_eq (storage_exp, param.type_expression)
) )
| _ -> dummy_fail | _ -> dummy_fail
) )
@ -25,3 +27,5 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As
let pretty_print ppf program = let pretty_print ppf program =
Ast_typed.PP.program 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 uncompile_value func_or_expr program entry ex_ty_value =
let%bind entry_expression = Ast_typed.get_entry program entry in let%bind entry_expression = Ast_typed.get_entry program entry in
let%bind output_type = match func_or_expr with let%bind output_type = match func_or_expr with
| Expression -> ok entry_expression.type_annotation | Expression -> ok entry_expression.type_expression
| Function -> | 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 ok output_type in
let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in let%bind mini_c = Compiler.Uncompiler.translate_value ex_ty_value in
let%bind typed = Transpiler.untranspile mini_c output_type 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 let selection_to_region = function
FieldName {region; _} FieldName {region; _}
| Component {region; _} -> region | Component {region; _} -> region
let map_ne_injection f ne_injection =
{ ne_injection with ne_elements = nsepseq_map f ne_injection.ne_elements }

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) | Error _ -> ok @@ make_t @@ T_variable (Var.of_name v.value)
) )
| TFun x -> ( | TFun x -> (
let%bind (a , b) = let%bind (type1 , type2) =
let (a , _ , b) = x.value in let (a , _ , b) = x.value in
let%bind a = simpl_type_expression a in let%bind a = simpl_type_expression a in
let%bind b = simpl_type_expression b in let%bind b = simpl_type_expression b in
ok (a , b) ok (a , b)
in in
ok @@ make_t @@ T_arrow (a , b) ok @@ make_t @@ T_arrow {type1;type2}
) )
| TApp x -> ( | TApp x -> (
let (name, tuple) = x.value in 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 | [hd] -> simpl_type_expression hd
| lst -> | lst ->
let%bind lst = bind_map_list simpl_type_expression lst in 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 : let rec simpl_expression :
Raw.expr -> expr result = fun t -> Raw.expr -> expr result = fun t ->
@ -261,13 +261,13 @@ let rec simpl_expression :
let path' = let path' =
let aux (s:Raw.selection) = let aux (s:Raw.selection) =
match s with match s with
FieldName property -> Access_record property.value FieldName property -> property.value
| Component index -> Access_tuple (Z.to_int (snd index.value)) | Component index -> Z.to_string (snd index.value)
in in
List.map aux @@ npseq_to_list path 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 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 match p with
| Raw.Name v -> (v.value , []) | Raw.Name v -> (v.value , [])
| Raw.Path p -> ( | Raw.Path p -> (
@ -277,8 +277,8 @@ let rec simpl_expression :
let path' = let path' =
let aux (s:Raw.selection) = let aux (s:Raw.selection) =
match s with match s with
| FieldName property -> Access_record property.value | FieldName property -> Label property.value
| Component index -> Access_tuple (Z.to_int (snd index.value)) | Component index -> Label (Z.to_string (snd index.value))
in in
List.map aux @@ npseq_to_list path in List.map aux @@ npseq_to_list path in
(var , path') (var , path')
@ -289,7 +289,9 @@ let rec simpl_expression :
let (name, path) = simpl_path u.record in let (name, path) = simpl_path u.record in
let record = match path with let record = match path with
| [] -> e_variable (Var.of_name name) | [] -> 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 updates = u.updates.value.ne_elements in
let%bind updates' = let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) = let aux (f:Raw.field_path_assign Raw.reg) =
@ -304,7 +306,7 @@ let rec simpl_expression :
| [] -> failwith "error in parsing" | [] -> failwith "error in parsing"
| hd :: [] -> ok @@ e_update ~loc record hd expr | hd :: [] -> ok @@ e_update ~loc record hd expr
| hd :: tl -> | 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 ok @@ e_update ~loc record hd expr
in in
aux ur path in aux ur path in
@ -352,19 +354,20 @@ let rec simpl_expression :
match variables with match variables with
| hd :: [] -> | hd :: [] ->
if (List.length prep_vars = 1) if (List.length prep_vars = 1)
then e_let_in hd inline rhs_b_expr body then e_let_in hd false inline rhs_b_expr body
else e_let_in hd inline (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - 1)]) body else e_let_in hd false inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body
| hd :: tl -> | hd :: tl ->
e_let_in hd e_let_in hd
false
inline 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) (chain_let_in tl body)
| [] -> body (* Precluded by corner case assertion above *) | [] -> body (* Precluded by corner case assertion above *)
in in
if List.length prep_vars = 1 if List.length prep_vars = 1
then ok (chain_let_in prep_vars body) then ok (chain_let_in prep_vars body)
(* Bind the right hand side so we only evaluate it once *) (* 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 *) (* let f p1 ps... = rhs in body *)
| (f, p1 :: ps) -> | (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 ((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)) @@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
@@ npseq_to_list r.ne_elements in @@ npseq_to_list r.ne_elements in
let map = SMap.of_list fields in return @@ e_record_ez ~loc fields
return @@ e_record ~loc map
| EProj p -> simpl_projection p | EProj p -> simpl_projection p
| EUpdate u -> simpl_update u | EUpdate u -> simpl_update u
| EConstr (ESomeApp a) -> | EConstr (ESomeApp a) ->
@ -501,7 +503,7 @@ let rec simpl_expression :
| Raw.PVar y -> | Raw.PVar y ->
let var_name = Var.of_name y.value in let var_name = Var.of_name y.value in
let%bind type_expr = simpl_type_expression x'.type_expr 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 ()
) )
| _ -> 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'))] 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 -> fun t ->
let open Raw in let open Raw in
let rec get_var (t:Raw.pattern) = 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 ()) in bind_or (as_option () , as_variant ())
let simpl_program : Raw.ast -> program result = fun t -> 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 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 get_value : 'a Raw.reg -> 'a = fun x -> x.value
let is_compiler_generated name = String.contains (Var.to_name name) '#' 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 let%bind aux = Self_ast_simplified.fold_expression
(fun (nlist, cur_loop : expression_variable list * bool) (ass_exp : expression) -> (fun (nlist, cur_loop : expression_variable list * bool) (ass_exp : expression) ->
if cur_loop then if cur_loop then
match ass_exp.expression with match ass_exp.expression_content with
| E_let_in {binder;rhs = _;result = _} -> | E_let_in {let_binder;mut=false;rhs = _;let_result = _} ->
let (name,_) = binder in let (name,_) = let_binder in
ok (name::nlist, cur_loop) ok (name::nlist, cur_loop)
| E_constant (C_MAP_FOLD, _) | E_constant {cons_name=C_MAP_FOLD;arguments= _}
| E_constant (C_SET_FOLD, _) | E_constant {cons_name=C_SET_FOLD;arguments= _}
| E_constant (C_LIST_FOLD, _) -> ok @@ (nlist, false) | E_constant {cons_name=C_LIST_FOLD;arguments= _} -> ok @@ (nlist, false)
| _ -> ok (nlist, cur_loop) | _ -> ok (nlist, cur_loop)
else else
ok @@ (nlist, cur_loop) ok @@ (nlist, cur_loop)
@ -35,17 +35,14 @@ let detect_local_declarations (for_body : expression) =
for_body in for_body in
ok @@ fst aux 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 let%bind captured_names = Self_ast_simplified.fold_expression
(fun (prev : expression_variable list) (ass_exp : expression) -> (fun (prev : expression_variable list) (ass_exp : expression) ->
match ass_exp.expression with match ass_exp.expression_content with
| E_assign ( name , _ , _ ) -> | E_constant {cons_name=n;arguments=[a;b]}
if is_compiler_generated name then ok prev
else ok (name::prev)
| E_constant (n, [a;b])
when n=C_OR || n=C_AND || n=C_LT || n=C_GT || 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 -> ( 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 -> | E_variable na , E_variable nb ->
let ret = [] in let ret = [] in
let ret = if not (is_compiler_generated na) then 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 ok @@ SSet.elements
@@ SSet.diff (SSet.of_list captured_names) (SSet.of_list local_decl_names) @@ 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 module Errors = struct
let unsupported_cst_constr p = let unsupported_cst_constr p =
let title () = "" in let title () = "" in
@ -78,18 +161,6 @@ module Errors = struct
] in ] in
error ~data title message 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 unknown_predefined_type name =
let title () = "\nType constants" in let title () = "\nType constants" in
let message () = let message () =
@ -196,16 +267,17 @@ let r_split = Location.r_split
[return_statement] is used for non-let-in statements. [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 match expr'_opt with
| None -> fail @@ corner_case ~loc:__LOC__ "missing return" | None -> ok @@ e_let_in ?loc binder mut inline rhs (e_skip ())
| Some expr' -> ok @@ e_let_in ?loc binder inline rhs expr' | Some expr' -> ok @@ e_let_in ?loc binder mut inline rhs expr'
let return_statement expr = ok @@ fun expr'_opt -> let return_statement expr = ok @@ fun expr'_opt ->
match expr'_opt with match expr'_opt with
| None -> ok @@ expr | None -> ok @@ expr
| Some expr' -> ok @@ e_sequence expr expr' | Some expr' -> ok @@ e_sequence expr expr'
let rec simpl_type_expression (t:Raw.type_expr) : type_expression result = let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
match t with match t with
TPar x -> simpl_type_expression x.value.inside 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%bind (a , b) =
let (a , _ , b) = x.value in let (a , _ , b) = x.value in
bind_map_pair simpl_type_expression (a , b) 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 -> | TApp x ->
let (name, tuple) = x.value in 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 | [hd] -> simpl_type_expression hd
| lst -> | lst ->
let%bind lst = bind_list @@ List.map simpl_type_expression lst in 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 simpl_projection : Raw.projection Region.reg -> _ = fun p ->
let (p' , loc) = r_split p in let (p' , loc) = r_split p in
@ -279,11 +351,11 @@ let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
let path' = let path' =
let aux (s:Raw.selection) = let aux (s:Raw.selection) =
match s with match s with
| FieldName property -> Access_record property.value | FieldName property -> property.value
| Component index -> Access_tuple (Z.to_int (snd index.value)) | Component index -> (Z.to_string (snd index.value))
in in
List.map aux @@ npseq_to_list path 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 = 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 expr = simpl_expression c.test in
let%bind match_true = simpl_expression c.ifso in let%bind match_true = simpl_expression c.ifso in
let%bind match_false = simpl_expression c.ifnot 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 -> ( | ECase c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind e = simpl_expression c.expr 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 @@ List.map get_value
@@ npseq_to_list c.cases.value in @@ npseq_to_list c.cases.value in
let%bind cases = simpl_cases lst 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) -> ( | EMap (MapInj mi) -> (
let (mi , loc) = r_split mi in 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 (name, path) = simpl_path u.record in
let record = match path with let record = match path with
| [] -> e_variable (Var.of_name name) | [] -> 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 updates = u.updates.value.ne_elements in
let%bind updates' = let%bind updates' =
let aux (f:Raw.field_path_assign Raw.reg) = 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" | [] -> failwith "error in parsing"
| hd :: [] -> ok @@ e_update ~loc record hd expr | hd :: [] -> ok @@ e_update ~loc record hd expr
| hd :: tl -> | 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 ok @@ e_update ~loc record hd expr
in in
aux ur path in aux ur path in
@ -584,7 +663,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
let name = x.name.value in let name = x.name.value in
let%bind t = simpl_type_expression x.var_type in let%bind t = simpl_type_expression x.var_type in
let%bind expression = simpl_expression x.init 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 -> | LocalConst x ->
let (x , loc) = r_split x in let (x , loc) = r_split x in
let name = x.name.value in let name = x.name.value in
@ -596,7 +675,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
| Some {value; _} -> | Some {value; _} ->
npseq_to_list value.ne_elements npseq_to_list value.ne_elements
|> List.exists (fun Region.{value; _} -> value = "\"inline\"") |> 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 -> | LocalFun f ->
let (f , loc) = r_split f in let (f , loc) = r_split f in
let%bind (binder, expr) = simpl_fun_decl ~loc 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; _} -> | Some {value; _} ->
npseq_to_list value.ne_elements npseq_to_list value.ne_elements
|> List.exists (fun Region.{value; _} -> value = "\"inline\"") |> 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 : and simpl_param :
Raw.param_decl -> (expression_variable * type_expression) result = Raw.param_decl -> (string * type_expression) result =
fun t -> fun t ->
match t with match t with
| ParamConst c -> | ParamConst c ->
let c = c.value in 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 let%bind type_expression = simpl_type_expression c.param_type in
ok (type_name , type_expression) ok (param_name , type_expression)
| ParamVar v -> | ParamVar v ->
let c = v.value in 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 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 : and simpl_fun_decl :
loc:_ -> Raw.fun_decl -> loc:_ -> Raw.fun_decl ->
@ -652,10 +731,10 @@ and simpl_fun_decl :
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body 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 (Some output_type) result in
let type_annotation = 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) ok ((Var.of_name fun_name.value, type_annotation), expression)
) )
| lst -> ( | lst -> (
@ -667,11 +746,11 @@ and simpl_fun_decl :
let type_expression = t_tuple (List.map snd params) in let type_expression = t_tuple (List.map snd params) in
(arguments_name , type_expression) in (arguments_name , type_expression) in
let%bind tpl_declarations = let%bind tpl_declarations =
let aux = fun i x -> let aux = fun i (param, type_expr) ->
let expr = let expr =
e_accessor (e_variable arguments_name) [Access_tuple i] in e_accessor (e_variable arguments_name) (string_of_int i) in
let type_variable = Some (snd x) in let type_variable = Some type_expr in
let ass = return_let_in (fst x , type_variable) inline expr in let ass = return_let_in (Var.of_name param , type_variable) false inline expr in
ass ass
in in
bind_list @@ List.mapi aux params in bind_list @@ List.mapi aux params in
@ -683,8 +762,8 @@ and simpl_fun_decl :
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body in bind_fold_right_list aux result body in
let expression = let expression =
e_lambda ~loc binder (Some input_type) (Some output_type) result in 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 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) ok ((Var.of_name fun_name.value, type_annotation), expression)
) )
) )
@ -706,11 +785,10 @@ and simpl_fun_expression :
let%bind result = let%bind result =
let aux prec cur = cur (Some prec) in let aux prec cur = cur (Some prec) in
bind_fold_right_list aux result body 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 (Some output_type) result in
let type_annotation = let type_annotation = Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
Some (make_t @@ T_arrow (input_type, output_type)) in ok (type_annotation , expression)
ok (type_annotation, expression)
) )
| lst -> ( | lst -> (
let lst = npseq_to_list lst in 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 let type_expression = t_tuple (List.map snd params) in
(arguments_name , type_expression) in (arguments_name , type_expression) in
let%bind tpl_declarations = let%bind tpl_declarations =
let aux = fun i x -> let aux = fun i (param, param_type) ->
let expr = let expr = e_accessor (e_variable arguments_name) (string_of_int i) in
e_accessor (e_variable arguments_name) [Access_tuple i] in let type_variable = Some param_type in
let type_variable = Some (snd x) in let ass = return_let_in (Var.of_name param , type_variable) false false expr in
let ass = return_let_in (fst x , type_variable) false expr in
ass ass
in in
bind_list @@ List.mapi aux params in bind_list @@ List.mapi aux params in
@ -738,8 +815,8 @@ and simpl_fun_expression :
bind_fold_right_list aux result body in bind_fold_right_list aux result body in
let expression = let expression =
e_lambda ~loc binder (Some (input_type)) (Some output_type) result in 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 let type_annotation = Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
ok (type_annotation, expression) ok (type_annotation , expression)
) )
) )
@ -770,6 +847,35 @@ and simpl_statement_list statements =
hook (simpl_data_declaration d :: acc) statements hook (simpl_data_declaration d :: acc) statements
in bind_list @@ hook [] (List.rev 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 = and simpl_single_instruction : Raw.instruction -> (_ -> expression result) result =
fun t -> fun t ->
match t with match t with
@ -799,19 +905,14 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
return_statement @@ e_skip ~loc () return_statement @@ e_skip ~loc ()
) )
| Loop (While l) -> | Loop (While l) ->
let l = l.value in simpl_while_loop l.value
let%bind cond = simpl_expression l.cond in | Loop (For (ForInt fi)) -> (
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)) ->
let%bind loop = simpl_for_int fi.value in let%bind loop = simpl_for_int fi.value in
let%bind loop = loop None in ok loop
return_statement @@ loop )
| Loop (For (ForCollect fc)) -> | Loop (For (ForCollect fc)) ->
let%bind loop = simpl_for_collect fc.value in let%bind loop = simpl_for_collect fc.value in
let%bind loop = loop None in ok loop
return_statement @@ loop
| Cond c -> ( | Cond c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = simpl_expression c.test 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 simpl_block value
| ShortBlock {value; _} -> | ShortBlock {value; _} ->
simpl_statements @@ fst value.inside in simpl_statements @@ fst value.inside in
let%bind match_true = match_true None in let env = Var.fresh () in
let%bind match_false = match_false None in
return_statement @@ e_matching expr ~loc (Match_bool {match_true; match_false}) 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 -> ( | Assign a -> (
let (a , loc) = r_split a in let (a , loc) = r_split a in
@ -843,7 +957,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
match a.lhs with match a.lhs with
| Path path -> ( | Path path -> (
let (name , path') = simpl_path path in 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 -> ( | MapPath v -> (
let v' = v.value in let v' = v.value in
@ -856,14 +971,16 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
in in
let%bind key_expr = simpl_expression v'.index.value.inside in let%bind key_expr = simpl_expression v'.index.value.inside in
let expr' = e_map_add key_expr value_expr map 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 -> ( | CaseInstr c -> (
let (c , loc) = r_split c in let (c , loc) = r_split c in
let%bind expr = simpl_expression c.expr in let%bind expr = simpl_expression c.expr in
let%bind cases = let env = Var.fresh () in
let aux (x : Raw.if_clause Raw.case_clause Raw.reg) = let%bind (fv,cases) =
let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) =
let%bind case_clause = let%bind case_clause =
match x.value.rhs with match x.value.rhs with
ClauseInstr i -> ClauseInstr i ->
@ -874,42 +991,43 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
simpl_block value simpl_block value
| ShortBlock {value; _} -> | ShortBlock {value; _} ->
simpl_statements @@ fst value.inside in simpl_statements @@ fst value.inside in
let%bind case_clause = case_clause None in let%bind case_clause'= case_clause @@ None in
ok (x.value.pattern, case_clause) in let%bind case_clause = case_clause @@ Some(e_variable env) in
bind_list let%bind case_vars = get_case_variables x.value.pattern in
@@ List.map aux let%bind ((_,free_vars), case_clause) = repair_mutable_variable case_clause case_vars env in
@@ npseq_to_list c.cases.value 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 let%bind m = simpl_cases cases in
return_statement @@ e_matching ~loc expr m 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 -> ( | RecordPatch r -> (
let r = r.value in let reg = r.region in
let (name , access_path) = simpl_path r.path in let (r,loc) = r_split r in
let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg=
let head, tail = r.record_inj.value.ne_elements in {value = {field_path = (fa.value.field_name, []); equal=fa.value.equal; field_expr = fa.value.field_expr};
region = fa.region}
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
in 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 -> ( | MapPatch patch -> (
let (map_p, loc) = r_split patch in 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') in ok @@ (key', value')
) )
@@ npseq_to_list map_p.map_inj.value.ne_elements in @@ npseq_to_list map_p.map_inj.value.ne_elements in
let expr =
match inj with match inj with
| [] -> e_skip ~loc () | [] -> return_statement @@ e_skip ~loc ()
| _ :: _ -> | _ :: _ ->
let assigns = List.fold_right let assigns = List.fold_right
(fun (key, value) map -> (e_map_add key value map)) (fun (key, value) map -> (e_map_add key value map))
inj inj
(e_accessor ~loc (e_variable (Var.of_name name)) access_path) (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
in e_assign ~loc name access_path assigns in
in return_statement @@ expr let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
return_let_in binder mut inline rhs
) )
| SetPatch patch -> ( | SetPatch patch -> (
let (setp, loc) = r_split patch in let (setp, loc) = r_split patch in
@ -941,15 +1059,14 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
bind_list @@ bind_list @@
List.map simpl_expression @@ List.map simpl_expression @@
npseq_to_list setp.set_inj.value.ne_elements in npseq_to_list setp.set_inj.value.ne_elements in
let expr =
match inj with match inj with
| [] -> e_skip ~loc () | [] -> return_statement @@ e_skip ~loc ()
| _ :: _ -> | _ :: _ ->
let assigns = List.fold_right let assigns = List.fold_right
(fun hd s -> e_constant C_SET_ADD [hd ; s]) (fun hd s -> e_constant C_SET_ADD [hd ; s])
inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in
e_assign ~loc name access_path assigns in let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
return_statement @@ expr return_let_in binder mut inline rhs
) )
| MapRemove r -> ( | MapRemove r -> (
let (v , loc) = r_split r in let (v , loc) = r_split r in
@ -963,7 +1080,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
in in
let%bind key' = simpl_expression key in let%bind key' = simpl_expression key in
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] 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 -> ( | SetRemove r -> (
let (set_rm, loc) = r_split r in let (set_rm, loc) = r_split r in
@ -976,10 +1094,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
in in
let%bind removed' = simpl_expression set_rm.element in let%bind removed' = simpl_expression set_rm.element in
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] 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 match p with
| Raw.Name v -> (v.value , []) | Raw.Name v -> (v.value , [])
| Raw.Path p -> ( | Raw.Path p -> (
@ -989,14 +1108,14 @@ and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
let path' = let path' =
let aux (s:Raw.selection) = let aux (s:Raw.selection) =
match s with match s with
| FieldName property -> Access_record property.value | FieldName property -> property.value
| Component index -> Access_tuple (Z.to_int (snd index.value)) | Component index -> (Z.to_string (snd index.value))
in in
List.map aux @@ npseq_to_list path in List.map aux @@ npseq_to_list path in
(var , path') (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 open Raw in
let get_var (t:Raw.pattern) = let get_var (t:Raw.pattern) =
match t with match t with
@ -1105,223 +1224,108 @@ and simpl_statements : Raw.statements -> (_ -> expression result) result =
and simpl_block : Raw.block -> (_ -> expression result) result = and simpl_block : Raw.block -> (_ -> expression result) result =
fun t -> simpl_statements t.statements 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 -> and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
(* cond part *) let env_rec = Var.fresh () in
let var = e_variable (Var.of_name fi.assign.value.name.value) 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 value = simpl_expression fi.assign.value.expr in
let%bind bound = simpl_expression fi.bound in let%bind bound = simpl_expression fi.bound in
let comp = e_annotation (e_constant C_LE [var ; bound]) t_bool let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in
in
(* body part *)
let%bind body = simpl_block fi.block.value in
let%bind body = body None in
let step = e_int 1 in let step = e_int 1 in
let ctrl = e_assign let ctrl =
fi.assign.value.name.value [] (e_constant C_ADD [ var ; step ]) in e_let_in (it,Some t_int) false false (e_constant C_ADD [ var ; step ])
let rec add_to_seq expr = match expr.expression with (e_let_in (binder, None) false false (e_update (e_variable binder) name var)
| E_sequence (_,a) -> add_to_seq a (e_variable binder))
| _ -> e_sequence body ctrl in in
let body' = add_to_seq body in (* Modify the body loop*)
let loop = e_loop comp body' in let%bind for_body = simpl_block fi.block.value in
return_statement @@ e_let_in (Var.of_name fi.assign.value.name.value, Some t_int) false value loop 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 let aux name expr=
For loops over collections, like e_let_in (name,None) false false (e_accessor (e_variable binder) (Var.to_name name)) expr
in
``` concrete syntax : (* restores the initial value of the free_var*)
for x : int in set myset let restore = fun expr -> List.fold_right aux captured_name_list expr in
begin
myint := myint + x ;
myst := myst ^ "to" ;
end
```
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 (* Make the fold_while en precharge the vakye *)
let #COMPILER#folded_record = list_fold( mylist , let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in
record st = st; acc = acc; end; let init_rec = store_mutable_variable @@ it::captured_name_list in
lamby = fun arguments -> ( let return_expr = e_let_in (env_rec,None) false false init_rec (loop) in
let #COMPILER#acc = arguments.0 in let return_expr = e_let_in (it, Some t_int) false false value @@ return_expr in
let #COMPILER#elt_x = arguments.1 in restore_mutable_variable return_expr captured_name_list env_rec
#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 ;
}
```
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 -> and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc ->
let elt_name = "#COMPILER#elt_"^fc.var.value in let _elt_name = fc.var.value in
let elt_v_name = match fc.bind_to with let binder = Var.of_name "arguments" in
| Some v -> "#COMPILER#elt_"^(snd v).value let%bind element_names = ok @@ match fc.bind_to with
| None -> "#COMPILER#elt_unused" in
let element_names = ok @@ match fc.bind_to with
| Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value] | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value]
| None -> [Var.of_name fc.var.value] in | 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 = simpl_block fc.block.value in
let%bind for_body = for_body None in let%bind _for_body' = for_body None in
(* STEP 2 *) let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in
let%bind local_decl_name_list = bind_concat (detect_local_declarations for_body) element_names in let%bind ((_,free_vars), for_body) = repair_mutable_variable_for_collect for_body element_names binder in
let%bind captured_name_list = detect_free_variables for_body local_decl_name_list in
(* STEP 3 *) let init_record = store_mutable_variable free_vars in
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 collect = simpl_expression fc.expr 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 let op_name = match fc.collection with
| Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in | Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in
let fold = e_constant op_name [lambda; collect ; init_record] in let fold = e_constant op_name [lambda; collect ; init_record] in
(* STEP 8 *) restore_mutable_variable fold free_vars env
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
and simpl_declaration_list declarations : and simpl_declaration_list declarations :
Ast_simplified.declaration Location.wrap list result = 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 Ast_simplified
open Trace open Trace
open Stage_common.Helpers
type 'a folder = 'a -> expression -> 'a result type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e -> let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
let self = fold_expression f in let self = fold_expression f in
let%bind init' = f init e 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_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 let%bind res = bind_fold_list self init' lst in
ok res 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 let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
ok res 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 let%bind res = bind_fold_pair self init' ab in
ok res ok res
) )
| E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e } | 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 let%bind res = self init' e in
ok res ok res
) )
| E_assign (_ , _path , e) | E_accessor (e , _path) -> ( | E_matching {matchee=e; cases} -> (
let%bind res = self init' e in
ok res
)
| E_matching (e , cases) -> (
let%bind res = self init' e in let%bind res = self init' e in
let%bind res = fold_cases f res cases in let%bind res = fold_cases f res cases in
ok res 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 let%bind res = bind_fold_lmap aux (ok init') m in
ok res ok res
) )
| E_update {record;update=(_,expr)} -> ( | E_record_update {record;update} -> (
let%bind res = self init' record in 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 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 init' rhs in
let%bind res = self res result in let%bind res = self res let_result in
ok res ok res
) )
@ -85,8 +94,8 @@ type mapper = expression -> expression result
let rec map_expression : mapper -> expression -> expression result = fun f e -> let rec map_expression : mapper -> expression -> expression result = fun f e ->
let self = map_expression f in let self = map_expression f in
let%bind e' = f e in let%bind e' = f e in
let return expression = ok { e' with expression } in let return expression_content = ok { e' with expression_content } in
match e'.expression with match e'.expression_content with
| E_list lst -> ( | E_list lst -> (
let%bind lst' = bind_map_list self lst in let%bind lst' = bind_map_list self lst in
return @@ E_list lst' 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 let%bind lst' = bind_map_list (bind_map_pair self) lst in
return @@ E_big_map lst' 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 -> ( | E_look_up ab -> (
let%bind ab' = bind_map_pair self ab in let%bind ab' = bind_map_pair self ab in
return @@ E_look_up ab' return @@ E_look_up ab'
) )
| E_loop ab -> ( | E_loop {condition;body} -> (
let%bind ab' = bind_map_pair self ab in let ab = (condition,body) in
return @@ E_loop ab' let%bind (a,b) = bind_map_pair self ab in
return @@ E_loop {condition = a; body = b}
) )
| E_ascription (e , t) -> ( | E_ascription ascr -> (
let%bind e' = self e in let%bind e' = self ascr.anno_expr in
return @@ E_ascription (e' , t) return @@ E_ascription {ascr with anno_expr=e'}
) )
| E_assign (name , path , e) -> ( | E_matching {matchee=e;cases} -> (
let%bind e' = self e in
return @@ E_assign (name , path , e')
)
| E_matching (e , cases) -> (
let%bind e' = self e in let%bind e' = self e in
let%bind cases' = map_cases f cases 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) -> ( | E_record_accessor acc -> (
let%bind e' = self e in let%bind e' = self acc.expr in
return @@ E_accessor (e' , path) return @@ E_record_accessor {acc with expr = e'}
) )
| E_record m -> ( | E_record m -> (
let%bind m' = bind_map_lmap self m in let%bind m' = bind_map_lmap self m in
return @@ E_record m' return @@ E_record m'
) )
| E_update {record; update=(l,expr)} -> ( | E_record_update {record; path; update} -> (
let%bind record = self record in let%bind record = self record in
let%bind expr = self expr in let%bind update = self update in
return @@ E_update {record;update=(l,expr)} return @@ E_record_update {record;path;update}
) )
| E_constructor (name , e) -> ( | E_constructor c -> (
let%bind e' = self e in let%bind e' = self c.element in
return @@ E_constructor (name , e') return @@ E_constructor {c with element = e'}
) )
| E_tuple lst -> ( | E_application {expr1;expr2} -> (
let%bind lst' = bind_map_list self lst in let ab = (expr1,expr2) in
return @@ E_tuple lst' let%bind (a,b) = bind_map_pair self ab in
return @@ E_application {expr1=a;expr2=b}
) )
| E_application ab -> ( | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
let%bind ab' = bind_map_pair self ab in
return @@ E_application ab'
)
| E_let_in { binder ; rhs ; result; inline } -> (
let%bind rhs = self rhs in let%bind rhs = self rhs in
let%bind result = self result in let%bind let_result = self let_result in
return @@ E_let_in { binder ; rhs ; result; inline } return @@ E_let_in { let_binder ; mut; rhs ; let_result; inline }
) )
| E_lambda { binder ; input_type ; output_type ; result } -> ( | E_lambda { binder ; input_type ; output_type ; result } -> (
let%bind result = self result in let%bind result = self result in
return @@ E_lambda { binder ; input_type ; output_type ; result } return @@ E_lambda { binder ; input_type ; output_type ; result }
) )
| E_constant (name , lst) -> ( | E_constant c -> (
let%bind lst' = bind_map_list self lst in let%bind args = bind_map_list self c.arguments in
return @@ E_constant (name , lst') return @@ E_constant {c with arguments=args}
) )
| E_literal _ | E_variable _ | E_skip as e' -> return e' | 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 | Declaration_type _ -> ok x
in in
bind_map_list (bind_map_location aux) p 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 open Errors
let peephole_expression : expression -> expression result = fun e -> let peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in let return expression_content = ok { e with expression_content } in
match e.expression with match e.expression_content with
| E_literal (Literal_key_hash s) as l -> ( | E_literal (Literal_key_hash s) as l -> (
let open Tezos_crypto in let open Tezos_crypto in
let%bind (_pkh:Crypto.Signature.public_key_hash) = 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 Signature.Public_key.of_b58check s in
return l 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 = let%bind elt =
trace_option (bad_single_arity cst e.location) @@ trace_option (bad_single_arity cst e.location) @@
List.to_singleton lst List.to_singleton lst
in in
let%bind lst = let%bind lst =
trace_strong (bad_map_param_type cst e.location) @@ trace_strong (bad_map_param_type cst e.location) @@
get_e_list elt.expression get_e_list elt.expression_content
in in
let aux = fun (e' : expression) -> let aux = fun (e : expression) ->
trace_strong (bad_map_param_type cst e.location) @@ 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) = let%bind (a , b) =
trace_option (simple_error "of pairs") @@ trace_option (simple_error "of pairs") @@
List.to_pair tpl 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 let%bind pairs = bind_map_list aux lst in
return @@ E_big_map pairs 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 = let%bind elt =
trace_option (bad_single_arity cst e.location) @@ trace_option (bad_single_arity cst e.location) @@
List.to_singleton lst List.to_singleton lst
in in
let%bind lst = let%bind lst =
trace_strong (bad_map_param_type cst e.location) @@ trace_strong (bad_map_param_type cst e.location) @@
get_e_list elt.expression get_e_list elt.expression_content
in in
let aux = fun (e' : expression) -> let aux = fun (e : expression) ->
trace_strong (bad_map_param_type cst e.location) @@ 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) = let%bind (a , b) =
trace_option (simple_error "of pairs") @@ trace_option (simple_error "of pairs") @@
List.to_pair tpl 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 let%bind pairs = bind_map_list aux lst in
return @@ E_map pairs 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 () = let%bind () =
trace_strong (bad_empty_arity cst e.location) @@ trace_strong (bad_empty_arity cst e.location) @@
Assert.assert_list_empty lst Assert.assert_list_empty lst
in in
return @@ E_big_map [] 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 () = let%bind () =
trace_strong (bad_empty_arity cst e.location) @@ trace_strong (bad_empty_arity cst e.location) @@
Assert.assert_list_empty lst Assert.assert_list_empty lst
in in
return @@ E_map [] 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 = let%bind elt =
trace_option (bad_single_arity cst e.location) @@ trace_option (bad_single_arity cst e.location) @@
List.to_singleton lst List.to_singleton lst
in in
let%bind lst = let%bind lst =
trace_strong (bad_set_param_type cst e.location) @@ trace_strong (bad_set_param_type cst e.location) @@
get_e_list elt.expression get_e_list elt.expression_content
in in
return @@ E_set lst 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 () = let%bind () =
trace_strong (bad_empty_arity cst e.location) @@ trace_strong (bad_empty_arity cst e.location) @@
Assert.assert_list_empty lst 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 open Trace
let peephole_expression : expression -> expression result = fun e -> let peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in let return expression_content = ok { e with expression_content } in
match e.expression with match e.expression_content with
| E_constructor (Constructor "Some" , e) -> return @@ E_constant (C_SOME , [ e ]) | E_constructor {constructor=Constructor "Some";element=e} -> return @@ E_constant {cons_name=C_SOME;arguments=[ e ]}
| E_constructor (Constructor "None" , _) -> return @@ E_constant (C_NONE , [ ]) | E_constructor {constructor=Constructor "None"; _} -> return @@ E_constant {cons_name=C_NONE ; arguments=[]}
| e -> return e | 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 map_expression = Helpers.map_expression
let fold_expression = Helpers.fold_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 open Errors
let peephole_expression : expression -> expression result = fun e -> let peephole_expression : expression -> expression result = fun e ->
let return expression = ok { e with expression } in let return expression_content = ok { e with expression_content } in
match e.expression with match e.expression_content with
| E_ascription (e' , t) as e -> ( | E_ascription {anno_expr=e'; type_annotation=t} as e -> (
match (e'.expression , t.type_expression') with 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_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_signature)) -> return @@ E_literal (Literal_signature s)
| (E_literal (Literal_string s) , T_constant (TC_key)) -> return @@ E_literal (Literal_key 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 let ct = match c_tag with
| Solver.Core.C_arrow -> "arrow" | Solver.Core.C_arrow -> "arrow"
| Solver.Core.C_option -> "option" | Solver.Core.C_option -> "option"
| Solver.Core.C_tuple -> "tuple"
| Solver.Core.C_record -> failwith "record" | Solver.Core.C_record -> failwith "record"
| Solver.Core.C_variant -> failwith "variant" | Solver.Core.C_variant -> failwith "variant"
| Solver.Core.C_map -> "map" | Solver.Core.C_map -> "map"

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

@ -9,13 +9,13 @@ module Wrap = struct
module Errors = 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 let title = (thunk "unknown type constructor") in
(* TODO: sanitize the "ctor" argument before displaying it. *) (* TODO: sanitize the "ctor" argument before displaying it. *)
let message () = ctor in let message () = ctor in
let data = [ let data = [
("ctor" , fun () -> ctor) ; ("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 *) (* ("location" , fun () -> Format.asprintf "%a" Location.pp te.location) *) (* TODO *)
] in ] in
error ~data title message () error ~data title message ()
@ -32,16 +32,17 @@ module Wrap = struct
(* let%bind state' = add_type state t in *) (* let%bind state' = add_type state t in *)
(* return expr state' in *) (* return expr state' in *)
let rec type_expression_to_type_value : T.type_value -> O.type_value = fun te -> let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun te ->
match te.type_value' with match te.type_content with
| T_sum kvmap -> | 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 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) P_constant (C_variant, T.CMap.to_list @@ T.CMap.map type_expression_to_type_value kvmap)
| T_record 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 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) P_constant (C_record, T.LMap.to_list @@ T.LMap.map type_expression_to_type_value kvmap)
| T_arrow (arg , ret) -> | T_arrow {type1;type2} ->
P_constant (C_arrow, List.map type_expression_to_type_value [ arg ; ret ]) P_constant (C_arrow, List.map type_expression_to_type_value [ type1 ; type2 ])
| T_variable (type_name) -> P_variable type_name | T_variable (type_name) -> P_variable type_name
| T_constant (type_name) -> | T_constant (type_name) ->
let csttag = Core.(match type_name with let csttag = Core.(match type_name with
@ -58,7 +59,8 @@ module Wrap = struct
| TC_key -> C_key | TC_key -> C_key
| TC_signature -> C_signature | TC_signature -> C_signature
| TC_operation -> C_operation | 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 in
P_constant (csttag, []) P_constant (csttag, [])
@ -68,25 +70,24 @@ module Wrap = struct
| TC_set s -> (C_set, [s]) | TC_set s -> (C_set, [s])
| TC_map ( k , v ) -> (C_map, [k;v]) | TC_map ( k , v ) -> (C_map, [k;v])
| TC_big_map ( k , v) -> (C_big_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_list l -> (C_list, [l])
| TC_contract c -> (C_contract, [c]) | TC_contract c -> (C_contract, [c])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
| TC_tuple lst -> (C_tuple, lst)
) )
in in
P_constant (csttag, List.map type_expression_to_type_value args) 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 -> 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 -> | 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 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) P_constant (C_variant, I.CMap.to_list @@ I.CMap.map type_expression_to_type_value_copypasted kvmap)
| T_record 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 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) P_constant (C_record, I.LMap.to_list @@ I.LMap.map type_expression_to_type_value_copypasted kvmap)
| T_arrow (arg , ret) -> | T_arrow {type1;type2} ->
P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ arg ; ret ]) P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ type1 ; type2 ])
| T_variable type_name -> P_variable type_name | T_variable type_name -> P_variable (type_name) (* eird stuff*)
| T_constant (type_name) -> | T_constant (type_name) ->
let csttag = Core.(match type_name with let csttag = Core.(match type_name with
| TC_unit -> C_unit | TC_unit -> C_unit
@ -104,7 +105,6 @@ module Wrap = struct
| TC_big_map ( k , v ) -> (C_big_map, [k;v]) | TC_big_map ( k , v ) -> (C_big_map, [k;v])
| TC_contract c -> (C_contract, [c]) | TC_contract c -> (C_contract, [c])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ]) | TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
| TC_tuple lst -> (C_tuple, lst)
) )
in in
P_constant (csttag, List.map type_expression_to_type_value_copypasted args) 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 let type_name = Core.fresh_type_variable () in
[] , type_name [] , 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 pattern = type_expression_to_type_value expr in
let type_name = Core.fresh_type_variable () in let type_name = Core.fresh_type_variable () in
[C_equation (P_variable (type_name) , pattern)] , type_name [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 pattern = type_expression_to_type_value t in
let type_name = Core.fresh_type_variable () in let type_name = Core.fresh_type_variable () in
[C_equation (P_variable (type_name) , pattern)] , type_name [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 [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 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 let type_name = Core.fresh_type_variable () in
[C_equation (P_variable (type_name) , pattern)] , type_name [C_equation (P_variable (type_name) , pattern)] , type_name
@ -165,16 +165,13 @@ module Wrap = struct
end end
(* TODO: I think we should take an I.expression for the base+label *) (* 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 base' = type_expression_to_type_value base in
let expr_type = Core.fresh_type_variable () in let expr_type = Core.fresh_type_variable () in
[O.C_access_label (base' , label , expr_type)] , expr_type [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 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 -> = fun t_arg c_arg sum ->
let t_arg = type_expression_to_type_value t_arg in let t_arg = type_expression_to_type_value t_arg in
let c_arg = type_expression_to_type_value c_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) C_equation (t_arg , c_arg)
] , whole_expr ] , 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 record_type = type_expression_to_type_value (T.t_record fields ()) in
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
[C_equation (P_variable whole_expr , record_type)] , whole_expr [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 -> fun ctor element_tys ->
let elttype = O.P_variable (Core.fresh_type_variable ()) in let elttype = O.P_variable (Core.fresh_type_variable ()) in
let aux elt = let aux elt =
@ -205,7 +202,7 @@ module Wrap = struct
let list = collection O.C_list let list = collection O.C_list
let set = collection O.C_set 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 -> fun kv_tys ->
let k_type = O.P_variable (Core.fresh_type_variable ()) in let k_type = O.P_variable (Core.fresh_type_variable ()) in
let v_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])) C_equation (P_variable whole_expr , O.P_constant (C_map , [k_type ; v_type]))
] @ equations_k @ equations_v , whole_expr ] @ 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 -> fun kv_tys ->
let k_type = O.P_variable (Core.fresh_type_variable ()) in let k_type = O.P_variable (Core.fresh_type_variable ()) in
let v_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])) C_equation (P_variable whole_expr , O.P_constant (C_big_map , [k_type ; v_type]))
] @ equations_k @ equations_v , whole_expr ] @ 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 -> fun f arg ->
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
let f' = type_expression_to_type_value f 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])) C_equation (f' , P_constant (C_arrow , [arg' ; P_variable whole_expr]))
] , 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 -> fun ds ind ->
let ds' = type_expression_to_type_value ds in let ds' = type_expression_to_type_value ds in
let ind' = type_expression_to_type_value ind 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])) C_equation (P_variable whole_expr , P_constant (C_option , [P_variable v]))
] , whole_expr ] , 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 -> fun a b ->
let a' = type_expression_to_type_value a in let a' = type_expression_to_type_value a in
let b' = type_expression_to_type_value b in let b' = type_expression_to_type_value b in
@ -271,7 +268,7 @@ module Wrap = struct
C_equation (b' , P_variable whole_expr) C_equation (b' , P_variable whole_expr)
] , 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 -> fun expr body ->
let expr' = type_expression_to_type_value expr in let expr' = type_expression_to_type_value expr in
let body' = type_expression_to_type_value body 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 , [])) C_equation (P_variable whole_expr , P_constant (C_unit , []))
] , whole_expr ] , 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 -> fun rhs rhs_tv_opt result ->
let rhs' = type_expression_to_type_value rhs in let rhs' = type_expression_to_type_value rhs in
let result' = type_expression_to_type_value result in let result' = type_expression_to_type_value result in
@ -294,7 +291,7 @@ module Wrap = struct
C_equation (result' , P_variable whole_expr) C_equation (result' , P_variable whole_expr)
] @ rhs_tv_opt', 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 -> fun v e ->
let v' = type_expression_to_type_value v in let v' = type_expression_to_type_value v in
let e' = type_expression_to_type_value e 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 , [])) C_equation (P_variable whole_expr , P_constant (C_unit , []))
] , whole_expr ] , 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 -> fun e annot ->
let e' = type_expression_to_type_value e in let e' = type_expression_to_type_value e in
let annot' = type_expression_to_type_value annot in let annot' = type_expression_to_type_value annot in
@ -314,20 +311,20 @@ module Wrap = struct
C_equation (e' , P_variable whole_expr) C_equation (e' , P_variable whole_expr)
] , 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 -> fun es ->
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
let type_values = (List.map type_expression_to_type_value es) in 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_values let cs = List.map (fun e -> O.C_equation (P_variable whole_expr , e)) type_expressions
in cs, whole_expr in cs, whole_expr
let fresh_binder () = let fresh_binder () =
Core.fresh_type_variable () Core.fresh_type_variable ()
let lambda let lambda
: T.type_value -> : T.type_expression ->
T.type_value option -> T.type_expression option ->
T.type_value option -> T.type_expression option ->
(constraints * T.type_variable) = (constraints * T.type_variable) =
fun fresh arg body -> fun fresh arg body ->
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
@ -347,11 +344,11 @@ module Wrap = struct
] @ arg' @ body' , whole_expr ] @ arg' @ body' , whole_expr
(* This is pretty much a wrapper for an n-ary function. *) (* This is pretty much a wrapper for an n-ary function. *)
let constant : O.type_value -> T.type_value list -> (constraints * T.type_variable) = let constant : O.type_value -> T.type_expression list -> (constraints * T.type_variable) =
fun f args -> fun f args ->
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
let args' = List.map type_expression_to_type_value args in let args' = List.map type_expression_to_type_value args in
let args_tuple = O.P_constant (C_tuple , args') in let args_tuple = O.P_constant (C_record , args') in
O.[ O.[
C_equation (f , P_constant (C_arrow , [args_tuple ; P_variable whole_expr])) C_equation (f , P_constant (C_arrow , [args_tuple ; P_variable whole_expr]))
] , whole_expr ] , whole_expr
@ -441,8 +438,8 @@ and c_constructor_simpl = {
tv_list : type_variable list; tv_list : type_variable list;
} }
(* copy-pasted from core.ml *) (* copy-pasted from core.ml *)
and c_const = (type_variable * type_value) and c_const = (type_variable * type_expression)
and c_equation = (type_value * type_value) and c_equation = (type_expression * type_expression)
and c_typeclass_simpl = { and c_typeclass_simpl = {
tc : typeclass ; tc : typeclass ;
args : type_variable list ; args : type_variable list ;
@ -742,97 +739,93 @@ let compare_simple_c_constant = function
| C_arrow -> (function | C_arrow -> (function
(* N/A -> 1 *) (* N/A -> 1 *)
| C_arrow -> 0 | 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 | 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_option -> (function
| C_arrow -> 1 | C_arrow -> 1
| C_option -> 0 | 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 | 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_record -> (function
| C_arrow | C_option | C_tuple -> 1 | C_arrow | C_option -> 1
| C_record -> 0 | 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 | 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_variant -> (function
| C_arrow | C_option | C_tuple | C_record -> 1 | C_arrow | C_option | C_record -> 1
| C_variant -> 0 | 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 | 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_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant -> 1 | C_arrow | C_option | C_record | C_variant -> 1
| C_map -> 0 | 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 | 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_big_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1 | C_arrow | C_option | C_record | C_variant | C_map -> 1
| C_big_map -> 0 | 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 | 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_list -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1 | C_arrow | C_option | C_record | C_variant | C_map | C_big_map -> 1
| C_list -> 0 | 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 | 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_set -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1 | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list -> 1
| C_set -> 0 | 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 | 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_unit -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1 | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
| C_unit -> 0 | 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 | 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_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_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1
| C_bool -> 0 | 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 | 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_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_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_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 | 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_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_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_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 | 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_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_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_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 | 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_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_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_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 | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_int -> (function | 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_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_int -> 0
| C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_address -> (function | 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_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_address -> 0
| C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_bytes -> (function | 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_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_bytes -> 0
| C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key_hash -> (function | 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_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_hash -> 0
| C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key -> (function | 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_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_key -> 0
| C_signature | C_operation | C_contract | C_chain_id -> -1) | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_signature -> (function | 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_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_signature -> 0
| C_operation | C_contract | C_chain_id -> -1) | C_operation | C_contract | C_chain_id -> -1)
| C_operation -> (function | 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_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_operation -> 0
| C_contract | C_chain_id -> -1) | C_contract | C_chain_id -> -1)
| C_contract -> (function | 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_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_contract -> 0
| C_chain_id -> -1) | C_chain_id -> -1)
| C_chain_id -> (function | 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_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 | C_chain_id -> 0
(* N/A -> -1 *) (* N/A -> -1 *)
) )
@ -844,7 +837,6 @@ let debug_pp_constant : _ -> constant_tag -> unit = fun ppf c_tag ->
let ct = match c_tag with let ct = match c_tag with
| Core.C_arrow -> "arrow" | Core.C_arrow -> "arrow"
| Core.C_option -> "option" | Core.C_option -> "option"
| Core.C_tuple -> "tuple"
| Core.C_record -> failwith "record" | Core.C_record -> failwith "record"
| Core.C_variant -> failwith "variant" | Core.C_variant -> failwith "variant"
| Core.C_map -> "map" | Core.C_map -> "map"
@ -910,16 +902,17 @@ let rec compare_list f = function
| [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *) | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *)
let compare_type_variable a b = let compare_type_variable a b =
Var.compare a b Var.compare a b
let compare_label = function let compare_label (a:accessor) (b:accessor) =
| L_int a -> (function L_int b -> Int.compare a b | L_string _ -> -1) let Label a = a in
| L_string a -> (function L_int _ -> 1 | L_string b -> String.compare a b) let Label b = b in
let rec compare_typeclass a b = compare_list (compare_list compare_type_value) a b String.compare a b
and compare_type_value = function 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=a1; constraints=a2; body=a3 } -> (function
| P_forall { binder=b1; constraints=b2; body=b3 } -> | P_forall { binder=b1; constraints=b2; body=b3 } ->
compare_type_variable a1 b1 <? fun () -> compare_type_variable a1 b1 <? fun () ->
compare_list compare_type_constraint a2 b2 <? fun () -> compare_list compare_type_constraint a2 b2 <? fun () ->
compare_type_value a3 b3 compare_type_expression a3 b3
| P_variable _ -> -1 | P_variable _ -> -1
| P_constant _ -> -1 | P_constant _ -> -1
| P_apply _ -> -1) | P_apply _ -> -1)
@ -931,33 +924,33 @@ and compare_type_value = function
| P_constant (a1, a2) -> (function | P_constant (a1, a2) -> (function
| P_forall _ -> 1 | P_forall _ -> 1
| P_variable _ -> 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 _ -> -1)
| P_apply (a1, a2) -> (function | P_apply (a1, a2) -> (function
| P_forall _ -> 1 | P_forall _ -> 1
| P_variable _ -> 1 | P_variable _ -> 1
| P_constant _ -> 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 and compare_type_constraint = function
| C_equation (a1, a2) -> (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_typeclass _ -> -1
| C_access_label _ -> -1) | C_access_label _ -> -1)
| C_typeclass (a1, a2) -> (function | C_typeclass (a1, a2) -> (function
| C_equation _ -> 1 | 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 _ -> -1)
| C_access_label (a1, a2, a3) -> (function | C_access_label (a1, a2, a3) -> (function
| C_equation _ -> 1 | C_equation _ -> 1
| C_typeclass _ -> 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_type_constraint_list = compare_list compare_type_constraint
let compare_p_forall let compare_p_forall
{ binder = a1; constraints = a2; body = a3 } { binder = a1; constraints = a2; body = a3 }
{ binder = b1; constraints = b2; body = b3 } = { binder = b1; constraints = b2; body = b3 } =
compare_type_variable a1 b1 <? fun () -> compare_type_variable a1 b1 <? fun () ->
compare_type_constraint_list a2 b2 <? 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 } = let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } =
compare_type_variable a1 b1 <? fun () -> compare_type_variable a1 b1 <? fun () ->
compare_p_forall a2 b2 compare_p_forall a2 b2
@ -1110,7 +1103,7 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s
* unification_vars : unionfind ; * unification_vars : unionfind ;
* *
* (\* assigns a value to the representant in the 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 related to a type variable *\)
* constraints : constraints TypeVariableMap.t ; * constraints : constraints TypeVariableMap.t ;
@ -1151,7 +1144,7 @@ let initial_state : state = (* {
let discard_state (_ : state) = () let discard_state (_ : state) = ()
(* let replace_var_in_state = fun (v : type_variable) (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_forall (w , cs , tval) -> failwith "TODO" *)
(* | P_variable (w) -> *) (* | P_variable (w) -> *)
(* if w = v then *) (* if w = v then *)

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

@ -15,7 +15,7 @@ module Errors = struct
let title = (thunk "unbound type variable") in let title = (thunk "unbound type variable") in
let message () = "" in let message () = "" in
let data = [ 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. *) (* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *) (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
@ -23,7 +23,7 @@ module Errors = struct
error ~data title message () error ~data title message ()
let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () = 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 title = (thunk ("unbound variable "^(name ()))) in
let message () = "" in let message () = "" in
let data = [ let data = [
@ -33,7 +33,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "match with no cases") in let title = (thunk "match with no cases") in
let message () = "" in let message () = "" in
@ -43,7 +43,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "missing case in match") in
let message () = "" in let message () = "" in
@ -53,7 +53,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "redundant case in match") in let title = (thunk "redundant case in match") in
let message () = "" in let message () = "" in
@ -63,11 +63,11 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "unbound constructor") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
@ -103,27 +103,27 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "typing constant declaration") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () -> ("expected" , fun () ->
match expected with match expected with
None -> "(no annotation for the expected type)" 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) ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in ] in
error ~data title message () 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 () -> fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in let title = (thunk "typing match") in
let message () = msg in let message () = msg in
let data = [ let data = [
("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected); ("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) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
@ -148,39 +148,17 @@ module Errors = struct
* ] in * ] in
* error ~data title message () *) * 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 title = (thunk "type error") in
let message () = msg in let message () = msg in
let data = [ let data = [
("expected" , fun () -> Format.asprintf "%a" O.PP.type_value expected); ("expected" , fun () -> Format.asprintf "%a" O.PP.type_expression 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) ; ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () 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 not_supported_yet_untranspile (message : string) (ae : O.expression) () =
let title = (thunk "not supported yet") in let title = (thunk "not supported yet") in
let message () = message 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 let rec type_declaration env state : I.declaration -> (environment * Solver.state * O.declaration option) result = function
| Declaration_type (type_name , type_expression) -> | Declaration_type (type_name , type_expression) ->
let%bind tv = evaluate_type env type_expression in 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) ok (env', state , None)
| Declaration_constant (name , tv_opt , inline, expression) -> ( | 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) @@ trace (constant_declaration_error name expression tv'_opt) @@
type_expression env state expression in type_expression env state expression in
let env' = Environment.add_ez_ae name ae' env 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 fun e state t i ae loc -> match i with
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
let%bind _ = let%bind _ =
@ -285,7 +263,7 @@ and type_match : environment -> Solver.state -> O.type_value -> ('i, unit) I.mat
~expression:ae ~expression:ae
loc loc
) @@ ) @@
Ast_typed.assert_type_value_eq (variant , variant') >>? fun () -> Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
ok (Some variant) ok (Some variant)
) in ) in
ok acc 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 Recursively search the type_expression and return a result containing the
type_value at the leaves 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 let return tv' = ok (make_t tv' (Some t)) in
match t.type_expression' with match t.type_content with
| T_arrow (a, b) -> | T_arrow {type1;type2} ->
let%bind a' = evaluate_type e a in let%bind type1 = evaluate_type e type1 in
let%bind b' = evaluate_type e b in let%bind type2 = evaluate_type e type2 in
return (T_arrow (a', b')) return (T_arrow {type1;type2})
| T_sum m -> | T_sum m ->
let aux k v prev = let aux k v prev =
let%bind prev' = prev in 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 -> | T_variable name ->
let%bind tv = let%bind tv =
trace_option (unbound_type_variable e name) trace_option (unbound_type_variable e name)
@@ Environment.get_type_opt name e in @@ Environment.get_type_opt (name) e in
ok tv ok tv
| T_constant cst -> | T_constant cst ->
return (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 arg' = evaluate_type e arg in
let%bind ret' = evaluate_type e ret in let%bind ret' = evaluate_type e ret in
ok @@ O.TC_arrow ( arg' , ret' ) 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 in
return (T_operator (opt)) 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 () = 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 open Solver in
let module L = Logger.Stateful() 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 ] in
error ~data title content in error ~data title content in
trace main_error @@ 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 (* TODO: this file should take care only of the order in which program fragments
are translated by Wrap.xyz 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 * return expr'' state' constraints expr_type
* ) *) * ) *)
| E_variable name -> ( | E_variable name -> (
let name'= name in
let%bind (tv' : Environment.element) = let%bind (tv' : Environment.element) =
trace_option (unbound_variable e name ae.location) 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 (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 return expr' state constraints expr_type
) )
| E_literal (Literal_bool b) -> ( | 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) -> ( | E_literal (Literal_unit) -> (
return_wrapped (e_unit ()) state @@ Wrap.literal (t_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 -> (
(* E_skip just returns unit *) (* E_skip just returns unit *)
return_wrapped (e_unit ()) state @@ Wrap.literal (t_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 ()) * | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ())
* | _ -> return (E_literal (Literal_string s)) (t_string ()) * | _ -> return (E_literal (Literal_string s)) (t_string ())
* ) *) * ) *)
(* Tuple *) | E_record_accessor {expr;label} -> (
| E_tuple lst -> ( let%bind (base' , state') = type_expression e state expr in
let aux state hd = type_expression e state hd >>? swap in let wrapped = Wrap.access_label ~base:base'.type_expression ~label in
let%bind (state', lst') = bind_fold_map_list aux state lst in return_wrapped (E_record_accessor {expr=base';label}) state' wrapped
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."
) )
(* Sum *) (* Sum *)
| E_constructor (c, expr) -> | E_constructor {constructor;element} ->
let%bind (c_tv, sum_tv) = let%bind (c_tv, sum_tv) =
let error = let error =
let title () = "no such constructor" in let title () = "no such constructor" in
let content () = let content () =
Format.asprintf "%a in:\n%a\n" Format.asprintf "%a in:\n%a\n"
Stage_common.PP.constructor c Stage_common.PP.constructor constructor
O.Environment.PP.full_environment e O.Environment.PP.full_environment e
in in
error title content in error title content in
trace_option error @@ trace_option error @@
Environment.get_constructor c e in Environment.get_constructor constructor e in
let%bind (expr' , state') = type_expression e state expr in let%bind (expr' , state') = type_expression e state element in
let wrapped = Wrap.constructor expr'.type_annotation c_tv sum_tv in let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
return_wrapped (E_constructor (c , expr')) state' wrapped let wrapped = Wrap.constructor expr'.type_expression c_tv sum_tv in
return_wrapped (E_constructor {constructor; element=expr'}) state' wrapped
(* Record *) (* Record *)
| E_record m -> | 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 let%bind (expr' , state') = type_expression e state expr in
ok (I.LMap.add k expr' acc , state') ok (I.LMap.add k expr' acc , state')
in in
let%bind (m' , state') = I.bind_fold_lmap aux (ok (I.LMap.empty , state)) 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_annotation m') in let wrapped = Wrap.record (I.LMap.map get_type_expression m') in
return_wrapped (E_record m') state' wrapped 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 (record, state) = type_expression e state record in
let%bind (expr,state) = type_expression e state expr in let%bind (update,state) = type_expression e state update in
let wrapped = get_type_annotation record in let wrapped = get_type_expression record in
let%bind (wrapped,tv) = let%bind (wrapped,tv) =
match wrapped.type_value' with match wrapped.type_content with
| T_record record -> ( | 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 match field_op with
| Some tv -> ok (record,tv) | 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" | _ -> failwith "Update an expression which is not a record"
in in
let%bind () = O.assert_type_value_eq (tv, get_type_annotation expr) in let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
return_wrapped (E_record_update (record, (k,expr))) state (Wrap.record wrapped) return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
(* Data-structure *) (* Data-structure *)
(* (*
@ -629,20 +593,20 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
| E_list lst -> | E_list lst ->
let%bind (state', lst') = let%bind (state', lst') =
bind_fold_map_list (fun state' elt -> type_expression e state' elt >>? swap) state lst in 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 return_wrapped (E_list lst') state' wrapped
| E_set set -> | E_set set ->
let aux = fun state' elt -> type_expression e state' elt >>? swap in let aux = fun state' elt -> type_expression e state' elt >>? swap in
let%bind (state', set') = let%bind (state', set') =
bind_fold_map_list aux state set in 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 return_wrapped (E_set set') state' wrapped
| E_map map -> | E_map map ->
let aux' state' elt = type_expression e state' elt >>? swap in 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 aux = fun state' elt -> bind_fold_map_pair aux' state' elt in
let%bind (state', map') = let%bind (state', map') =
bind_fold_map_list aux state map in 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 let wrapped = Wrap.map (List.map aux map') in
return_wrapped (E_map map') state' wrapped 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 aux = fun state' elt -> bind_fold_map_pair aux' state' elt in
let%bind (state', big_map') = let%bind (state', big_map') =
bind_fold_map_list aux state big_map in 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 let wrapped = Wrap.big_map (List.map aux big_map') in
return_wrapped (E_big_map big_map') state' wrapped 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) = * let%bind (name', tv) =
* type_constant name tv_lst tv_opt ae.location in * type_constant name tv_lst tv_opt ae.location in
* return (E_constant (name' , lst')) tv *) * return (E_constant (name' , lst')) tv *)
| E_application (f, arg) -> | E_application {expr1;expr2} ->
let%bind (f' , state') = type_expression e state f in let%bind (f' , state') = type_expression e state expr1 in
let%bind (arg , state'') = type_expression e state' arg in let%bind (arg , state'') = type_expression e state' expr2 in
let wrapped = Wrap.application f'.type_annotation arg.type_annotation in let wrapped = Wrap.application f'.type_expression arg.type_expression in
return_wrapped (E_application (f' , arg)) state'' wrapped return_wrapped (E_application {expr1=f';expr2=arg}) state'' wrapped
(* | E_look_up dsi -> (* | E_look_up dsi ->
* let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in * 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 -> | E_look_up dsi ->
let aux' state' elt = type_expression e state' elt >>? swap in 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%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 return_wrapped (E_look_up (ds , ind)) state'' wrapped
(* Advanced *) (* Advanced *)
@ -770,82 +734,52 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
* tv_opt in * tv_opt in
* return (O.E_matching (ex', m')) tv * return (O.E_matching (ex', m')) tv
* ) *) * ) *)
| E_sequence (a , b) -> | E_loop {condition; body} ->
let%bind (a' , state') = type_expression e state a in let%bind (expr' , state') = type_expression e state condition 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
let%bind (body' , state'') = type_expression e state' body in let%bind (body' , state'') = type_expression e state' body in
let wrapped = Wrap.loop expr'.type_annotation body'.type_annotation in let wrapped = Wrap.loop expr'.type_expression body'.type_expression in
return_wrapped (O.E_loop (expr' , body')) state'' wrapped return_wrapped (O.E_loop {condition=expr';body=body'}) state'' wrapped
| E_let_in {binder ; rhs ; result ; inline} -> | E_let_in {let_binder ; rhs ; let_result; inline} ->
let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd binder) in 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 *) (* TODO: the binder annotation should just be an annotation node *)
let%bind (rhs , state') = type_expression e state rhs in let%bind (rhs , state') = type_expression e state rhs in
let e' = Environment.add_ez_declaration (fst binder) rhs e in let let_binder = fst let_binder in
let%bind (result , state'') = type_expression e' state' result 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 = let wrapped =
Wrap.let_in rhs.type_annotation rhs_tv_opt result.type_annotation in Wrap.let_in rhs.type_expression rhs_tv_opt let_result.type_expression in
return_wrapped (E_let_in {binder = fst binder; rhs; result; inline}) state'' wrapped return_wrapped (E_let_in {let_binder; rhs; let_result; inline}) state'' wrapped
| E_assign (name , path , expr) -> | E_ascription {anno_expr;type_annotation} ->
let%bind typed_name = let%bind tv = evaluate_type e type_annotation in
let%bind ele = Environment.get_trace name e in let%bind (expr' , state') = type_expression e state anno_expr in
ok @@ make_n_t name ele.type_value in let wrapped = Wrap.annotation expr'.type_expression tv
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
(* TODO: we're probably discarding too much by using expr'.expression. (* TODO: we're probably discarding too much by using expr'.expression.
Previously: {expr' with type_annotation = the_explicit_type_annotation} Previously: {expr' with type_annotation = the_explicit_type_annotation}
but then this case is not like the others and doesn't call return_wrapped, but then this case is not like the others and doesn't call return_wrapped,
which might do some necessary work *) 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) -> ( | E_matching {matchee;cases} -> (
let%bind (ex' , state') = type_expression e state ex in let%bind (ex' , state') = type_expression e state matchee in
let%bind (m' , state'') = type_match e state' ex'.type_annotation m ae ae.location in let%bind (m' , state'') = type_match e state' ex'.type_expression cases ae ae.location in
let tvs = 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 cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ] | Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ] | 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_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ] | Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in | 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 let%bind () = match tvs with
[] -> fail @@ match_empty_variant m ae.location [] -> fail @@ match_empty_variant cases ae.location
| _ -> ok () in | _ -> ok () in
(* constraints: (* constraints:
all the items of tvs should be equal to the first one all the items of tvs should be equal to the first one
result = first item of tvs result = first item of tvs
*) *)
let wrapped = Wrap.matching tvs in 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 *) (* match m with *)
@ -885,18 +819,19 @@ 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 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%bind output_type' = bind_map_option (evaluate_type e) output_type in
let fresh : O.type_value = t_variable (Wrap.fresh_binder ()) () in let fresh : O.type_expression = t_variable (Wrap.fresh_binder ()) () in
let e' = Environment.add_ez_binder (fst binder) fresh e 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%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 () = 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 let wrapped = Wrap.lambda fresh input_type' output_type' in
return_wrapped 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 state' wrapped
) )
| E_constant (name, lst) -> | E_constant {cons_name=name; arguments=lst} ->
let () = ignore (name , lst) in let () = ignore (name , lst) in
let%bind t = Operators.Typer.Operators_types.constant_type name in let%bind t = Operators.Typer.Operators_types.constant_type name in
let aux acc expr = let aux acc expr =
@ -904,10 +839,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let%bind (expr, state') = type_expression e state expr in let%bind (expr, state') = type_expression e state expr in
ok (expr::lst , state') in ok (expr::lst , state') in
let%bind (lst , state') = bind_fold_list aux ([], state) lst in let%bind (lst , state') = bind_fold_list aux ([], state) lst in
let lst_annot = List.map (fun (x : O.value) -> x.type_annotation) lst in let lst_annot = List.map (fun (x : O.expression) -> x.type_expression) lst in
let wrapped = Wrap.constant t lst_annot in let wrapped = Wrap.constant t lst_annot in
return_wrapped return_wrapped
(E_constant (name, lst)) (E_constant {cons_name=name;arguments=lst})
state' wrapped state' wrapped
(* (*
let%bind lst' = bind_list @@ List.map (type_expression e) lst in let%bind lst' = bind_list @@ List.map (type_expression e) lst in
@ -919,13 +854,13 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
(* Advanced *) (* 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 typer = Operators.Typer.constant_typers name in
let%bind tv = typer lst tv_opt in let%bind tv = typer lst tv_opt in
ok(name, tv) ok(name, tv)
let untype_type_value (t:O.type_value) : (I.type_expression) result = let untype_type_value (t:O.type_expression) : (I.type_expression) result =
match t.simplified with match t.type_meta with
| Some s -> ok s | Some s -> ok s
| _ -> fail @@ internal_assertion_failure "trying to untype generated type" | _ -> 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 -> *) (* let type_statement : environment -> I.declaration -> Solver.state -> (environment * O.declaration * Solver.state) result = fun env declaration state -> *)
@ -978,7 +913,7 @@ let type_and_subst_xyz (env_state_node : environment * Solver.state * 'a) (apply
(Solver.TypeVariableMap.find_opt root assignments) in (Solver.TypeVariableMap.find_opt root assignments) in
let Solver.{ tv ; c_tag ; tv_list } = assignment 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 () = 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 ok @@ expr
in in
let p = apply_substs ~substs program in let p = apply_substs ~substs program in
@ -992,14 +927,14 @@ let type_program (p : I.program) : (O.program * Solver.state) result =
let empty_state = Solver.initial_state in 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 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) -> fun (env, state, e) ->
let%bind (e , state) = type_expression env state e in let%bind (e , state) = type_expression env state e in
ok (env, state, e) 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. *) 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 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
@ -1025,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 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? *) (* 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 -> | 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' ok @@ I.T_sum x'
| O.T_record 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' ok @@ I.T_record x'
| O.T_constant (tag) -> | O.T_constant (tag) ->
ok @@ I.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_variable (name) -> ok @@ I.T_variable (name) (* TODO: is this the right conversion? *)
| O.T_arrow (a , b) -> | O.T_arrow {type1;type2} ->
let%bind a' = untype_type_expression a in let%bind type1 = untype_type_expression type1 in
let%bind b' = untype_type_expression b in let%bind type2 = untype_type_expression type2 in
ok @@ I.T_arrow (a' , b') ok @@ I.T_arrow {type1;type2}
| O.T_operator (type_name) -> | O.T_operator (type_name) ->
let%bind type_name = match type_name with let%bind type_name = match type_name with
| O.TC_option t -> | O.TC_option t ->
@ -1060,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 k = untype_type_expression k in
let%bind v = untype_type_expression v in let%bind v = untype_type_expression v in
ok @@ I.TC_big_map (k,v) 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 ) -> | O.TC_arrow ( arg , ret ) ->
let%bind arg' = untype_type_expression arg in let%bind arg' = untype_type_expression arg in
let%bind ret' = untype_type_expression ret in let%bind ret' = untype_type_expression ret in
ok @@ I.TC_arrow ( arg' , ret' ) ok @@ I.TC_arrow ( arg' , ret' )
| O.TC_tuple lst -> | O.TC_contract c->
let%bind lst' = bind_map_list untype_type_expression lst in let%bind c = untype_type_expression c in
ok @@ I.TC_tuple lst' ok @@ I.TC_contract c
in in
ok @@ I.T_operator (type_name) ok @@ I.T_operator (type_name)
in in
@ -1087,6 +1019,7 @@ let untype_literal (l:O.literal) : I.literal result =
let open I in let open I in
match l with match l with
| Literal_unit -> ok Literal_unit | Literal_unit -> ok Literal_unit
| Literal_void -> ok Literal_void
| Literal_bool b -> ok (Literal_bool b) | Literal_bool b -> ok (Literal_bool b)
| Literal_nat n -> ok (Literal_nat n) | Literal_nat n -> ok (Literal_nat n)
| Literal_timestamp n -> ok (Literal_timestamp n) | Literal_timestamp n -> ok (Literal_timestamp n)
@ -1104,51 +1037,46 @@ let untype_literal (l:O.literal) : I.literal result =
(* (*
Tranform a Ast_typed expression into an ast_simplified matching 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 open I in
let return e = ok e in let return e = ok e in
match e.expression with match e.expression_content with
| E_literal l -> | E_literal l ->
let%bind l = untype_literal l in let%bind l = untype_literal l in
return (e_literal l) return (e_literal l)
| E_constant (const, lst) -> | E_constant {cons_name;arguments} ->
let%bind lst' = bind_map_list untype_expression lst in let%bind lst' = bind_map_list untype_expression arguments in
return (e_constant const lst') return (e_constant cons_name lst')
| E_variable (n) -> | E_variable (n) ->
return (e_variable n) return (e_variable (n))
| E_application (f, arg) -> | E_application {expr1;expr2} ->
let%bind f' = untype_expression f in let%bind f' = untype_expression expr1 in
let%bind arg' = untype_expression arg in let%bind arg' = untype_expression expr2 in
return (e_application f' arg') return (e_application f' arg')
| E_lambda {binder; body} -> ( | E_lambda {binder; result} -> (
let%bind io = get_t_function e.type_annotation in 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 (input_type , output_type) = bind_map_pair untype_type_value io in
let%bind result = untype_expression body in let%bind result = untype_expression result in
return (e_lambda binder (Some input_type) (Some output_type) result) return (e_lambda (binder) (Some input_type) (Some output_type) result)
) )
| E_tuple lst -> | E_constructor {constructor; element} ->
let%bind lst' = bind_list let%bind p' = untype_expression element in
@@ List.map untype_expression lst in let Constructor n = constructor in
return (e_tuple lst') return (e_constructor n p')
| 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_record r -> | E_record r ->
let aux ( Label k ,v) = (k, v) in let aux ( Label k ,v) = (k, v) in
let r = Map.String.of_list @@ List.map aux (LMap.to_kv_list r) in let r = Map.String.of_list @@ List.map aux (LMap.to_kv_list r) in
let%bind r' = bind_smap let%bind r' = bind_smap
@@ Map.String.map untype_expression r in @@ Map.String.map untype_expression r in
return (e_record r') return (e_record r')
| E_record_accessor (r, Label s) -> | E_record_accessor {expr; label} ->
let%bind r' = untype_expression r in let%bind r' = untype_expression expr in
return (e_accessor r' [Access_record s]) let Label s = label in
| E_record_update (r, (l,e)) -> return (e_accessor r' s)
let%bind r' = untype_expression r in | E_record_update {record; path; update} ->
let%bind e = untype_expression e in let%bind r' = untype_expression record in
let Label l = l in let%bind e = untype_expression update in
let Label l = path in
return (e_update r' l e) return (e_update r' l e)
| E_map m -> | E_map m ->
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
@ -1165,26 +1093,24 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result =
| E_look_up dsi -> | E_look_up dsi ->
let%bind (a , b) = bind_map_pair untype_expression dsi in let%bind (a , b) = bind_map_pair untype_expression dsi in
return (e_look_up a b) return (e_look_up a b)
| E_matching (ae, m) -> | E_matching {matchee;cases} ->
let%bind ae' = untype_expression ae in let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression m in let%bind m' = untype_matching untype_expression cases in
return (e_matching ae' m') return (e_matching ae' m')
(* | E_failwith ae -> (* | E_failwith ae ->
* let%bind ae' = untype_expression ae in * let%bind ae' = untype_expression ae in
* return (e_failwith ae') *) * return (e_failwith ae') *)
| E_sequence _ | E_loop _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e
| E_loop _ | E_let_in {let_binder; rhs;let_result; inline} ->
| E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression let%bind tv = untype_type_value rhs.type_expression in
| E_let_in {binder; rhs; result; inline} ->
let%bind tv = untype_type_value rhs.type_annotation in
let%bind rhs = untype_expression rhs in let%bind rhs = untype_expression rhs in
let%bind result = untype_expression result in let%bind result = untype_expression let_result in
return (e_let_in (binder , (Some tv)) inline rhs result) return (e_let_in (let_binder , (Some tv)) false inline rhs result)
(* (*
Tranform a Ast_typed matching into an ast_simplified matching 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 let open I in
match m with match m with
| Match_bool {match_true ; match_false} -> | 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_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_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 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 evaluate_type : environment -> I.type_expression -> O.type_expression result
val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) 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_value -> I.expression -> (O.annotated_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_value list -> O.type_value option -> (O.constant * O.type_value) 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_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal result val untype_literal : O.literal -> I.literal result
*) *)
val untype_type_expression : O.type_value -> I.type_expression result val untype_type_expression : O.type_expression -> I.type_expression 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 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 title = (thunk "unbound type variable") in
let message () = "" in let message () = "" in
let data = [ 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. *) (* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *) (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
@ -30,7 +30,7 @@ module Errors = struct
error ~data title message () error ~data title message ()
let unbound_variable (e:environment) (n:I.expression_variable) (loc:Location.t) () = 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 title = (thunk ("unbound variable "^(name ()))) in
let message () = "" in let message () = "" in
let data = [ let data = [
@ -40,7 +40,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "match with no cases") in let title = (thunk "match with no cases") in
let message () = "" in let message () = "" in
@ -50,7 +50,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "missing case in match") in
let message () = "" in let message () = "" in
@ -60,7 +60,7 @@ module Errors = struct
] in ] in
error ~data title message () 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 () -> fun matching loc () ->
let title = (thunk "redundant case in match") in let title = (thunk "redundant case in match") in
let message () = "" in let message () = "" in
@ -70,11 +70,11 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "unbound constructor") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
@ -91,6 +91,7 @@ module Errors = struct
] in ] in
error ~data title message () error ~data title message ()
let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () = let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () =
let title () = "matching tuple of different size" in let title () = "matching tuple of different size" in
let message () = "" in let message () = "" in
@ -110,27 +111,27 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "typing constant declaration") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () -> ("expected" , fun () ->
match expected with match expected with
None -> "(no annotation for the expected type)" 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) ("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in ] in
error ~data title message () 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 () -> fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in let title = (thunk "typing match") in
let message () = msg in let message () = msg in
let data = [ let data = [
("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected); ("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) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
@ -144,46 +145,35 @@ module Errors = struct
] in ] in
error ~data title message () 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 title = (thunk "type error") in
let message () = msg in let message () = msg in
let data = [ let data = [
("expected" , fun () -> Format.asprintf "%s" expected); ("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) ; ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () 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 title = (thunk "type error") in
let message () = msg in let message () = msg in
let data = [ let data = [
("expected" , fun () -> Format.asprintf "%a" O.PP.type_value expected); ("expected" , fun () -> Format.asprintf "%a" O.PP.type_expression 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) ; ("expression" , fun () -> Format.asprintf "%a" I.PP.expression expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let bad_tuple_index (index : int) (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 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 title = (thunk "invalid record field") in let title = (thunk "invalid record field") in
let message () = "" in let message () = "" in
let data = [ 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) ; ("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) ("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () 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 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) -> | Declaration_type (type_name , type_expression) ->
let%bind tv = evaluate_type env type_expression in 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) ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None)
| Declaration_constant (name , tv_opt , inline, expression) -> ( | Declaration_constant (name , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in 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) @@ trace (constant_declaration_error name expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in type_expression' ?tv_opt:tv'_opt env expression in
let env' = Environment.add_ez_ae name ae' env 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 fun f e t i ae loc -> match i with
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
let%bind _ = let%bind _ =
@ -282,7 +272,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
~expression:ae ~expression:ae
loc loc
) @@ ) @@
Ast_typed.assert_type_value_eq (variant , variant') >>? fun () -> Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
ok (Some variant) ok (Some variant)
) in ) in
ok acc 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 bind_map_list aux lst in
ok (O.Match_variant (lst' , variant)) 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 let return tv' = ok (make_t tv' (Some t)) in
match t.type_expression' with match t.type_content with
| T_arrow (a, b) -> | T_arrow {type1;type2} ->
let%bind a' = evaluate_type e a in let%bind type1 = evaluate_type e type1 in
let%bind b' = evaluate_type e b in let%bind type2 = evaluate_type e type2 in
return (T_arrow (a', b')) return (T_arrow {type1;type2})
| T_sum m -> | T_sum m ->
let aux k v prev = let aux k v prev =
let%bind prev' = prev in 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 -> | T_variable name ->
let%bind tv = let%bind tv =
trace_option (unbound_type_variable e name) trace_option (unbound_type_variable e name)
@@ Environment.get_type_opt name e in @@ Environment.get_type_opt (name) e in
ok tv ok tv
| T_constant cst -> | T_constant cst ->
return (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 k = evaluate_type e k in
let%bind v = evaluate_type e v in let%bind v = evaluate_type e v in
ok @@ O.TC_big_map (k,v) 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 ) -> | TC_arrow ( arg , ret ) ->
let%bind arg' = evaluate_type e arg in let%bind arg' = evaluate_type e arg in
let%bind ret' = evaluate_type e ret in let%bind ret' = evaluate_type e ret in
ok @@ I.TC_arrow ( arg' , ret' ) ok @@ O.TC_arrow ( arg' , ret' )
| TC_tuple lst -> | TC_contract c ->
let%bind lst' = bind_map_list (evaluate_type e) lst in let%bind c = evaluate_type e c in
ok @@ I.TC_tuple lst' ok @@ O.TC_contract c
in in
return (T_operator (opt)) 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 -> = fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
let%bind res = type_expression' e ?tv_opt ae in let%bind res = type_expression' e ?tv_opt ae in
ok (res, (Solver.placeholder_for_state_of_new_typer ())) 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 module L = Logger.Stateful() in
let return expr tv = let return expr tv =
let%bind () = let%bind () =
match tv_opt with match tv_opt with
| None -> ok () | 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 let location = ae.location in
ok @@ make_a_e ~location expr tv e in ok @@ make_a_e ~location expr tv e in
let main_error = let main_error =
@ -405,7 +392,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
] in ] in
error ~data title content in error ~data title content in
trace main_error @@ trace main_error @@
match ae.expression with match ae.expression_content with
(* Basic *) (* Basic *)
| E_variable name -> | E_variable name ->
let%bind tv' = 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 ()) return (E_literal (Literal_bool b)) (t_bool ())
| E_literal Literal_unit | E_skip -> | E_literal Literal_unit | E_skip ->
return (E_literal (Literal_unit)) (t_unit ()) 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) -> | E_literal (Literal_string s) ->
return (E_literal (Literal_string s)) (t_string ()) return (E_literal (Literal_string s)) (t_string ())
| E_literal (Literal_key s) -> | 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 ()) return (e_address s) (t_address ())
| E_literal (Literal_operation op) -> | E_literal (Literal_operation op) ->
return (e_operation op) (t_operation ()) return (e_operation op) (t_operation ())
(* Tuple *) | E_record_accessor {expr;label} ->
| E_tuple lst -> let%bind e' = type_expression' e expr in
let%bind lst' = bind_list @@ List.map (type_expression' e) lst in let aux (prev:O.expression) (a:I.label) : O.expression result =
let tv_lst = List.map get_type_annotation lst' in let property = a in
return (E_tuple lst') (t_tuple tv_lst ()) let%bind r_tv = get_t_record prev.type_expression in
| 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
let%bind tv = let%bind tv =
generic_try (bad_tuple_index index ae' prev.type_annotation ae.location) generic_try (bad_record_access property ae prev.type_expression 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)
@@ (fun () -> I.LMap.find property r_tv) in @@ (fun () -> I.LMap.find property r_tv) in
let location = ae.location 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 in
let%bind ae = let%bind ae =
trace (simple_info "accessing") @@ trace (simple_info "accessing") @@ aux e' label in
bind_fold_list aux e' path in
(* check type annotation of the final accessed element *) (* check type annotation of the final accessed element *)
let%bind () = let%bind () =
match tv_opt with match tv_opt with
| None -> ok () | 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) ok(ae)
(* Sum *) (* Sum *)
| E_constructor (c, expr) -> | E_constructor {constructor; element} ->
let%bind (c_tv, sum_tv) = let%bind (c_tv, sum_tv) =
let error = let error =
let title () = "no such constructor" in let title () = "no such constructor" in
let content () = let content () =
Format.asprintf "%a in:\n%a\n" Format.asprintf "%a in:\n%a\n"
Stage_common.PP.constructor c Stage_common.PP.constructor constructor
O.Environment.PP.full_environment e O.Environment.PP.full_environment e
in in
error title content in error title content in
trace_option error @@ trace_option error @@
Environment.get_constructor c e in Environment.get_constructor constructor e in
let%bind expr' = type_expression' e expr in let%bind expr' = type_expression' e element in
let%bind _assert = O.assert_type_value_eq (expr'.type_annotation, c_tv) in let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
return (E_constructor (c , expr')) sum_tv return (E_constructor {constructor; element=expr'}) sum_tv
(* Record *) (* Record *)
| E_record m -> | E_record m ->
let aux prev k expr = let aux prev k expr =
let%bind expr' = type_expression' e expr in let%bind expr' = type_expression' e expr in
ok (I.LMap.add k expr' prev) ok (I.LMap.add k expr' prev)
in in
let%bind m' = I.bind_fold_lmap aux (ok I.LMap.empty) m in 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_annotation m') ()) return (E_record m') (t_record (I.LMap.map get_type_expression m') ())
| E_update {record; update =(l,expr)} -> | E_record_update {record; path; update} ->
let%bind record = type_expression' e record in let%bind record = type_expression' e record in
let%bind expr' = type_expression' e expr in let%bind update = type_expression' e update in
let wrapped = get_type_annotation record in let wrapped = get_type_expression record in
let%bind tv = let%bind tv =
match wrapped.type_value' with match wrapped.type_content with
| T_record record -> ( | 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 match field_op with
| Some tv -> ok (tv) | 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" | _ -> failwith "Update an expression which is not a record"
in in
let%bind () = O.assert_type_value_eq (tv, get_type_annotation expr') in let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
return (E_record_update (record, (l,expr'))) wrapped return (E_record_update {record; path; update}) wrapped
(* Data-structure *) (* Data-structure *)
| E_list lst -> | E_list lst ->
let%bind lst' = bind_map_list (type_expression' e) lst in 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 match opt with
| None -> ok (Some c) | None -> ok (Some c)
| 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 ok (Some c') in
let%bind init = match tv_opt with let%bind init = match tv_opt with
| None -> ok None | None -> ok None
@ -533,7 +505,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
ok (Some ty') in ok (Some ty') in
let%bind ty = let%bind ty =
let%bind opt = bind_fold_list aux init 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 trace_option (needs_annotation ae "empty list") opt in
ok (t_list ty ()) ok (t_list ty ())
in in
@ -545,7 +517,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
match opt with match opt with
| None -> ok (Some c) | None -> ok (Some c)
| 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 ok (Some c') in
let%bind init = match tv_opt with let%bind init = match tv_opt with
| None -> ok None | None -> ok None
@ -554,7 +526,7 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
ok (Some ty') in ok (Some ty') in
let%bind ty = let%bind ty =
let%bind opt = bind_fold_list aux init 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 trace_option (needs_annotation ae "empty set") opt in
ok (t_set ty ()) ok (t_set ty ())
in in
@ -566,12 +538,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
match opt with match opt with
| None -> ok (Some c) | None -> ok (Some c)
| 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 ok (Some c') in
let%bind key_type = let%bind key_type =
let%bind sub = let%bind sub =
bind_fold_list aux None bind_fold_list aux None
@@ List.map get_type_annotation @@ List.map get_type_expression
@@ List.map fst lst' in @@ List.map fst lst' in
let%bind annot = bind_map_option get_t_map_key tv_opt in let%bind annot = bind_map_option get_t_map_key tv_opt in
trace (simple_info "empty map expression without a type annotation") @@ 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 value_type =
let%bind sub = let%bind sub =
bind_fold_list aux None bind_fold_list aux None
@@ List.map get_type_annotation @@ List.map get_type_expression
@@ List.map snd lst' in @@ List.map snd lst' in
let%bind annot = bind_map_option get_t_map_value tv_opt in let%bind annot = bind_map_option get_t_map_value tv_opt in
trace (simple_info "empty map expression without a type annotation") @@ 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 match opt with
| None -> ok (Some c) | None -> ok (Some c)
| 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 ok (Some c') in
let%bind key_type = let%bind key_type =
let%bind sub = let%bind sub =
bind_fold_list aux None bind_fold_list aux None
@@ List.map get_type_annotation @@ List.map get_type_expression
@@ List.map fst lst' in @@ List.map fst lst' in
let%bind annot = bind_map_option get_t_big_map_key tv_opt 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") @@ 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 value_type =
let%bind sub = let%bind sub =
bind_fold_list aux None bind_fold_list aux None
@@ List.map get_type_annotation @@ List.map get_type_expression
@@ List.map snd lst' in @@ List.map snd lst' in
let%bind annot = bind_map_option get_t_big_map_value tv_opt 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") @@ 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 match input_type with
| Some ty -> ok ty | Some ty -> ok ty
| None -> ( | None -> (
match result.expression with match result.expression_content with
| I.E_let_in li -> ( | I.E_let_in li -> (
match li.rhs.expression with match li.rhs.expression_content with
| I.E_variable name when name = (fst binder) -> ( | I.E_variable name when name = (fst binder) -> (
match snd li.binder with match snd li.let_binder with
| Some ty -> ok ty | Some ty -> ok ty
| None -> default_action li.rhs () | 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 = let%bind output_type =
bind_map_option (evaluate_type e) output_type bind_map_option (evaluate_type e) output_type
in 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%bind body = type_expression' ?tv_opt:output_type e' result in
let output_type = body.type_annotation in let output_type = body.type_expression in
return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ()) 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 , | E_constant {cons_name=( C_LIST_FOLD | C_MAP_FOLD | C_SET_FOLD) as opname ;
[ arguments=[
( { expression = (I.E_lambda { binder = (lname, None) ; ( { expression_content = (I.E_lambda { binder = (lname, None) ;
input_type = None ; input_type = None ;
output_type = None ; output_type = None ;
result }) ; result }) ;
location = _ }) as _lambda ; location = _ }) as _lambda ;
collect ; collect ;
init_record ; init_record ;
] ) -> ]} ->
(* this special case is here force annotation of the untyped lambda (* this special case is here force annotation of the untyped lambda
generated by pascaligo's for_collect loop *) generated by pascaligo's for_collect loop *)
let%bind (v_col , v_initr ) = bind_map_pair (type_expression' e) (collect , init_record ) in 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_col = get_type_expression 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 tv_out = get_type_expression v_initr in (* this is the output type of the lambda*)
let%bind input_type = match tv_col.type_value' with let%bind input_type = match tv_col.type_content with
| O.T_operator ( TC_list t | TC_set t) -> ok @@ t_tuple (tv_out::[t]) () | 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 @@ t_tuple (tv_out::[(t_tuple [k;v] ())]) () | 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 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 fail @@ simple_error wtype in
let lname = lname in
let e' = Environment.add_ez_binder lname input_type e 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%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
let output_type = body.type_annotation in let output_type = body.type_expression in
let lambda' = make_a_e (E_lambda {binder = lname ; body}) (t_function input_type output_type ()) e 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 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) = let%bind (opname', tv) =
type_constant opname tv_lst tv_opt in type_constant opname tv_lst tv_opt in
return (E_constant (opname' , lst')) tv return (E_constant {cons_name=opname';arguments=lst'}) tv
| E_constant (name, lst) -> | E_constant {cons_name=C_FOLD_WHILE as opname;
let%bind lst' = bind_list @@ List.map (type_expression' e) lst in arguments = [
let tv_lst = List.map get_type_annotation lst' in ( { 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) = let%bind (name', tv) =
type_constant name tv_lst tv_opt in type_constant cons_name tv_lst tv_opt in
return (E_constant (name' , lst')) tv return (E_constant {cons_name=name';arguments=lst'}) tv
| E_application (f, arg) -> | E_application {expr1;expr2} ->
let%bind f' = type_expression' e f in let%bind expr1' = type_expression' e expr1 in
let%bind arg = type_expression' e arg in let%bind expr2 = type_expression' e expr2 in
let%bind tv = match f'.type_annotation.type_value' with let%bind tv = match expr1'.type_expression.type_content with
| T_arrow (param, result) -> | T_arrow {type1;type2} ->
let%bind _ = O.assert_type_value_eq (param, arg.type_annotation) in let%bind _ = O.assert_type_expression_eq (type1, expr2.type_expression) in
ok result ok type2
| _ -> | _ ->
fail @@ type_error_approximate fail @@ type_error_approximate
~expected:"should be a function type" ~expected:"should be a function type"
~expression:f ~expression:expr1
~actual:f'.type_annotation ~actual:expr1'.type_expression
f'.location expr1'.location
in in
return (E_application (f' , arg)) tv return (E_application {expr1=expr1';expr2}) tv
| E_look_up dsi -> | E_look_up dsi ->
let%bind (ds, ind) = bind_map_pair (type_expression' e) dsi in 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 (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_expression in
let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in let%bind _ = O.assert_type_expression_eq (ind.type_expression, src) in
return (E_look_up (ds , ind)) (t_option dst ()) return (E_look_up (ds , ind)) (t_option dst ())
(* Advanced *) (* Advanced *)
| E_matching (ex, m) -> ( | E_matching {matchee;cases} -> (
let%bind ex' = type_expression' e ex in let%bind ex' = type_expression' e matchee in
let%bind m' = type_match (type_expression' ?tv_opt:None) e ex'.type_annotation m ae ae.location in let%bind m' = type_match (type_expression' ?tv_opt:None) e ex'.type_expression cases ae ae.location in
let tvs = let tvs =
let aux (cur:(O.value, O.type_value) O.matching) = let aux (cur:O.matching_expr) =
match cur with match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ] | Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ] | 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_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ] | Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in | 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 aux prec cur =
let%bind () = let%bind () =
match prec with match prec with
| None -> ok () | 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 ok (Some cur) in
let%bind tv_opt = bind_fold_list aux None tvs in let%bind tv_opt = bind_fold_list aux None tvs in
let%bind tv = let%bind tv =
trace_option (match_empty_variant m ae.location) @@ trace_option (match_empty_variant cases ae.location) @@
tv_opt in tv_opt in
return (O.E_matching (ex', m')) tv return (O.E_matching {matchee=ex'; cases=m'}) tv
) )
| E_sequence (a , b) -> | E_loop {condition; body} ->
let%bind a' = type_expression' e a in let%bind expr' = type_expression' e condition 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
let%bind body' = type_expression' e body 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 () = let%bind () =
trace_strong (type_error trace_strong (type_error
~msg:"while condition isn't of type bool" ~msg:"while condition isn't of type bool"
~expected:(O.t_bool ()) ~expected:(O.t_bool ())
~actual:t_expr' ~actual:t_expr'
~expression:expr ~expression:condition
expr'.location) @@ expr'.location) @@
Ast_typed.assert_type_value_eq (t_bool () , t_expr') in Ast_typed.assert_type_expression_eq (t_bool () , t_expr') in
let t_body' = get_type_annotation body' in let t_body' = get_type_expression body' in
let%bind () = let%bind () =
trace_strong (type_error trace_strong (type_error
~msg:"while body isn't of unit type" ~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' ~actual:t_body'
~expression:body ~expression:body
body'.location) @@ body'.location) @@
Ast_typed.assert_type_value_eq (t_unit () , t_body') in Ast_typed.assert_type_expression_eq (t_unit () , t_body') in
return (O.E_loop (expr' , body')) (t_unit ()) return (O.E_loop {condition=expr'; body=body'}) (t_unit ())
| E_assign (name , path , expr) -> | E_let_in {let_binder ; rhs ; let_result; inline} ->
let%bind typed_name = let%bind rhs_tv_opt = bind_map_option (evaluate_type e) (snd let_binder) in
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
let%bind rhs = type_expression' ?tv_opt:rhs_tv_opt e rhs 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 let_binder = fst let_binder in
let%bind result = type_expression' e' result in let e' = Environment.add_ez_declaration (let_binder) rhs e in
return (E_let_in {binder = fst binder; rhs; result; inline}) result.type_annotation let%bind let_result = type_expression' e' let_result in
| E_ascription (expr , te) -> return (E_let_in {let_binder; rhs; let_result; inline}) let_result.type_expression
let%bind tv = evaluate_type e te in | E_ascription {anno_expr; type_annotation} ->
let%bind expr' = type_expression' ~tv_opt:tv e expr in 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 = let%bind type_annotation =
O.merge_annotation O.merge_annotation
(Some tv) (Some tv)
(Some expr'.type_annotation) (Some expr'.type_expression)
(internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in (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') ) *) (* check type annotation of the expression as a whole (e.g. let x : t = (v : t') ) *)
let%bind () = let%bind () =
match tv_opt with match tv_opt with
| None -> ok () | None -> ok ()
| Some tv' -> O.assert_type_value_eq (tv' , type_annotation) in | Some tv' -> O.assert_type_expression_eq (tv' , type_annotation) in
ok @@ {expr' with type_annotation} 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 typer = Operators.Typer.constant_typers name in
let%bind tv = typer lst tv_opt in let%bind tv = typer lst tv_opt in
ok(name, tv) ok(name, tv)
let untype_type_value (t:O.type_value) : (I.type_expression) result = let untype_type_expression (t:O.type_expression) : (I.type_expression) result =
match t.simplified with match t.type_meta with
| Some s -> ok s | Some s -> ok s
| _ -> fail @@ internal_assertion_failure "trying to untype generated type" | _ -> 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 let open I in
match l with match l with
| Literal_unit -> ok Literal_unit | Literal_unit -> ok Literal_unit
| Literal_void -> ok Literal_void
| Literal_bool b -> ok (Literal_bool b) | Literal_bool b -> ok (Literal_bool b)
| Literal_nat n -> ok (Literal_nat n) | Literal_nat n -> ok (Literal_nat n)
| Literal_timestamp n -> ok (Literal_timestamp 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_string s -> ok (Literal_string s)
| Literal_signature s -> ok (Literal_signature s) | Literal_signature s -> ok (Literal_signature s)
| Literal_key s -> ok (Literal_key s) | Literal_key s -> ok (Literal_key s)
| Literal_key_hash s -> ok (Literal_key_hash s) | Literal_key_hash s -> ok (Literal_key_hash s)
| Literal_chain_id s -> ok (Literal_chain_id s) | Literal_chain_id s -> ok (Literal_chain_id s)
| Literal_bytes b -> ok (Literal_bytes b) | Literal_bytes b -> ok (Literal_bytes b)
| Literal_address s -> ok (Literal_address s) | Literal_address s -> ok (Literal_address s)
| Literal_operation s -> ok (Literal_operation 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 open I in
let return e = ok e in let return e = ok e in
match e.expression with match e.expression_content with
| E_literal l -> | E_literal l ->
let%bind l = untype_literal l in let%bind l = untype_literal l in
return (e_literal l) return (e_literal l)
| E_constant (const, lst) -> | E_constant {cons_name;arguments} ->
let%bind lst' = bind_map_list untype_expression lst in let%bind lst' = bind_map_list untype_expression arguments in
return (e_constant const lst') return (e_constant cons_name lst')
| E_variable n -> | E_variable n ->
return (e_variable n) return (e_variable (n))
| E_application (f, arg) -> | E_application {expr1;expr2} ->
let%bind f' = untype_expression f in let%bind f' = untype_expression expr1 in
let%bind arg' = untype_expression arg in let%bind arg' = untype_expression expr2 in
return (e_application f' arg') return (e_application f' arg')
| E_lambda {binder ; body} -> ( | E_lambda {binder ; result} -> (
let%bind io = get_t_function e.type_annotation in 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 (input_type , output_type) = bind_map_pair untype_type_expression io in
let%bind result = untype_expression body in let%bind result = untype_expression result in
return (e_lambda binder (Some input_type) (Some output_type) result) return (e_lambda (binder) (Some input_type) (Some output_type) result)
) )
| E_tuple lst -> | E_constructor {constructor; element} ->
let%bind lst' = bind_list let%bind p' = untype_expression element in
@@ List.map untype_expression lst in let Constructor n = constructor 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
return (e_constructor n p') return (e_constructor n p')
| E_record r -> | E_record r ->
let aux ( Label k ,v) = (k, v) in 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 let%bind r' = bind_smap
@@ Map.String.map untype_expression r in @@ Map.String.map untype_expression r in
return (e_record r') return (e_record r')
| E_record_accessor (r, Label s) -> | E_record_accessor {expr; label} ->
let%bind r' = untype_expression r in let%bind r' = untype_expression expr in
return (e_accessor r' [Access_record s]) let Label s = label in
| E_record_update (r, (l,e)) -> return (e_accessor r' s)
| E_record_update {record=r; path=l; update=e} ->
let%bind r' = untype_expression r in let%bind r' = untype_expression r in
let%bind e = untype_expression e in let%bind e = untype_expression e in
let Label l = l 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 -> | E_look_up dsi ->
let%bind (a , b) = bind_map_pair untype_expression dsi in let%bind (a , b) = bind_map_pair untype_expression dsi in
return (e_look_up a b) return (e_look_up a b)
| E_matching (ae, m) -> | E_matching {matchee;cases} ->
let%bind ae' = untype_expression ae in let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression m in let%bind m' = untype_matching untype_expression cases in
return (e_matching ae' m') return (e_matching ae' m')
| E_sequence _ | E_loop _-> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e
| E_loop _ | E_let_in {let_binder;rhs;let_result; inline} ->
| E_assign _ -> fail @@ not_supported_yet_untranspile "not possible to untranspile statements yet" e.expression let%bind tv = untype_type_expression rhs.type_expression in
| E_let_in {binder; rhs; result; inline} ->
let%bind tv = untype_type_value rhs.type_annotation in
let%bind rhs = untype_expression rhs in let%bind rhs = untype_expression rhs in
let%bind result = untype_expression result in let%bind result = untype_expression let_result in
return (e_let_in (binder , (Some tv)) inline rhs result) 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 let open I in
match m with match m with
| Match_bool {match_true ; match_false} -> | 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_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_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 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 evaluate_type : environment -> I.type_expression -> O.type_expression result
val type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.expression -> (O.annotated_expression * Solver.state) 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_value list -> O.type_value option -> (O.constant * O.type_value) 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_type_value : O.type_value -> (I.type_expression) result
val untype_literal : O.literal -> I.literal 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 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 type environment = Environment.t
val type_program : I.program -> (O.program * Solver.state) result 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 type_expression_subst : environment -> Solver.state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * Solver.state) result
val untype_expression : O.annotated_expression -> I.expression 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 let open Map.String in
List.fold_left (fun prev (k, v) -> add k v prev) empty lst 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 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 match tv with
| Leaf (Constructor k, t), v -> ok (k, v, t) | Leaf (Constructor k, t), v -> ok (k, v, t)
| Node {a}, D_left v -> aux (a, v) | 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 let%bind (s, v, t) = aux (tree, v) in
ok (s, v, t) 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 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 match tv with
| Leaf t, v -> ok @@ [v, t] | Leaf t, v -> ok @@ [v, t]
| Node {a;b}, D_pair (va, vb) -> | 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 extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
let open Append_tree in 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 match tv with
| Leaf (s, t), v -> ok @@ [s, (v, t)] | Leaf (s, t), v -> ok @@ [s, (v, t)]
| Node {a;b}, D_pair (va, vb) -> | 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 ] in
error ~data title content 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 end
open Errors open Errors
let rec transpile_type (t:AST.type_value) : type_value result = let rec transpile_type (t:AST.type_expression) : type_value result =
match t.type_value' with match t.type_content with
| T_variable (name) -> fail @@ no_type_variable @@ name | T_variable (name) -> fail @@ no_type_variable @@ name
| T_constant (TC_bool) -> ok (T_base Base_bool) | T_constant (TC_bool) -> ok (T_base TC_bool)
| T_constant (TC_int) -> ok (T_base Base_int) | T_constant (TC_int) -> ok (T_base TC_int)
| T_constant (TC_nat) -> ok (T_base Base_nat) | T_constant (TC_nat) -> ok (T_base TC_nat)
| T_constant (TC_mutez) -> ok (T_base Base_mutez) | T_constant (TC_mutez) -> ok (T_base TC_mutez)
| T_constant (TC_string) -> ok (T_base Base_string) | T_constant (TC_string) -> ok (T_base TC_string)
| T_constant (TC_bytes) -> ok (T_base Base_bytes) | T_constant (TC_bytes) -> ok (T_base TC_bytes)
| T_constant (TC_address) -> ok (T_base Base_address) | T_constant (TC_address) -> ok (T_base TC_address)
| T_constant (TC_timestamp) -> ok (T_base Base_timestamp) | T_constant (TC_timestamp) -> ok (T_base TC_timestamp)
| T_constant (TC_unit) -> ok (T_base Base_unit) | T_constant (TC_unit) -> ok (T_base TC_unit)
| T_constant (TC_operation) -> ok (T_base Base_operation) | T_constant (TC_operation) -> ok (T_base TC_operation)
| T_constant (TC_signature) -> ok (T_base Base_signature) | T_constant (TC_signature) -> ok (T_base TC_signature)
| T_constant (TC_key) -> ok (T_base Base_key) | T_constant (TC_key) -> ok (T_base TC_key)
| T_constant (TC_key_hash) -> ok (T_base Base_key_hash) | T_constant (TC_key_hash) -> ok (T_base TC_key_hash)
| T_constant (TC_chain_id) -> ok (T_base Base_chain_id) | 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) -> | T_operator (TC_contract x) ->
let%bind x' = transpile_type x in let%bind x' = transpile_type x in
ok (T_contract x') 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)) ok (None, T_or (a, b))
in in
let%bind m' = Append_tree.fold_ne 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 let%bind a = transpile_type a in
ok (Some (String.uncapitalize_ascii ann), a)) ok (Some (String.uncapitalize_ascii ann), a))
aux node in aux node in
@ -173,49 +168,22 @@ let rec transpile_type (t:AST.type_value) : type_value result =
ok (None, T_pair (a, b)) ok (None, T_pair (a, b))
in in
let%bind m' = Append_tree.fold_ne 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 let%bind a = transpile_type a in
ok (Some ann, a)) ok (Some ann, a))
aux node in aux node in
ok @@ snd m' ok @@ snd m'
| T_operator (TC_tuple lst) -> | T_arrow {type1;type2} -> (
let node = Append_tree.of_list lst in let%bind param' = transpile_type type1 in
let aux a b : type_value result = let%bind result' = transpile_type type2 in
let%bind a = a in ok (T_function (param',result'))
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'))
) )
let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [`Left | `Right]) list result = fun ty tys 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 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 tys = kv_list_of_lmap tym in let tys = kv_list_of_lmap tym in
let node_tv = Append_tree.of_list tys in let node_tv = Append_tree.of_list tys in
let%bind path = 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") @@ trace_option (corner_case ~loc:__LOC__ "record access leaf") @@
Append_tree.exists_path aux node_tv in Append_tree.exists_path aux node_tv in
let lr_path = List.map (fun b -> if b then `Right else `Left) path 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_chain_id s -> D_string s
| Literal_operation op -> D_operation op | Literal_operation op -> D_operation op
| Literal_unit -> D_unit | Literal_unit -> D_unit
| Literal_void -> D_none
and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele -> and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele ->
transpile_type ele.type_value 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 let%bind map_tv = get_t_sum t in
ok @@ Append_tree.of_list @@ kv_list_of_cmap map_tv ok @@ Append_tree.of_list @@ kv_list_of_cmap map_tv
and transpile_annotated_expression (ae:AST.annotated_expression) : expression result = and transpile_annotated_expression (ae:AST.expression) : expression result =
let%bind tv = transpile_type ae.type_annotation in let%bind tv = transpile_type ae.type_expression in
let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
let f = transpile_annotated_expression in let f = transpile_annotated_expression in
let info = 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 let content () = Format.asprintf "%a" Location.pp ae.location in
info title content in info title content in
trace info @@ trace info @@
match ae.expression with match ae.expression_content with
| E_let_in {binder; rhs; result; inline} -> | E_let_in {let_binder; rhs; let_result; inline} ->
let%bind rhs' = transpile_annotated_expression rhs in let%bind rhs' = transpile_annotated_expression rhs in
let%bind result' = transpile_annotated_expression result in let%bind result' = transpile_annotated_expression let_result in
return (E_let_in ((binder, rhs'.type_value), inline, rhs', result')) return (E_let_in ((let_binder, rhs'.type_value), inline, rhs', result'))
| E_literal l -> return @@ E_literal (transpile_literal l) | E_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> ( | E_variable name -> (
let%bind ele = 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 let%bind tv = transpile_environment_element_type ele in
return ~tv @@ E_variable (name) return ~tv @@ E_variable (name)
) )
| E_application (a, b) -> | E_application {expr1;expr2} ->
let%bind a = transpile_annotated_expression a in let%bind a = transpile_annotated_expression expr1 in
let%bind b = transpile_annotated_expression b in let%bind b = transpile_annotated_expression expr2 in
return @@ E_application (a, b) return @@ E_application (a, b)
| E_constructor (m, param) -> ( | E_constructor {constructor;element} -> (
let%bind param' = transpile_annotated_expression param in let%bind param' = transpile_annotated_expression element in
let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in
let%bind node_tv = let%bind node_tv =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@ 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 = let leaf (k, tv) : (expression' option * type_value) result =
if k = m then ( if k = constructor then (
let%bind _ = let%bind _ =
trace_strong (corner_case ~loc:__LOC__ "wrong type for constructor parameter") 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) ok (Some (param'_expr), param'_tv)
) else ( ) else (
let%bind tv = transpile_type tv in 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 match (a, b) with
| (None, a), (None, b) -> ok (None, T_or ((None, a), (None, b))) | (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 _, _), (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))) | (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 (C_RIGHT, [Combinators.Expression.make_tpl (v, b)])), 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 in
let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
let%bind ae = let%bind ae =
@ -310,36 +279,6 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
ae_opt in ae_opt in
return ~tv ae 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 -> ( | E_record m -> (
let node = Append_tree.of_list @@ list_of_lmap m in let node = Append_tree.of_list @@ list_of_lmap m in
let aux a b : expression result = 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 a_ty = Combinators.Expression.get_type a in
let b_ty = Combinators.Expression.get_type b in let b_ty = Combinators.Expression.get_type b in
let tv = T_pair ((None, a_ty) , (None, b_ty)) 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 in
trace_strong (corner_case ~loc:__LOC__ "record build") @@ trace_strong (corner_case ~loc:__LOC__ "record build") @@
Append_tree.fold_ne (transpile_annotated_expression) aux node Append_tree.fold_ne (transpile_annotated_expression) aux node
) )
| E_record_accessor (record, property) -> | E_record_accessor {expr; label} ->
let%bind ty' = transpile_type (get_type_annotation record) in let%bind ty' = transpile_type (get_type_expression expr) in
let%bind ty_lmap = let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@ trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_annotation record) in get_t_record (get_type_expression expr) in
let%bind ty'_lmap = AST.bind_map_lmap transpile_type ty_lmap in let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind path = let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@ 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 aux = fun pred (ty, lr) ->
let c = match lr with let c = match lr with
| `Left -> C_CAR | `Left -> C_CAR
| `Right -> C_CDR in | `Right -> C_CDR in
Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in Combinators.Expression.make_tpl (E_constant {cons_name=c;arguments=[pred]} , ty) in
let%bind record' = transpile_annotated_expression record in let%bind record' = transpile_annotated_expression expr in
let expr = List.fold_left aux record' path in let expr = List.fold_left aux record' path in
ok expr ok expr
| E_record_update (record, (l,expr)) -> | E_record_update {record; path; update} ->
let%bind ty' = transpile_type (get_type_annotation record) in let%bind ty' = transpile_type (get_type_expression record) in
let%bind ty_lmap = let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@ trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_annotation record) in get_t_record (get_type_expression record) in
let%bind ty'_lmap = AST.bind_map_lmap transpile_type ty_lmap in let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind path = let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@ trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_lmap l in record_access_to_lr ty' ty'_lmap path in
let path' = List.map snd path in let path = List.map snd path in
let%bind expr' = transpile_annotated_expression expr in let%bind update = transpile_annotated_expression update in
let%bind record = transpile_annotated_expression record in let%bind record = transpile_annotated_expression record in
return @@ E_update (record, (path',expr')) return @@ E_record_update (record, path, update)
| E_constant (name , lst) -> ( | E_constant {cons_name=name; arguments=lst} -> (
let iterator_generator iterator_name = let iterator_generator iterator_name =
let lambda_to_iterator_body (f : AST.annotated_expression) (l : AST.lambda) = let lambda_to_iterator_body (f : AST.expression) (l : AST.lambda) =
let%bind body' = transpile_annotated_expression l.body in let%bind body' = transpile_annotated_expression l.result in
let%bind (input , _) = AST.get_t_function f.type_annotation in let%bind (input , _) = AST.get_t_function f.type_expression in
let%bind input' = transpile_type input in let%bind input' = transpile_type input in
ok ((l.binder , input') , body') ok ((l.binder , input') , body')
in in
let expression_to_iterator_body (f : AST.annotated_expression) = let expression_to_iterator_body (f : AST.expression) =
match f.expression with match f.expression_content with
| E_lambda l -> lambda_to_iterator_body f l | E_lambda l -> lambda_to_iterator_body f l
| E_variable v -> ( | E_variable v -> (
let%bind elt = 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 AST.Environment.get_opt v f.environment in
match elt.definition with match elt.definition with
| ED_declaration (f , _) -> ( | ED_declaration (f , _) -> (
match f.expression with match f.expression_content with
| E_lambda l -> lambda_to_iterator_body f l | E_lambda l -> lambda_to_iterator_body f l
| _ -> fail @@ unsupported_iterator f.location | _ -> fail @@ unsupported_iterator f.location
) )
@ -408,7 +347,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
) )
| _ -> fail @@ unsupported_iterator f.location | _ -> fail @@ unsupported_iterator f.location
in 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 -> ( | [f ; i] , C_ITER | [f ; i] , C_MAP -> (
let%bind f' = expression_to_iterator_body f in let%bind f' = expression_to_iterator_body f in
let%bind i' = transpile_annotated_expression i 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 | (C_MAP_FOLD , lst) -> fold lst
| _ -> ( | _ -> (
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in 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 -> | 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 transpile_lambda l io
| E_list lst -> ( | E_list lst -> (
let%bind t = let%bind t =
@ -446,7 +385,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
get_t_list tv in get_t_list tv in
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur -> 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 let%bind (init : expression) = return @@ E_make_empty_list t in
bind_fold_right_list aux init lst' 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 get_t_set tv in
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur -> 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 let%bind (init : expression) = return @@ E_make_empty_set t in
bind_fold_list aux init lst' bind_fold_list aux init lst'
) )
@ -464,12 +403,12 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind (src, dst) = let%bind (src, dst) =
trace_strong (corner_case ~loc:__LOC__ "not a map") @@ trace_strong (corner_case ~loc:__LOC__ "not a map") @@
Mini_c.Combinators.get_t_map tv in 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 prev' = prev in
let%bind (k', v') = let%bind (k', v') =
let v' = e_a_some v ae.environment in let v' = e_a_some v ae.environment in
bind_map_pair (transpile_annotated_expression) (k , v') 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 in
let init = return @@ E_make_empty_map (src, dst) in let init = return @@ E_make_empty_map (src, dst) in
List.fold_left aux init m List.fold_left aux init m
@ -478,63 +417,26 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
let%bind (src, dst) = let%bind (src, dst) =
trace_strong (corner_case ~loc:__LOC__ "not a map") @@ trace_strong (corner_case ~loc:__LOC__ "not a map") @@
Mini_c.Combinators.get_t_big_map tv in 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 prev' = prev in
let%bind (k', v') = let%bind (k', v') =
let v' = e_a_some v ae.environment in let v' = e_a_some v ae.environment in
bind_map_pair (transpile_annotated_expression) (k , v') 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 in
let init = return @@ E_make_empty_big_map (src, dst) in let init = return @@ E_make_empty_big_map (src, dst) in
List.fold_left aux init m List.fold_left aux init m
) )
| E_look_up dsi -> ( | E_look_up dsi -> (
let%bind (ds', i') = bind_map_pair f dsi in let%bind (ds', i') = bind_map_pair f dsi in
return @@ E_constant (C_MAP_FIND_OPT, [i' ; ds']) return @@ E_constant {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']}
) )
| E_sequence (a , b) -> ( | E_loop {condition; body} -> (
let%bind a' = transpile_annotated_expression a in let%bind expr' = transpile_annotated_expression condition 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
let%bind body' = transpile_annotated_expression body in let%bind body' = transpile_annotated_expression body in
return @@ E_while (expr' , body') return @@ E_while (expr' , body')
) )
| E_assign (typed_name , path , expr) -> ( | E_matching {matchee=expr; cases=m} -> (
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) -> (
let%bind expr' = transpile_annotated_expression expr in let%bind expr' = transpile_annotated_expression expr in
match m with match m with
| Match_bool {match_true ; match_false} -> | 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) = and transpile_lambda l (input_type , output_type) =
let { binder ; body } : AST.lambda = l in let { binder ; result } : AST.lambda = l in
let%bind result' = transpile_annotated_expression body in let%bind result' = transpile_annotated_expression result in
let%bind input = transpile_type input_type in let%bind input = transpile_type input_type in
let%bind output = transpile_type output_type in let%bind output = transpile_type output_type in
let tv = Combinators.t_function input output in let tv = Combinators.t_function input output in
let binder = binder in
let closure = E_closure { binder; body = result'} in let closure = E_closure { binder; body = result'} in
ok @@ Combinators.Expression.make_tpl (closure , tv) ok @@ Combinators.Expression.make_tpl (closure , tv)
let transpile_declaration env (d:AST.declaration) : toplevel_statement result = let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
match d with match d with
| Declaration_constant ({name;annotated_expression} , inline , _) -> | Declaration_constant (name,expression, inline, _) ->
let%bind expression = transpile_annotated_expression annotated_expression in let name = name in
let%bind expression = transpile_annotated_expression expression in
let tv = Combinators.Expression.get_type expression in let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (name, tv) env in let env' = Environment.add (name, tv) env in
ok @@ ((name, inline, expression), environment_wrap env env') 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 if aux (snd storage) false then ok (f, ty) else fail @@ bad_big_map loc
| _ -> ok (f, ty) | _ -> 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 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 match tv with
| Leaf (k, t), v -> ok (k, v, t) | Leaf (k, t), v -> ok (k, v, t)
| Node {a}, D_left v -> aux (a, v) | 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 let%bind (s, v, t) = aux (tree, v) in
ok (s, v, t) 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 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 match tv with
| Leaf t, v -> ok @@ [v, t] | Leaf t, v -> ok @@ [v, t]
| Node {a;b}, D_pair (va, vb) -> | 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 extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
let open Append_tree in 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 match tv with
| Leaf (s, t), v -> ok @@ [s, (v, t)] | Leaf (s, t), v -> ok @@ [s, (v, t)]
| Node {a;b}, D_pair (va, vb) -> | 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 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 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_lambda : AST.lambda -> expression result
val transpile_declaration : environment -> AST.declaration -> toplevel_statement 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] *) (* From an expression [expr], build the expression [fun () -> expr] *)
val translate_entry : AST.program -> string -> ( anon_function * ( type_value * type_value )) result 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_constructor : value -> ( string * AST.type_expression ) Append_tree.t' -> (string * value * AST.type_expression) result
val extract_tuple : value -> AST.type_value Append_tree.t' -> (value * AST.type_value) list result val extract_tuple : value -> AST.type_expression Append_tree.t' -> (value * AST.type_expression) list result
val extract_record : value -> ( string * AST.type_value ) Append_tree.t' -> ( string * ( value * AST.type_value )) 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_value -> AST.annotated_expression 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 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 open! AST in
let return e = ok (make_a_e_empty e t) 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 -> ( | T_constant type_constant -> (
match type_constant with match type_constant with
| TC_unit -> ( | TC_unit -> (
@ -95,6 +95,7 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
return (E_literal (Literal_bytes n)) return (E_literal (Literal_bytes n))
) )
| TC_address -> ( | TC_address -> (
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "address" v) @@ trace_strong (wrong_mini_c_value "address" v) @@
get_string v in get_string v in
@ -124,6 +125,12 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
get_string v in get_string v in
return (E_literal (Literal_chain_id n)) 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 -> ( | TC_signature -> (
let%bind n = let%bind n =
trace_strong (wrong_mini_c_value "signature" v) @@ 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 bind_map_list aux lst in
return (E_list lst') 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 -> ( | TC_set ty -> (
let%bind lst = let%bind lst =
trace_strong (wrong_mini_c_value "set" v) @@ 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 _ -> | TC_contract _ ->
fail @@ bad_untranspile "contract" v 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 -> | T_sum m ->
let lst = kv_list_of_cmap m in 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") @@ trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
extract_constructor v node in extract_constructor v node in
let%bind sub = untranspile v tv 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 -> | T_record m ->
let lst = kv_list_of_lmap m in let lst = kv_list_of_lmap m in
let%bind node = match Append_tree.of_list lst with 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' ok init'
) )
| E_literal _ -> ok init' | E_literal _ -> ok init'
| E_constant (_, lst) -> ( | E_constant (c) -> (
let%bind res = bind_fold_list self init' lst in let%bind res = bind_fold_list self init' c.arguments in
ok res ok res
) )
| E_closure af -> ( | 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 let%bind res = self init' exp in
ok res ok res
) )
| E_update (r, (_,e)) -> ( | E_record_update (r, _, e) -> (
let%bind res = self init' r in let%bind res = self init' r in
let%bind res = self res e in let%bind res = self res e in
ok res 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_big_map _
| E_make_empty_list _ | E_make_empty_list _
| E_make_empty_set _ as em -> return em | E_make_empty_set _ as em -> return em
| E_constant (name, lst) -> ( | E_constant (c) -> (
let%bind lst' = bind_map_list self lst in let%bind lst = bind_map_list self c.arguments in
return @@ E_constant (name,lst') return @@ E_constant {cons_name = c.cons_name; arguments = lst}
) )
| E_closure af -> ( | E_closure af -> (
let%bind body = self af.body in 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 let%bind exp' = self exp in
return @@ E_assignment (s, lrl, exp') 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 r = self r in
let%bind e = self e 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 -> 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} -> | E_closure {binder=_ ; body} ->
let%bind _self_in_lambdas = Helpers.map_expression let%bind _self_in_lambdas = Helpers.map_expression
(fun e -> match e.content with (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) | _ -> ok e)
body in body in
ok e ok e

19
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 (* true if the name names a pure constant -- i.e. if uses will be pure
assuming arguments are pure *) assuming arguments are pure *)
let is_pure_constant : constant -> bool = let is_pure_constant : constant' -> bool =
function function
| C_UNIT | C_UNIT
| C_CAR | C_CDR | C_PAIR | C_CAR | C_CDR | C_PAIR
@ -64,10 +64,10 @@ let rec is_pure : expression -> bool = fun e ->
| E_sequence (e1, e2) | E_sequence (e1, e2)
-> List.for_all is_pure [ e1 ; e2 ] -> List.for_all is_pure [ e1 ; e2 ]
| E_constant (c, args) | E_constant (c)
-> is_pure_constant c && List.for_all is_pure args -> is_pure_constant c.cons_name && List.for_all is_pure c.arguments
| E_update (r, (_,e)) | E_record_update (e, _,up)
-> is_pure r && is_pure e -> is_pure e && is_pure up
(* I'm not sure about these. Maybe can be tested better? *) (* I'm not sure about these. Maybe can be tested better? *)
| E_application _ | E_application _
@ -79,6 +79,7 @@ let rec is_pure : expression -> bool = fun e ->
is near... *) is near... *)
| E_while _ -> false | E_while _ -> false
(* definitely not pure *) (* definitely not pure *)
| E_assignment _ -> false | E_assignment _ -> false
@ -111,14 +112,14 @@ let rec is_assigned : ignore_lambdas:bool -> expression_variable -> expression -
match e.content with match e.content with
| E_assignment (x, _, e) -> | E_assignment (x, _, e) ->
it x || self e it x || self e
| E_update (r, (_,e)) -> | E_record_update (r, _, e) ->
self r || self e self r || self e
| E_closure { binder; body } -> | E_closure { binder; body } ->
if ignore_lambdas if ignore_lambdas
then false then false
else self_binder binder body else self_binder binder body
| E_constant (_, args) -> | E_constant (c) ->
selfs args selfs c.arguments
| E_application (f, arg) -> | E_application (f, arg) ->
selfs [ f ; arg ] selfs [ f ; arg ]
| E_iterator (_, ((x, _), e1), e2) -> | E_iterator (_, ((x, _), e1), e2) ->
@ -236,7 +237,7 @@ let beta : bool ref -> expression -> expression =
else e else e
(* also do CAR (PAIR x y) ↦ x, or CDR (PAIR x y) ↦ y, only if x and y are pure *) (* 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 if is_pure e1 && is_pure e2
then (changed := true ; then (changed := true ;
match const with 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 let binder = replace_var binder in
return @@ E_closure { binder ; body } return @@ E_closure { binder ; body }
| E_skip -> e | E_skip -> e
| E_constant (c, args) -> | E_constant (c) ->
let args = List.map replace args in let args = List.map replace c.arguments in
return @@ E_constant (c, args) return @@ E_constant {cons_name = c.cons_name; arguments = args}
| E_application (f, x) -> | E_application (f, x) ->
let (f, x) = Tuple.map2 replace (f, x) in let (f, x) = Tuple.map2 replace (f, x) in
return @@ E_application (f, x) 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 v = replace_var v in
let e = replace e in let e = replace e in
return @@ E_assignment (v, path, e) return @@ E_assignment (v, path, e)
| E_update (r, (p,e)) -> | E_record_update (r, p, e) ->
let r = replace r in let r = replace r in
let e = replace e in let e = replace e in
return @@ E_update (r, (p,e)) return @@ E_record_update (r, p, e)
| E_while (cond, body) -> | E_while (cond, body) ->
let cond = replace cond in let cond = replace cond in
let body = replace body 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: (* 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 *) intuitively, we substitute in \hd tl. expr' as if it were \hd. \tl. expr *)
let subst_binder2 y z 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' } ; let hack = { content = E_closure { binder = z ; body = expr' } ;
type_value = dummy } in type_value = dummy } in
match subst_binder y hack with 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_big_map _
| E_make_empty_list _ | E_make_empty_list _
| E_make_empty_set _ as em -> return em | E_make_empty_set _ as em -> return em
| E_constant (name, lst) -> ( | E_constant (c) -> (
let lst' = List.map self lst in let lst = List.map self c.arguments in
return @@ E_constant (name,lst') return @@ E_constant {cons_name = c.cons_name; arguments = lst }
) )
| E_application farg -> ( | E_application farg -> (
let farg' = Tuple.map2 self farg in 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 ; if Var.equal s x then raise Bad_argument ;
return @@ E_assignment (s, lrl, exp') return @@ E_assignment (s, lrl, exp')
) )
| E_update (r, (p,e)) -> ( | E_record_update (r, p, e) -> (
let r' = self r in let r' = self r in
let e' = self e in let e' = self e in
return @@ E_update(r', (p,e')) return @@ E_record_update(r', p, e')
) )
let%expect_test _ = 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 wrap e = { content = e ; type_value = dummy_type } in
let show_subst ~body ~x ~expr = 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 error =
let title () = "Environment.get" in let title () = "Environment.get" in
let content () = Format.asprintf "%a in %a" let content () = Format.asprintf "%a in %a"
Stage_common.PP.name s Var.pp s
PP.environment e in PP.environment e in
error title content in error title content in
generic_try error @@ generic_try error @@

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

@ -27,7 +27,7 @@ end
open Errors open Errors
(* This does not makes sense to me *) (* 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 match Operators.Compiler.get_operators s with
| Ok (x,_) -> ok x | Ok (x,_) -> ok x
| Error _ -> ( | Error _ -> (
@ -114,7 +114,7 @@ let get_operator : constant -> type_value -> expression list -> predicate result
i_drop ; (* drop the entrypoint... *) i_drop ; (* drop the entrypoint... *)
prim ~annot:[entry] ~children:[r_ty] I_CONTRACT ; 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 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' ; b' ;
] ]
) )
| E_constant(str, lst) -> | E_constant{cons_name=str;arguments= lst} ->
let module L = Logger.Stateful() in let module L = Logger.Stateful() in
let%bind pre_code = let%bind pre_code =
let aux code expr = let aux code expr =
@ -249,7 +249,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
pre_code ; pre_code ;
f ; 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 in
let error = let error =
let title () = "error compiling constant" in let title () = "error compiling constant" in
@ -347,7 +347,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
]) in ]) in
return code return code
) )
| E_iterator (name , (v , body) , expr) -> ( | E_iterator (name,(v , body) , expr) -> (
let%bind expr' = translate_expression expr env in let%bind expr' = translate_expression expr env in
let%bind body' = translate_expression body (Environment.add v env) in let%bind body' = translate_expression body (Environment.add v env) in
match name with match name with
@ -367,7 +367,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
return code return code
) )
| s -> ( | 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 let error = error (thunk "bad iterator") (thunk iter) in
fail error fail error
) )
@ -422,7 +422,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result
i_push_unit ; i_push_unit ;
] ]
) )
| E_update (record, (path, expr)) -> ( | E_record_update (record, path, expr) -> (
let%bind record' = translate_expression record env in let%bind record' = translate_expression record env in
let record_var = Var.fresh () 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 ; 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_expression : expression -> environment -> michelson result
val translate_function_body : anon_function -> environment_element list -> type_value -> michelson result val translate_function_body : anon_function -> environment_element list -> type_value -> michelson result
val translate_value : value -> 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 tez_k = Mutez_key None
let int_k = Int_key None let int_k = Int_key None
let string_k = String_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 address_k = Address_key None
let timestamp_k = Timestamp_key None let timestamp_k = Timestamp_key None
let bytes_k = Bytes_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_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
let not_compilable_type name () = error (thunk "not a compilable 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 let return x = ok @@ Ex_comparable_ty x in
match tb with match tb with
| Base_unit -> fail (not_comparable "unit") | TC_unit -> fail (not_comparable "unit")
| Base_void -> fail (not_comparable "void") | TC_void -> fail (not_comparable "void")
| Base_bool -> fail (not_comparable "bool") | TC_bool -> fail (not_comparable "bool")
| Base_nat -> return nat_k | TC_nat -> return nat_k
| Base_mutez -> return tez_k | TC_mutez -> return tez_k
| Base_int -> return int_k | TC_int -> return int_k
| Base_string -> return string_k | TC_string -> return string_k
| Base_address -> return address_k | TC_address -> return address_k
| Base_timestamp -> return timestamp_k | TC_timestamp -> return timestamp_k
| Base_bytes -> return bytes_k | TC_bytes -> return bytes_k
| Base_operation -> fail (not_comparable "operation") | TC_operation -> fail (not_comparable "operation")
| Base_signature -> fail (not_comparable "signature") | TC_signature -> fail (not_comparable "signature")
| Base_key -> fail (not_comparable "key") | TC_key -> fail (not_comparable "key")
| Base_key_hash -> return key_hash_k | TC_key_hash -> fail (not_comparable "key_hash")
| Base_chain_id -> fail (not_comparable "chain_id") | TC_chain_id -> fail (not_comparable "chain_id")
let comparable_type : type_value -> ex_comparable_ty result = fun tv -> let comparable_type : type_value -> ex_comparable_ty result = fun tv ->
match tv with match tv with
@ -89,24 +89,24 @@ module Ty = struct
| T_option _ -> fail (not_comparable "option") | T_option _ -> fail (not_comparable "option")
| T_contract _ -> fail (not_comparable "contract") | 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 let return x = ok @@ Ex_ty x in
match b with match b with
| Base_unit -> return unit | TC_unit -> return unit
| Base_void -> fail (not_compilable_type "void") | TC_void -> fail (not_compilable_type "void")
| Base_bool -> return bool | TC_bool -> return bool
| Base_int -> return int | TC_int -> return int
| Base_nat -> return nat | TC_nat -> return nat
| Base_mutez -> return tez | TC_mutez -> return tez
| Base_string -> return string | TC_string -> return string
| Base_address -> return address | TC_address -> return address
| Base_timestamp -> return timestamp | TC_timestamp -> return timestamp
| Base_bytes -> return bytes | TC_bytes -> return bytes
| Base_operation -> return operation | TC_operation -> return operation
| Base_signature -> return signature | TC_signature -> return signature
| Base_key -> return key | TC_key -> return key
| Base_key_hash -> return key_hash | TC_key_hash -> return key_hash
| Base_chain_id -> return chain_id | TC_chain_id -> return chain_id
let rec type_ : type_value -> ex_ty result = let rec type_ : type_value -> ex_ty result =
function function
@ -175,23 +175,23 @@ module Ty = struct
end end
let base_type : type_base -> O.michelson result = let base_type : type_constant -> O.michelson result =
function function
| Base_unit -> ok @@ O.prim T_unit | TC_unit -> ok @@ O.prim T_unit
| Base_void -> fail (Ty.not_compilable_type "void") | TC_void -> fail (Ty.not_compilable_type "void")
| Base_bool -> ok @@ O.prim T_bool | TC_bool -> ok @@ O.prim T_bool
| Base_int -> ok @@ O.prim T_int | TC_int -> ok @@ O.prim T_int
| Base_nat -> ok @@ O.prim T_nat | TC_nat -> ok @@ O.prim T_nat
| Base_mutez -> ok @@ O.prim T_mutez | TC_mutez -> ok @@ O.prim T_mutez
| Base_string -> ok @@ O.prim T_string | TC_string -> ok @@ O.prim T_string
| Base_address -> ok @@ O.prim T_address | TC_address -> ok @@ O.prim T_address
| Base_timestamp -> ok @@ O.prim T_timestamp | TC_timestamp -> ok @@ O.prim T_timestamp
| Base_bytes -> ok @@ O.prim T_bytes | TC_bytes -> ok @@ O.prim T_bytes
| Base_operation -> ok @@ O.prim T_operation | TC_operation -> ok @@ O.prim T_operation
| Base_signature -> ok @@ O.prim T_signature | TC_signature -> ok @@ O.prim T_signature
| Base_key -> ok @@ O.prim T_key | TC_key -> ok @@ O.prim T_key
| Base_key_hash -> ok @@ O.prim T_key_hash | TC_key_hash -> ok @@ O.prim T_key_hash
| Base_chain_id -> ok @@ O.prim T_chain_id | TC_chain_id -> ok @@ O.prim T_chain_id
let rec type_ : type_value -> O.michelson result = let rec type_ : type_value -> O.michelson result =
function 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 title () = "these types are not comparable" in
let message () = "" in let message () = "" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_value a) ; ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_value b ) ("b" , fun () -> Format.asprintf "%a" PP.type_expression b )
] in ] in
error ~data title message () error ~data title message ()
end end
open Errors open Errors
type type_result = type_value type type_result = type_expression
type typer = type_value list -> type_value option -> type_result result 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 match lst with
| [] -> ( | [] -> (
let%bind tv' = f tv_opt in let%bind tv' = f tv_opt in
@ -32,7 +32,7 @@ module Typer = struct
) )
| _ -> fail @@ wrong_param_number s 0 lst | _ -> 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 match lst with
| [ a ] -> ( | [ a ] -> (
let%bind tv' = f a in let%bind tv' = f a in
@ -40,7 +40,7 @@ module Typer = struct
) )
| _ -> fail @@ wrong_param_number s 1 lst | _ -> 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 match lst with
| [ a ] -> ( | [ a ] -> (
let%bind tv' = f a tv_opt in let%bind tv' = f a tv_opt in
@ -48,7 +48,7 @@ module Typer = struct
) )
| _ -> fail @@ wrong_param_number s 1 lst | _ -> 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 match lst with
| [ a ; b ] -> ( | [ a ; b ] -> (
let%bind tv' = f a b in let%bind tv' = f a b in
@ -56,7 +56,7 @@ module Typer = struct
) )
| _ -> fail @@ wrong_param_number s 2 lst | _ -> 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 match lst with
| [ a ; b ] -> ( | [ a ; b ] -> (
let%bind tv' = f a b tv_opt in let%bind tv' = f a b tv_opt in
@ -64,7 +64,7 @@ module Typer = struct
) )
| _ -> fail @@ wrong_param_number s 2 lst | _ -> 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 match lst with
| [ a ; b ; c ] -> ( | [ a ; b ; c ] -> (
let%bind tv' = f a b c in let%bind tv' = f a b c in
@ -72,7 +72,7 @@ module Typer = struct
) )
| _ -> fail @@ wrong_param_number s 3 lst | _ -> 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 match lst with
| [ a ; b ; c ; d ] -> ( | [ a ; b ; c ; d ] -> (
let%bind tv' = f a b c d in let%bind tv' = f a b c d in
@ -80,7 +80,7 @@ module Typer = struct
) )
| _ -> fail @@ wrong_param_number s 4 lst | _ -> 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 match lst with
| [ a ; b ; c ; d ; e ] -> ( | [ a ; b ; c ; d ; e ] -> (
let%bind tv' = f a b c d e in let%bind tv' = f a b c d e in
@ -88,7 +88,7 @@ module Typer = struct
) )
| _ -> fail @@ wrong_param_number s 5 lst | _ -> 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 match lst with
| [ a ; b ; c ; d ; e ; f_ ] -> ( | [ a ; b ; c ; d ; e ; f_ ] -> (
let%bind tv' = f a b c d e f_ in 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 | _ -> 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 open Combinators
let eq_1 a cst = type_value_eq (a , cst) let eq_1 a cst = type_expression_eq (a , cst)
let eq_2 (a , b) cst = type_value_eq (a , cst) && type_value_eq (b , 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) let assert_eq_1 ?msg a b = Assert.assert_true ?msg (eq_1 a b)
@ -125,11 +125,11 @@ module Typer = struct
let%bind () = let%bind () =
trace_strong (simple_error "A isn't of type bool") @@ trace_strong (simple_error "A isn't of type bool") @@
Assert.assert_true @@ Assert.assert_true @@
type_value_eq (t_bool () , a) in type_expression_eq (t_bool () , a) in
let%bind () = let%bind () =
trace_strong (simple_error "B isn't of type bool") @@ trace_strong (simple_error "B isn't of type bool") @@
Assert.assert_true @@ Assert.assert_true @@
type_value_eq (t_bool () , b) in type_expression_eq (t_bool () , b) in
ok @@ t_bool () ok @@ t_bool ()
end end

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

@ -4,51 +4,51 @@ module Typer : sig
module Errors : sig module Errors : sig
val wrong_param_number : string -> int -> 'a list -> unit -> error 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 end
type type_result = type_value type type_result = type_expression
type typer = type_value list -> type_value option -> type_result result 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 : string -> (type_expression -> type_expression -> type_expression result) -> typer
val typer_2_opt : string -> (type_value -> type_value -> type_value option -> type_value 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_1 : type_expression -> type_expression -> bool
val eq_2 : ( type_value * type_value ) -> type_value -> bool val eq_2 : ( type_expression * type_expression ) -> type_expression -> bool
val assert_eq_1 : ?msg:string -> type_value -> type_value -> unit result val assert_eq_1 : ?msg:string -> type_expression -> type_expression -> unit result
val comparator : string -> typer val comparator : string -> typer
val boolean_operator_2 : string -> typer val boolean_operator_2 : string -> typer

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

@ -181,11 +181,11 @@ module Simplify = struct
| "Bytes.sub" -> ok C_SLICE | "Bytes.sub" -> ok C_SLICE
| "Set.mem" -> ok C_SET_MEM | "Set.mem" -> ok C_SET_MEM
| "Set.iter" -> ok C_SET_ITER
| "Set.empty" -> ok C_SET_EMPTY | "Set.empty" -> ok C_SET_EMPTY
| "Set.literal" -> ok C_SET_LITERAL | "Set.literal" -> ok C_SET_LITERAL
| "Set.add" -> ok C_SET_ADD | "Set.add" -> ok C_SET_ADD
| "Set.remove" -> ok C_SET_REMOVE | "Set.remove" -> ok C_SET_REMOVE
| "Set.iter" -> ok C_SET_ITER
| "Set.fold" -> ok C_SET_FOLD | "Set.fold" -> ok C_SET_FOLD
| "Set.size" -> ok C_SIZE | "Set.size" -> ok C_SIZE
@ -273,8 +273,8 @@ module Typer = struct
let type_error msg expected_type actual_type () = let type_error msg expected_type actual_type () =
let message () = let message () =
Format.asprintf "Expected an expression of type %a but got an expression of type %a" 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_expression expected_type
Ast_typed.PP.type_value actual_type in Ast_typed.PP.type_expression actual_type in
error (thunk msg) message error (thunk msg) message
open PP_helpers open PP_helpers
@ -286,8 +286,8 @@ module Typer = struct
let typeclass_error msg f expected_types actual_types () = let typeclass_error msg f expected_types actual_types () =
let message () = let message () =
Format.asprintf "Expected arguments with one of the following combinations of types: %a but got this combination instead: %a" 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 (list_sep (print_f_args f Ast_typed.PP.type_expression) (const " or ")) expected_types
(print_f_args f Ast_typed.PP.type_value) actual_types in (print_f_args f Ast_typed.PP.type_expression) actual_types in
error (thunk msg) message error (thunk msg) message
end end
(* (*
@ -329,6 +329,7 @@ module Typer = struct
let tc_addargs a b c = tc [a;b;c] [ (*TODO…*) ] let tc_addargs a b c = tc [a;b;c] [ (*TODO…*) ]
let t_none = forall "a" @@ fun a -> option a 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] => tuple2 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_some = forall "a" @@ fun a -> a --> option a
let t_map_remove = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> map src dst let t_map_remove = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> map src dst
@ -376,7 +377,7 @@ module Typer = struct
let t_set_remove = 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 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_INT -> ok @@ t_int ;
| C_UNIT -> ok @@ t_unit ; | C_UNIT -> ok @@ t_unit ;
| C_NOW -> ok @@ t_now ; | C_NOW -> ok @@ t_now ;
@ -490,42 +491,42 @@ module Typer = struct
let list_cons : typer = typer_2 "CONS" @@ fun hd tl -> let list_cons : typer = typer_2 "CONS" @@ fun hd tl ->
let%bind tl' = get_t_list tl in 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 ok tl
let map_remove : typer = typer_2 "MAP_REMOVE" @@ fun k m -> 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 (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 ok m
let map_add : typer = typer_3 "MAP_ADD" @@ fun k v 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 (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 () = assert_type_value_eq (dst, v) in let%bind () = assert_type_expression_eq (dst, v) in
ok m ok m
let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v 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 (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 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 ok m
let map_mem : typer = typer_2 "MAP_MEM" @@ fun k 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 (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 () ok @@ t_bool ()
let map_find : typer = typer_2 "MAP_FIND" @@ fun k m -> let map_find : typer = typer_2 "MAP_FIND" @@ fun k m ->
let%bind (src, dst) = let%bind (src, dst) =
trace_strong (simple_error "MAP_FIND: not map or bigmap") @@ trace_strong (simple_error "MAP_FIND: not map or bigmap") @@
bind_map_or (get_t_map , get_t_big_map) m in 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 ok @@ dst
let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m -> 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 (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 () ok @@ t_option dst ()
let map_iter : typer = typer_2 "MAP_ITER" @@ fun f m -> let map_iter : typer = typer_2 "MAP_ITER" @@ fun f m ->
@ -602,17 +603,17 @@ module Typer = struct
let%bind () = assert_t_bytes b in let%bind () = assert_t_bytes b in
ok @@ t_bool () 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 address = typer_1 "ADDRESS" @@ fun contract ->
let%bind () = assert_t_contract contract in let%bind () = assert_t_contract contract in
@ -625,12 +626,12 @@ module Typer = struct
let%bind () = assert_t_key_hash key_hash in let%bind () = assert_t_key_hash key_hash in
ok @@ t_contract (t_unit () ) () 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 transaction = typer_3 "CALL" @@ fun param amount contract ->
let%bind () = assert_t_mutez amount in let%bind () = assert_t_mutez amount in
let%bind contract_param = get_t_contract contract 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 () ok @@ t_operation ()
let originate = typer_6 "ORIGINATE" @@ fun manager delegate_opt spendable delegatable init_balance code -> let originate = typer_6 "ORIGINATE" @@ fun manager delegate_opt spendable delegatable init_balance code ->
@ -647,8 +648,8 @@ module Typer = struct
ok @@ (t_pair (t_operation ()) (t_address ()) ()) ok @@ (t_pair (t_operation ()) (t_address ()) ())
let get_contract = typer_1_opt "CONTRACT" @@ fun addr_tv tv_opt -> let get_contract = typer_1_opt "CONTRACT" @@ fun addr_tv tv_opt ->
if not (type_value_eq (addr_tv, t_address ())) if not (type_expression_eq (addr_tv, t_address ()))
then fail @@ simple_error (Format.asprintf "get_contract expects an address, got %a" PP.type_value addr_tv) then fail @@ simple_error (Format.asprintf "get_contract expects an address, got %a" PP.type_expression addr_tv)
else else
let%bind tv = let%bind tv =
trace_option (simple_error "get_contract needs a type annotation") tv_opt in trace_option (simple_error "get_contract needs a type annotation") tv_opt in
@ -658,8 +659,8 @@ module Typer = struct
ok @@ t_contract tv' () ok @@ t_contract tv' ()
let get_contract_opt = typer_1_opt "CONTRACT OPT" @@ fun addr_tv tv_opt -> let get_contract_opt = typer_1_opt "CONTRACT OPT" @@ fun addr_tv tv_opt ->
if not (type_value_eq (addr_tv, t_address ())) 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_value addr_tv) then fail @@ simple_error (Format.asprintf "get_contract_opt expects an address, got %a" PP.type_expression addr_tv)
else else
let%bind tv = let%bind tv =
trace_option (simple_error "get_contract_opt needs a type annotation") tv_opt in trace_option (simple_error "get_contract_opt needs a type annotation") tv_opt in
@ -672,11 +673,11 @@ module Typer = struct
ok @@ t_option (t_contract tv' ()) () ok @@ t_option (t_contract tv' ()) ()
let get_entrypoint = typer_2_opt "CONTRACT_ENTRYPOINT" @@ fun entry_tv addr_tv tv_opt -> let get_entrypoint = typer_2_opt "CONTRACT_ENTRYPOINT" @@ fun entry_tv addr_tv tv_opt ->
if not (type_value_eq (entry_tv, t_string ())) 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_value entry_tv) then fail @@ simple_error (Format.asprintf "get_entrypoint expects a string entrypoint label for first argument, got %a" PP.type_expression entry_tv)
else else
if not (type_value_eq (addr_tv, t_address ())) 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_value addr_tv) then fail @@ simple_error (Format.asprintf "get_entrypoint expects an address for second argument, got %a" PP.type_expression addr_tv)
else else
let%bind tv = let%bind tv =
trace_option (simple_error "get_entrypoint needs a type annotation") tv_opt in trace_option (simple_error "get_entrypoint needs a type annotation") tv_opt in
@ -686,11 +687,11 @@ module Typer = struct
ok @@ t_contract tv' () ok @@ t_contract tv' ()
let get_entrypoint_opt = typer_2_opt "CONTRACT_ENTRYPOINT_OPT" @@ fun entry_tv addr_tv tv_opt -> 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 ())) 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_value entry_tv) 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 else
if not (type_value_eq (addr_tv, t_address ())) 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_value addr_tv) then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects an address for second argument, got %a" PP.type_expression addr_tv)
else else
let%bind tv = let%bind tv =
trace_option (simple_error "get_entrypoint_opt needs a type annotation") tv_opt in trace_option (simple_error "get_entrypoint_opt needs a type annotation") tv_opt in
@ -841,8 +842,8 @@ module Typer = struct
let%bind (prec , cur) = get_t_pair arg in let%bind (prec , cur) = get_t_pair arg in
let%bind key = get_t_list lst in let%bind key = get_t_list lst in
let msg = Format.asprintf "%a vs %a" let msg = Format.asprintf "%a vs %a"
Ast_typed.PP.type_value key PP.type_expression key
Ast_typed.PP.type_value arg PP.type_expression arg
in in
trace (simple_error ("bad list fold:" ^ msg)) @@ trace (simple_error ("bad list fold:" ^ msg)) @@
let%bind () = assert_eq_1 ~msg:"key cur" key cur in let%bind () = assert_eq_1 ~msg:"key cur" key cur in
@ -855,8 +856,8 @@ module Typer = struct
let%bind (prec , cur) = get_t_pair arg in let%bind (prec , cur) = get_t_pair arg in
let%bind key = get_t_set lst in let%bind key = get_t_set lst in
let msg = Format.asprintf "%a vs %a" let msg = Format.asprintf "%a vs %a"
Ast_typed.PP.type_value key PP.type_expression key
Ast_typed.PP.type_value arg PP.type_expression arg
in in
trace (simple_error ("bad set fold:" ^ msg)) @@ trace (simple_error ("bad set fold:" ^ msg)) @@
let%bind () = assert_eq_1 ~msg:"key cur" key cur in let%bind () = assert_eq_1 ~msg:"key cur" key cur in
@ -869,10 +870,10 @@ module Typer = struct
let%bind (prec , cur) = get_t_pair arg in let%bind (prec , cur) = get_t_pair arg in
let%bind (key , value) = get_t_map map in let%bind (key , value) = get_t_map map in
let msg = Format.asprintf "%a vs %a" let msg = Format.asprintf "%a vs %a"
Ast_typed.PP.type_value key PP.type_expression key
Ast_typed.PP.type_value arg PP.type_expression arg
in 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:"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:"prec res" prec res in
let%bind () = assert_eq_1 ~msg:"res init" res init in let%bind () = assert_eq_1 ~msg:"res init" res init in
@ -1063,7 +1064,7 @@ module Typer = struct
| C_SELF_ADDRESS -> ok @@ self_address; | C_SELF_ADDRESS -> ok @@ self_address;
| C_IMPLICIT_ACCOUNT -> ok @@ implicit_account; | C_IMPLICIT_ACCOUNT -> ok @@ implicit_account;
| C_SET_DELEGATE -> ok @@ set_delegate ; | 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

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

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

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

@ -1,110 +1,93 @@
[@@@coverage exclude_file] [@@@coverage exclude_file]
open Types open Types
open PP_helpers
open Format open Format
open PP_helpers
include Stage_common.PP include Stage_common.PP
include Ast_PP_type(Ast_simplified_parameter)
let list_sep_d x ppf lst = match lst with let expression_variable ppf (ev : expression_variable) : unit =
| [] -> () fprintf ppf "%a" Var.pp ev
| _ -> 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 rec te' ppf (te : type_expression type_expression') : unit =
type_expression' type_expression ppf te
and type_expression ppf (te: type_expression) : unit = let rec expression ppf (e : expression) =
te' ppf te.type_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 and option_type_name ppf
| E_literal l -> fprintf ppf "%a" literal l ((n, ty_opt) : expression_variable * type_expression option) =
| 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) =
match ty_opt with match ty_opt with
| None -> fprintf ppf "%a" name n | None ->
| Some ty -> fprintf ppf "%a : %a" name n type_expression ty fprintf ppf "%a" expression_variable n
| Some ty ->
fprintf ppf "%a : %a" expression_variable n type_expression ty
and option_inline ppf inline = and assoc_expression ppf : expr * expr -> unit =
if inline then fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
fprintf ppf "[@inline]"
else
fprintf ppf ""
and assoc_expression ppf : (expr * expr) -> unit = fun (a, b) -> and single_record_patch ppf ((p, expr) : label * expr) =
fprintf ppf "%a -> %a" expression a expression b fprintf ppf "%a <- %a" label p expression expr
and access ppf (a:access) = and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
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 =
fun f ppf ((c,n),a) -> 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 fun f ppf m -> match m with
| Match_tuple ((lst, b), _) -> | 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, _) -> | Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> | 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, _)} -> | 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 *) (* Shows the type expected for the matched value *)
and matching_type ppf m = match m with and matching_type ppf m = match m with
@ -120,13 +103,30 @@ and matching_type ppf m = match m with
fprintf ppf "option" fprintf ppf "option"
and matching_variant_case_type ppf ((c,n),_a) = 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 and option_mut ppf mut =
| Declaration_type (type_name , te) -> if mut then
fprintf ppf "type %a = %a" type_variable (type_name) type_expression te fprintf ppf "[@mut]"
| Declaration_constant (name , ty_opt , inline, expr) -> else
fprintf ppf "const %a = %a%a" option_type_name (name , ty_opt) expression expr option_inline inline fprintf ppf ""
let program ppf (p:program) = and option_inline ppf inline =
fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p) 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 Types
(* include Misc *) (* include Misc *)
include Combinators include Combinators
module Types = Types module Types = Types
module Misc = Misc module Misc = Misc
module PP = PP module PP=PP
module Combinators = Combinators module Combinators = Combinators

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

@ -13,13 +13,19 @@ module Errors = struct
] in ] in
error ~data title message error ~data title message
let bad_type_operator type_op = 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 let message () = "" in
error title message error title message
end end
open Errors 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_bool : type_expression = make_t @@ T_constant (TC_bool)
let t_string : type_expression = make_t @@ T_constant (TC_string) 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_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_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_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 t_record_ez lst =
let lst = List.map (fun (k, v) -> (Label k, v)) lst in let lst = List.map (fun (k, v) -> (Label k, v)) lst in
let m = LMap.of_list 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 let lst = Map.String.to_kv_list m in
t_record_ez lst 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 ez_t_sum (lst:(string * type_expression) list) : type_expression =
let aux prev (k, v) = CMap.add (Constructor k) v prev in let aux prev (k, v) = CMap.add (Constructor k) v prev in
let map = List.fold_left aux CMap.empty lst 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 let lst = Map.String.to_kv_list m in
ez_t_sum lst 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_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_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) 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 | TC_contract _ , [t] -> ok @@ t_contract t
| _ , _ -> fail @@ bad_type_operator op | _ , _ -> fail @@ bad_type_operator op
let location_wrap ?(loc = Location.generated) expression = let location_wrap ?(loc = Location.generated) expression_content =
let location = loc in 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_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 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 ?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_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_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 let%bind bytes = generic_try (simple_error "bad hex to bytes") (fun () -> Hex.to_bytes (`Hex b)) in
ok @@ E_literal (Literal_bytes bytes) ok @@ E_literal (Literal_bytes bytes)
let e_bytes_hex ?loc b : expression result = 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 = let e_bytes_string ?loc (s: string) : expression =
location_wrap ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s))) 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_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_some ?loc s : expression = location_wrap ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_tuple ?loc lst : expression = location_wrap ?loc @@ E_tuple lst let e_none ?loc () : expression = location_wrap ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_some ?loc s : expression = location_wrap ?loc @@ E_constant (C_SOME, [s]) let e_string_cat ?loc sl sr : expression = location_wrap ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_none ?loc () : expression = location_wrap ?loc @@ E_constant (C_NONE, []) 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_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_map ?loc lst : expression = location_wrap ?loc @@ E_map lst 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_set ?loc lst : expression = location_wrap ?loc @@ E_set lst
let e_list ?loc lst : expression = location_wrap ?loc @@ E_list 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 = Constructor s; element = a}
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 {matchee=a;cases=b}
let e_matching ?loc a b : expression = location_wrap ?loc @@ E_matching (a , b)
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) 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 ?loc a b = location_wrap ?loc @@ E_record_accessor {expr = a; label= Label b}
let e_accessor_props ?loc a b = e_accessor ?loc a (List.map (fun x -> Access_record x) 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_variable ?loc v = location_wrap ?loc @@ E_variable v
let e_skip ?loc () = location_wrap ?loc @@ E_skip let e_skip ?loc () = location_wrap ?loc @@ E_skip
let e_loop ?loc cond body = location_wrap ?loc @@ E_loop (cond , body) let e_loop ?loc condition body = location_wrap ?loc @@ E_loop {condition; body}
let e_sequence ?loc a b = location_wrap ?loc @@ E_sequence (a , b) let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
let e_let_in ?loc (binder, ascr) inline rhs result = location_wrap ?loc @@ E_let_in { binder = (binder, ascr) ; rhs ; result ; inline } location_wrap ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline }
let e_annotation ?loc expr ty = location_wrap ?loc @@ E_ascription (expr , ty) 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 (a , b) 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 (name , [a ; 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 (name , lst) 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_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 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 let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
Match_variant (lst,()) Match_variant (lst,())
let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) = let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
e_matching ?loc a (ez_match_variant lst) 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 = let make_option_typed ?loc e t_opt =
match t_opt with match t_opt with
@ -138,12 +159,6 @@ let make_option_typed ?loc e t_opt =
| Some t -> e_annotation ?loc e t | 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 e_typed_none ?loc t_opt =
let type_annotation = t_option t_opt in let type_annotation = t_option t_opt in
e_annotation ?loc (e_none ?loc ()) type_annotation 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_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
let e_lambda ?loc (binder : expression_variable) let e_lambda ?loc (binder : expression_variable)
(input_type : type_expression option) (input_type : type_expression option)
(output_type : type_expression option) (output_type : type_expression option)
@ -168,34 +184,41 @@ let e_lambda ?loc (binder : expression_variable)
result ; 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 e_assign_with_let ?loc var access_path expr =
let update = (Label path, expr) in let var = Var.of_name (var) in
location_wrap ?loc @@ E_update {record; update} 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 -> let get_e_accessor = fun t ->
match t with match t with
| E_accessor (a , b) -> ok (a , b) | E_record_accessor {expr; label} -> ok (expr , label)
| _ -> simple_fail "not an accessor" | _ -> simple_fail "not an accessor"
let assert_e_accessor = fun t -> let assert_e_accessor = fun t ->
let%bind _ = get_e_accessor t in let%bind _ = get_e_accessor t in
ok () 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 -> let get_e_pair = fun t ->
match t with 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" | _ -> simple_fail "not a pair"
let get_e_list = fun t -> let get_e_list = fun t ->
@ -203,27 +226,42 @@ let get_e_list = fun t ->
| E_list lst -> ok lst | E_list lst -> ok lst
| _ -> simple_fail "not a list" | _ -> 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 -> let get_e_tuple = fun t ->
match t with 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" | _ -> simple_fail "ast_simplified: get_e_tuple: not a tuple"
(* Same as get_e_pair *)
let extract_pair : expression -> (expression * expression) result = fun e -> let extract_pair : expression -> (expression * expression) result = fun e ->
match e.expression with match e.expression_content 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)
| _ -> fail @@ bad_kind "pair" e.location
)
| _ -> fail @@ bad_kind "pair" e.location | _ -> fail @@ bad_kind "pair" e.location
let extract_list : expression -> (expression list) result = fun e -> let extract_list : expression -> (expression list) result = fun e ->
match e.expression with match e.expression_content with
| E_list lst -> ok lst | E_list lst -> ok lst
| _ -> fail @@ bad_kind "list" e.location | _ -> fail @@ bad_kind "list" e.location
let extract_record : expression -> (label * expression) list result = fun e -> 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 | E_record lst -> ok @@ LMap.to_kv_list lst
| _ -> fail @@ bad_kind "record" e.location | _ -> fail @@ bad_kind "record" e.location
let extract_map : expression -> (expression * expression) list result = fun e -> let extract_map : expression -> (expression * expression) list result = fun e ->
match e.expression with match e.expression_content with
| E_map lst -> ok lst | E_map lst -> ok lst
| _ -> fail @@ bad_kind "map" e.location | _ -> 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 val bad_kind : name -> Location.t -> unit -> error
end end
*) *)
val make_t : type_expression type_expression' -> type_expression val make_t : type_content -> type_expression
val t_bool : type_expression val t_bool : type_expression
val t_string : type_expression val t_string : type_expression
val t_bytes : 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_list : type_expression -> type_expression
val t_variable : string -> 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_record : te_map -> type_expression
*) *)
val t_pair : ( type_expression * type_expression ) -> 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 : type_expression Map.String.t -> type_expression
val t_record_ez : (string * type_expression) list -> 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_function : type_expression -> type_expression -> type_expression
val t_map : 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 t_set : type_expression -> type_expression
val e_var : ?loc:Location.t -> string -> 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_key_hash : ?loc:Location.t -> string -> expression
val e_chain_id : ?loc:Location.t -> string -> expression val e_chain_id : ?loc:Location.t -> string -> expression
val e_mutez : ?loc:Location.t -> int -> 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_hex : ?loc:Location.t -> string -> expression result
val e_bytes_raw : ?loc:Location.t -> bytes -> expression val e_bytes_raw : ?loc:Location.t -> bytes -> expression
val e_bytes_string : ?loc:Location.t -> string -> expression val e_bytes_string : ?loc:Location.t -> string -> expression
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> 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_tuple : ?loc:Location.t -> expression list -> expression
val e_some : ?loc:Location.t -> expression -> expression val e_some : ?loc:Location.t -> expression -> expression
val e_none : ?loc:Location.t -> unit -> 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_constructor : ?loc:Location.t -> string -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> 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 : ?loc:Location.t -> expression -> string -> expression
val e_accessor_props : ?loc:Location.t -> expression -> string list -> expression val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_skip : ?loc:Location.t -> unit -> expression val e_skip : ?loc:Location.t -> unit -> expression
val e_loop : ?loc:Location.t -> expression -> expression -> expression val e_loop : ?loc:Location.t -> expression -> expression -> expression
val e_sequence : ?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_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_binop : ?loc:Location.t -> constant -> 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_constant : ?loc:Location.t -> constant' -> expression list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> 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_content
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression 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 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 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_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_record : ?loc:Location.t -> expr Map.String.t -> expression
val e_update : ?loc:Location.t -> expression -> string -> expression -> 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 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_content -> ( expression list ) result
val get_e_tuple : expression_content -> ( expression list ) result
val get_e_list : expression' -> ( expression list ) result
val get_e_tuple : expression' -> ( expression list ) result
(* (*
val get_e_failwith : expression -> expression result val get_e_failwith : expression -> expression result
val is_e_failwith : expression -> bool val is_e_failwith : expression -> bool

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

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

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

@ -1,14 +1,19 @@
[@@@warning "-30"] [@@@warning "-30"]
module Location = Simple_utils.Location module Location = Simple_utils.Location
module Ast_simplified_parameter = struct
type type_meta = unit
end
include Stage_common.Types 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 type program = declaration Location.wrap list
and inline = bool
and type_expression = {
type_expression' : type_expression type_expression'
}
and declaration = and declaration =
| Declaration_type of (type_variable * type_expression) | Declaration_type of (type_variable * type_expression)
@ -19,59 +24,91 @@ and declaration =
* an expression *) * an expression *)
| Declaration_constant of (expression_variable * type_expression option * inline * 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 = { and expression_content =
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' =
(* Base *) (* Base *)
| E_literal of literal | 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_variable of expression_variable
| E_application of application
| E_lambda of lambda | E_lambda of lambda
| E_application of (expr * expr)
| E_let_in of let_in | 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 | E_skip
(* Annotate *) (* Variant *)
| E_ascription of expr * type_expression | 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 = { and constant =
expression : expression' ; { cons_name: constant' (* this is at the end because it is huge *)
location : Location.t ; ; arguments: expression list }
}
and update = { record: expr; update: (label *expr) }
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 Types
open Format open Format
open PP_helpers open PP_helpers
include Stage_common.PP 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 = let rec expression ppf (e : expression) =
type_expression' type_value ppf tv' 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 = and assoc_expression ppf : expr * expr -> unit =
type_value' ppf tv.type_value' fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
let rec annotated_expression ppf (ae:annotated_expression) : unit = and single_record_patch ppf ((p, expr) : label * expr) =
match ae.type_annotation.simplified with fprintf ppf "%a <- %a" label p expression expr
| _ -> fprintf ppf "@[<v>%a:%a@]" expression ae.expression type_value ae.type_annotation
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 = and option_inline ppf inline =
if inline then if inline then
@ -29,68 +63,28 @@ and option_inline ppf inline =
else else
fprintf ppf "" fprintf ppf ""
and expression ppf (e:expression) : unit = and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> 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 =
fun f ppf ((c,n),a) -> 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),_) -> | 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, _) -> | Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f 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, _)} -> | 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, _)} -> | 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 let declaration ppf (d : declaration) =
| Access_record n -> fprintf ppf ".%s" n
| Access_tuple i -> fprintf ppf ".%d" i
let declaration ppf (d:declaration) =
match d with match d with
| Declaration_constant ({name ; annotated_expression = ae} , inline, _) -> | Declaration_constant (name, expr, inline,_) ->
fprintf ppf "const %a = %a%a" Stage_common.PP.name name annotated_expression ae option_inline inline fprintf ppf "const %a = %a%a" expression_variable name expression expr option_inline inline
let program ppf (p:program) = let program ppf (p : program) =
fprintf ppf "@[<v>%a@]" (list_sep declaration (tag "@;")) (List.map Location.unwrap p) 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 () = let message () =
Format.asprintf "Expected the type %s but got the type %a" Format.asprintf "Expected the type %s but got the type %a"
expected_type expected_type
PP.type_value actual_type in PP.type_expression actual_type in
error (thunk "Expected a different type") message error (thunk "Expected a different type") message
let declaration_not_found expected_declaration () = let declaration_not_found expected_declaration () =
@ -23,177 +23,182 @@ module Errors = struct
error (thunk "No declaration with the given name") message error (thunk "No declaration with the given name") message
end end
let make_t type_value' simplified = { type_value' ; simplified } let make_t type_content simplified = { type_content ; type_meta=simplified }
let make_a_e ?(location = Location.generated) expression type_annotation environment = { let make_a_e ?(location = Location.generated) expression_content type_expression environment = {
expression ; expression_content ;
type_annotation ; type_expression ;
environment ; environment ;
location ; 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 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_signature ?s () : type_expression = make_t (T_constant TC_signature) s
let t_chain_id ?s () : type_value = make_t (T_constant TC_chain_id) s let t_chain_id ?s () : type_expression = make_t (T_constant TC_chain_id) s
let t_bool ?s () : type_value = make_t (T_constant TC_bool) s let t_bool ?s () : type_expression = make_t (T_constant TC_bool) s
let t_string ?s () : type_value = make_t (T_constant TC_string) s let t_string ?s () : type_expression = make_t (T_constant TC_string) s
let t_bytes ?s () : type_value = make_t (T_constant TC_bytes) s let t_bytes ?s () : type_expression = make_t (T_constant TC_bytes) s
let t_key ?s () : type_value = make_t (T_constant TC_key) s let t_key ?s () : type_expression = make_t (T_constant TC_key) s
let t_key_hash ?s () : type_value = make_t (T_constant TC_key_hash) s let t_key_hash ?s () : type_expression = make_t (T_constant TC_key_hash) s
let t_int ?s () : type_value = make_t (T_constant TC_int) s let t_int ?s () : type_expression = make_t (T_constant TC_int) s
let t_address ?s () : type_value = make_t (T_constant TC_address) s let t_address ?s () : type_expression = make_t (T_constant TC_address) s
let t_operation ?s () : type_value = make_t (T_constant TC_operation) s let t_operation ?s () : type_expression = make_t (T_constant TC_operation) s
let t_nat ?s () : type_value = make_t (T_constant TC_nat) s let t_nat ?s () : type_expression = make_t (T_constant TC_nat) s
let t_mutez ?s () : type_value = make_t (T_constant TC_mutez) s let t_mutez ?s () : type_expression = make_t (T_constant TC_mutez) s
let t_timestamp ?s () : type_value = make_t (T_constant TC_timestamp) s let t_timestamp ?s () : type_expression = make_t (T_constant TC_timestamp) s
let t_unit ?s () : type_value = make_t (T_constant TC_unit) s let t_unit ?s () : type_expression = make_t (T_constant TC_unit) s
let t_option o ?s () : type_value = make_t (T_operator (TC_option o)) s let t_option o ?s () : type_expression = 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_expression = make_t (T_variable t) s
let t_variable t ?s () : type_value = make_t (T_variable t) s let t_list t ?s () : type_expression = make_t (T_operator (TC_list t)) s
let t_list t ?s () : type_value = 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_set t ?s () : type_value = 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_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_record m ?s () : type_value = make_t (T_record m) s let t_record m ?s () : type_expression = make_t (T_record m) s
let make_t_ez_record (lst:(label * type_value) list) : type_value = let make_t_ez_record (lst:(string * type_expression) list) : type_expression =
let aux prev (k, v) = LMap.add k v prev in let lst = List.map (fun (x,y) -> (Label x, y) ) lst in
let map = List.fold_left aux LMap.empty lst in let map = LMap.of_list lst in
make_t (T_record map) None 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 let m = LMap.of_list lst in
t_record m ?s () 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_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_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 t_sum m ?s () : type_expression = make_t (T_sum m) s
let make_t_ez_sum (lst:(constructor * type_value) list) : type_value = let make_t_ez_sum (lst:(constructor' * type_expression) list) : type_expression =
let aux prev (k, v) = CMap.add k v prev in let aux prev (k, v) = CMap.add k v prev in
let map = List.fold_left aux CMap.empty lst in let map = List.fold_left aux CMap.empty lst in
make_t (T_sum map) None make_t (T_sum map) None
let t_function 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_value = make_t (T_arrow (param, 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_expression (x:expression) = x.type_expression
let get_type' (x:type_value) = x.type_value' let get_type' (x:type_expression) = x.type_content
let get_environment (x:annotated_expression) = x.environment let get_environment (x:expression) = x.environment
let get_expression (x:annotated_expression) = x.expression 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 | E_lambda l -> ok l
| _ -> fail @@ Errors.not_a_x_expression "lambda" e () | _ -> fail @@ Errors.not_a_x_expression "lambda" e ()
let get_lambda_with_type e = let get_lambda_with_type e =
match (e.expression , e.type_annotation.type_value') with match (e.expression_content , e.type_expression.type_content) with
| E_lambda l , T_arrow (i,o) -> ok (l , (i,o)) | E_lambda l , T_arrow {type1;type2} -> ok (l , (type1,type2))
| _ -> fail @@ Errors.not_a_x_expression "lambda with functional type" e.expression () | _ -> 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 () | T_constant (TC_bool) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "bool" t () | _ -> 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 () | T_constant (TC_int) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "int" t () | _ -> 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 () | T_constant (TC_nat) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "nat" t () | _ -> 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 () | T_constant (TC_unit) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "unit" t () | _ -> 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 () | T_constant (TC_mutez) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "tez" t () | _ -> 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 () | T_constant (TC_bytes) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "bytes" t () | _ -> 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 () | T_constant (TC_string) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "string" t () | _ -> 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 | T_operator (TC_contract x) -> ok x
| _ -> fail @@ Errors.not_a_x_type "contract" t () | _ -> 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 | T_operator (TC_option o) -> ok o
| _ -> fail @@ Errors.not_a_x_type "option" t () | _ -> 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 | T_operator (TC_list l) -> ok l
| _ -> fail @@ Errors.not_a_x_type "list" t () | _ -> 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 | T_operator (TC_set s) -> ok s
| _ -> fail @@ Errors.not_a_x_type "set" t () | _ -> 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 () | T_constant (TC_key) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "key" t () | _ -> 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 () | T_constant (TC_signature) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "signature" t () | _ -> 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 () | T_constant (TC_key_hash) -> ok ()
| _ -> fail @@ Errors.not_a_x_type "key_hash" t () | _ -> 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 let tuple_of_record (m: _ LMap.t) =
| T_operator (TC_tuple lst) -> ok lst 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 () | _ -> 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 let get_t_pair (t:type_expression) : (type_expression * type_expression) result = match t.type_content with
| T_operator (TC_tuple lst) -> | T_record m ->
let lst = tuple_of_record m in
let%bind () = let%bind () =
trace_strong (Errors.not_a_x_type "pair (tuple with two elements)" t ()) @@ trace_strong (Errors.not_a_x_type "pair (tuple with two elements)" t ()) @@
Assert.assert_list_size lst 2 in Assert.assert_list_size lst 2 in
ok List.(nth lst 0 , nth lst 1) ok List.(nth lst 0 , nth lst 1)
| _ -> fail @@ Errors.not_a_x_type "pair (tuple with two elements)" t () | _ -> 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 let get_t_function (t:type_expression) : (type_expression * type_expression) result = match t.type_content with
| T_arrow (a,r) -> ok (a,r) | T_arrow {type1;type2} -> ok (type1,type2)
| T_operator (TC_arrow (a , b)) -> ok (a , b) | _ -> simple_fail "not a function"
| _ -> fail @@ Errors.not_a_x_type "function" t ()
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 | T_sum m -> ok m
| _ -> fail @@ Errors.not_a_x_type "sum" t () | _ -> 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 | T_record m -> ok m
| _ -> fail @@ Errors.not_a_x_type "record" t () | _ -> fail @@ Errors.not_a_x_type "record" t ()
let get_t_map (t:type_value) : (type_value * type_value) result = let get_t_map (t:type_expression) : (type_expression * type_expression) result =
match t.type_value' with match t.type_content with
| T_operator (TC_map (k,v)) -> ok (k, v) | T_operator (TC_map (k,v)) -> ok (k, v)
| _ -> fail @@ Errors.not_a_x_type "map" t () | _ -> fail @@ Errors.not_a_x_type "map" t ()
let get_t_big_map (t:type_value) : (type_value * type_value) result = let get_t_big_map (t:type_expression) : (type_expression * type_expression) result =
match t.type_value' with match t.type_content with
| T_operator (TC_big_map (k,v)) -> ok (k, v) | T_operator (TC_big_map (k,v)) -> ok (k, v)
| _ -> fail @@ Errors.not_a_x_type "big_map" t () | _ -> 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 let%bind (key , _) = get_t_map t in
ok key 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 let%bind (_ , value) = get_t_map t in
ok value 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 let%bind (key , _) = get_t_big_map t in
ok key 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 let%bind (_ , value) = get_t_big_map t in
ok value 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_map = Function.compose to_bool get_t_map
let is_t_big_map = Function.compose to_bool get_t_big_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_key = get_t_key
let assert_t_signature = get_t_signature let assert_t_signature = get_t_signature
let assert_t_key_hash = get_t_key_hash 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 () | T_operator (TC_contract _) -> ok ()
| _ -> simple_fail "not a contract" | _ -> simple_fail "not a contract"
@ -228,57 +233,56 @@ let assert_t_bytes = fun t ->
let%bind _ = get_t_bytes t in let%bind _ = get_t_bytes t in
ok () ok ()
let assert_t_operation (t:type_value) : unit result = let assert_t_operation (t:type_expression) : unit result =
match t.type_value' with match t.type_content with
| T_constant (TC_operation) -> ok () | T_constant (TC_operation) -> ok ()
| _ -> simple_fail "assert: not an operation" | _ -> 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 let%bind t' = get_t_list t in
assert_t_operation t' 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 () | T_constant (TC_int) -> ok ()
| _ -> simple_fail "not an int" | _ -> 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 () | T_constant (TC_nat) -> ok ()
| _ -> simple_fail "not an nat" | _ -> simple_fail "not an nat"
let assert_t_bool : type_value -> unit result = fun v -> get_t_bool v let assert_t_bool : type_expression -> 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_unit : type_expression -> unit result = fun v -> get_t_unit v
let e_record map : expression = E_record map let e_record map : expression_content = E_record map
let ez_e_record (lst : (label * ae) list) : expression = let ez_e_record (lst : (label * expression) list) : expression_content =
let aux prev (k, v) = LMap.add k v prev in let aux prev (k, v) = LMap.add k v prev in
let map = List.fold_left aux LMap.empty lst in let map = List.fold_left aux LMap.empty lst in
e_record map e_record map
let e_some s : expression = E_constant (C_SOME, [s]) let e_some s : expression_content = E_constant {cons_name=C_SOME;arguments=[s]}
let e_none () : expression = E_constant (C_NONE, []) 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_unit () : expression_content = E_literal (Literal_unit)
let e_int n : expression = E_literal (Literal_int n) let e_int n : expression_content = E_literal (Literal_int n)
let e_nat n : expression = E_literal (Literal_nat n) let e_nat n : expression_content = E_literal (Literal_nat n)
let e_mutez n : expression = E_literal (Literal_mutez n) let e_mutez n : expression_content = E_literal (Literal_mutez n)
let e_bool b : expression = E_literal (Literal_bool b) let e_bool b : expression_content = E_literal (Literal_bool b)
let e_string s : expression = E_literal (Literal_string s) let e_string s : expression_content = E_literal (Literal_string s)
let e_bytes s : expression = E_literal (Literal_bytes s) let e_bytes s : expression_content = E_literal (Literal_bytes s)
let e_timestamp s : expression = E_literal (Literal_timestamp s) let e_timestamp s : expression_content = E_literal (Literal_timestamp s)
let e_address s : expression = E_literal (Literal_address s) let e_address s : expression_content = E_literal (Literal_address s)
let e_signature s : expression = E_literal (Literal_signature s) let e_signature s : expression_content = E_literal (Literal_signature s)
let e_key s : expression = E_literal (Literal_key s) let e_key s : expression_content = E_literal (Literal_key s)
let e_key_hash s : expression = E_literal (Literal_key_hash s) let e_key_hash s : expression_content = E_literal (Literal_key_hash s)
let e_chain_id s : expression = E_literal (Literal_chain_id s) let e_chain_id s : expression_content = E_literal (Literal_chain_id s)
let e_operation s : expression = E_literal (Literal_operation s) let e_operation s : expression_content = E_literal (Literal_operation s)
let e_lambda l : expression = E_lambda l let e_lambda l : expression_content = E_lambda l
let e_pair a b : expression = E_tuple [a; b] let e_pair a b : expression_content = ez_e_record [(Label "0",a);(Label "1", b)]
let e_application a b : expression = E_application (a , b) let e_application expr1 expr2 : expression_content = E_application {expr1;expr2}
let e_variable v : expression = E_variable v let e_variable v : expression_content = E_variable v
let e_list lst : expression = E_list lst let e_list lst : expression_content = E_list lst
let e_let_in binder inline rhs result = E_let_in { binder ; rhs ; result; inline } let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; let_result; inline }
let e_tuple lst : expression = E_tuple lst
let e_a_unit = make_a_e (e_unit ()) (t_unit ()) let e_a_unit = make_a_e (e_unit ()) (t_unit ())
let e_a_int n = make_a_e (e_int n) (t_int ()) 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_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_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_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_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_annotation ()) 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_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_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_expression r) ())
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_expression b)
let e_a_application a b = make_a_e (e_application a b) (get_type_annotation b)
let e_a_variable v ty = make_a_e (e_variable v) ty 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_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_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 | E_literal (Literal_int n) -> ok n
| _ -> simple_fail "not an int" | _ -> simple_fail "not an int"
let get_a_unit (t:annotated_expression) = let get_a_unit (t:expression) =
match t.expression with match t.expression_content with
| E_literal (Literal_unit) -> ok () | E_literal (Literal_unit) -> ok ()
| _ -> simple_fail "not a unit" | _ -> simple_fail "not a unit"
let get_a_bool (t:annotated_expression) = let get_a_bool (t:expression) =
match t.expression with match t.expression_content with
| E_literal (Literal_bool b) -> ok b | E_literal (Literal_bool b) -> ok b
| _ -> simple_fail "not a bool" | _ -> simple_fail "not a bool"
let get_a_record_accessor = fun t -> let get_a_record_accessor = fun t ->
match t.expression with match t.expression_content with
| E_record_accessor (a , b) -> ok (a , b) | E_record_accessor {expr ; label} -> ok (expr , label)
| _ -> simple_fail "not an accessor" | _ -> simple_fail "not an accessor"
let get_declaration_by_name : program -> string -> declaration result = fun p name -> let get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration -> let aux : declaration -> bool = fun declaration ->
match declaration with match declaration with
| Declaration_constant (d , _, _) -> d.name = Var.of_name name | Declaration_constant (d, _, _, _) -> d = Var.of_name name
in in
trace_option (Errors.declaration_not_found name ()) @@ trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p 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 Trace
open Types open Types
open Stage_common.Types
val make_n_e : expression_variable -> annotated_expression -> named_expression val make_n_t : type_variable -> type_expression -> named_type_content
val make_n_t : expression_variable -> type_value -> named_type_value val make_t : type_content -> S.type_expression option -> type_expression
val make_t : type_value' -> S.type_expression option -> type_value val make_a_e : ?location:Location.t -> expression_content -> type_expression -> full_environment -> expression
val make_a_e : ?location:Location.t -> expression -> type_value -> full_environment -> annotated_expression
val t_bool : ?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_value val t_string : ?s:S.type_expression -> unit -> type_expression
val t_bytes : ?s:S.type_expression -> unit -> type_value val t_bytes : ?s:S.type_expression -> unit -> type_expression
val t_key : ?s:S.type_expression -> unit -> type_value val t_key : ?s:S.type_expression -> unit -> type_expression
val t_key_hash : ?s:S.type_expression -> unit -> type_value val t_key_hash : ?s:S.type_expression -> unit -> type_expression
val t_operation : ?s:S.type_expression -> unit -> type_value val t_operation : ?s:S.type_expression -> unit -> type_expression
val t_timestamp : ?s:S.type_expression -> unit -> type_value val t_timestamp : ?s:S.type_expression -> unit -> type_expression
val t_set : type_value -> ?s:S.type_expression -> unit -> type_value val t_set : type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_contract : type_value -> ?s:S.type_expression -> unit -> type_value val t_contract : type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_int : ?s:S.type_expression -> unit -> type_value val t_int : ?s:S.type_expression -> unit -> type_expression
val t_nat : ?s:S.type_expression -> unit -> type_value val t_nat : ?s:S.type_expression -> unit -> type_expression
val t_mutez : ?s:S.type_expression -> unit -> type_value val t_mutez : ?s:S.type_expression -> unit -> type_expression
val t_address : ?s:S.type_expression -> unit -> type_value val t_address : ?s:S.type_expression -> unit -> type_expression
val t_chain_id : ?s:S.type_expression -> unit -> type_value val t_chain_id : ?s:S.type_expression -> unit -> type_expression
val t_signature : ?s:S.type_expression -> unit -> type_value val t_signature : ?s:S.type_expression -> unit -> type_expression
val t_unit : ?s:S.type_expression -> unit -> type_value val t_unit : ?s:S.type_expression -> unit -> type_expression
val t_option : type_value -> ?s:S.type_expression -> unit -> type_value val t_option : type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_pair : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value val t_pair : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_list : type_value -> ?s:S.type_expression -> unit -> type_value val t_list : type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_tuple : type_value list -> ?s:S.type_expression -> unit -> type_value val t_variable : type_variable -> ?s:S.type_expression -> unit -> type_expression
val t_variable : type_variable -> ?s:S.type_expression -> unit -> type_value val t_record : type_expression label_map -> ?s:S.type_expression -> unit -> type_expression
val t_record : type_value label_map -> ?s:S.type_expression -> unit -> type_value val make_t_ez_record : (string* type_expression) list -> type_expression
val make_t_ez_record : (label* type_value) list -> type_value val ez_t_record : ( label * type_expression ) list -> ?s:S.type_expression -> unit -> type_expression
(*
val ez_t_record : ( string * type_value ) list -> ?s:S.type_expression -> unit -> type_value
*)
val t_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value val t_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_big_map : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value val t_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_sum : type_value constructor_map -> ?s:S.type_expression -> unit -> type_value val t_sum : type_expression constructor_map -> ?s:S.type_expression -> unit -> type_expression
val make_t_ez_sum : ( constructor * type_value ) list -> type_value val make_t_ez_sum : ( constructor' * type_expression ) list -> type_expression
val t_function : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value val t_function : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_shallow_closure : type_value -> type_value -> ?s:S.type_expression -> unit -> type_value val t_shallow_closure : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val get_type_annotation : annotated_expression -> type_value val get_type_expression : expression -> type_expression
val get_type' : type_value -> type_value' val get_type' : type_expression -> type_content
val get_environment : annotated_expression -> full_environment val get_environment : expression -> full_environment
val get_expression : annotated_expression -> expression val get_expression : expression -> expression_content
val get_lambda : expression -> lambda result val get_lambda : expression -> lambda result
val get_lambda_with_type : annotated_expression -> (lambda * ( type_value * type_value) ) result val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression) ) result
val get_t_bool : type_value -> unit result val get_t_bool : type_expression -> unit result
(* (*
val get_t_int : type_value -> unit result val get_t_int : type_expression -> unit result
val get_t_nat : type_value -> unit result val get_t_nat : type_expression -> unit result
val get_t_unit : type_value -> unit result val get_t_unit : type_expression -> unit result
val get_t_mutez : type_value -> unit result val get_t_mutez : type_expression -> unit result
val get_t_bytes : type_value -> unit result val get_t_bytes : type_expression -> unit result
val get_t_string : type_value -> unit result val get_t_string : type_expression -> unit result
*) *)
val get_t_contract : type_value -> type_value result val get_t_contract : type_expression -> type_expression result
val get_t_option : type_value -> type_value result val get_t_option : type_expression -> type_expression result
val get_t_list : type_value -> type_value result val get_t_list : type_expression -> type_expression result
val get_t_set : type_value -> type_value result val get_t_set : type_expression -> type_expression result
(* (*
val get_t_key : type_value -> unit result val get_t_key : type_expression -> unit result
val get_t_signature : type_value -> unit result val get_t_signature : type_expression -> unit result
val get_t_key_hash : type_value -> unit result val get_t_key_hash : type_expression -> unit result
*) *)
val get_t_tuple : type_value -> type_value list result val get_t_tuple : type_expression -> type_expression list result
val get_t_pair : type_value -> ( type_value * type_value ) result val get_t_pair : type_expression -> ( type_expression * type_expression ) result
val get_t_function : type_value -> ( type_value * type_value ) result val get_t_function : type_expression -> ( type_expression * type_expression ) result
val get_t_sum : type_value -> type_value constructor_map result val get_t_sum : type_expression -> type_expression constructor_map result
val get_t_record : type_value -> type_value label_map result val get_t_record : type_expression -> type_expression label_map result
val get_t_map : type_value -> ( type_value * type_value ) result val get_t_map : type_expression -> ( type_expression * type_expression ) result
val get_t_big_map : type_value -> ( type_value * type_value ) result val get_t_big_map : type_expression -> ( type_expression * type_expression ) result
val get_t_map_key : type_value -> type_value result val get_t_map_key : type_expression -> type_expression result
val get_t_map_value : type_value -> type_value result val get_t_map_value : type_expression -> type_expression result
val get_t_big_map_key : type_value -> type_value result val get_t_big_map_key : type_expression -> type_expression result
val get_t_big_map_value : type_value -> type_value 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_map : type_expression -> bool
val is_t_big_map : type_value -> bool val is_t_big_map : type_expression -> bool
val assert_t_mutez : type_value -> unit result val assert_t_mutez : type_expression -> unit result
val assert_t_key : type_value -> unit result val assert_t_key : type_expression -> unit result
val assert_t_signature : type_value -> unit result val assert_t_signature : type_expression -> unit result
val assert_t_key_hash : type_value -> 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_list : type_expression -> bool
val is_t_set : type_value -> bool val is_t_set : type_expression -> bool
val is_t_nat : type_value -> bool val is_t_nat : type_expression -> bool
val is_t_string : type_value -> bool val is_t_string : type_expression -> bool
val is_t_bytes : type_value -> bool val is_t_bytes : type_expression -> bool
val is_t_int : type_value -> 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_list_operation : type_expression -> unit result
val assert_t_int : type_value -> unit result val assert_t_int : type_expression -> unit result
val assert_t_nat : type_value -> unit result val assert_t_nat : type_expression -> unit result
val assert_t_bool : type_value -> unit result val assert_t_bool : type_expression -> unit result
val assert_t_unit : type_value -> unit result val assert_t_unit : type_expression -> unit result
val assert_t_contract : type_value -> unit result val assert_t_contract : type_expression -> unit result
(* (*
val e_record : ae_map -> expression 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_some : expression -> expression_content
val e_none : unit -> expression val e_none : unit -> expression_content
val e_map : ( value * value ) list -> expression val e_map : ( expression * expression ) list -> expression_content
val e_unit : unit -> expression val e_unit : unit -> expression_content
val e_int : int -> expression val e_int : int -> expression_content
val e_nat : int -> expression val e_nat : int -> expression_content
val e_mutez : int -> expression val e_mutez : int -> expression_content
val e_bool : bool -> expression val e_bool : bool -> expression_content
val e_string : string -> expression val e_string : string -> expression_content
val e_bytes : bytes -> expression val e_bytes : bytes -> expression_content
val e_timestamp : int -> expression val e_timestamp : int -> expression_content
val e_address : string -> expression val e_address : string -> expression_content
val e_signature : string -> expression val e_signature : string -> expression_content
val e_key : string -> expression val e_key : string -> expression_content
val e_key_hash : string -> expression val e_key_hash : string -> expression_content
val e_chain_id : string -> expression val e_chain_id : string -> expression_content
val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression_content
val e_lambda : lambda -> expression val e_lambda : lambda -> expression_content
val e_pair : value -> value -> expression val e_pair : expression -> expression -> expression_content
val e_application : value -> value -> expression val e_application : expression -> expr -> expression_content
val e_variable : expression_variable -> expression val e_variable : expression_variable -> expression_content
val e_list : value list -> expression val e_list : expression list -> expression_content
val e_let_in : expression_variable -> inline -> value -> value -> expression val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
val e_tuple : value list -> expression
val e_a_unit : full_environment -> annotated_expression val e_a_unit : full_environment -> expression
val e_a_int : int -> full_environment -> annotated_expression val e_a_int : int -> full_environment -> expression
val e_a_nat : int -> full_environment -> annotated_expression val e_a_nat : int -> full_environment -> expression
val e_a_mutez : int -> full_environment -> annotated_expression val e_a_mutez : int -> full_environment -> expression
val e_a_bool : bool -> full_environment -> annotated_expression val e_a_bool : bool -> full_environment -> expression
val e_a_string : string -> full_environment -> annotated_expression val e_a_string : string -> full_environment -> expression
val e_a_address : string -> full_environment -> annotated_expression val e_a_address : string -> full_environment -> expression
val e_a_pair : annotated_expression -> annotated_expression -> full_environment -> annotated_expression val e_a_pair : expression -> expression -> full_environment -> expression
val e_a_some : annotated_expression -> full_environment -> annotated_expression val e_a_some : expression -> full_environment -> expression
val e_a_lambda : lambda -> type_value -> type_value -> full_environment -> annotated_expression val e_a_lambda : lambda -> type_expression -> type_expression -> full_environment -> expression
val e_a_none : type_value -> full_environment -> annotated_expression val e_a_none : type_expression -> full_environment -> expression
val e_a_tuple : annotated_expression list -> full_environment -> annotated_expression val e_a_record : expression label_map -> full_environment -> expression
val e_a_record : annotated_expression label_map -> full_environment -> annotated_expression val e_a_application : expression -> expression -> full_environment -> expression
val e_a_application : annotated_expression -> annotated_expression -> full_environment -> annotated_expression val e_a_variable : expression_variable -> type_expression -> full_environment -> expression
val e_a_variable : expression_variable -> type_value -> full_environment -> annotated_expression val ez_e_a_record : ( label * expression ) list -> full_environment -> expression
val ez_e_a_record : ( label * annotated_expression ) list -> full_environment -> annotated_expression val e_a_map : ( expression * expression ) list -> type_expression -> type_expression -> full_environment -> expression
val e_a_map : ( annotated_expression * annotated_expression ) list -> type_value -> type_value -> full_environment -> annotated_expression val e_a_list : expression list -> type_expression -> full_environment -> expression
val e_a_list : annotated_expression list -> type_value -> full_environment -> annotated_expression val e_a_let_in : expression_variable -> bool -> expression -> expression -> full_environment -> expression
val e_a_let_in : expression_variable -> inline -> annotated_expression -> annotated_expression -> full_environment -> annotated_expression
val get_a_int : annotated_expression -> int result val get_a_int : expression -> int result
val get_a_unit : annotated_expression -> unit result val get_a_unit : expression -> unit result
val get_a_bool : annotated_expression -> bool result val get_a_bool : expression -> bool result
val get_a_record_accessor : annotated_expression -> (annotated_expression * label) result val get_a_record_accessor : expression -> (expression * label) result
val get_declaration_by_name : program -> string -> declaration 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_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_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_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_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_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 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) let env_sum_type ?(env = full_empty)
?(type_name = Var.of_name "a_sum_type") ?(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 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 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_unit : expression
val e_a_empty_int : int -> annotated_expression val e_a_empty_int : int -> expression
val e_a_empty_nat : int -> annotated_expression val e_a_empty_nat : int -> expression
val e_a_empty_mutez : int -> annotated_expression val e_a_empty_mutez : int -> expression
val e_a_empty_bool : bool -> annotated_expression val e_a_empty_bool : bool -> expression
val e_a_empty_string : string -> annotated_expression val e_a_empty_string : string -> expression
val e_a_empty_address : string -> annotated_expression val e_a_empty_address : string -> expression
val e_a_empty_pair : annotated_expression -> annotated_expression -> annotated_expression val e_a_empty_pair : expression -> expression -> expression
val e_a_empty_some : annotated_expression -> annotated_expression val e_a_empty_some : expression -> expression
val e_a_empty_none : type_value -> annotated_expression val e_a_empty_none : type_expression -> expression
val e_a_empty_tuple : annotated_expression list -> annotated_expression val e_a_empty_record : expression label_map -> expression
val e_a_empty_record : annotated_expression label_map -> annotated_expression val e_a_empty_map : (expression * expression ) list -> type_expression -> type_expression -> expression
val e_a_empty_map : (annotated_expression * annotated_expression ) list -> type_value -> type_value -> annotated_expression val e_a_empty_list : expression list -> type_expression -> expression
val e_a_empty_list : annotated_expression list -> type_value -> annotated_expression val ez_e_a_empty_record : ( label * expression ) list -> expression
val ez_e_a_empty_record : ( label * annotated_expression ) list -> annotated_expression val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression
val e_a_empty_lambda : lambda -> type_value -> type_value -> annotated_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 Types
open Stage_common.Types
open Combinators open Combinators
type element = environment_element 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} 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_binder = fun t s -> make_element t s ED_binder
let make_element_declaration = fun s (ae : annotated_expression) -> let make_element_declaration = fun s (ae : expression) ->
let free_variables = Misc.Free_variables.(annotated_expression empty ae) in let free_variables = Misc.Free_variables.(expression empty ae) in
make_element (get_type_annotation ae) s (ED_declaration (ae , free_variables)) make_element (get_type_expression ae) s (ED_declaration (ae , free_variables))
module Small = struct module Small = struct
type t = small_environment 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 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 : 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_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 end
type t = full_environment type t = full_environment
let empty : environment = Small.(get_environment empty) let empty : environment = Small.(get_environment empty)
let full_empty : t = List.Ne.singleton Small.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 : 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 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 List.Ne.hd_map (Small.add k (make_element_declaration e ae)) e
let add_ez_ae = add_ez_declaration 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_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 x ->
let aux = fun (_type_name , x) -> let aux = fun (_type_name , x) ->
match x.type_value' with match x.type_content with
| T_sum m -> | T_sum m ->
(match CMap.find_opt k m with (match CMap.find_opt k m with
Some km -> Some (km , x) Some km -> Some (km , x)
@ -56,15 +55,16 @@ let get_constructor : constructor -> t -> (type_value * type_value) option = fun
module PP = struct module PP = struct
open Format open Format
include PP
open PP_helpers open PP_helpers
let list_sep_scope x = list_sep x (const " | ") let list_sep_scope x = list_sep x (const " | ")
let environment_element = fun ppf (k , (ele : environment_element)) -> 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) -> 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 -> let environment : _ -> environment -> unit = fun ppf lst ->
fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) 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 get_trace : expression_variable -> t -> element result = fun s env ->
let error = let error =
let title () = "missing var not in env" in 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 error title content in
trace_option error @@ get_opt s env 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 empty : environment
val full_empty : t val full_empty : t
val add : expression_variable -> element -> t -> t val add : expression_variable -> element -> t -> t
val add_ez_binder : expression_variable -> type_value -> t -> t val add_ez_binder : expression_variable -> type_expression -> t -> t
val add_ez_declaration : expression_variable -> annotated_expression -> t -> t val add_ez_declaration : expression_variable -> expression -> t -> t
val add_ez_ae : expression_variable -> annotated_expression -> t -> t val add_ez_ae : expression_variable -> expression -> t -> t
val add_type : type_variable -> type_value -> t -> t val add_type : type_variable -> type_expression -> t -> t
val get_opt : expression_variable -> t -> element option val get_opt : expression_variable -> t -> element option
val get_type_opt : type_variable -> t -> type_value option val get_type_opt : type_variable -> t -> type_expression option
val get_constructor : constructor -> t -> (type_value * type_value) option val get_constructor : constructor' -> t -> (type_expression * type_expression) option
module Small : sig module Small : sig
type t = small_environment type t = small_environment
@ -28,16 +28,16 @@ module Small : sig
val map_type_environment : ( type_environment -> type_environment ) -> t -> t val map_type_environment : ( type_environment -> type_environment ) -> t -> t
val add : string -> element -> 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_opt : string -> t -> element option
val get_type_opt : string -> t -> type_value option val get_type_opt : string -> t -> type_expression option
*) *)
end end
(* (*
val make_element : type_value -> full_environment -> environment_element_definition -> element val make_element : type_expression -> full_environment -> environment_element_definition -> element
val make_element_binder : type_value -> full_environment -> element val make_element_binder : type_expression -> full_environment -> element
val make_element_declaration : full_environment -> annotated_expression -> 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 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 val environment : formatter -> environment -> unit

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

@ -1,15 +1,13 @@
open Trace open Trace
open Types open Types
include Stage_common.Misc
module Errors = struct module Errors = struct
let different_kinds a b () = let different_kinds a b () =
let title = (thunk "different kinds") in let title = (thunk "different kinds") in
let message () = "" in let message () = "" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_value a) ; ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_value b ) ("b" , fun () -> Format.asprintf "%a" PP.type_expression b )
] in ] in
error ~data title message () error ~data title message ()
@ -17,16 +15,16 @@ module Errors = struct
let title = (thunk "different type constructors") in 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 message () = "Expected these two constant type constructors to be the same, but they're different" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant a) ; ("a" , fun () -> Format.asprintf "%a" PP.type_constant a) ;
("b" , fun () -> Format.asprintf "%a" Stage_common.PP.type_constant b ) ("b" , fun () -> Format.asprintf "%a" PP.type_constant b )
] in ] in
error ~data title message () error ~data title message ()
let different_operators a b () = let different_operators a b () =
let title = (thunk "different type constructors") in 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 message () = "Expected these two n-ary type constructors to be the same, but they're different" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) a) ; ("a" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) a) ;
("b" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) b) ("b" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) b)
] in ] in
error ~data title message () 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)" "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 (type_operator_name opa) lena lenb in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) opa) ; ("a" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) opa) ;
("b" , fun () -> Format.asprintf "%a" (Stage_common.PP.type_operator PP.type_value) opb) ; ("b" , fun () -> Format.asprintf "%a" (PP.type_operator PP.type_expression) opb) ;
("op" , fun () -> type_operator_name opa) ; ("op" , fun () -> type_operator_name opa) ;
("len_a" , fun () -> Format.asprintf "%d" lena) ; ("len_a" , fun () -> Format.asprintf "%d" lena) ;
("len_b" , fun () -> Format.asprintf "%d" lenb) ; ("len_b" , fun () -> Format.asprintf "%d" lenb) ;
] in ] in
error ~data title message () error ~data title message ()
let different_size_type name a b () = let different_size_type names a b () =
let title () = name ^ " have different sizes" in let title () = names ^ " 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 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 = [ let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_value a) ; ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_value b ) ("b" , fun () -> Format.asprintf "%a" PP.type_expression b)
] in ] in
error ~data title message () error ~data title message ()
let different_props_in_record ka kb () = let different_props_in_record a b ra rb ka kb () =
let title () = "different keys in record" in 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 message () = "" in
let data = [ let data = [
("key_a" , fun () -> Format.asprintf "%s" ka) ; ("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 ] in
error ~data title message () 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_constants = different_size_type "type constructors"
let different_size_sums = different_size_type "sums" 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 different_types name a b () =
let title () = name ^ " are different" in let title () = name ^ " are different" in
let message () = "Expected these two types to be the same, but they're different" in let message () = "Expected these two types to be the same, but they're different" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" PP.type_value a) ; ("a" , fun () -> Format.asprintf "%a" PP.type_expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.type_value b ) ("b" , fun () -> Format.asprintf "%a" PP.type_expression b )
] in ] in
error ~data title message () error ~data title message ()
@ -91,8 +109,8 @@ module Errors = struct
let title () = name ^ " are different" in let title () = name ^ " are different" in
let message () = "" in let message () = "" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" PP.value a) ; ("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.value b ) ("b" , fun () -> Format.asprintf "%a" PP.expression b )
] in ] in
error ~data title message () error ~data title message ()
@ -109,8 +127,8 @@ module Errors = struct
let title () = "values have different types: " ^ name in let title () = "values have different types: " ^ name in
let message () = "" in let message () = "" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" PP.value a) ; ("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.value b ) ("b" , fun () -> Format.asprintf "%a" PP.expression b)
] in ] in
error ~data title message () error ~data title message ()
@ -127,8 +145,8 @@ module Errors = struct
let title () = name ^ " are not comparable" in let title () = name ^ " are not comparable" in
let message () = "" in let message () = "" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" PP.value a) ; ("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.value b ) ("b" , fun () -> Format.asprintf "%a" PP.expression b )
] in ] in
error ~data title message () error ~data title message ()
@ -136,8 +154,8 @@ module Errors = struct
let title () = name in let title () = name in
let message () = "" in let message () = "" in
let data = [ let data = [
("a" , fun () -> Format.asprintf "%a" PP.value a) ; ("a" , fun () -> Format.asprintf "%a" PP.expression a) ;
("b" , fun () -> Format.asprintf "%a" PP.value b ) ("b" , fun () -> Format.asprintf "%a" PP.expression b )
] in ] in
error ~data title message () error ~data title message ()
@ -177,49 +195,45 @@ module Free_variables = struct
let empty : bindings = [] let empty : bindings = []
let of_list : expression_variable list -> bindings = fun x -> x let of_list : expression_variable list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings = fun b e -> let rec expression_content : bindings -> expression_content -> bindings = fun b ec ->
let self = annotated_expression b in let self = expression b in
match e with match ec with
| E_lambda l -> lambda b l | E_lambda l -> lambda b l
| E_literal _ -> empty | E_literal _ -> empty
| E_constant (_ , lst) -> unions @@ List.map self lst | E_constant {arguments;_} -> unions @@ List.map self arguments
| E_variable name -> ( | E_variable name -> (
match mem name b with match mem name b with
| true -> empty | true -> empty
| false -> singleton name | false -> singleton name
) )
| E_application (a, b) -> unions @@ List.map self [ a ; b ] | E_application {expr1;expr2} -> unions @@ List.map self [ expr1 ; expr2 ]
| E_tuple lst -> unions @@ List.map self lst | E_constructor {element;_} -> self element
| E_constructor (_ , a) -> self a
| E_record m -> unions @@ List.map self @@ LMap.to_list m | E_record m -> unions @@ List.map self @@ LMap.to_list m
| E_record_accessor (a, _) -> self a | E_record_accessor {expr;_} -> self expr
| E_record_update (r,(_,e)) -> union (self r) @@ self e | E_record_update {record; update;_} -> union (self record) @@ self update
| E_tuple_accessor (a, _) -> self a
| E_list lst -> unions @@ List.map self lst | E_list lst -> unions @@ List.map self lst
| E_set 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_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_look_up (a , b) -> unions @@ List.map self [ a ; b ]
| E_matching (a , cs) -> union (self a) (matching_expression b cs) | E_matching {matchee; cases;_} -> union (self matchee) (matching_expression b cases)
| E_sequence (a , b) -> unions @@ List.map self [ a ; b ] | E_loop {condition ; body} -> unions @@ List.map self [ condition ; body ]
| E_loop (expr , body) -> unions @@ List.map self [ expr ; body ] | E_let_in { let_binder; rhs; let_result; _} ->
| E_assign (_ , _ , expr) -> self expr let b' = union (singleton let_binder) b in
| E_let_in { binder; rhs; result; _ } ->
let b' = union (singleton binder) b in
union union
(annotated_expression b' result) (expression b' let_result)
(annotated_expression b rhs) (self rhs)
and lambda : bindings -> lambda -> bindings = fun b l -> and lambda : bindings -> lambda -> bindings = fun b l ->
let b' = union (singleton l.binder) b in 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 -> and expression : bindings -> expression -> bindings = fun b e ->
expression b ae.expression 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 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 m with
| Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa) | 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) | 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 f (union (of_list lst) b) a
| Match_variant (lst,_) -> unions @@ List.map (matching_variant_case f b) lst | 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 end
@ -314,7 +328,7 @@ end
open Errors 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 -> ( | T_constant ca, T_constant cb -> (
trace_strong (different_constants ca cb) trace_strong (different_constants ca cb)
@@ Assert.assert_true (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_set la, TC_set lb -> ok @@ ([la], [lb])
| TC_map (ka,va), TC_map (kb,vb) | TC_map (ka,va), TC_map (kb,vb)
| TC_big_map (ka,va), TC_big_map (kb,vb) -> ok @@ ([ka;va] ,[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_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _),
| 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_arrow _ ) -> fail @@ different_operators opa opb
| (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
in in
if List.length lsta <> List.length lstb then if List.length lsta <> List.length lstb then
fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb) fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb)
else else
trace (different_types "arguments to type operators" a b) 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_operator _, _ -> fail @@ different_kinds a b
| T_sum sa, T_sum sb -> ( | 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 _ = let%bind _ =
Assert.assert_true ~msg:"different keys in sum types" Assert.assert_true ~msg:"different keys in sum types"
@@ (ka = kb) in @@ (ka = kb) in
assert_type_value_eq (va, vb) assert_type_expression_eq (va, vb)
in in
let%bind _ = let%bind _ =
trace_strong (different_size_sums a b) 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') bind_list_iter aux (List.combine sa' sb')
) )
| T_sum _, _ -> fail @@ different_kinds a b | 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 -> ( | T_record ra, T_record rb -> (
let ra' = LMap.to_kv_list ra in let sort_lmap r' = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) r' in
let rb' = LMap.to_kv_list rb 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 aux ((ka, va), (kb, vb)) =
let%bind _ = let%bind _ =
trace (different_types "records" a b) @@ trace (different_types "records" a b) @@
let Label ka = ka in let Label ka = ka in
let Label kb = kb 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.assert_true (ka = kb) in
assert_type_value_eq (va, vb) assert_type_expression_eq (va, vb)
in in
let%bind _ = 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 @@ Assert.assert_list_same_size ra' rb' in
trace (different_types "record type" a b) trace (different_types "record type" a b)
@@ bind_list_iter aux (List.combine ra' rb') @@ bind_list_iter aux (List.combine ra' rb')
) )
| T_record _, _ -> fail @@ different_kinds a b | T_record _, _ -> fail @@ different_kinds a b
| T_arrow (param, result), T_arrow (param', result') -> | T_arrow {type1;type2}, T_arrow {type1=type1';type2=type2'} ->
let%bind _ = assert_type_value_eq (param, param') in let%bind _ = assert_type_expression_eq (type1, type1') in
let%bind _ = assert_type_value_eq (result, result') in let%bind _ = assert_type_expression_eq (type2, type2') in
ok () ok ()
| T_arrow _, _ -> fail @@ different_kinds a b | 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 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 | T_variable _, _ -> fail @@ different_kinds a b
(* No information about what made it fail *) (* 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 = let assert_literal_eq (a, b : literal * literal) : unit result =
match (a, b) with 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 a, Literal_bytes b when a = b -> ok ()
| Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytes" a b | 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_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, Literal_unit -> ok ()
| Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b
| Literal_address a, Literal_address b when a = b -> ok () | 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 | 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 () = 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 in
trace (fun () -> error (thunk "not equal") error_content ()) @@ 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 -> | E_literal a, E_literal b ->
assert_literal_eq (a, 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 = let%bind lst =
generic_try (different_size_values "constants with different number of elements" a b) generic_try (different_size_values "constants with different number of elements" a b)
(fun () -> List.combine lsta lstb) in (fun () -> List.combine lsta lstb) in
@ -451,12 +470,12 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
| E_constant _, _ -> | E_constant _, _ ->
let error_content () = let error_content () =
Format.asprintf "%a vs %a" Format.asprintf "%a vs %a"
PP.annotated_expression a PP.expression a
PP.annotated_expression b PP.expression b
in in
fail @@ (fun () -> error (thunk "comparing constant with other stuff") error_content ()) 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 let%bind _eq = assert_value_eq (a, b) in
ok () ok ()
) )
@ -464,24 +483,13 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
fail @@ different_values "constructors" a b fail @@ different_values "constructors" a b
| E_constructor _, _ -> | E_constructor _, _ ->
fail @@ different_values_because_different_types "constructor vs. non-constructor" a b 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 -> ( | E_record sma, E_record smb -> (
let aux (Label k) a b = let aux (Label k) a b =
match a, b with match a, b with
| Some a, Some b -> Some (assert_value_eq (a, b)) | Some a, Some b -> Some (assert_value_eq (a, b))
| _ -> Some (fail @@ missing_key_in_record_value k) | _ -> Some (fail @@ missing_key_in_record_value k)
in 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 () ok ()
) )
| E_record _, _ -> | E_record _, _ ->
@ -522,30 +530,28 @@ let rec assert_value_eq (a, b: (value*value)) : unit result =
| E_set _, _ -> | E_set _, _ ->
fail @@ different_values_because_different_types "set vs. non-set" a b fail @@ different_values_because_different_types "set vs. non-set" a b
| (E_literal _, _) | (E_variable _, _) | (E_application _, _) | (E_literal _, _) | (E_variable _, _) | (E_application _, _)
| (E_lambda _, _) | (E_let_in _, _) | (E_tuple_accessor _, _) | (E_lambda _, _) | (E_let_in _, _)
| (E_record_update _,_) | (E_record_accessor _, _) | (E_record_update _,_)
| (E_record_accessor _, _)
| (E_look_up _, _) | (E_matching _, _) | (E_look_up _, _) | (E_matching _, _)
| (E_assign _ , _) | (E_loop _, _)-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
| (E_sequence _, _) | (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 match a, b with
| None, None -> fail @@ err | None, None -> fail @@ err
| Some a, None -> ok a | Some a, None -> ok a
| None, Some b -> ok b | None, Some b -> ok b
| Some a, Some b -> | Some a, Some b ->
let%bind _ = assert_type_value_eq (a, b) in let%bind _ = assert_type_expression_eq (a, b) in
match a.simplified, b.simplified with match a.type_meta, b.type_meta with
| _, None -> ok a | _, None -> ok a
| _, Some _ -> ok b | _, 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) @@ trace_option (Errors.missing_entry_point name) @@
let aux x = let aux x =
let (Declaration_constant (an , _, _)) = Location.unwrap x in let (Declaration_constant (an , expr, _, _)) = Location.unwrap x in
if (an.name = Var.of_name name) if (an = Var.of_name name)
then Some an.annotated_expression then Some expr
else None else None
in in
List.find_map aux lst 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 program_environment (program : program) : full_environment =
let last_declaration = Location.unwrap List.(hd @@ rev program) in let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with 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 Trace
open Types 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_expression option -> type_expression option -> error_thunk -> type_expression result
val merge_annotation : type_value option -> type_value option -> error_thunk -> type_value result
(* No information about what made it fail *) (* 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 module Free_variables : sig
type bindings = expression_variable list type bindings = expression_variable list
@ -18,7 +16,7 @@ module Free_variables : sig
val matching_expression : bindings -> matching_expr -> bindings val matching_expression : bindings -> matching_expr -> bindings
val lambda : bindings -> lambda -> bindings val lambda : bindings -> lambda -> bindings
val annotated_expression : bindings -> annotated_expression -> bindings val expression : bindings -> expression -> bindings
val empty : bindings val empty : bindings
val singleton : expression_variable -> bindings val singleton : expression_variable -> bindings
@ -40,14 +38,16 @@ end
module Errors : sig 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_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_props_in_record : string -> string -> unit -> error
val different_size_constants : type_value -> type_value -> unit -> error val different_size_constants : type_expression -> type_expression -> unit -> error
val different_size_sums : type_value -> type_value -> unit -> error val different_size_tuples : type_expression -> type_expression -> unit -> error
val different_size_records : type_value -> type_value -> unit -> error val different_size_sums : type_expression -> type_expression -> unit -> error
val different_types : name -> type_value -> type_value -> 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_literals : name -> literal -> literal -> unit -> error
val different_values : name -> value -> value -> unit -> error val different_values : name -> value -> value -> unit -> error
val different_literals_because_different_types : name -> literal -> literal -> 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 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 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%bind (main , input_type , _) =
let pred = fun d -> let pred = fun d ->
match d with 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 | Declaration_constant _ -> None
in in
let%bind main = let%bind main =
trace_option (simple_error "no main with given name") @@ trace_option (simple_error "no main with given name") @@
List.find_map (Function.compose pred Location.unwrap) p in List.find_map (Function.compose pred Location.unwrap) p in
let%bind (input_ty , output_ty) = let%bind (input_ty , output_ty) =
match (get_type' @@ get_type_annotation main) with match (get_type' @@ get_type_expression main) with
| T_arrow (i , o) -> ok (i , o) | T_arrow {type1;type2} -> ok (type1 , type2)
| _ -> simple_fail "program main isn't a function" in | _ -> simple_fail "program main isn't a function" in
ok (main , input_ty , output_ty) ok (main , input_ty , output_ty)
in in
let env = let env =
let aux = fun _ d -> let aux = fun _ d ->
match d with 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 List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
let binder = Var.of_name "@contract_input" 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 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 e_a_application main_expr input_expr env in
ok { ok {
binder ; binder ;
body ; result ;
} }
module Captured_variables = struct module Captured_variables = struct
@ -45,13 +45,13 @@ module Captured_variables = struct
let empty : bindings = [] let empty : bindings = []
let of_list : expression_variable list -> bindings = fun x -> x let of_list : expression_variable list -> bindings = fun x -> x
let rec annotated_expression : bindings -> annotated_expression -> bindings result = fun b ae -> let rec expression : bindings -> expression -> bindings result = fun b ae ->
let self = annotated_expression b in let self = expression b in
match ae.expression with match ae.expression_content with
| E_lambda l -> ok @@ Free_variables.lambda empty l | E_lambda l -> ok @@ Free_variables.lambda empty l
| E_literal _ -> ok empty | E_literal _ -> ok empty
| E_constant (_ , lst) -> | E_constant {arguments;_} ->
let%bind lst' = bind_map_list self lst in let%bind lst' = bind_map_list self arguments in
ok @@ unions lst' ok @@ unions lst'
| E_variable name -> ( | E_variable name -> (
let%bind env_element = let%bind env_element =
@ -61,22 +61,18 @@ module Captured_variables = struct
| ED_binder -> ok empty | ED_binder -> ok empty
| ED_declaration (_ , _) -> simple_fail "todo" | ED_declaration (_ , _) -> simple_fail "todo"
) )
| E_application (a, b) -> | E_application {expr1;expr2} ->
let%bind lst' = bind_map_list self [ a ; b ] in let%bind lst' = bind_map_list self [ expr1 ; expr2 ] in
ok @@ unions lst' ok @@ unions lst'
| E_tuple lst -> | E_constructor {element;_} -> self element
let%bind lst' = bind_map_list self lst in
ok @@ unions lst'
| E_constructor (_ , a) -> self a
| E_record m -> | E_record m ->
let%bind lst' = bind_map_list self @@ LMap.to_list m in let%bind lst' = bind_map_list self @@ LMap.to_list m in
ok @@ unions lst' ok @@ unions lst'
| E_record_accessor (a, _) -> self a | E_record_accessor {expr;_} -> self expr
| E_record_update (r,(_,e)) -> | E_record_update {record;update;_} ->
let%bind r = self r in let%bind r = self record in
let%bind e = self e in let%bind e = self update in
ok @@ union r e ok @@ union r e
| E_tuple_accessor (a, _) -> self a
| E_list lst -> | E_list lst ->
let%bind lst' = bind_map_list self lst in let%bind lst' = bind_map_list self lst in
ok @@ unions lst' ok @@ unions lst'
@ -89,23 +85,21 @@ module Captured_variables = struct
| E_look_up (a , b) -> | E_look_up (a , b) ->
let%bind lst' = bind_map_list self [ a ; b ] in let%bind lst' = bind_map_list self [ a ; b ] in
ok @@ unions lst' ok @@ unions lst'
| E_matching (a , cs) -> | E_matching {matchee;cases;_} ->
let%bind a' = self a in let%bind a' = self matchee in
let%bind cs' = matching_expression b cs in let%bind cs' = matching_expression b cases in
ok @@ union a' cs' ok @@ union a' cs'
| E_sequence (_ , b) -> self b | E_loop {condition; body} ->
| E_loop (expr , body) -> let%bind lst' = bind_map_list self [ condition ; body ] in
let%bind lst' = bind_map_list self [ expr ; body ] in
ok @@ unions lst' ok @@ unions lst'
| E_assign (_ , _ , expr) -> self expr
| E_let_in li -> | E_let_in li ->
let b' = union (singleton li.binder) b in let b' = union (singleton li.let_binder) b in
annotated_expression b' li.result 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 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 m with
| Match_bool { match_true = t ; match_false = fa } -> | Match_bool { match_true = t ; match_false = fa } ->
let%bind t' = f b t in 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 let%bind lst' = bind_map_list (matching_variant_case f b) lst in
ok @@ unions lst' ok @@ unions lst'
and matching_expression = fun x -> matching annotated_expression x and matching_expression = fun x -> matching expression x
end end

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

@ -1,13 +1,12 @@
open Trace open Trace
open Types open Types
open Stage_common.Types
val program_to_main : program -> string -> lambda result val program_to_main : program -> string -> lambda result
module Captured_variables : sig module Captured_variables : sig
type bindings = expression_variable list 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 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 module S = Ast_simplified
include Stage_common.Types 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 type program = declaration Location.wrap list
and inline = bool and inline = bool
@ -13,105 +19,108 @@ and declaration =
* a boolean indicating whether it should be inlined * a boolean indicating whether it should be inlined
* the environment before the declaration (the original environment) * the environment before the declaration (the original environment)
* the environment after the declaration (i.e. with that new declaration added to 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 = and environment_element_definition =
| ED_binder | ED_binder
| ED_declaration of (annotated_expression * free_variables) | ED_declaration of (expression * free_variables)
and free_variables = expression_variable list and free_variables = expression_variable list
and environment_element = { and environment_element =
type_value : type_value ; { type_value: type_expression
source_environment : full_environment ; ; source_environment: full_environment
definition : environment_element_definition ; ; definition: environment_element_definition }
}
and environment = (expression_variable * environment_element) list 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 full_environment = small_environment List.Ne.t
and annotated_expression = { and expr = expression
expression : expression ;
type_annotation : type_value ; (* SUBST *) and texpr = type_expression
environment : full_environment ;
location : Location.t ; 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

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

@ -2,19 +2,45 @@ open Types
open Format open Format
open PP_helpers open PP_helpers
let name ppf (n:expression_variable) : unit = let constructor ppf (c:constructor') : 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 c = c in fprintf ppf "%s" c let Constructor c = c in fprintf ppf "%s" c
let label ppf (l:label) : unit = let label ppf (l:label) : unit =
let Label l = l in fprintf ppf "%s" l 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_INT -> fprintf ppf "INT"
| C_UNIT -> fprintf ppf "UNIT" | C_UNIT -> fprintf ppf "UNIT"
| C_NIL -> fprintf ppf "NIL" | C_NIL -> fprintf ppf "NIL"
@ -84,6 +110,8 @@ let constant ppf : constant -> unit = function
| C_MAP -> fprintf ppf "MAP" | C_MAP -> fprintf ppf "MAP"
| C_MAP_EMPTY -> fprintf ppf "MAP_EMPTY" | C_MAP_EMPTY -> fprintf ppf "MAP_EMPTY"
| C_MAP_LITERAL -> fprintf ppf "MAP_LITERAL" | C_MAP_LITERAL -> fprintf ppf "MAP_LITERAL"
| C_MAP_GET -> fprintf ppf "MAP_GET"
| C_MAP_GET_FORCE -> fprintf ppf "MAP_GET_FORCE"
| C_MAP_ADD -> fprintf ppf "MAP_ADD" | C_MAP_ADD -> fprintf ppf "MAP_ADD"
| C_MAP_REMOVE -> fprintf ppf "MAP_REMOVE" | C_MAP_REMOVE -> fprintf ppf "MAP_REMOVE"
| C_MAP_UPDATE -> fprintf ppf "MAP_UPDATE" | C_MAP_UPDATE -> fprintf ppf "MAP_UPDATE"
@ -101,6 +129,7 @@ let constant ppf : constant -> unit = function
| C_SHA256 -> fprintf ppf "SHA256" | C_SHA256 -> fprintf ppf "SHA256"
| C_SHA512 -> fprintf ppf "SHA512" | C_SHA512 -> fprintf ppf "SHA512"
| C_BLAKE2b -> fprintf ppf "BLAKE2b" | C_BLAKE2b -> fprintf ppf "BLAKE2b"
| C_HASH -> fprintf ppf "HASH"
| C_HASH_KEY -> fprintf ppf "HASH_KEY" | C_HASH_KEY -> fprintf ppf "HASH_KEY"
| C_CHECK_SIGNATURE -> fprintf ppf "CHECK_SIGNATURE" | C_CHECK_SIGNATURE -> fprintf ppf "CHECK_SIGNATURE"
| C_CHAIN_ID -> fprintf ppf "CHAIN_ID" | C_CHAIN_ID -> fprintf ppf "CHAIN_ID"
@ -120,85 +149,119 @@ let constant ppf : constant -> unit = function
| C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE" | C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE"
| C_STEPS_TO_QUOTA -> fprintf ppf "STEPS_TO_QUOTA" | C_STEPS_TO_QUOTA -> fprintf ppf "STEPS_TO_QUOTA"
let cmap_sep value sep ppf m = let literal ppf (l : literal) =
let lst = Types.CMap.to_kv_list m in match l with
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in | Literal_unit ->
fprintf ppf "%a" (list_sep new_pp sep) lst 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 type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
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 lrecord_sep value sep ppf m = let rec type_expression' :
let lst = Types.LMap.to_kv_list m in (formatter -> type_expression -> unit)
let new_pp ppf (k, v) = fprintf ppf "%a = %a" label k value v in -> formatter
fprintf ppf "%a" (list_sep new_pp sep) lst -> type_expression
-> unit =
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 =
fun f ppf te -> fun f ppf te ->
match te with match te.type_content with
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m | T_sum m ->
| T_record m -> fprintf ppf "record[%a]" (lmap_sep_d f ) m fprintf ppf "sum[%a]" (cmap_sep_d f) m
| T_arrow (a, b) -> fprintf ppf "%a -> %a" f a f b | T_record m ->
| T_variable tv -> type_variable ppf tv fprintf ppf "%a" (tuple_or_record_sep_type f) m
| T_constant tc -> type_constant ppf tc | T_arrow a ->
| T_operator to_ -> type_operator f ppf to_ 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 = and type_expression ppf (te : type_expression) : unit =
let s = match tc with type_expression' type_expression ppf te
| TC_unit -> "unit"
| TC_string -> "string" and type_constant ppf (tc : type_constant) : unit =
| TC_bytes -> "bytes" let s =
| TC_nat -> "nat" match tc with
| TC_int -> "int" | TC_unit ->
| TC_mutez -> "mutez" "unit"
| TC_bool -> "bool" | TC_string ->
| TC_operation -> "operation" "string"
| TC_address -> "address" | TC_bytes ->
| TC_key -> "key" "bytes"
| TC_key_hash -> "key_hash" | TC_nat ->
| TC_signature -> "signature" "nat"
| TC_timestamp -> "timestamp" | TC_int ->
| TC_chain_id -> "chain_id" "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 in
fprintf ppf "%s" s fprintf ppf "%s" s
and type_operator :
and type_operator : type a . (formatter -> a -> unit) -> formatter -> a type_operator -> unit = (formatter -> type_expression -> unit)
-> formatter
-> type_operator
-> unit =
fun f ppf to_ -> fun f ppf to_ ->
let s = match to_ with let s =
| TC_option (tv) -> Format.asprintf "option(%a)" f tv match to_ with
| TC_list (tv) -> Format.asprintf "list(%a)" f tv | TC_option te -> Format.asprintf "option(%a)" f te
| TC_set (tv) -> Format.asprintf "set(%a)" f tv | 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_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_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 (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
| TC_arrow (a , b) -> Format.asprintf "TC_Arrow (%a,%a)" f a f b | TC_contract te -> Format.asprintf "Contract (%a)" f te
| TC_tuple lst -> Format.asprintf "tuple[%a]" (list_sep_d f) lst
in in
fprintf ppf "(TO_%s)" s fprintf ppf "(TO_%s)" s
end
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 |}]

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 Types = Types
module PP = PP 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))

18
src/stages/common/helpers.mli Normal file
View File

@ -0,0 +1,18 @@
val bind_lmap :
('a * 'b list, 'c) result Types.label_map ->
('a Types.label_map * 'b list, 'c) result
val bind_cmap :
('a * 'b list, 'c) result Types.constructor_map ->
('a Types.constructor_map * 'b list, 'c) result
val bind_fold_lmap :
('a -> Types.label -> 'b -> ('a * 'c list, 'd) result) ->
('a * 'c list, 'd) result ->
'b Types.label_map -> ('a * 'c list, 'd) result
val bind_map_lmap :
('a -> ('b * 'c list, 'd) result) ->
'a Types.label_map -> ('b Types.label_map * 'c list, 'd) result
val bind_map_cmap :
('a -> ('b * 'c list, 'd) result) ->
'a Types.constructor_map ->
('b Types.constructor_map * 'c list, 'd) result
val is_tuple_lmap : 'a Types.label_map -> bool

94
src/stages/common/misc.ml
View File

@ -1,94 +0,0 @@
open Types
open Trace
let map_type_operator f = function
TC_contract x -> TC_contract (f x)
| TC_option x -> TC_option (f x)
| TC_list x -> TC_list (f x)
| TC_set x -> TC_set (f x)
| TC_map (x , y) -> TC_map (f x , f y)
| TC_big_map (x , y) -> TC_big_map (f x , f y)
| TC_arrow (x , y) -> TC_arrow (f x , f y)
| TC_tuple lst -> TC_tuple (List.map f lst)
let bind_map_type_operator f = function
TC_contract x -> let%bind x = f x in ok @@ TC_contract x
| TC_option x -> let%bind x = f x in ok @@ TC_option x
| TC_list x -> let%bind x = f x in ok @@ TC_list x
| TC_set x -> let%bind x = f x in ok @@ TC_set x
| TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y)
| TC_big_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y)
| TC_arrow (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y)
| TC_tuple lst -> let%bind lst = bind_map_list f lst in ok @@ TC_tuple lst
let type_operator_name = function
TC_contract _ -> "TC_contract"
| TC_option _ -> "TC_option"
| TC_list _ -> "TC_list"
| TC_set _ -> "TC_set"
| TC_map _ -> "TC_map"
| TC_big_map _ -> "TC_big_map"
| TC_arrow _ -> "TC_arrow"
| TC_tuple _ -> "TC_tuple"
let type_expression'_of_string = function
| "TC_contract" , [x] -> ok @@ T_operator(TC_contract x)
| "TC_option" , [x] -> ok @@ T_operator(TC_option x)
| "TC_list" , [x] -> ok @@ T_operator(TC_list x)
| "TC_set" , [x] -> ok @@ T_operator(TC_set x)
| "TC_map" , [x ; y] -> ok @@ T_operator(TC_map (x , y))
| "TC_big_map" , [x ; y] -> ok @@ T_operator(TC_big_map (x, y))
| ("TC_contract" | "TC_option" | "TC_list" | "TC_set" | "TC_map" | "TC_big_map"), _ ->
failwith "internal error: wrong number of arguments for type operator"
| "TC_unit" , [] -> ok @@ T_constant(TC_unit)
| "TC_string" , [] -> ok @@ T_constant(TC_string)
| "TC_bytes" , [] -> ok @@ T_constant(TC_bytes)
| "TC_nat" , [] -> ok @@ T_constant(TC_nat)
| "TC_int" , [] -> ok @@ T_constant(TC_int)
| "TC_mutez" , [] -> ok @@ T_constant(TC_mutez)
| "TC_bool" , [] -> ok @@ T_constant(TC_bool)
| "TC_operation" , [] -> ok @@ T_constant(TC_operation)
| "TC_address" , [] -> ok @@ T_constant(TC_address)
| "TC_key" , [] -> ok @@ T_constant(TC_key)
| "TC_key_hash" , [] -> ok @@ T_constant(TC_key_hash)
| "TC_chain_id" , [] -> ok @@ T_constant(TC_chain_id)
| "TC_signature" , [] -> ok @@ T_constant(TC_signature)
| "TC_timestamp" , [] -> ok @@ T_constant(TC_timestamp)
| _, [] ->
failwith "internal error: wrong number of arguments for type constant"
| op, _ ->
failwith (Format.asprintf "internal error: unknown type operator in src/stages/common/misc.ml %s" op)
let string_of_type_operator = function
| TC_contract x -> "TC_contract" , [x]
| TC_option x -> "TC_option" , [x]
| TC_list x -> "TC_list" , [x]
| TC_set x -> "TC_set" , [x]
| TC_map (x , y) -> "TC_map" , [x ; y]
| TC_big_map (x , y) -> "TC_big_map" , [x ; y]
| TC_arrow (x , y) -> "TC_arrow" , [x ; y]
| TC_tuple lst -> "TC_tuple" , lst
let string_of_type_constant = function
| TC_unit -> "TC_unit", []
| TC_string -> "TC_string", []
| TC_bytes -> "TC_bytes", []
| TC_nat -> "TC_nat", []
| TC_int -> "TC_int", []
| TC_mutez -> "TC_mutez", []
| TC_bool -> "TC_bool", []
| TC_operation -> "TC_operation", []
| TC_address -> "TC_address", []
| TC_key -> "TC_key", []
| TC_key_hash -> "TC_key_hash", []
| TC_chain_id -> "TC_chain_id", []
| TC_signature -> "TC_signature", []
| TC_timestamp -> "TC_timestamp", []
let string_of_type_expression' = function
| T_operator o -> string_of_type_operator o
| T_constant c -> string_of_type_constant c
| T_sum _|T_record _|T_arrow (_, _)|T_variable _ ->
failwith "not a type operator or constant"

9
src/stages/common/misc.mli
View File

@ -1,9 +0,0 @@
open Types
val map_type_operator : ('a -> 'b) -> 'a type_operator -> 'b type_operator
val bind_map_type_operator : ('a -> ('b * 'c list, 'd) Pervasives.result) -> 'a type_operator -> ('b type_operator * 'c list, 'd) Pervasives.result
val type_operator_name : 'a type_operator -> string
val type_expression'_of_string : string * 'a list -> ('a type_expression' * 'b list, 'c) Pervasives.result
val string_of_type_operator : 'a type_operator -> string * 'a list
val string_of_type_constant : type_constant -> string * 'a list
val string_of_type_expression' : 'a type_expression' -> string * 'a list

242
src/stages/common/types.ml
View File

@ -1,78 +1,19 @@
type expression_ type expression_
and expression_variable = expression_ Var.t
type type_ type type_
and type_variable = type_ Var.t
type expression_variable = expression_ Var.t
type type_variable = type_ Var.t type constructor' = Constructor of string
type constructor = Constructor of string
type label = Label of string type label = Label of string
module CMap = Map.Make( struct type t = constructor let compare (Constructor a) (Constructor b) = compare a b end)
module CMap = Map.Make( struct type t = constructor' let compare (Constructor a) (Constructor b) = compare a b end)
module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = String.compare a b end) module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = String.compare a b end)
type 'a label_map = 'a LMap.t type 'a label_map = 'a LMap.t
type 'a constructor_map = 'a CMap.t type 'a constructor_map = 'a CMap.t
and type_constant =
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)
type access =
| Access_tuple of int
| Access_record of string
and access_path = access list
and literal =
| Literal_unit
| Literal_bool of bool
| Literal_int of int
| Literal_nat of int
| Literal_timestamp of int
| Literal_mutez of int
| Literal_string of string
| Literal_bytes of bytes
| Literal_address of string
| Literal_signature of string
| Literal_key of string
| Literal_key_hash of string
| Literal_chain_id of string
| Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
(* The ast is a tree of node, 'a is the type of the node (type_variable or {type_variable, previous_type}) *)
type 'a type_expression' =
| T_sum of 'a constructor_map
| T_record of 'a label_map
| T_arrow of 'a * 'a
| T_variable of type_variable
| T_constant of type_constant
| T_operator of 'a type_operator
and type_constant =
| TC_unit | TC_unit
| TC_string | TC_string
| TC_bytes | TC_bytes
@ -87,35 +28,145 @@ and type_constant =
| TC_chain_id | TC_chain_id
| TC_signature | TC_signature
| TC_timestamp | TC_timestamp
| TC_void
module type AST_PARAMETER_TYPE = sig
type type_meta
end
and 'a type_operator = module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_contract of 'a open PARAMETER
| TC_option of 'a
| TC_list of 'a
| TC_set of 'a
| TC_map of 'a * 'a
| TC_big_map of 'a * 'a
| TC_arrow of 'a * 'a
| TC_tuple of 'a list
type type_base = type type_content =
| Base_unit | T_sum of type_expression constructor_map
| Base_string | T_record of type_expression label_map
| Base_bytes | T_arrow of arrow
| Base_nat | T_variable of type_variable
| Base_int | T_constant of type_constant
| Base_mutez | T_operator of type_operator
| Base_bool
| Base_operation
| Base_address
| Base_void
| Base_timestamp
| Base_signature
| Base_key
| Base_key_hash
| Base_chain_id
and ('a,'tv) matching = and arrow = {type1: type_expression; type2: type_expression}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| TC_list of type_expression
| TC_set of type_expression
| TC_map of type_expression * type_expression
| TC_big_map of type_expression * type_expression
| TC_arrow of type_expression * type_expression
and type_expression = {type_content: type_content; type_meta: type_meta}
open Trace
let map_type_operator f = function
TC_contract x -> TC_contract (f x)
| TC_option x -> TC_option (f x)
| TC_list x -> TC_list (f x)
| TC_set x -> TC_set (f x)
| TC_map (x , y) -> TC_map (f x , f y)
| TC_big_map (x , y)-> TC_big_map (f x , f y)
| TC_arrow (x, y) -> TC_arrow (f x, f y)
let bind_map_type_operator f = function
TC_contract x -> let%bind x = f x in ok @@ TC_contract x
| TC_option x -> let%bind x = f x in ok @@ TC_option x
| TC_list x -> let%bind x = f x in ok @@ TC_list x
| TC_set x -> let%bind x = f x in ok @@ TC_set x
| TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y)
| TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y)
| TC_arrow (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y)
let type_operator_name = function
TC_contract _ -> "TC_contract"
| TC_option _ -> "TC_option"
| TC_list _ -> "TC_list"
| TC_set _ -> "TC_set"
| TC_map _ -> "TC_map"
| TC_big_map _ -> "TC_big_map"
| TC_arrow _ -> "TC_arrow"
let type_expression'_of_string = function
| "TC_contract" , [x] -> ok @@ T_operator(TC_contract x)
| "TC_option" , [x] -> ok @@ T_operator(TC_option x)
| "TC_list" , [x] -> ok @@ T_operator(TC_list x)
| "TC_set" , [x] -> ok @@ T_operator(TC_set x)
| "TC_map" , [x ; y] -> ok @@ T_operator(TC_map (x , y))
| "TC_big_map" , [x ; y] -> ok @@ T_operator(TC_big_map (x, y))
| ("TC_contract" | "TC_option" | "TC_list" | "TC_set" | "TC_map" | "TC_big_map"), _ ->
failwith "internal error: wrong number of arguments for type operator"
| "TC_unit" , [] -> ok @@ T_constant(TC_unit)
| "TC_string" , [] -> ok @@ T_constant(TC_string)
| "TC_bytes" , [] -> ok @@ T_constant(TC_bytes)
| "TC_nat" , [] -> ok @@ T_constant(TC_nat)
| "TC_int" , [] -> ok @@ T_constant(TC_int)
| "TC_mutez" , [] -> ok @@ T_constant(TC_mutez)
| "TC_bool" , [] -> ok @@ T_constant(TC_bool)
| "TC_operation" , [] -> ok @@ T_constant(TC_operation)
| "TC_address" , [] -> ok @@ T_constant(TC_address)
| "TC_key" , [] -> ok @@ T_constant(TC_key)
| "TC_key_hash" , [] -> ok @@ T_constant(TC_key_hash)
| "TC_chain_id" , [] -> ok @@ T_constant(TC_chain_id)
| "TC_signature" , [] -> ok @@ T_constant(TC_signature)
| "TC_timestamp" , [] -> ok @@ T_constant(TC_timestamp)
| _, [] ->
failwith "internal error: wrong number of arguments for type constant"
| _ ->
failwith "internal error: unknown type operator"
let string_of_type_operator = function
| TC_contract x -> "TC_contract" , [x]
| TC_option x -> "TC_option" , [x]
| TC_list x -> "TC_list" , [x]
| TC_set x -> "TC_set" , [x]
| TC_map (x , y) -> "TC_map" , [x ; y]
| TC_big_map (x , y) -> "TC_big_map" , [x ; y]
| TC_arrow (x , y) -> "TC_arrow" , [x ; y]
let string_of_type_constant = function
| TC_unit -> "TC_unit", []
| TC_string -> "TC_string", []
| TC_bytes -> "TC_bytes", []
| TC_nat -> "TC_nat", []
| TC_int -> "TC_int", []
| TC_mutez -> "TC_mutez", []
| TC_bool -> "TC_bool", []
| TC_operation -> "TC_operation", []
| TC_address -> "TC_address", []
| TC_key -> "TC_key", []
| TC_key_hash -> "TC_key_hash", []
| TC_chain_id -> "TC_chain_id", []
| TC_signature -> "TC_signature", []
| TC_timestamp -> "TC_timestamp", []
| TC_void -> "TC_void", []
let string_of_type_expression' = function
| T_operator o -> string_of_type_operator o
| T_constant c -> string_of_type_constant c
| T_sum _ | T_record _ | T_arrow _ | T_variable _ ->
failwith "not a type operator or constant"
end
type literal =
| Literal_unit
| Literal_bool of bool
| Literal_int of int
| Literal_nat of int
| Literal_timestamp of int
| Literal_mutez of int
| Literal_string of string
| Literal_bytes of bytes
| Literal_address of string
| Literal_signature of string
| Literal_key of string
| Literal_key_hash of string
| Literal_chain_id of string
| Literal_void
| Literal_operation of
Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
and ('a,'tv) matching_content =
| Match_bool of { | Match_bool of {
match_true : 'a ; match_true : 'a ;
match_false : 'a ; match_false : 'a ;
@ -129,9 +180,9 @@ and ('a,'tv) matching =
match_some : expression_variable * 'a * 'tv; match_some : expression_variable * 'a * 'tv;
} }
| Match_tuple of (expression_variable list * 'a) * 'tv list | Match_tuple of (expression_variable list * 'a) * 'tv list
| Match_variant of ((constructor * expression_variable) * 'a) list * 'tv | Match_variant of ((constructor' * expression_variable) * 'a) list * 'tv
type constant = and constant' =
| C_INT | C_INT
| C_UNIT | C_UNIT
| C_NIL | C_NIL
@ -201,6 +252,8 @@ type constant =
| C_MAP | C_MAP
| C_MAP_EMPTY | C_MAP_EMPTY
| C_MAP_LITERAL | C_MAP_LITERAL
| C_MAP_GET
| C_MAP_GET_FORCE
| C_MAP_ADD | C_MAP_ADD
| C_MAP_REMOVE | C_MAP_REMOVE
| C_MAP_UPDATE | C_MAP_UPDATE
@ -218,6 +271,7 @@ type constant =
| C_SHA256 | C_SHA256
| C_SHA512 | C_SHA512
| C_BLAKE2b | C_BLAKE2b
| C_HASH
| C_HASH_KEY | C_HASH_KEY
| C_CHECK_SIGNATURE | C_CHECK_SIGNATURE
| C_CHAIN_ID | C_CHAIN_ID

39
src/stages/ligo_interpreter/PP.ml Normal file
View File

@ -0,0 +1,39 @@
open Types
let rec pp_value : value -> string = function
| V_Ct (C_int i) -> Format.asprintf "%i : int" i
| V_Ct (C_nat n) -> Format.asprintf "%i : nat" n
| V_Ct (C_string s) -> Format.asprintf "\"%s\" : string" s
| V_Ct (C_unit) -> Format.asprintf "unit"
| V_Ct (C_bool true) -> Format.asprintf "true"
| V_Ct (C_bool false) -> Format.asprintf "false"
| V_Ct (C_bytes b) -> Format.asprintf "0x%a : bytes" Hex.pp (Hex.of_bytes b)
| V_Ct (C_mutez i) -> Format.asprintf "%i : mutez" i
| V_Ct (C_address s) -> Format.asprintf "\"%s\" : address" s
| V_Ct _ -> Format.asprintf "PP, TODO"
| V_Failure s -> Format.asprintf "\"%s\" : failure " s
| V_Record recmap ->
let content = LMap.fold (fun label field prev ->
let (Label l) = label in
Format.asprintf "%s ; %s = (%s)" prev l (pp_value field))
recmap "" in
Format.asprintf "{ %s }" content
| V_Func_val _ -> Format.asprintf "<fun>"
| V_Construct (name,v) -> Format.asprintf "%s(%s)" name (pp_value v)
| V_List vl ->
Format.asprintf "[%s]" @@
List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" vl
| V_Map vmap ->
Format.asprintf "[%s]" @@
List.fold_left (fun prev (k,v) -> Format.asprintf "%s ; %s -> %s" prev (pp_value k) (pp_value v)) "" vmap
| V_Set slist ->
Format.asprintf "{%s}" @@
List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" slist
let pp_env : env -> unit = fun env ->
let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in
let () = Env.iter (fun var v ->
Format.printf "\t%s -> %s\n" (Var.to_name var) (pp_value v))
env in
let () = Format.printf "\n}\n" in
()

34
src/stages/ligo_interpreter/combinators.ml Normal file
View File

@ -0,0 +1,34 @@
open Trace
open Types
let v_pair : value * value -> value =
fun (a,b) -> V_Record (LMap.of_list [(Label "0", a) ; (Label "1",b)])
let v_bool : bool -> value =
fun b -> V_Ct (C_bool b)
let v_unit : unit -> value =
fun () -> V_Ct (C_unit)
let v_some : value -> value =
fun v -> V_Construct ("Some", v)
let v_none : unit -> value =
fun () -> V_Construct ("None", v_unit ())
let extract_pair : value -> (value * value) result =
fun p ->
let err = simple_error "value is not a pair" in
( match p with
| V_Record lmap ->
let%bind fst = trace_option err @@
LMap.find_opt (Label "0") lmap in
let%bind snd = trace_option err @@
LMap.find_opt (Label "1") lmap in
ok (fst,snd)
| _ -> fail err )
let is_true : value -> bool result =
fun b -> match b with
| V_Ct (C_bool b) -> ok b
| _ -> simple_fail "value is not a bool"

14
src/stages/ligo_interpreter/dune Normal file
View File

@ -0,0 +1,14 @@
(library
(name ligo_interpreter)
(public_name ligo.ligo_interpreter)
(libraries
simple-utils
tezos-utils
ast_typed
stage_common
)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
(flags (:standard -open Simple_utils))
)

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