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

.gitignore

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

.gitlab-ci.yml

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

gitlab-pages/docs/advanced/first-contract.md

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

gitlab-pages/docs/advanced/timestamps-addresses.md

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

gitlab-pages/docs/contributors/getting-started.md

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

gitlab-pages/docs/contributors/ligo_test_guide.md

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

gitlab-pages/docs/contributors/origin.md

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

gitlab-pages/docs/contributors/philosophy.md

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

gitlab-pages/docs/intro/installation.md

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

gitlab-pages/docs/intro/what-and-why.md

@@ -64,7 +64,7 @@ Unfortunately (???), we **can't run Javascript on the Tezos blockchain** at the
 
 ## C-like smart contracts instead of Michelson
 
-Let's take a look at a similar LIGO program. Don't worry if it's a little confusing at first; we'll explain all the syntax in the upcoming sections of the documentation.
+Let's take a look at a similar LIGO program. Don't worry if it is a little confusing at first; we'll explain all the syntax in the upcoming sections of the documentation.
 
 <!--DOCUSAURUS_CODE_TABS-->
 <!--Pascaligo-->
@@ -132,7 +132,7 @@ The LIGO contract behaves exactly* like the Michelson contract we've saw first,
 ## Runnable code snippets & exercises
 
 Some of the sections in this documentation will include runnable code snippets and exercises. Sources for those are available at
-the [LIGO Gitlab repository](https://gitlab.com/ligolang/ligo). 
+the [LIGO GitLab repository](https://gitlab.com/ligolang/ligo). 
 
 ### Snippets
 For example **code snippets** for the *Types* subsection of this doc, can be found here:
@@ -141,7 +141,7 @@ For example **code snippets** for the *Types* subsection of this doc, can be fou
 ### Exercises
 Solutions to exercises can be found e.g. here:  `gitlab-pages/docs/language-basics/exercises/types/**/solutions/**`
 
-### Running snippets / excercise solutions
+### Running snippets / exercise solutions
 In certain cases it makes sense to be able to run/evaluate the given snippet or a solution, usually there'll be an example command which you can use, such as:
 
 ```shell

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

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

gitlab-pages/docs/language-basics/tezos-specific.md

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

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

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

gitlab-pages/docs/reference/string.md

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

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

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

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

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

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

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

gitlab-pages/website/pages/en/contact.js

@@ -47,8 +47,8 @@ const TEAM = [
 
 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"
   },
   {

gitlab-pages/website/pages/en/index.js

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

gitlab-pages/website/pages/en/versions.js

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

gitlab-pages/website/siteConfig.js

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

gitlab-pages/website/static/img/telegram.svg

@@ -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>

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

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

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

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

gitlab-pages/website/versioned_sidebars/version-next-sidebars.json

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

scripts/distribution/generic/parameters.sh

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

scripts/test_cli.sh

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

src/bin/cli.ml

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

src/bin/expect_tests/failwith_tests.ml

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

src/bin/expect_tests/help_tests.ml

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

src/bin/expect_tests/ligo_interpreter_tests.ml

@@ -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) } |}] ;

src/bin/expect_tests/literals.ml

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

src/bin/expect_tests/misc_cli_commands.ml

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

src/bin/expect_tests/typer_error_tests.ml

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

src/main/compile/dune

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

src/main/compile/of_simplified.ml

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

src/main/compile/of_typed.ml

@@ -4,20 +4,22 @@ open Ast_typed
 let compile : Ast_typed.program -> Mini_c.program result = fun p ->
   Transpiler.transpile_program p
 
-let compile_expression : annotated_expression -> Mini_c.expression result = fun e ->
+let compile_expression : expression -> Mini_c.expression result = fun e ->
   Transpiler.transpile_annotated_expression e
 
 type check_type = Check_parameter | Check_storage
-let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.value -> unit result =
+let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.expression -> unit result =
     fun c entry contract param -> Trace.trace (simple_info "Check argument type against contract type") (
   let%bind entry_point = Ast_typed.get_entry contract entry in
-  match entry_point.type_annotation.type_value' with
+  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
-          | 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
   )
@@ -25,3 +27,5 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As
 
 let pretty_print ppf program =
   Ast_typed.PP.program ppf program
+
+let some_interpret = Interpreter.dummy

src/main/compile/wrapper.ml

@@ -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

src/main/uncompile/uncompile.ml

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

src/passes/1-parser/cameligo/AST.ml

@@ -464,10 +464,10 @@ let expr_to_region = function
 | EList e -> list_expr_to_region e
 | EConstr e -> constr_expr_to_region e
 | EAnnot {region;_ } | ELetIn {region;_} | EFun {region;_}
-| ECond {region;_} | ETuple {region;_} | ECase {region;_}
+| ECond {region;_}   | ETuple {region;_} | ECase {region;_}
-| ECall {region;_} | EVar {region; _} | EProj {region; _}
+| ECall {region;_}   | EVar {region; _}  | EProj {region; _}
-| EUnit {region;_} | EPar {region;_} | EBytes {region; _}
+| EUnit {region;_}   | EPar {region;_}   | EBytes {region; _}
-| ESeq {region; _} | ERecord {region; _} | EUpdate {region; _} -> region
+| ESeq {region; _}   | ERecord {region; _} | EUpdate {region; _} -> region
 
 let selection_to_region = function
   FieldName f -> f.region

src/passes/1-parser/pascaligo/AST.ml

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

src/passes/1-parser/pascaligo/Scoping.ml

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

src/passes/2-simplify/cameligo.ml

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

src/passes/2-simplify/pascaligo.ml

@@ -16,17 +16,17 @@ let pseq_to_list = function
 let get_value : 'a Raw.reg -> 'a = fun x -> x.value
 let is_compiler_generated name = String.contains (Var.to_name name) '#'
 
-let detect_local_declarations (for_body : expression) =
+let _detect_local_declarations (for_body : expression) =
   let%bind aux = Self_ast_simplified.fold_expression
     (fun (nlist, cur_loop : expression_variable list * bool) (ass_exp : expression) ->
       if cur_loop then 
-        match ass_exp.expression with
+        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)
-        | 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)
       else
         ok @@ (nlist, cur_loop)
@@ -35,17 +35,14 @@ let detect_local_declarations (for_body : expression) =
     for_body in
   ok @@ fst aux
 
-let detect_free_variables (for_body : expression) (local_decl_names : expression_variable list) =
+let _detect_free_variables (for_body : expression) (local_decl_names : expression_variable list) =
   let%bind captured_names = Self_ast_simplified.fold_expression
     (fun (prev : expression_variable list) (ass_exp : expression) ->
-      match ass_exp.expression with
+      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 ||
              n=C_LE || n=C_GE  || n=C_EQ || n=C_NEQ -> (
-          match (a.expression,b.expression) with
+          match (a.expression_content,b.expression_content) with
           | E_variable na , E_variable nb -> 
             let ret = [] in
             let ret = if not (is_compiler_generated na) then
@@ -66,6 +63,92 @@ let detect_free_variables (for_body : expression) (local_decl_names : expression
   ok @@ SSet.elements
      @@ SSet.diff (SSet.of_list captured_names) (SSet.of_list local_decl_names)
 
+and repair_mutable_variable (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
+  let%bind captured_names = Self_ast_simplified.fold_map_expression
+    (* TODO : these should use Variables sets *)
+    (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) ->
+      match ass_exp.expression_content with
+        | E_let_in {let_binder;mut=false;rhs;let_result} ->
+          let (name,_) = let_binder in
+          ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result)
+        | E_let_in {let_binder;mut=true; rhs;let_result} ->
+          let (name,_) = let_binder in
+          if List.mem name decl_var then 
+            ok (true,(decl_var, free_var), e_let_in let_binder false false rhs let_result)
+          else(
+            let free_var = if (List.mem name free_var) then free_var else name::free_var in
+            let expr = e_let_in (env,None) false false (e_update (e_variable env) (Var.show name) (e_variable name)) let_result in
+            ok (true,(decl_var, free_var), e_let_in let_binder false  false rhs expr)
+          )
+        | E_variable name ->
+          if List.mem name decl_var || List.mem name free_var || Var.equal name env then 
+            ok (true,(decl_var, free_var), e_variable name)
+          else
+            ok (true, (decl_var, name::free_var), e_variable name)
+        | E_constant {cons_name=C_MAP_FOLD;arguments= _}
+        | E_constant {cons_name=C_SET_FOLD;arguments= _}
+        | E_constant {cons_name=C_LIST_FOLD;arguments= _} 
+        | E_matching _ -> ok @@ (false, (decl_var,free_var),ass_exp)
+      | _ -> ok (true, (decl_var, free_var),ass_exp)
+    )
+      (element_names,[])
+      for_body in
+  ok @@ captured_names
+
+and repair_mutable_variable_for_collect (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
+  let%bind captured_names = Self_ast_simplified.fold_map_expression
+    (* TODO : these should use Variables sets *)
+    (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) ->
+      match ass_exp.expression_content with
+        | E_let_in {let_binder;mut=false;rhs;let_result} ->
+          let (name,_) = let_binder in
+          ok (true,(name::decl_var, free_var),e_let_in let_binder false false rhs let_result)
+        | E_let_in {let_binder;mut=true; rhs;let_result} ->
+          let (name,_) = let_binder in
+          if List.mem name decl_var then 
+            ok (true,(decl_var, free_var), e_let_in let_binder false false rhs let_result)
+          else(
+            let free_var = if (List.mem name free_var) then free_var else name::free_var in
+            let expr = e_let_in (env,None) false false (
+              e_update (e_variable env) ("0") 
+              (e_update (e_accessor (e_variable env) "0") (Var.show name) (e_variable name))
+              )
+              let_result in
+            ok (true,(decl_var, free_var), e_let_in let_binder false  false rhs expr)
+          )
+        | E_variable name ->
+          if List.mem name decl_var || List.mem name free_var || Var.equal name env then 
+            ok (true,(decl_var, free_var), e_variable name)
+          else
+            ok (true,(decl_var, name::free_var), e_variable name)
+        | E_constant {cons_name=C_MAP_FOLD;arguments= _}
+        | E_constant {cons_name=C_SET_FOLD;arguments= _}
+        | E_constant {cons_name=C_LIST_FOLD;arguments= _} 
+        | E_matching _ -> ok @@ (false,(decl_var,free_var),ass_exp)
+      | _ -> ok (true,(decl_var, free_var),ass_exp)
+    )
+      (element_names,[])
+      for_body in
+  ok @@ captured_names
+
+and store_mutable_variable (free_vars : expression_variable list) =
+  if (List.length free_vars == 0) then
+    e_unit ()
+  else
+    let aux var = (Var.show var, e_variable var) in
+    e_record_ez (List.map aux free_vars)
+ 
+and restore_mutable_variable (expr : expression) (free_vars : expression_variable list) (env :expression_variable) =
+  let aux (f:expression -> expression) (ev:expression_variable) =
+    ok @@ fun expr -> f (e_let_in (ev,None) true false (e_accessor (e_variable env) (Var.show ev)) expr)
+  in
+  let%bind ef = bind_fold_list aux (fun e -> e) free_vars in
+  ok @@ fun expr'_opt -> match expr'_opt with
+  | None -> ok @@ e_let_in (env,None) false false expr (ef (e_skip ()))
+  | Some expr' -> ok @@ e_let_in (env,None) false false expr (ef expr')
+ 
+
+
 module Errors = struct
   let unsupported_cst_constr p =
     let title () = "" in
@@ -78,18 +161,6 @@ module Errors = struct
     ] in
     error ~data title message
 
-  let corner_case ~loc message =
-    let title () = "\nCorner case" in
-    let content () = "We do not have a good error message for this case. \
-                      We are striving find ways to better report them and \
-                      find the use-cases that generate them. \
-                      Please report this to the developers.\n" in
-    let data = [
-      ("location" , fun () -> loc) ;
-      ("message" , fun () -> message) ;
-    ] in
-    error ~data title content
-
   let unknown_predefined_type name =
     let title () = "\nType constants" in
     let message () =
@@ -196,16 +267,17 @@ let r_split = Location.r_split
    [return_statement] is used for non-let-in statements.
  *)
 
-let return_let_in ?loc binder inline rhs = ok @@ fun expr'_opt ->
+let return_let_in ?loc binder mut inline rhs = ok @@ fun expr'_opt ->
   match expr'_opt with
-  | None -> fail @@ corner_case ~loc:__LOC__ "missing return"
+  | 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 ->
   match expr'_opt with
   | None -> ok @@ expr
   | Some expr' -> ok @@ e_sequence expr expr'
 
+
 let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
   match t with
     TPar x -> simpl_type_expression x.value.inside
@@ -218,7 +290,7 @@ let rec simpl_type_expression (t:Raw.type_expr) : type_expression result =
       let%bind (a , b) =
         let (a , _ , b) = x.value in
         bind_map_pair simpl_type_expression (a , b) in
-      ok @@ make_t @@ T_arrow (a , b)
+      ok @@ make_t @@ T_arrow {type1=a;type2=b}
     )
   | TApp x ->
       let (name, tuple) = x.value in
@@ -268,7 +340,7 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result
   | [hd] -> simpl_type_expression hd
   | lst ->
       let%bind lst = bind_list @@ List.map simpl_type_expression lst in
-      ok @@ make_t @@ T_operator (TC_tuple lst)
+      ok @@ t_tuple lst
 
 let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
   let (p' , loc) = r_split p in
@@ -279,11 +351,11 @@ let simpl_projection : Raw.projection Region.reg -> _ = fun p ->
   let path' =
     let aux (s:Raw.selection) =
       match s with
-      | FieldName property -> Access_record property.value
+      | FieldName property -> property.value
-      | Component index -> Access_tuple (Z.to_int (snd index.value))
+      | Component index -> (Z.to_string (snd index.value))
     in
     List.map aux @@ npseq_to_list path in
-  ok @@ e_accessor ~loc var path'
+  ok @@ List.fold_left (e_accessor ~loc) var path'
 
 
 let rec simpl_expression (t:Raw.expr) : expr result =
@@ -409,7 +481,11 @@ let rec simpl_expression (t:Raw.expr) : expr result =
       let%bind expr = simpl_expression c.test in
       let%bind match_true = simpl_expression c.ifso in
       let%bind match_false = simpl_expression c.ifnot in
-      return @@ e_matching expr ~loc (Match_bool {match_true; match_false})
+      let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in
+      let env = Var.fresh () in
+      let%bind (_, match_expr) = repair_mutable_variable match_expr [] env in
+      return @@ match_expr
+
   | ECase c -> (
       let (c , loc) = r_split c in
       let%bind e = simpl_expression c.expr in
@@ -422,7 +498,10 @@ let rec simpl_expression (t:Raw.expr) : expr result =
         @@ List.map get_value
         @@ npseq_to_list c.cases.value in
       let%bind cases = simpl_cases lst in
-      return @@ e_matching ~loc e cases
+      let match_expr = e_matching ~loc e cases in
+      let env = Var.fresh () in
+      let%bind (_, match_expr) = repair_mutable_variable match_expr [] env in
+      return @@ match_expr
     )
   | EMap (MapInj mi)  -> (
       let (mi , loc) = r_split mi in
@@ -471,7 +550,7 @@ and simpl_update = fun (u:Raw.update Region.reg) ->
   let (name, path) = simpl_path u.record in
   let record = match path with
   | [] -> e_variable (Var.of_name name)
-  | _ -> e_accessor (e_variable (Var.of_name name)) path in
+  | _ -> e_accessor_list (e_variable (Var.of_name name)) path in 
   let updates = u.updates.value.ne_elements in
   let%bind updates' =
     let aux (f:Raw.field_path_assign Raw.reg) =
@@ -486,7 +565,7 @@ and simpl_update = fun (u:Raw.update Region.reg) ->
       | [] -> failwith "error in parsing"
       | hd :: [] -> ok @@ e_update ~loc record hd expr
       | hd :: tl -> 
-        let%bind expr = (aux (e_accessor ~loc record [Access_record hd]) tl) in
+        let%bind expr = (aux (e_accessor ~loc record hd) tl) in
         ok @@ e_update ~loc record hd expr 
     in
     aux ur path in
@@ -584,7 +663,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
       let name = x.name.value in
       let%bind t = simpl_type_expression x.var_type in
       let%bind expression = simpl_expression x.init in
-      return_let_in ~loc (Var.of_name name, Some t) false expression
+      return_let_in ~loc (Var.of_name name, Some t) false false expression
   | LocalConst x ->
       let (x , loc) = r_split x in
       let name = x.name.value in
@@ -596,7 +675,7 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
         | Some {value; _} ->
            npseq_to_list value.ne_elements
            |> List.exists (fun Region.{value; _} -> value = "\"inline\"")
-      in return_let_in ~loc (Var.of_name name, Some t) inline expression
+      in return_let_in ~loc (Var.of_name name, Some t) false inline expression
   | LocalFun f  ->
       let (f , loc) = r_split f in
       let%bind (binder, expr) = simpl_fun_decl ~loc f in
@@ -606,22 +685,22 @@ and simpl_data_declaration : Raw.data_decl -> _ result =
         | Some {value; _} ->
            npseq_to_list value.ne_elements
            |> List.exists (fun Region.{value; _} -> value = "\"inline\"")
-      in return_let_in ~loc binder inline expr
+      in return_let_in ~loc binder false inline expr
 
 and simpl_param :
-      Raw.param_decl -> (expression_variable * type_expression) result =
+      Raw.param_decl -> (string * type_expression) result =
   fun t ->
   match t with
   | ParamConst c ->
       let c = c.value in
-      let type_name = Var.of_name c.var.value in
+      let param_name = c.var.value in
       let%bind type_expression = simpl_type_expression c.param_type in
-      ok (type_name , type_expression)
+      ok (param_name , type_expression)
   | ParamVar v ->
       let c = v.value in
-      let type_name = Var.of_name c.var.value in
+      let param_name = c.var.value in
       let%bind type_expression = simpl_type_expression c.param_type in
-      ok (type_name , type_expression)
+      ok (param_name , type_expression)
 
 and simpl_fun_decl :
       loc:_ -> Raw.fun_decl ->
@@ -652,10 +731,10 @@ and simpl_fun_decl :
        let%bind result =
          let aux prec cur = cur (Some prec) in
          bind_fold_right_list aux result body in
-       let expression : expression = e_lambda ~loc binder (Some input_type)
+       let expression : expression = e_lambda ~loc (Var.of_name binder) (Some input_type)
            (Some output_type) result in
        let type_annotation =
-         Some (make_t @@ T_arrow (input_type, output_type)) in
+         Some (make_t @@ T_arrow {type1=input_type;type2=output_type}) in
        ok ((Var.of_name fun_name.value, type_annotation), expression)
      )
    | lst -> (
@@ -667,11 +746,11 @@ and simpl_fun_decl :
          let type_expression = t_tuple (List.map snd params) in
          (arguments_name , type_expression) in
        let%bind tpl_declarations =
-         let aux = fun i x ->
+         let aux = fun i (param, type_expr) ->
            let expr =
-             e_accessor (e_variable arguments_name) [Access_tuple i] in
+             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
          in
          bind_list @@ List.mapi aux params in
@@ -683,8 +762,8 @@ and simpl_fun_decl :
          let aux prec cur = cur (Some prec) in
          bind_fold_right_list aux result body in
        let expression =
-         e_lambda ~loc binder (Some input_type) (Some output_type) result in
+         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)
      )
   )
@@ -706,11 +785,10 @@ and simpl_fun_expression :
        let%bind result =
          let aux prec cur = cur (Some prec) in
          bind_fold_right_list aux result body in
-       let expression : expression = e_lambda ~loc binder (Some input_type)
+       let expression : expression = e_lambda ~loc (Var.of_name binder) (Some input_type)
            (Some output_type) result in
-       let type_annotation =
+       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 -> (
        let lst = npseq_to_list lst in
@@ -721,11 +799,10 @@ and simpl_fun_expression :
          let type_expression = t_tuple (List.map snd params) in
          (arguments_name , type_expression) in
        let%bind tpl_declarations =
-         let aux = fun i x ->
+         let 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
          in
          bind_list @@ List.mapi aux params in
@@ -738,8 +815,8 @@ and simpl_fun_expression :
          bind_fold_right_list aux result body in
        let expression =
          e_lambda ~loc binder (Some (input_type)) (Some output_type) result in
-       let type_annotation = Some (make_t @@ T_arrow (input_type, output_type)) in
+       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
   in bind_list @@ hook [] (List.rev statements)
 
+and get_case_variables (t:Raw.pattern) : expression_variable list result = 
+  match t with 
+    | PConstr PFalse _ 
+    | PConstr PTrue _ 
+    | PConstr PNone _ -> ok @@ [] 
+    | PConstr PSomeApp v -> (let (_,v) = v.value in get_case_variables (v.value.inside)) 
+    | PConstr PConstrApp v -> (
+      match v.value with
+      | constr, None -> ok @@ [ Var.of_name constr.value]
+      | constr, pat_opt ->
+        let%bind pat =
+          trace_option (unsupported_cst_constr t) @@
+          pat_opt in
+        let pat = npseq_to_list pat.value.inside in
+        let%bind var = bind_map_list get_case_variables pat in
+        ok @@ [Var.of_name constr.value ] @ (List.concat var)
+    )
+    | PList PNil _  -> ok @@ []
+    | PList PCons c -> (
+        match c.value with
+        | a, [(_, b)] ->
+            let%bind a = get_case_variables a in
+            let%bind b = get_case_variables b in
+            ok @@ a@b
+        | _ -> fail @@ unsupported_deep_list_patterns c
+    )
+    | PVar  v -> ok @@ [Var.of_name v.value] 
+    | p -> fail @@ unsupported_cst_constr p
+
 and simpl_single_instruction : Raw.instruction -> (_ -> expression result) result =
   fun t ->
   match t with
@@ -799,19 +905,14 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
       return_statement @@ e_skip ~loc ()
     )
   | Loop (While l) ->
-      let l = l.value in
+      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 = loop None in
+      ok loop
-      return_statement @@ loop
+  )
   | Loop (For (ForCollect fc)) ->
       let%bind loop = simpl_for_collect fc.value in
-      let%bind loop = loop None in
+      ok loop
-      return_statement @@ loop
   | Cond c -> (
       let (c , loc) = r_split c in
       let%bind expr = simpl_expression c.test in
@@ -833,9 +934,22 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
                 simpl_block value
             | ShortBlock {value; _} ->
                 simpl_statements @@ fst value.inside in
-      let%bind match_true = match_true None in
+      let 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 -> (
       let (a , loc) = r_split a in
@@ -843,7 +957,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
       match a.lhs with
         | Path path -> (
             let (name , path') = simpl_path path in
-            return_statement @@ e_assign ~loc name path' value_expr
+            let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in
+            return_let_in let_binder mut inline rhs
           )
         | MapPath v -> (
             let v' = v.value in
@@ -856,14 +971,16 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
             in
             let%bind key_expr = simpl_expression v'.index.value.inside in
             let expr' = e_map_add key_expr value_expr map in
-            return_statement @@ e_assign ~loc varname path expr'
+            let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in
+            return_let_in let_binder mut inline rhs  
           )
     )
   | CaseInstr c -> (
       let (c , loc) = r_split c in
       let%bind expr = simpl_expression c.expr in
-      let%bind cases =
+      let 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 =
             match x.value.rhs with
               ClauseInstr i ->
@@ -874,42 +991,43 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
                     simpl_block value
                 | ShortBlock {value; _} ->
                   simpl_statements @@ fst value.inside in
-          let%bind case_clause = case_clause None in
+          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
-      let%bind m = simpl_cases cases in
+        bind_fold_map_list aux [] (npseq_to_list c.cases.value) in
-      return_statement @@ e_matching ~loc expr m
+      let free_vars = List.concat fv in
+      if (List.length free_vars == 0) then (
+        let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
+        let%bind m = simpl_cases cases in
+        return_statement @@ e_matching ~loc expr m
+      ) else (
+        let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in
+        let%bind m = simpl_cases cases in
+        let match_expr = e_matching ~loc expr m in
+        let return_expr = e_let_in (env,None) false false (store_mutable_variable free_vars) match_expr in
+        restore_mutable_variable return_expr free_vars env
+      )
     )
   | RecordPatch r -> (
-      let r = r.value in
+      let 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
-      return_statement @@ expr
+      let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = {
+        value = Raw.map_ne_injection aux r.record_inj.value;
+        region=r.record_inj.region
+        } in
+      let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
+      let%bind expr = simpl_update {value=u;region=reg} in
+      let (name , access_path) = simpl_path r.path in
+      let loc = Some loc in
+      let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in
+      return_let_in binder mut inline rhs
+
   )
   | MapPatch patch -> (
       let (map_p, loc) = r_split patch in
@@ -923,16 +1041,16 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
             in ok @@ (key', value')
           )
         @@ npseq_to_list map_p.map_inj.value.ne_elements in
-      let expr =
+      match inj with
-        match inj with
+      | [] -> return_statement @@ e_skip ~loc ()
-        | [] -> 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_list ~loc (e_variable (Var.of_name name)) access_path)
-              (e_accessor ~loc (e_variable (Var.of_name name)) access_path)
+        in 
-          in e_assign ~loc name access_path assigns
+        let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
-      in return_statement @@ expr
+        return_let_in binder mut inline rhs
     )
   | SetPatch patch -> (
       let (setp, loc) = r_split patch in
@@ -941,15 +1059,14 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
         bind_list @@
         List.map simpl_expression @@
         npseq_to_list setp.set_inj.value.ne_elements in
-      let expr =
+      match inj with
-        match inj with
+      | [] -> return_statement @@ e_skip ~loc ()
-        | [] -> 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_list ~loc (e_variable (Var.of_name name)) access_path) in
-            inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
+        let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
-          e_assign ~loc name access_path assigns in
+        return_let_in binder mut inline rhs
-      return_statement @@ expr
     )
   | MapRemove r -> (
       let (v , loc) = r_split r in
@@ -963,7 +1080,8 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
       in
       let%bind key' = simpl_expression key in
       let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
-      return_statement @@ e_assign ~loc varname path expr
+      let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
+      return_let_in binder mut inline rhs
     )
   | SetRemove r -> (
       let (set_rm, loc) = r_split r in
@@ -976,10 +1094,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul
       in
       let%bind removed' = simpl_expression set_rm.element in
       let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
-      return_statement @@ e_assign ~loc varname path expr
+      let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
+      return_let_in binder mut inline rhs
     )
 
-and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
+and simpl_path : Raw.path -> string * string list = fun p ->
   match p with
   | Raw.Name v -> (v.value , [])
   | Raw.Path p -> (
@@ -989,14 +1108,14 @@ and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p ->
       let path' =
         let aux (s:Raw.selection) =
           match s with
-          | FieldName property -> Access_record property.value
+          | FieldName property -> property.value
-          | Component index -> Access_tuple (Z.to_int (snd index.value))
+          | Component index -> (Z.to_string (snd index.value))
         in
         List.map aux @@ npseq_to_list path in
       (var , path')
     )
 
-and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result = fun t ->
+and simpl_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
   let open Raw in
   let get_var (t:Raw.pattern) =
     match t with
@@ -1105,223 +1224,108 @@ and simpl_statements : Raw.statements -> (_ -> expression result) result =
 and simpl_block : Raw.block -> (_ -> expression result) result =
   fun t -> simpl_statements t.statements
 
+and simpl_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl ->
+  let env_rec = Var.fresh () in
+  let binder  = Var.fresh () in
+
+  let%bind cond = simpl_expression wl.cond in
+  let%bind for_body = simpl_block wl.block.value in
+
+  let ctrl = 
+    (e_variable binder)
+    in
+  let%bind for_body = for_body @@ Some( ctrl ) in
+  let%bind ((_,captured_name_list),for_body) = repair_mutable_variable for_body [] binder in
+
+  let aux name expr=
+    e_let_in (name,None) false false (e_accessor (e_variable binder) (Var.to_name name)) expr
+  in
+  let init_rec = store_mutable_variable @@ captured_name_list in
+  let restore = fun expr -> List.fold_right aux captured_name_list expr in
+  let continue_expr = e_constant C_CONTINUE [for_body] in
+  let stop_expr = e_constant C_STOP [e_variable binder] in
+  let aux_func = e_cond cond continue_expr (stop_expr) in
+  let aux_func = (restore (aux_func)) in
+  let aux_func = e_lambda binder None None @@ aux_func in
+  let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in
+  let return_expr = e_let_in (env_rec,None) false false init_rec (loop) in
+  restore_mutable_variable return_expr captured_name_list env_rec 
+
+
 and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
-  (* cond part *)
+  let 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 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 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 ->
-  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]
     | None -> [Var.of_name fc.var.value] in
-  (* STEP 1 *)
+  
+  let env = Var.fresh () in
   let%bind for_body = simpl_block fc.block.value in
-  let%bind for_body = for_body None in
+  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 lambda = e_lambda (Var.of_name "arguments") None None for_body in
+  let aux name expr=
+    e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr
+  in
+  let restore = fun expr -> List.fold_right aux free_vars expr in
+  let restore = match fc.collection with
+    | Map _ -> (match fc.bind_to with 
+      | Some v -> fun expr -> restore (e_let_in (Var.of_name  fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0") 
+                                    (e_let_in (Var.of_name (snd v).value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "1") expr))
+      | None -> fun expr -> restore (e_let_in (Var.of_name  fc.var.value, None) false false (e_accessor (e_accessor (e_variable binder) "1") "0") expr) 
+    )
+    | _ -> fun expr -> restore (e_let_in (Var.of_name fc.var.value, None) false false (e_accessor (e_variable binder) "1") expr)
+  in
+  let lambda = e_lambda binder None None (restore for_body) in
   let op_name = match fc.collection with
    | Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in
   let fold = e_constant op_name [lambda; collect ; init_record] in
-  (* STEP 8 *)
+  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 :
   Ast_simplified.declaration Location.wrap list result =

src/passes/3-self_ast_simplified/helpers.ml

@@ -1,13 +1,14 @@
 open Ast_simplified
 open Trace
+open Stage_common.Helpers
 
 type 'a folder = 'a -> expression -> 'a result
 let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
   let self = fold_expression f in 
   let%bind init' = f init e in
-  match e.expression with
+  match e.expression_content with
   | E_literal _ | E_variable _ | E_skip -> ok init'
-  | E_list lst | E_set lst | E_tuple lst | E_constant (_ , lst) -> (
+  | E_list lst | E_set lst | E_constant {arguments=lst} -> (
     let%bind res = bind_fold_list self init' lst in
     ok res
   )
@@ -15,20 +16,24 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
     let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
     ok res
   )
-  | E_look_up ab | E_sequence ab | E_loop ab | E_application ab -> (
+  | E_look_up ab ->
+      let%bind res = bind_fold_pair self init' ab in
+      ok res
+  | E_loop {condition;body} ->
+      let ab = (condition,body) in 
+      let%bind res = bind_fold_pair self init' ab in
+      ok res
+  | E_application {expr1;expr2} -> (
+      let ab = (expr1,expr2) in
       let%bind res = bind_fold_pair self init' ab in
       ok res
     )
   | E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e }
-  | E_ascription (e , _) | E_constructor (_ , e) -> (
+  | E_ascription {anno_expr=e; _} | E_constructor {element=e} -> (
       let%bind res = self init' e in
       ok res
     )
-  | E_assign (_ , _path , e) | E_accessor (e , _path) -> (
+  | 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 = fold_cases f res cases in
       ok res
@@ -41,14 +46,18 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
     let%bind res = bind_fold_lmap aux (ok init') m in
     ok res
   )
-  | E_update {record;update=(_,expr)} -> (
+  | E_record_update {record;update} -> (
     let%bind res = self init' record in
-    let%bind res = fold_expression self res expr in
+    let%bind res = fold_expression self res update in
     ok res 
   )
-  | E_let_in { binder = _ ; rhs ; result } -> (
+  | E_record_accessor {expr} -> (
+     let%bind res = self init' expr in
+     ok res
+    )
+  | E_let_in { let_binder = _ ; rhs ; let_result } -> (
       let%bind res = self init' rhs in
-      let%bind res = self res result in
+      let%bind res = self res let_result in
       ok res
     )
 
@@ -85,8 +94,8 @@ type mapper = expression -> expression result
 let rec map_expression : mapper -> expression -> expression result = fun f e ->
   let self = map_expression f in
   let%bind e' = f e in
-  let return expression = ok { e' with expression } in
+  let return expression_content = ok { e' with expression_content } in
-  match e'.expression with
+  match e'.expression_content with
   | E_list lst -> (
     let%bind lst' = bind_map_list self lst in
     return @@ E_list lst'
@@ -103,68 +112,58 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
     let%bind lst' = bind_map_list (bind_map_pair self) lst in
     return @@ E_big_map lst'
   )
-  | E_sequence ab -> (
-      let%bind ab' = bind_map_pair self ab in
-      return @@ E_sequence ab'
-    )
   | E_look_up ab -> (
       let%bind ab' = bind_map_pair self ab in
       return @@ E_look_up ab'
     )
-  | E_loop ab -> (
+  | 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 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 -> (
     let%bind m' = bind_map_lmap self m in
     return @@ E_record m'
   )
-  | E_update {record; update=(l,expr)} -> (
+  | E_record_update {record; path; update} -> (
     let%bind record = self record in
-    let%bind expr = self expr in
+    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_application {expr1;expr2} -> (
+      let ab = (expr1,expr2) in
+      let%bind (a,b) = bind_map_pair self ab in
+      return @@ E_application {expr1=a;expr2=b}
     )
-  | E_tuple lst -> (
+  | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
-      let%bind lst' = bind_map_list self lst in
-      return @@ E_tuple lst'
-    )
-  | E_application ab -> (
-      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 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 } -> (
       let%bind result = self result in
       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'
 
@@ -209,3 +208,113 @@ and map_program : mapper -> program -> program result = fun m p ->
     | Declaration_type _ -> ok x
   in
   bind_map_list (bind_map_location aux) p
+
+type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
+let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
+  let self = fold_map_expression f in
+  let%bind (continue, init',e') = f a e in
+  if (not continue) then ok(init',e')
+  else
+  let return expression_content = { e' with expression_content } in
+  match e'.expression_content with
+  | E_list lst -> (
+    let%bind (res, lst') = bind_fold_map_list self init' lst in
+    ok (res, return @@ E_list lst')
+  )
+  | E_set lst -> (
+    let%bind (res, lst') = bind_fold_map_list self init' lst in
+    ok (res, return @@ E_set lst')
+  )
+  | E_map lst -> (
+    let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
+    ok (res, return @@ E_map lst')
+  )
+  | E_big_map lst -> (
+    let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
+    ok (res, return @@ E_big_map lst')
+  )
+  | E_look_up ab -> (
+      let%bind (res, ab') = bind_fold_map_pair self init' ab in
+      ok (res, return @@ E_look_up ab')
+    )
+  | E_loop {condition;body} -> (
+      let ab = (condition,body) in
+      let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
+      ok (res, return @@ E_loop {condition = a; body = b})
+    )
+  | E_ascription ascr -> (
+      let%bind (res,e') = self init' ascr.anno_expr in
+      ok (res, return @@ E_ascription {ascr with anno_expr=e'})
+    )
+  | E_matching {matchee=e;cases} -> (
+      let%bind (res, e') = self init' e in
+      let%bind (res,cases') = fold_map_cases f res cases in
+      ok (res, return @@ E_matching {matchee=e';cases=cases'})
+    )
+  | E_record_accessor acc -> (
+      let%bind (res, e') = self init' acc.expr in
+      ok (res, return @@ E_record_accessor {acc with expr = e'})
+    )
+  | E_record m -> (
+    let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
+    let m' = LMap.of_list lst' in
+    ok (res, return @@ E_record m')
+  )
+  | E_record_update {record; path; update} -> (
+    let%bind (res, record) = self init' record in
+    let%bind (res, update) = self res update in
+    ok (res, return @@ E_record_update {record;path;update})
+  )
+  | E_constructor c -> (
+      let%bind (res,e') = self init' c.element in
+      ok (res, return @@ E_constructor {c with element = e'})
+  )
+  | E_application {expr1;expr2} -> (
+      let ab = (expr1,expr2) in
+      let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
+      ok (res, return @@ E_application {expr1=a;expr2=b})
+    )
+  | E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
+      let%bind (res,rhs) = self init' rhs in
+      let%bind (res,let_result) = self res let_result in
+      ok (res, return @@ E_let_in { let_binder ; mut; rhs ; let_result ; inline })
+    )
+  | E_lambda { binder ; input_type ; output_type ; result } -> (
+      let%bind (res,result) = self init' result in
+      ok ( res, return @@ E_lambda { binder ; input_type ; output_type ; result })
+    )
+  | E_constant c -> (
+      let%bind (res,args) = bind_fold_map_list self init' c.arguments in
+      ok (res, return @@ E_constant {c with arguments=args})
+    )
+  | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e')
+
+and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
+  match m with
+  | Match_bool { match_true ; match_false } -> (
+      let%bind (init, match_true) = fold_map_expression f init match_true in
+      let%bind (init, match_false) = fold_map_expression f init match_false in
+      ok @@ (init, Match_bool { match_true ; match_false })
+    )
+  | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
+      let%bind (init, match_nil) = fold_map_expression f init match_nil in
+      let%bind (init, cons) = fold_map_expression f init cons in
+      ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) })
+    )
+  | Match_option { match_none ; match_some = (name , some, _) } -> (
+      let%bind (init, match_none) = fold_map_expression f init match_none in
+      let%bind (init, some) = fold_map_expression f init some in
+      ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) })
+    )
+  | Match_tuple ((names , e), _) -> (
+      let%bind (init, e') = fold_map_expression f init e in
+      ok @@ (init, Match_tuple ((names , e'), []))
+    )
+  | Match_variant (lst, _) -> (
+      let aux init ((a , b) , e) =
+        let%bind (init,e') = fold_map_expression f init e in
+        ok (init, ((a , b) , e'))
+      in
+      let%bind (init,lst') = bind_fold_map_list aux init lst in
+      ok @@ (init, Match_variant (lst', ()))
+    )  

src/passes/3-self_ast_simplified/literals.ml

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

src/passes/3-self_ast_simplified/none_variant.ml

@@ -2,8 +2,8 @@ open Ast_simplified
 open Trace
 
 let peephole_expression : expression -> expression result = fun e ->
-  let return expression = ok { e with expression } in
+  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

src/passes/3-self_ast_simplified/self_ast_simplified.ml

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

src/passes/3-self_ast_simplified/tezos_type_annotation.ml

@@ -13,10 +13,10 @@ end
 open Errors
 
 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_signature)) -> return @@ E_literal (Literal_signature s)
       | (E_literal (Literal_string s) , T_constant (TC_key)) -> return @@ E_literal (Literal_key s)

src/passes/4-typer-new/PP.ml

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

src/passes/4-typer-new/solver.ml

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

src/passes/4-typer-new/typer.ml

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

src/passes/4-typer-new/typer.mli

@@ -42,16 +42,16 @@ val type_program : I.program -> (O.program * Solver.state) result
 val type_program' : I.program -> (O.program) result (* TODO: merge with type_program *)
 val type_declaration : environment -> Solver.state -> I.declaration -> (environment * Solver.state * O.declaration option) result
 (* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
-val evaluate_type : environment -> I.type_expression -> O.type_value result
+val 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_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
 *)

src/passes/4-typer-old/typer.ml

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

src/passes/4-typer-old/typer.mli

@@ -41,14 +41,14 @@ end
 val type_program : I.program -> (O.program * Solver.state) result
 val type_declaration : environment -> Solver.state -> I.declaration -> (environment * Solver.state * O.declaration option) result
 (* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
-val evaluate_type : environment -> I.type_expression -> O.type_value result
+val 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_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
 *)

src/passes/4-typer/typer.mli

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

src/passes/6-interpreter/dune

@@ -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 ))
+)

src/passes/6-interpreter/interpreter.ml

@@ -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

src/passes/6-interpreter/interpreter.mli

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

src/passes/6-transpiler/helpers.ml

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

src/passes/6-transpiler/transpiler.ml

@@ -102,32 +102,27 @@ them. please report this to the developers." in
     ] in
     error ~data title content
 
-  let not_found content =
-    let title () = "Not_found" in
-    let content () = content in
-    let data = [
-    ] in
-    error ~data title content
 end
 open Errors
 
-let rec transpile_type (t:AST.type_value) : type_value result =
+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_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) ->
       let%bind x' = transpile_type x in
       ok (T_contract x')
@@ -160,7 +155,7 @@ let rec transpile_type (t:AST.type_value) : type_value result =
         ok (None, T_or (a, b))
       in
       let%bind m' = Append_tree.fold_ne
-                      (fun (Constructor ann, a) ->
+                      (fun (Stage_common.Types.Constructor ann, a) ->
                         let%bind a = transpile_type a in
                         ok (Some (String.uncapitalize_ascii ann), a))
                       aux node in
@@ -173,49 +168,22 @@ let rec transpile_type (t:AST.type_value) : type_value result =
         ok (None, T_pair (a, b))
       in
       let%bind m' = Append_tree.fold_ne
-                      (fun (Label ann, a) ->
+                      (fun (Stage_common.Types.Label ann, a) ->
                         let%bind a = transpile_type a in
                         ok (Some ann, a))
                       aux node in
       ok @@ snd m'
-  | T_operator (TC_tuple lst) ->
+  | 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 node_tv = Append_tree.of_list tys in
   let%bind path =
-    let aux (Label i , _) = let Label ind = ind in i = ind in
+    let aux (i , _) = i = ind  in
     trace_option (corner_case ~loc:__LOC__ "record access leaf") @@
     Append_tree.exists_path aux node_tv in
   let lr_path = List.map (fun b -> if b then `Right else `Left) path in
@@ -245,16 +213,17 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
   | Literal_chain_id s -> D_string s
   | Literal_operation op -> D_operation op
   | Literal_unit -> D_unit
+  | Literal_void -> D_none
 
 and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele ->
   transpile_type ele.type_value
 
-and tree_of_sum : AST.type_value -> (constructor * AST.type_value) Append_tree.t result = fun t ->
+and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t ->
   let%bind map_tv = get_t_sum t in
   ok @@ Append_tree.of_list @@ kv_list_of_cmap map_tv
 
-and transpile_annotated_expression (ae:AST.annotated_expression) : expression result =
+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 f = transpile_annotated_expression in
   let info =
@@ -262,11 +231,11 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
     let content () = Format.asprintf "%a" Location.pp ae.location in
     info title content in
   trace info @@
-  match ae.expression with
+  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 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_variable name -> (
       let%bind ele =
@@ -275,21 +244,21 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind tv = transpile_environment_element_type ele in
       return ~tv @@ E_variable (name)
     )
-  | E_application (a, b) ->
+  | 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)
-  | 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%bind node_tv =
         trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
-        tree_of_sum ae.type_annotation in
+        tree_of_sum ae.type_expression in
       let leaf (k, tv) : (expression' option * type_value) result =
-        if k = m then (
+        if k = constructor then (
           let%bind _ =
             trace_strong (corner_case ~loc:__LOC__ "wrong type for constructor parameter")
-            @@ AST.assert_type_value_eq (tv, param.type_annotation) in
+            @@ AST.assert_type_expression_eq (tv, element.type_expression) in
           ok (Some (param'_expr), param'_tv)
         ) else (
           let%bind tv = transpile_type tv in
@@ -301,8 +270,8 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         match (a, b) with
         | (None, a), (None, b) -> ok (None, T_or ((None, a), (None, b)))
         | (Some _, _), (Some _, _) -> fail @@ corner_case ~loc:__LOC__ "multiple identical constructors in the same variant"
-        | (Some v, a), (None, b) -> ok (Some (E_constant (C_LEFT, [Combinators.Expression.make_tpl (v, a)])), T_or ((None, a), (None, b)))
+        | (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
       let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
       let%bind ae =
@@ -310,36 +279,6 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
           ae_opt in
       return ~tv ae
     )
-  | E_tuple lst -> (
-      let node = Append_tree.of_list lst in
-      let aux (a:expression result) (b:expression result) : expression result =
-        let%bind a = a in
-        let%bind b = b in
-        let a_ty = Combinators.Expression.get_type a in
-        let b_ty = Combinators.Expression.get_type b in
-        let tv = T_pair ((None, a_ty) , (None, b_ty)) in
-        return ~tv @@ E_constant (C_PAIR, [a; b])
-      in
-      Append_tree.fold_ne (transpile_annotated_expression) aux node
-    )
-  | E_tuple_accessor (tpl, ind) -> (
-      let%bind ty' = transpile_type tpl.type_annotation in
-      let%bind ty_lst =
-        trace_strong (corner_case ~loc:__LOC__ "transpiler: E_tuple_accessor: not a tuple") @@
-        get_t_tuple tpl.type_annotation in
-      let%bind ty'_lst = bind_map_list transpile_type ty_lst in
-      let%bind path =
-        trace_strong (corner_case ~loc:__LOC__ "tuple access") @@
-        tuple_access_to_lr ty' ty'_lst ind in
-      let aux = fun pred (ty, lr) ->
-        let c = match lr with
-          | `Left  -> C_CAR
-          | `Right -> C_CDR in
-        Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
-      let%bind tpl' = transpile_annotated_expression tpl in
-      let expr = List.fold_left aux tpl' path in
-      ok expr
-    )
   | E_record m -> (
       let node = Append_tree.of_list @@ list_of_lmap m in
       let aux a b : expression result =
@@ -348,51 +287,51 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         let a_ty = Combinators.Expression.get_type a in
         let b_ty = Combinators.Expression.get_type b in
         let tv = T_pair ((None, a_ty) , (None, b_ty)) in
-        return ~tv @@ E_constant (C_PAIR, [a; b])
+        return ~tv @@ E_constant {cons_name=C_PAIR;arguments=[a; b]}
       in
       trace_strong (corner_case ~loc:__LOC__ "record build") @@
       Append_tree.fold_ne (transpile_annotated_expression) aux node
     )
-  | E_record_accessor (record, property) ->
+  | 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 =
         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 =
         trace_strong (corner_case ~loc:__LOC__ "record access") @@
-        record_access_to_lr ty' ty'_lmap property in
+        record_access_to_lr ty' ty'_lmap label in
       let aux = fun pred (ty, lr) ->
         let c = match lr with
           | `Left  -> C_CAR
           | `Right -> C_CDR in
-        Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in
+        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
       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 =
         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 = 
         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
-      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 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
           ok ((l.binder , input') , body')
         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_variable v -> (
               let%bind elt =
@@ -400,7 +339,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
                 AST.Environment.get_opt v f.environment in
               match elt.definition with
               | ED_declaration (f , _) -> (
-                  match f.expression with
+                  match f.expression_content with
                   | E_lambda l -> lambda_to_iterator_body f l
                   | _ -> fail @@ unsupported_iterator f.location
                 )
@@ -408,7 +347,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
             )
           | _ -> fail @@ unsupported_iterator f.location
         in
-        fun (lst : AST.annotated_expression list) -> match (lst , iterator_name) with
+        fun (lst : AST.expression list) -> match (lst , iterator_name) with
           | [f ; i] , C_ITER | [f ; i] , C_MAP -> (
               let%bind f' = expression_to_iterator_body f in
               let%bind i' = transpile_annotated_expression i in
@@ -434,11 +373,11 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
       | (C_MAP_FOLD , lst) -> fold lst
       | _ -> (
           let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
-          return @@ E_constant (name , lst')
+          return @@ E_constant {cons_name=name;arguments=lst'}
         )
     )
   | E_lambda l ->
-    let%bind io = AST.get_t_function ae.type_annotation in
+    let%bind io = AST.get_t_function ae.type_expression in
     transpile_lambda l io
   | E_list lst -> (
       let%bind t =
@@ -446,7 +385,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         get_t_list tv in
       let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
       let aux : expression -> expression -> expression result = fun prev cur ->
-        return @@ E_constant (C_CONS, [cur ; prev]) in
+        return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in
       let%bind (init : expression) = return @@ E_make_empty_list t in
       bind_fold_right_list aux init lst'
     )
@@ -456,7 +395,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         get_t_set tv in
       let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
       let aux : expression -> expression -> expression result = fun prev cur ->
-        return @@ E_constant (C_SET_ADD, [cur ; prev]) in
+        return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in
       let%bind (init : expression) = return @@ E_make_empty_set t in
       bind_fold_list aux init lst'
     )
@@ -464,12 +403,12 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind (src, dst) =
         trace_strong (corner_case ~loc:__LOC__ "not a map") @@
         Mini_c.Combinators.get_t_map tv in
-      let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) ->
+      let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) ->
         let%bind prev' = prev in
         let%bind (k', v') =
           let v' = e_a_some v ae.environment in
           bind_map_pair (transpile_annotated_expression) (k , v') in
-        return @@ E_constant (C_UPDATE, [k' ; v' ; prev'])
+        return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']}
       in
       let init = return @@ E_make_empty_map (src, dst) in
       List.fold_left aux init m
@@ -478,63 +417,26 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
       let%bind (src, dst) =
         trace_strong (corner_case ~loc:__LOC__ "not a map") @@
         Mini_c.Combinators.get_t_big_map tv in
-      let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) ->
+      let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) ->
         let%bind prev' = prev in
         let%bind (k', v') =
           let v' = e_a_some v ae.environment in
           bind_map_pair (transpile_annotated_expression) (k , v') in
-        return @@ E_constant (C_UPDATE, [k' ; v' ; prev'])
+        return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']}
       in
       let init = return @@ E_make_empty_big_map (src, dst) in
       List.fold_left aux init m
     )
   | E_look_up dsi -> (
       let%bind (ds', i') = bind_map_pair f dsi in
-      return @@ E_constant (C_MAP_GET, [i' ; ds'])
+      return @@ E_constant {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']}
     )
-  | E_sequence (a , b) -> (
+  | 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
       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
       match m with
       | Match_bool {match_true ; match_false} ->
@@ -607,23 +509,25 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
           in
           trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
           aux expr' tree''
-        )
+       )
       | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location
-    )
+  )
 
 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 output = transpile_type output_type in
   let tv = Combinators.t_function input output in
+  let binder = binder in 
   let closure = E_closure { binder; body = result'} in
   ok @@ Combinators.Expression.make_tpl (closure , tv)
 
 let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
   match d with
-  | Declaration_constant ({name;annotated_expression} , inline , _) ->
+  | 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 env' = Environment.add (name, tv) env in
       ok @@ ((name, inline, expression), environment_wrap env env')
@@ -658,9 +562,9 @@ let check_storage f ty loc : (anon_function * _) result =
       if aux (snd storage) false then ok (f, ty) else fail @@ bad_big_map loc
     | _ -> ok (f, ty)
 
-let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =
+let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_expression) result =
   let open Append_tree in
-  let rec aux tv : (string * value * AST.type_value) result=
+  let rec aux tv : (string * value * AST.type_expression) result=
     match tv with
     | Leaf (k, t), v -> ok (k, v, t)
     | Node {a}, D_left v -> aux (a, v)
@@ -670,9 +574,9 @@ let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value
   let%bind (s, v, t) = aux (tree, v) in
   ok (s, v, t)
 
-let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result =
+let extract_tuple (v : value) (tree : AST.type_expression Append_tree.t') : ((value * AST.type_expression) list) result =
   let open Append_tree in
-  let rec aux tv : ((value * AST.type_value) list) result =
+  let rec aux tv : ((value * AST.type_expression) list) result =
     match tv with
     | Leaf t, v -> ok @@ [v, t]
     | Node {a;b}, D_pair (va, vb) ->
@@ -685,7 +589,7 @@ let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value *
 
 let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result =
   let open Append_tree in
-  let rec aux tv : ((string * (value * AST.type_value)) list) result =
+  let rec aux tv : ((string * (value * AST.type_expression)) list) result =
     match tv with
     | Leaf (s, t), v -> ok @@ [s, (v, t)]
     | Node {a;b}, D_pair (va, vb) ->

src/passes/6-transpiler/transpiler.mli

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

src/passes/6-transpiler/untranspiler.ml

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

src/passes/7-self_mini_c/helpers.ml

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

src/passes/7-self_mini_c/michelson_restrictions.ml

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

src/passes/7-self_mini_c/self_mini_c.ml

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

src/passes/7-self_mini_c/subst.ml

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

src/passes/8-compiler/compiler_environment.ml

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

src/passes/8-compiler/compiler_program.ml

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

src/passes/8-compiler/compiler_program.mli

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

src/passes/8-compiler/compiler_type.ml

@@ -15,7 +15,7 @@ module Ty = struct
   let tez_k = Mutez_key None
   let int_k = Int_key None
   let string_k = String_key None
-  let key_hash_k = Key_hash_key None
+  let _key_hash_k = Key_hash_key None
   let address_k = Address_key None
   let timestamp_k = Timestamp_key None
   let bytes_k = Bytes_key None
@@ -57,24 +57,24 @@ module Ty = struct
   let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
   let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) ()
 
-  let comparable_type_base : type_base -> ex_comparable_ty result = fun tb ->
+  let comparable_type_base : type_constant -> ex_comparable_ty result = fun tb ->
     let return x = ok @@ Ex_comparable_ty x in
     match tb with
-    | Base_unit -> fail (not_comparable "unit")
+    | 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 ->
     match tv with
@@ -89,24 +89,24 @@ module Ty = struct
     | T_option _ -> fail (not_comparable "option")
     | T_contract _ -> fail (not_comparable "contract")
 
-  let base_type : type_base -> ex_ty result = fun b ->
+  let base_type : type_constant -> ex_ty result = fun b ->
     let return x = ok @@ Ex_ty x in
    match b with
-    | Base_unit -> return unit
+    | 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 =
     function
@@ -175,23 +175,23 @@ module Ty = struct
 end
 
 
-let base_type : type_base -> O.michelson result =
+let base_type : type_constant -> O.michelson result =
   function
-  | Base_unit -> ok @@ O.prim T_unit
+  | 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 =
   function

src/passes/operators/helpers.ml

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

src/passes/operators/helpers.mli

@@ -4,51 +4,51 @@ module Typer : sig
 
   module Errors : sig
     val wrong_param_number : string -> int -> 'a list -> unit -> error
-    val error_uncomparable_types : type_value -> type_value -> unit -> error
+    val error_uncomparable_types : type_expression -> type_expression -> unit -> error
   end
 
-  type type_result = type_value
+  type 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 boolean_operator_2 : string -> typer

src/passes/operators/operators.ml

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

src/passes/operators/operators.mli

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

src/stages/ast_simplified/PP.ml

@@ -1,110 +1,93 @@
 [@@@coverage exclude_file]
 open Types
-open PP_helpers
 open Format
+open PP_helpers
+
 include Stage_common.PP
+include Ast_PP_type(Ast_simplified_parameter)
 
-let list_sep_d x ppf lst = match lst with
+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
-  | 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) ->
-  fprintf ppf "| %a %a -> %a" constructor c name n f a
+  fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
 
-and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching -> unit =
+and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
   fun f ppf m -> match m with
     | Match_tuple ((lst, b), _) ->
-        fprintf ppf "let (%a) = %a" (list_sep_d name) lst f b
+        fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
     | Match_variant (lst, _) ->
         fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
     | Match_bool {match_true ; match_false} ->
         fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
     | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
-        fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil name hd name tl f match_cons
+        fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
     | Match_option {match_none ; match_some = (some, match_some, _)} ->
-        fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none name some f match_some
+        fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
 
 (* Shows the type expected for the matched value *)
 and matching_type ppf m = match m with
@@ -120,13 +103,30 @@ and matching_type ppf m = match m with
       fprintf ppf "option"
 
 and matching_variant_case_type ppf ((c,n),_a) =
-  fprintf ppf "| %a %a" constructor c name n
+  fprintf ppf "| %a %a" constructor c expression_variable n
 
-let declaration ppf (d:declaration) = match d with
+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)

src/stages/ast_simplified/PP.mli

@@ -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

src/stages/ast_simplified/ast_simplified.ml

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

src/stages/ast_simplified/combinators.ml

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

src/stages/ast_simplified/combinators.mli

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

src/stages/ast_simplified/misc.ml

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

src/stages/ast_simplified/misc.mli

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

src/stages/ast_simplified/types.ml

@@ -1,14 +1,19 @@
 [@@@warning "-30"]
+
 module Location = Simple_utils.Location
+
+module Ast_simplified_parameter = struct
+  type type_meta = unit
+end
+
 include Stage_common.Types
 
+(*include Ast_generic_type(Ast_simplified_parameter)
+*)
+include Ast_generic_type (Ast_simplified_parameter)
+
+type inline = bool 
 type program = declaration Location.wrap list
-
-and inline = bool
-
-and type_expression =  {
-  type_expression' : type_expression type_expression'
-  }
 and declaration =
   | Declaration_type of (type_variable * type_expression)
 
@@ -19,59 +24,91 @@ and declaration =
    *   an expression *)
   | Declaration_constant of (expression_variable * type_expression option * inline * expression)
 
-and expr = expression
+(* | Macro_declaration of macro_declaration *)
+and expression = {expression_content: expression_content; location: Location.t}
 
-and lambda = {
+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 *)
   | E_literal of literal
-  | E_constant of (constant * expr list) (* For language constants, like (Cons hd tl) or (plus i j) *)
+  | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
   | E_variable of expression_variable
+  | E_application of application
   | E_lambda of lambda
-  | E_application of (expr * expr)
   | E_let_in of let_in
-  (* E_Tuple *)
-  | E_tuple of expr list
-  (* Sum *)
-  | E_constructor of (constructor * expr) (* For user defined constructors *)
-  (* E_record *)
-  | E_record of expr label_map
-  (* TODO: Change it to (expr * access) *)
-  | E_accessor of (expr * access_path)
-  | E_update of update
-  (* Data Structures *)
-  | E_map of (expr * expr) list
-  | E_big_map of (expr * expr) list
-  | E_list of expr list
-  | E_set of expr list
-  | E_look_up of (expr * expr)
-  (* Matching *)
-  | E_matching of (expr * matching_expr)
-  (* Replace Statements *)
-  | E_sequence of (expr * expr)
-  | E_loop of (expr * expr)
-  | E_assign of (expression_variable * access_path * expr)
   | E_skip
-  (* Annotate *)
+  (* 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

src/stages/ast_typed/PP.ml

@@ -2,26 +2,60 @@
 open Types
 open Format
 open PP_helpers
+
 include Stage_common.PP
+include Ast_PP_type(Ast_typed_type_parameter)
 
-let list_sep_d x = list_sep x (const " , ")
+let expression_variable ppf (ev : expression_variable) : unit =
+  fprintf ppf "%a" Var.pp ev
 
 
-let rec type_value' ppf (tv':type_value type_expression') : unit =
+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 = 
   if inline then 
@@ -29,68 +63,28 @@ and option_inline ppf inline =
   else
     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) ->
-  fprintf ppf "| %a %a -> %a" constructor c name n f a
+  fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
 
-and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching -> unit = fun f ppf m -> match m with
+and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching_content -> unit = fun f ppf m -> match m with
   | Match_tuple ((lst, b),_) ->
-      fprintf ppf "let (%a) = %a" (list_sep_d Stage_common.PP.name) lst f b
+      fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
   | Match_variant (lst, _) ->
       fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
   | Match_bool {match_true ; match_false} ->
       fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
   | Match_list {match_nil ; match_cons = (hd_name, tl_name, match_cons, _)} ->
-      fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil Stage_common.PP.name hd_name Stage_common.PP.name tl_name f match_cons
+      fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd_name expression_variable tl_name f match_cons
   | Match_option {match_none ; match_some = (some, match_some, _)} ->
-      fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none name some f match_some
+      fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
 
-and pre_access ppf (a:access) = match a with
+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
-  | 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)

src/stages/ast_typed/PP.mli

@@ -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
-*)

src/stages/ast_typed/combinators.ml

@@ -13,7 +13,7 @@ module Errors = struct
     let message () =
       Format.asprintf "Expected the type %s but got the type %a"
         expected_type
-        PP.type_value actual_type in
+        PP.type_expression actual_type in
     error (thunk "Expected a different type") message
 
   let declaration_not_found expected_declaration () =
@@ -23,177 +23,182 @@ module Errors = struct
     error (thunk "No declaration with the given name") message
 end
 
-let make_t type_value' simplified = { type_value' ; simplified }
+let make_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 ;
   location ;
 }
-let make_n_e name a_e = { name ; annotated_expression = a_e }
 let make_n_t type_name type_value = { type_name ; type_value }
 
-let t_signature ?s ()  : type_value = make_t (T_constant TC_signature) s
+let t_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
-let ez_t_record lst ?s () : type_value =
+let ez_t_record lst ?s () : type_expression =
   let m = LMap.of_list lst in
   t_record m ?s ()
+let t_pair a b ?s ()   : type_expression = ez_t_record [(Label "0",a) ; (Label "1",b)] ?s ()
 
 let t_map key value ?s () = make_t (T_operator (TC_map (key , value))) s
 let t_big_map key value ?s () = make_t (T_operator (TC_big_map (key , value))) s
 
-let t_sum m ?s () : type_value = make_t (T_sum m) s
+let 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 map = List.fold_left aux CMap.empty lst in
   make_t (T_sum map) None
 
-let t_function param result ?s () : type_value = make_t (T_arrow (param, result)) s
+let t_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
   | _ -> fail @@ Errors.not_a_x_expression "lambda" 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 ()
   | _ -> fail @@ Errors.not_a_x_type "bool" t ()
 
-let get_t_int (t:type_value) : unit result = match t.type_value' with
+let get_t_int (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_int) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "int" t ()
 
-let get_t_nat (t:type_value) : unit result = match t.type_value' with
+let get_t_nat (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_nat) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "nat" t ()
 
-let get_t_unit (t:type_value) : unit result = match t.type_value' with
+let get_t_unit (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_unit) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "unit" t ()
 
-let get_t_mutez (t:type_value) : unit result = match t.type_value' with
+let get_t_mutez (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_mutez) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "tez" t ()
 
-let get_t_bytes (t:type_value) : unit result = match t.type_value' with
+let get_t_bytes (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_bytes) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "bytes" t ()
 
-let get_t_string (t:type_value) : unit result = match t.type_value' with
+let get_t_string (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_string) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "string" t ()
 
-let get_t_contract (t:type_value) : type_value result = match t.type_value' with
+let get_t_contract (t:type_expression) : type_expression result = match t.type_content with
   | T_operator (TC_contract x) -> ok x
   | _ -> fail @@ Errors.not_a_x_type "contract" t ()
 
-let get_t_option (t:type_value) : type_value result = match t.type_value' with
+let get_t_option (t:type_expression) : type_expression result = match t.type_content with
   | T_operator (TC_option o) -> ok o
   | _ -> fail @@ Errors.not_a_x_type "option" t ()
 
-let get_t_list (t:type_value) : type_value result = match t.type_value' with
+let get_t_list (t:type_expression) : type_expression result = match t.type_content with
   | T_operator (TC_list l) -> ok l
   | _ -> fail @@ Errors.not_a_x_type "list" t ()
 
-let get_t_set (t:type_value) : type_value result = match t.type_value' with
+let get_t_set (t:type_expression) : type_expression result = match t.type_content with
   | T_operator (TC_set s) -> ok s
   | _ -> fail @@ Errors.not_a_x_type "set" t ()
 
-let get_t_key (t:type_value) : unit result = match t.type_value' with
+let get_t_key (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_key) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "key" t ()
 
-let get_t_signature (t:type_value) : unit result = match t.type_value' with
+let get_t_signature (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_signature) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "signature" t ()
 
-let get_t_key_hash (t:type_value) : unit result = match t.type_value' with
+let get_t_key_hash (t:type_expression) : unit result = match t.type_content with
   | T_constant (TC_key_hash) -> ok ()
   | _ -> fail @@ Errors.not_a_x_type "key_hash" t ()
 
-let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with
+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 ()
 
-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 () =
         trace_strong (Errors.not_a_x_type "pair (tuple with two elements)" t ()) @@
         Assert.assert_list_size lst 2 in
       ok List.(nth lst 0 , nth lst 1)
   | _ -> fail @@ Errors.not_a_x_type "pair (tuple with two elements)" t ()
 
-let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with
+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
   | _ -> fail @@ Errors.not_a_x_type "sum" t ()
 
-let get_t_record (t:type_value) : type_value label_map result = match t.type_value' with
+let get_t_record (t:type_expression) : type_expression label_map result = match t.type_content with
   | T_record m -> ok m
   | _ -> fail @@ Errors.not_a_x_type "record" t ()
 
-let get_t_map (t:type_value) : (type_value * type_value) result =
+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)
   | _ -> 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)
   | _ -> fail @@ Errors.not_a_x_type "big_map" t ()
 
-let get_t_map_key : type_value -> type_value result = fun t ->
+let get_t_map_key : type_expression -> type_expression result = fun t ->
   let%bind (key , _) = get_t_map t in
   ok key
 
-let get_t_map_value : type_value -> type_value result = fun t ->
+let get_t_map_value : type_expression -> type_expression result = fun t ->
   let%bind (_ , value) = get_t_map t in
   ok value
 
-let get_t_big_map_key : type_value -> type_value result = fun t ->
+let get_t_big_map_key : type_expression -> type_expression result = fun t ->
   let%bind (key , _) = get_t_big_map t in
   ok key
 
-let get_t_big_map_value : type_value -> type_value result = fun t ->
+let get_t_big_map_value : type_expression -> type_expression result = fun t ->
   let%bind (_ , value) = get_t_big_map t in
   ok value
 
@@ -204,12 +209,12 @@ let assert_t_map = fun t ->
 let is_t_map = Function.compose to_bool get_t_map
 let is_t_big_map = Function.compose to_bool get_t_big_map
 
-let assert_t_mutez : type_value -> unit result = get_t_mutez
+let assert_t_mutez : type_expression -> unit result = get_t_mutez
 let assert_t_key = get_t_key
 let assert_t_signature = get_t_signature
 let assert_t_key_hash = get_t_key_hash
 
-let assert_t_contract (t:type_value) : unit result = match t.type_value' with
+let assert_t_contract (t:type_expression) : unit result = match t.type_content with
   | T_operator (TC_contract _) -> ok ()
   | _ -> simple_fail "not a contract"
 
@@ -228,57 +233,56 @@ let assert_t_bytes = fun t ->
   let%bind _ = get_t_bytes t in
   ok ()
 
-let assert_t_operation (t:type_value) : unit result =
+let assert_t_operation (t:type_expression) : unit result =
-  match t.type_value' with
+  match t.type_content with
   | T_constant (TC_operation) -> ok ()
   | _ -> simple_fail "assert: not an operation"
 
-let assert_t_list_operation (t : type_value) : unit result =
+let assert_t_list_operation (t : type_expression) : unit result =
   let%bind t' = get_t_list t in
   assert_t_operation t'
 
-let assert_t_int : type_value -> unit result = fun t -> match t.type_value' with
+let assert_t_int : type_expression -> unit result = fun t -> match t.type_content with
   | T_constant (TC_int) -> ok ()
   | _ -> simple_fail "not an int"
 
-let assert_t_nat : type_value -> unit result = fun t -> match t.type_value' with
+let assert_t_nat : type_expression -> unit result = fun t -> match t.type_content with
   | T_constant (TC_nat) -> ok ()
   | _ -> simple_fail "not an nat"
 
-let assert_t_bool : type_value -> unit result = fun v -> get_t_bool v
+let assert_t_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 map = List.fold_left aux LMap.empty lst in
   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_int n = make_a_e (e_int n) (t_int ())
@@ -287,44 +291,44 @@ let e_a_mutez n = make_a_e (e_mutez n) (t_mutez ())
 let e_a_bool b = make_a_e (e_bool b) (t_bool ())
 let e_a_string s = make_a_e (e_string s) (t_string ())
 let e_a_address s = make_a_e (e_address s) (t_address ())
-let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_annotation b.type_annotation ())
+let e_a_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_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 ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_annotation) r) ())
+let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_expression) r) ())
 let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ())
 let e_a_list lst t = make_a_e (e_list lst) (t_list t ())
-let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_annotation body)
+let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_expression body)
 
-let get_a_int (t:annotated_expression) =
+
-  match t.expression with
+let get_a_int (t:expression) =
+  match t.expression_content with
   | E_literal (Literal_int n) -> ok n
   | _ -> simple_fail "not an int"
 
-let get_a_unit (t:annotated_expression) =
+let get_a_unit (t:expression) =
-  match t.expression with
+  match t.expression_content with
   | E_literal (Literal_unit) -> ok ()
   | _ -> 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
   | _ -> simple_fail "not a bool"
 
 
 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"
 
 let get_declaration_by_name : program -> string -> declaration result = fun p name ->
   let aux : declaration -> bool = fun declaration ->
     match declaration with
-    | Declaration_constant (d , _, _) -> d.name = Var.of_name name
+    | Declaration_constant (d, _, _, _) -> d = Var.of_name name
   in
   trace_option (Errors.declaration_not_found name ()) @@
   List.find_opt aux @@ List.map Location.unwrap p

src/stages/ast_typed/combinators.mli

@@ -1,162 +1,155 @@
 open Trace
 open Types
-open Stage_common.Types
 
-val make_n_e : expression_variable -> annotated_expression -> named_expression
+val make_n_t : 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_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 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

src/stages/ast_typed/combinators_environment.ml

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

src/stages/ast_typed/combinators_environment.mli

@@ -1,22 +1,21 @@
 open Types
 
-val make_a_e_empty : expression -> type_value -> annotated_expression
+val make_a_e_empty : expression_content -> type_expression -> expression
 
-val e_a_empty_unit : annotated_expression
+val e_a_empty_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

src/stages/ast_typed/environment.ml

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

src/stages/ast_typed/environment.mli

@@ -8,13 +8,13 @@ val get_trace : expression_variable -> t -> element result
 val empty : environment
 val full_empty : t
 val add : expression_variable -> element -> t -> t
-val add_ez_binder : expression_variable -> type_value -> t -> t
+val add_ez_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_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
   type t = small_environment
@@ -28,16 +28,16 @@ module Small : sig
   val map_type_environment : ( type_environment -> type_environment ) -> t -> t
 
   val add : string -> element -> t -> t
-  val add_type : string -> type_value -> t -> t
+  val add_type : string -> type_expression -> t -> t
   val get_opt : string -> t -> element option
-  val get_type_opt : string -> t -> type_value option
+  val get_type_opt : string -> t -> type_expression option
   *)
 end
 (*
 
-val make_element : type_value -> full_environment -> environment_element_definition -> element
+val make_element : 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 type_environment_element : formatter -> ( string * type_value ) -> unit
+  val type_environment_element : formatter -> ( string * type_expression ) -> unit
 
   val environment : formatter -> environment -> unit
 

src/stages/ast_typed/misc.ml

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

src/stages/ast_typed/misc.mli

@@ -1,16 +1,14 @@
 open Trace
 open Types
 
-include module type of Stage_common.Misc
+val assert_value_eq : ( expression * expression ) -> unit result
 
-val assert_value_eq : ( value * value ) -> unit result
+val assert_type_expression_eq : ( type_expression * type_expression ) -> unit result
 
-val assert_type_value_eq : ( type_value * type_value ) -> unit result
+val merge_annotation : type_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 *)
-val type_value_eq : ( type_value * type_value ) -> bool
+val type_expression_eq : ( type_expression * type_expression ) -> bool
 
 module Free_variables : sig
   type bindings = expression_variable list
@@ -18,7 +16,7 @@ module Free_variables : sig
   val matching_expression : bindings -> matching_expr -> bindings
   val lambda : bindings -> lambda -> bindings
 
-  val annotated_expression : bindings -> annotated_expression -> bindings 
+  val expression : bindings -> expression -> bindings 
 
   val empty : bindings 
   val singleton : expression_variable -> bindings 
@@ -40,14 +38,16 @@ end
 
 module Errors : sig
   (*
-  val different_kinds : type_value -> type_value -> unit -> error
+  val different_kinds : type_expression -> type_expression -> unit -> error
   val different_constants : string -> string -> unit -> error
-  val different_size_type : name -> type_value -> type_value -> unit -> error
+  val different_size_type : name -> type_expression -> type_expression -> unit -> error
   val different_props_in_record : string -> string -> unit -> error
-  val different_size_constants : type_value -> type_value -> unit -> error
+  val different_size_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_values : name -> value -> value -> unit -> error
   val different_literals_because_different_types : name -> literal -> literal -> unit -> error
@@ -67,5 +67,5 @@ end
 val assert_literal_eq : ( literal * literal ) -> unit result
 *)
 
-val get_entry : program -> string -> annotated_expression result
+val get_entry : program -> string -> expression result
 val program_environment : program -> full_environment

src/stages/ast_typed/misc_smart.ml

@@ -8,31 +8,31 @@ let program_to_main : program -> string -> lambda result = fun p s ->
   let%bind (main , input_type , _) =
     let pred = fun d ->
       match d with
-      | Declaration_constant (d , _, _) when d.name = Var.of_name s -> Some d.annotated_expression
+      | Declaration_constant (d , expr, _, _) when d = Var.of_name s -> Some expr
       | Declaration_constant _ -> None
     in
     let%bind main =
       trace_option (simple_error "no main with given name") @@
       List.find_map (Function.compose pred Location.unwrap) p in
     let%bind (input_ty , output_ty) =
-      match (get_type' @@ get_type_annotation main) with
+      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
     ok (main , input_ty , output_ty)
   in
   let env =
     let aux = fun _ d ->
       match d with
-      | Declaration_constant (_ , _, (_ , post_env)) -> post_env in
+      | Declaration_constant (_ , _, _, post_env) -> post_env in
     List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
   let binder = Var.of_name "@contract_input" in
-  let body =
+  let result =
     let input_expr = e_a_variable binder input_type env in
-    let main_expr = e_a_variable (Var.of_name s) (get_type_annotation main) env in
+    let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) env in
     e_a_application main_expr input_expr env in
   ok {
     binder ;
-    body ;
+    result ;
   }
 
 module Captured_variables = struct
@@ -45,13 +45,13 @@ module Captured_variables = struct
   let empty : bindings = []
   let of_list : expression_variable list -> bindings = fun x -> x
 
-  let rec annotated_expression : bindings -> annotated_expression -> bindings result = fun b ae ->
+  let 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_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'
     | E_variable name -> (
         let%bind env_element =
@@ -61,22 +61,18 @@ module Captured_variables = struct
         | ED_binder -> ok empty
         | ED_declaration (_ , _) -> simple_fail "todo"
       )
-    | E_application (a, b) ->
+    | 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'
-    | 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 ->
       let%bind lst' = bind_map_list self @@ LMap.to_list m in
       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
-    | E_tuple_accessor (a, _) -> self a
     | E_list lst ->
       let%bind lst' = bind_map_list self lst in
       ok @@ unions lst'
@@ -89,23 +85,21 @@ module Captured_variables = struct
     | E_look_up (a , b) ->
       let%bind lst' = bind_map_list self [ a ; b ] in
       ok @@ unions lst'
-    | E_matching (a , cs) ->
+    | 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'
-    | 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'
-    | E_assign (_ , _ , expr) -> self expr
     | 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
 
-  and matching : type a . (bindings -> a -> bindings result) -> bindings -> (a, 'tv) matching -> bindings result = fun f b m ->
+  and matching : type a . (bindings -> a -> bindings result) -> bindings -> (a, 'tv) matching_content -> bindings result = fun f b m ->
     match m with
     | Match_bool { match_true = t ; match_false = fa } ->
       let%bind t' = f b t in
@@ -125,6 +119,6 @@ module Captured_variables = struct
       let%bind lst' = bind_map_list (matching_variant_case f b) lst in
       ok @@ unions lst'
 
-  and matching_expression = fun x -> matching annotated_expression x
+  and matching_expression = fun x -> matching expression x
 
 end

src/stages/ast_typed/misc_smart.mli

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

src/stages/ast_typed/types.ml

@@ -3,6 +3,12 @@
 module S = Ast_simplified
 include Stage_common.Types
 
+module Ast_typed_type_parameter = struct
+  type type_meta = S.type_expression option
+end
+
+include Ast_generic_type (Ast_typed_type_parameter)
+
 type program = declaration Location.wrap list
 
 and inline = bool
@@ -13,105 +19,108 @@ and declaration =
    *   a boolean indicating whether it should be inlined
    *   the environment before the declaration (the original environment)
    *   the environment after the declaration (i.e. with that new declaration added to the original environment). *)
-  | Declaration_constant of (named_expression * inline * (full_environment * full_environment))
+  | Declaration_constant of (expression_variable * expression * inline * full_environment)
+  (*
+  | Declaration_type of (type_variable * type_expression)
+  | Declaration_constant of (named_expression * (full_environment * full_environment))
+  *)
+(* | Macro_declaration of macro_declaration *)
+
+and expression =
+  { expression_content: expression_content
+  ; location: Location.t
+  ; type_expression: type_expression
+  ; environment: full_environment }
+
+and expression_content =
+  (* Base *)
+  | E_literal of literal
+  | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
+  | E_variable of expression_variable
+  | E_application of application
+  | E_lambda of lambda
+  | E_let_in of let_in
+  (* Variant *)
+  | E_constructor of constructor (* For user defined constructors *)
+  | E_matching of matching
+  (* Record *)
+  | E_record of expression label_map
+  | E_record_accessor of accessor
+  | E_record_update of update
+  (* Data Structures *)
+  (* TODO : move to constant*)
+  | E_map of (expression * expression) list (*move to operator *)
+  | E_big_map of (expression * expression) list (*move to operator *)
+  | E_list of expression list
+  | E_set of expression list
+  | E_look_up of (expression * expression)
+  (* Advanced *)
+  | E_loop of loop
+  (*
+  | E_ascription of ascription
+  *)
+
+and constant =
+  { cons_name: constant' (* this is at the end because it is huge *)
+  ; arguments: expression list }
+
+
+and application = {expr1: expression; expr2: expression}
+
+and lambda =
+  { binder: expression_variable 
+ (* ; input_type: type_expression option
+  ; output_type: type_expression option *)
+  ; result: expression }
+
+and let_in =
+  { let_binder: expression_variable
+  ; rhs: expression
+  ; let_result: expression
+  ; inline : inline }
+
+and constructor = {constructor: constructor'; element: expression}
+
+and accessor = {expr: expression; label: label}
+
+and update = {record: expression; path: label ; update: expression}
+
+and loop = {condition: expression; body: expression}
+
+and matching_expr = (expression,type_expression) matching_content
+and matching =
+  { matchee: expression
+  ; cases: matching_expr
+  }
+
+and ascription = {anno_expr: expression; type_annotation: type_expression}
+
 
 and environment_element_definition =
   | ED_binder
-  | ED_declaration of (annotated_expression * free_variables)
+  | ED_declaration of (expression * free_variables)
 
 and free_variables = expression_variable list
 
-and environment_element = {
+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 type_environment = (type_variable * type_value) list (* SUBST ??? *)
+
-and small_environment = (environment * type_environment)
+and type_environment = (type_variable * type_expression) list
+
+(* SUBST ??? *)
+and small_environment = environment * type_environment
+
 and full_environment = small_environment List.Ne.t
 
-and annotated_expression = {
+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

src/stages/common/PP.ml

@@ -2,19 +2,45 @@ open Types
 open Format
 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 label ppf (l:label) : unit =
   let Label l = l in fprintf ppf "%s" l
 
-let constant ppf : constant -> unit = function
+let cmap_sep value sep ppf m =
+  let lst = CMap.to_kv_list m in
+  let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
+  let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in
+  fprintf ppf "%a" (list_sep new_pp sep) lst
+
+let record_sep value sep ppf (m : 'a label_map) =
+  let lst = LMap.to_kv_list m in
+  let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
+  let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in
+  fprintf ppf "%a" (list_sep new_pp sep) lst
+
+let tuple_sep value sep ppf m =
+  assert (Helpers.is_tuple_lmap m);
+  let lst = LMap.to_kv_list m in
+  let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
+  let new_pp ppf (_k, v) = fprintf ppf "%a" value v in
+  fprintf ppf "%a" (list_sep new_pp sep) lst
+
+(* Prints records which only contain the consecutive fields
+   0..(cardinal-1) as tuples *)
+let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m =
+  if Helpers.is_tuple_lmap m then
+    fprintf ppf format_tuple (tuple_sep value (const sep_tuple)) m
+  else
+    fprintf ppf format_record (record_sep value (const sep_record)) m
+
+let list_sep_d x = list_sep x (const " , ")
+let cmap_sep_d x = cmap_sep x (const " , ")
+let tuple_or_record_sep_expr value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " , "
+let tuple_or_record_sep_type value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " * "
+
+let constant ppf : constant' -> unit = function
   | C_INT                   -> fprintf ppf "INT"
   | C_UNIT                  -> fprintf ppf "UNIT"
   | C_NIL                   -> fprintf ppf "NIL"
@@ -45,6 +71,8 @@ let constant ppf : constant -> unit = function
   | C_AND                   -> fprintf ppf "AND"
   | C_OR                    -> fprintf ppf "OR"
   | C_XOR                   -> fprintf ppf "XOR"
+  | C_LSL                   -> fprintf ppf "LSL"
+  | C_LSR                   -> fprintf ppf "LSR"
   (* COMPARATOR *)
   | C_EQ                    -> fprintf ppf "EQ"
   | C_NEQ                   -> fprintf ppf "NEQ"
@@ -121,85 +149,119 @@ let constant ppf : constant -> unit = function
   | C_SET_DELEGATE          -> fprintf ppf "SET_DELEGATE"
   | C_STEPS_TO_QUOTA        -> fprintf ppf "STEPS_TO_QUOTA"
 
-let cmap_sep value sep ppf m =
+let 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 =
+   fun f ppf te ->
+    match te.type_content with
+    | T_sum m ->
+        fprintf ppf "sum[%a]" (cmap_sep_d f) m
+    | T_record m ->
+        fprintf ppf "%a" (tuple_or_record_sep_type f) m
+    | T_arrow a ->
+        fprintf ppf "%a -> %a" f a.type1 f a.type2
+    | T_variable tv ->
+        type_variable ppf tv
+    | T_constant tc ->
+        type_constant ppf tc
+    | T_operator to_ ->
+        type_operator f ppf to_
 
-let list_sep_d x = list_sep x (const " , ")
+  and type_expression ppf (te : type_expression) : unit =
-let cmap_sep_d x = cmap_sep x (const " , ")
+    type_expression' type_expression ppf te
-let lmap_sep_d x = lmap_sep x (const " , ")
 
-let rec type_expression' : type a . (formatter -> a -> unit) -> formatter -> a type_expression' -> unit =
+  and type_constant ppf (tc : type_constant) : unit =
-  fun f ppf te ->
+    let s =
-  match te with
+      match tc with
-    | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
+      | TC_unit ->
-    | T_record m -> fprintf ppf "record[%a]" (lmap_sep_d f ) m
+          "unit"
-    | T_arrow (a, b) -> fprintf ppf "%a -> %a" f a f b
+      | TC_string ->
-    | T_variable tv -> type_variable ppf tv
+          "string"
-    | T_constant tc -> type_constant ppf tc
+      | TC_bytes ->
-    | T_operator to_ -> type_operator f ppf to_
+          "bytes"
-
+      | TC_nat ->
-and type_constant ppf (tc:type_constant) : unit =
+          "nat"
-  let s = match tc with
+      | TC_int ->
-    | TC_unit      -> "unit"
+          "int"
-    | TC_string    -> "string"
+      | TC_mutez ->
-    | TC_bytes     -> "bytes"
+          "mutez"
-    | TC_nat       -> "nat"
+      | TC_bool ->
-    | TC_int       -> "int"
+          "bool"
-    | TC_mutez     -> "mutez"
+      | TC_operation ->
-    | TC_bool      -> "bool"
+          "operation"
-    | TC_operation -> "operation"
+      | TC_address ->
-    | TC_address   -> "address"
+          "address"
-    | TC_key       -> "key"
+      | TC_key ->
-    | TC_key_hash  -> "key_hash"
+          "key"
-    | TC_signature -> "signature"
+      | TC_key_hash ->
-    | TC_timestamp -> "timestamp"
+          "key_hash"
-    | TC_chain_id  -> "chain_id"
+      | TC_signature ->
+          "signatuer"
+      | TC_timestamp ->
+          "timestamp"
+      | TC_chain_id ->
+          "chain_id"
+      | TC_void ->
+          "void"
     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)
-  fun f ppf to_ ->
+      -> formatter
-  let s = match to_ with
+      -> type_operator
-    | TC_option (tv) -> Format.asprintf "option(%a)" f tv
+      -> unit =
-    | TC_list   (tv) -> Format.asprintf "list(%a)" f tv
+   fun f ppf to_ ->
-    | TC_set    (tv) -> Format.asprintf "set(%a)" f tv
+    let s =
-    | TC_map    (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
+      match to_ with
-    | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
+      | TC_option te -> Format.asprintf "option(%a)" f te
-    | TC_contract (c) -> Format.asprintf "Contract (%a)" f c
+      | TC_list te -> Format.asprintf "list(%a)" f te
-    | TC_arrow (a , b) -> Format.asprintf "TC_Arrow (%a,%a)" f a f b
+      | TC_set te -> Format.asprintf "set(%a)" f te
-    | TC_tuple lst -> Format.asprintf "tuple[%a]" (list_sep_d f) lst
+      | 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_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
+      | TC_contract te  -> Format.asprintf "Contract (%a)" f te
     in
-  fprintf ppf "(TO_%s)" s
+    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 |}]

src/stages/common/PP.mli

@@ -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

src/stages/common/ast_common.ml

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