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

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

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-04-07 18:57:10 +02:00
commit a343989a6b
105 changed files with 4220 additions and 3267 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
gitlab-pages/docker-compose.yml
View File

@ -16,6 +16,7 @@ services:
# - ./website/versioned_sidebars:/app/website/versioned_sidebars
# - ./website/versioned_docs:/app/website/versioned_docs
- ./website/sidebars.json:/app/website/sidebars.json
- ./website/sitemap.xml:/app/website/sitemap.xml
- ./website/docusaurus.config.js:/app/website/docusaurus.config.js
# - ./website/versions.json:/app/website/versions.json
# - ./website/core/AlgoliaSearch.js:/app/website/core/AlgoliaSearch.js

12
gitlab-pages/docs/advanced/entrypoints-contracts.md
View File

@ -234,7 +234,7 @@ function deny (const action : parameter; const store : storage) : return is
else ((nil : list (operation)), store)
```
> Note that `amount` is *deprecated*.
> Note that `amount` is *deprecated*. Please use `Tezos.amount`.
</Syntax>
@ -251,7 +251,7 @@ let deny (action, store : parameter * storage) : return =
else (([] : operation list), store)
```
> Note that `amount` is *deprecated*.
> Note that `amount` is *deprecated*. Please use `Tezos.amount`.
</Syntax>
<Syntax syntax="reasonligo">
@ -268,7 +268,7 @@ let deny = ((action, store): (parameter, storage)) : return => {
};
```
> Note that `amount` is *deprecated*.
> Note that `amount` is *deprecated*. Please use `Tezos.amount`.
</Syntax>
@ -289,7 +289,7 @@ function main (const action : parameter; const store : storage) : return is
else ((nil : list (operation)), store)
```
> Note that `source` is *deprecated*.
> Note that `source` is *deprecated*. Please use `Tezos.source`.
</Syntax>
<Syntax syntax="cameligo">
@ -302,7 +302,7 @@ let main (action, store: parameter * storage) : return =
else (([] : operation list), store)
```
> Note that `source` is *deprecated*.
> Note that `source` is *deprecated*. Please use `Tezos.source`.
</Syntax>
<Syntax syntax="reasonligo">
@ -316,7 +316,7 @@ let main = ((action, store) : (parameter, storage)) : return => {
};
```
> Note that `source` is *deprecated*.
> Note that `source` is *deprecated*. Please use `Tezos.source`.
</Syntax>

70
gitlab-pages/docs/advanced/inline.md Normal file
View File

@ -0,0 +1,70 @@
---
id: inline
title: Inlining
---
import Syntax from '@theme/Syntax';
When compiling a contract in LIGO, declarations will get inlined if they are
only used once and pure. Inlining often results in larger contracts and is
therefore not aggressively done.
A pure declaration is one that doesn't cause side effects like causing a
failure or operation.
In some cases you might want to override the default behaviour of LIGO and
force inlining. The declaration still needs to be pure though.
## Inline attribute
To force inlining you can use the inline attribute.
<Syntax syntax="pascaligo">
```pascaligo
function fst(const p : nat * nat) : nat is p.0; attributes ["inline"] ;
function main(const p : nat * nat; const s : nat * nat) : list(operation) * (nat * nat) is
((list end : list(operation)), (fst(p.0,p.1), fst(s.1,s.0)))
```
</Syntax>
<Syntax syntax="cameligo">
```cameligo
let fst (p: (nat * nat)) : nat = p.0 [@@inline]
let main (p : (nat * nat)) (s : (nat * nat)) : (operation list * (nat * nat)) =
(([]: operation list), (fst (p.0, p.1), fst (s.1, s.0)))
```
</Syntax>
<Syntax syntax="reasonligo">
```reasonligo
[@inline]
let fst = (p: (nat, nat)) : nat => p[0]
let main = (p : (nat, nat), s : (nat, nat)) : (list(operation), (nat, nat)) =>
(([]: list(operation)), (fst((p[0], p[1])), fst((s[1], s[0]))))
```
</Syntax>
Now if we measure the difference between inlining and without inlining, using
`ligo measure-contract name_of_contract.ligo <entrypoint>`, we see the
following results:
<table>
<tr>
<td>With inlining</td><td>66 bytes</td>
</tr>
<tr>
<td>Without inlining</td><td>170 bytes</td>
</tr>
</table>
:::info
Note that these results can change due to ongoing work to optimize output of
the LIGO compiler.
:::

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

@ -11,13 +11,13 @@ LIGO features timestamps, as Michelson does, while bakers baking the
block (including the transaction in a block) are responsible for
providing the given current timestamp for the contract.
### Current Time
### Starting time of the current block
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
You can obtain the starting time of the current block using the
built-in `Tezos.now`. This timestamp does not change during the execution
of the contract. Please be aware that it is up to the baker to set the
current timestamp value.
<Syntax syntax="pascaligo">
```pascaligo group=a
@ -62,20 +62,20 @@ constraints on your smart contracts. Consider the following scenarios.
```pascaligo group=b
const today : timestamp = Tezos.now
const one_day : int = 86400
const one_day : int = 86_400
const in_24_hrs : timestamp = today + one_day
const some_date : timestamp = ("2000-01-01T10:10:10Z" : timestamp)
const one_day_later : timestamp = some_date + one_day
```
> Note that `now` is *deprecated*.
> Note that `now` is *deprecated*. Please use `Tezos.now`.
</Syntax>
<Syntax syntax="cameligo">
```cameligo group=b
let today : timestamp = Tezos.now
let one_day : int = 86400
let one_day : int = 86_400
let in_24_hrs : timestamp = today + one_day
let some_date : timestamp = ("2000-01-01t10:10:10Z" : timestamp)
let one_day_later : timestamp = some_date + one_day
@ -88,7 +88,7 @@ let one_day_later : timestamp = some_date + one_day
```reasonligo group=b
let today : timestamp = Tezos.now;
let one_day : int = 86400;
let one_day : int = 86_400;
let in_24_hrs : timestamp = today + one_day;
let some_date : timestamp = ("2000-01-01t10:10:10Z" : timestamp);
let one_day_later : timestamp = some_date + one_day;
@ -110,7 +110,7 @@ const one_day : int = 86400
const in_24_hrs : timestamp = today - one_day
```
> Note that `now` is *deprecated*.
> Note that `now` is *deprecated*. Please use `Tezos.now`.
</Syntax>
<Syntax syntax="cameligo">
@ -149,7 +149,7 @@ applying to numbers.
const not_tommorow : bool = (Tezos.now = in_24_hrs)
```
> Note that `now` is *deprecated*.
> Note that `now` is *deprecated*. Please use `Tezos.now`.
</Syntax>
<Syntax syntax="cameligo">

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

@ -36,6 +36,373 @@ let b : bool = false;
</Syntax>
Common operations:
<Syntax syntax="pascaligo">
<div className="boolean-example-table">
<div className="operation">
and
</div>
<div className="description">
Logical and
</div>
<div className="example">
```pascaligo
const logical_and: bool = True and True;
```
</div>
<div className="operation">
or
</div>
<div className="description">
Logical or
</div>
<div className="example">
```pascaligo
const logical_or: bool = False or True;
```
</div>
<div className="operation">
not
</div>
<div className="description">
Logical not
</div>
<div className="example">
```pascaligo
const logical_not: bool = not False;
```
</div>
<div className="operation">
=
</div>
<div className="description">
Equals
</div>
<div className="example">
```pascaligo
const eq: bool = 2 = 3;
```
</div>
<div className="operation">
=/=
</div>
<div className="description">
Not equals
</div>
<div className="example">
```pascaligo
const not_eq: bool = 2 =/= 3;
```
</div>
<div className="operation">
&gt;
</div>
<div className="description">
Greater than
</div>
<div className="example">
```pascaligo
const gt: bool = 4 > 3;
```
</div>
<div className="operation">
&lt;
</div>
<div className="description">
Less than
</div>
<div className="example">
```pascaligo
const lt: bool = 4 < 3;
```
</div>
<div className="operation">
&gt;=
</div>
<div className="description">
Greater than or equal to
</div>
<div className="example">
```pascaligo
const gte: bool = 4 >= 3;
```
</div>
<div className="operation">
&lt;=
</div>
<div className="description">
Less than or equal to
</div>
<div className="example">
```pascaligo
const lte: bool = 4 <= 3;
```
</div>
</div>
</Syntax>
<Syntax syntax="cameligo">
<div className="boolean-example-table">
<div className="operation">
&&
</div>
<div className="description">
Logical and
</div>
<div className="example">
```cameligo
let logical_and: bool = true && true
```
</div>
<div className="operation">
||
</div>
<div className="description">
Logical or
</div>
<div className="example">
```cameligo
let logical_or: bool = false || true
```
</div>
<div className="operation">
!
</div>
<div className="description">
Logical not
</div>
<div className="example">
```cameligo
let logical_not: bool = not false
```
</div>
<div className="operation">
=
</div>
<div className="description">
Equals
</div>
<div className="example">
```cameligo
let eq: bool = 2 = 3
```
</div>
<div className="operation">
&lt;&gt;
</div>
<div className="description">
Not equals
</div>
<div className="example">
```cameligo
let not_eq: bool = 2 <> 3
```
</div>
<div className="operation">
&gt;
</div>
<div className="description">
Greater than
</div>
<div className="example">
```cameligo
let gt: bool = 4 > 3
```
</div>
<div className="operation">
&lt;
</div>
<div className="description">
Less than
</div>
<div className="example">
```cameligo
let lt: bool = 4 < 3
```
</div>
<div className="operation">
&gt;=
</div>
<div className="description">
Greater than or equal to
</div>
<div className="example">
```cameligo
let gte: bool = 4 >= 3
```
</div>
<div className="operation">
&lt;=
</div>
<div className="description">
Less than or equal to
</div>
<div className="example">
```cameligo
let lte: bool = 4 <= 3
```
</div>
</div>
</Syntax>
<Syntax syntax="reasonligo">
<div className="boolean-example-table">
<div className="operation">
&&
</div>
<div className="description">
Logical and
</div>
<div className="example">
```reasonligo
let logical_and: bool = true && true;
```
</div>
<div className="operation">
||
</div>
<div className="description">
Logical or
</div>
<div className="example">
```reasonligo
let logical_or: bool = false || true;
```
</div>
<div className="operation">
!
</div>
<div className="description">
Logical not
</div>
<div className="example">
```reasonligo
let logical_not: bool = !false;
```
</div>
<div className="operation">
==
</div>
<div className="description">
Equals
</div>
<div className="example">
```reasonligo
let eq: bool = 2 == 3;
```
</div>
<div className="operation">
!=
</div>
<div className="description">
Not equals
</div>
<div className="example">
```reasonligo
let not_eq: bool = 2 != 3;
```
</div>
<div className="operation">
&gt;
</div>
<div className="description">
Greater than
</div>
<div className="example">
```reasonligo
let gt: bool = 4 > 3;
```
</div>
<div className="operation">
&lt;
</div>
<div className="description">
Less than
</div>
<div className="example">
```reasonligo
let lt: bool = 4 < 3;
```
</div>
<div className="operation">
&gt;=
</div>
<div className="description">
Greater than or equal to
</div>
<div className="example">
```reasonligo
let gte: bool = 4 >= 3;
```
</div>
<div className="operation">
&lt;=
</div>
<div className="description">
Less than or equal to
</div>
<div className="example">
```reasonligo
let lte: bool = 4 <= 3;
```
</div>
</div>
</Syntax>
## Comparing Values
@ -152,6 +519,7 @@ let c : bool = (a = b) // false
</Syntax>
<Syntax syntax="reasonligo">
```reasonligo group=d
let a : tez = 5mutez;
let b : tez = 10mutez;

117
gitlab-pages/docs/language-basics/maps-records.md
View File

@ -230,6 +230,106 @@ xy_translate "({x:2,y:3,z:1}, {dx:3,dy:4})"
You have to understand that `p` has not been changed by the functional
update: a nameless new version of it has been created and returned.
#### Nested updates
A unique feature of LIGO is the ability to perform nested updates on records.
For example if you have the following record structure:
<Syntax syntax="pascaligo">
```pascaligo
type color is
| Blue
| Green
type preferences is record [
color : color;
other : int;
]
type account is record [
id : int;
preferences : preferences;
]
```
</Syntax>
<Syntax syntax="cameligo">
```cameligo
type color =
Blue
| Green
type preferences = {
color : color;
other : int;
}
type account = {
id: int;
preferences: preferences;
}
```
</Syntax>
<Syntax syntax="reasonligo">
```reasonligo
type color =
Blue
| Green;
type preferences = {
color : color,
other : int
}
type account = {
id : int,
preferences : preferences
}
```
</Syntax>
You can update the nested record with the following code:
<Syntax syntax="pascaligo">
```pascaligo
function change_color_preference (const account : account; const color : color ) : account is
block {
account := account with record [preferences.color = color]
} with account
```
</Syntax>
<Syntax syntax="cameligo">
```cameligo
let change_color_preference (account : account) (color : color) : account =
{ account with preferences.color = color }
```
</Syntax>
<Syntax syntax="reasonligo">
```reasonligo
let change_color_preference = (account : account, color : color): account =>
{ ...account, preferences.color: color };
```
</Syntax>
Note that all the records in the path will get updated. In this example that's
`account` and `preferences`.
<Syntax syntax="pascaligo">
### Record Patches
Another way to understand what it means to update a record value is to
@ -318,6 +418,8 @@ xy_translate "(record [x=2;y=3;z=1], record [dx=3;dy=4])"
The hiding of a variable by another (here `p`) is called `shadowing`.
</Syntax>
## Maps
*Maps* are a data structure which associate values of the same type to
@ -959,12 +1061,23 @@ The values of a PascaLIGO big map can be updated using the
assignment syntax for ordinary maps
```pascaligo group=big_maps
function add (var m : register) : register is
function assign (var m : register) : register is
block {
m [("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN": address)] := (4,9)
} with m
```
const updated_map : register = add (moves)
If multiple bindings need to be updated, PascaLIGO offers a *patch
instruction* for maps, similar to that for records.
```pascaligo group=big_maps
function assignments (var m : register) : register is
block {
patch m with map [
("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address) -> (4,9);
("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) -> (1,2)
]
} with m
```
</Syntax>

27
gitlab-pages/docs/language-basics/strings.md
View File

@ -71,16 +71,17 @@ let full_greeting : string = greeting ++ " " ++ name;
## Slicing Strings
Strings can be sliced using a built-in function:
## Extracting Subtrings
Substrings can be extracted using the predefined function
`String.sub`. The first character has index 0 and the interval of
indices for the substring has inclusive bounds.
<Syntax syntax="pascaligo">
```pascaligo group=b
const name : string = "Alice"
const slice : string = String.slice (0n, 1n, name)
const slice : string = String.sub (0n, 1n, name)
```
> Note that `string_slide` is *deprecated*.
@ -90,17 +91,21 @@ const slice : string = String.slice (0n, 1n, name)
```cameligo group=b
let name : string = "Alice"
let slice : string = String.slice 0n 1n name
let slice : string = String.sub 0n 1n name
```
> Note that `String.slice` is *deprecated*.
</Syntax>
<Syntax syntax="reasonligo">
```reasonligo group=b
let name : string = "Alice";
let slice : string = String.slice (0n, 1n, name);
let slice : string = String.sub (0n, 1n, name);
```
> Note that `String.slice` is *deprecated*.
</Syntax>
@ -119,23 +124,27 @@ const name : string = "Alice"
const length : nat = String.length (name) // length = 5
```
> Note that `size` is *deprecated*.
> Note that `size` is *deprecated*.
</Syntax>
<Syntax syntax="cameligo">
```cameligo group=c
let name : string = "Alice"
let length : nat = String.size name // length = 5
let length : nat = String.length name // length = 5
```
> Note that `String.size` is *deprecated*.
</Syntax>
<Syntax syntax="reasonligo">
```reasonligo group=c
let name : string = "Alice";
let length : nat = String.size (name); // length == 5
let length : nat = String.length (name); // length == 5
```
> Note that `String.size` is *deprecated*.
</Syntax>

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

@ -11,10 +11,11 @@ functions. This page will tell you about them.
## Pack and Unpack
Michelson provides the `PACK` and `UNPACK` instructions for data
serialization. The former converts Michelson data structures into a
binary format, and the latter reverses that transformation. This
functionality can be accessed from within LIGO.
As Michelson provides the `PACK` and `UNPACK` instructions for data
serialization, so does LIGO with `Bytes.pack` and `Bytes.unpack`. The
former serializes Michelson data structures into a binary format, and
the latter reverses that transformation. Unpacking may fail, so the
return type of `Byte.unpack` is an option that needs to be annotated.
> ⚠️ `PACK` and `UNPACK` are Michelson instructions that are intended
> to be used by people that really know what they are doing. There are
@ -28,11 +29,11 @@ functionality can be accessed from within LIGO.
```pascaligo group=a
function id_string (const p : string) : option (string) is block {
const packed : bytes = bytes_pack (p)
const packed : bytes = Bytes.pack (p)
} with (Bytes.unpack (packed) : option (string))
```
> Note that `bytes_unpack` is *deprecated*.
> Note that `bytes_pack` and `bytes_unpack` are *deprecated*.
</Syntax>
<Syntax syntax="cameligo">
@ -72,18 +73,21 @@ a predefined functions returning a value of type `key_hash`.
function check_hash_key (const kh1 : key_hash; const k2 : key) : bool * key_hash is
block {
var ret : bool := False;
var kh2 : key_hash := crypto_hash_key (k2);
var kh2 : key_hash := Crypto.hash_key (k2);
if kh1 = kh2 then ret := True else skip
} with (ret, kh2)
```
> Note that `hash_key` is *deprecated*. Please use `Crypto.hash_key`.
</Syntax>
<Syntax syntax="cameligo">
```cameligo group=b
let check_hash_key (kh1, k2 : key_hash * key) : bool * key_hash =
let kh2 : key_hash = Crypto.hash_key k2 in
if kh1 = kh2 then true, kh2 else false, kh2
let kh2 : key_hash = Crypto.hash_key k2 in
(kh1 = kh2), kh2
```
</Syntax>
@ -92,7 +96,7 @@ let check_hash_key (kh1, k2 : key_hash * key) : bool * key_hash =
```reasonligo group=b
let check_hash_key = ((kh1, k2) : (key_hash, key)) : (bool, key_hash) => {
let kh2 : key_hash = Crypto.hash_key (k2);
if (kh1 == kh2) { (true, kh2); } else { (false, kh2); }
((kh1 == kh2), kh2);
};
```

10
gitlab-pages/docs/reference/bitwise.md
View File

@ -15,7 +15,7 @@ function and : nat -> nat -> nat
val and : nat -> nat -> nat
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let and: (nat, nat) -> nat
let and: (nat, nat) => nat
</SyntaxTitle>
A bitwise `and` operation.
@ -27,7 +27,7 @@ function or : nat -> nat -> nat
val or : nat -> nat -> nat
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let or: (nat, nat) -> nat
let or: (nat, nat) => nat
</SyntaxTitle>
A bitwise `or` operation.
@ -39,7 +39,7 @@ function xor : nat -> nat -> nat
val xor : nat -> nat -> nat
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let xor: (nat, nat) -> nat
let xor: (nat, nat) => nat
</SyntaxTitle>
A bitwise `xor` operation.
@ -51,7 +51,7 @@ function shift_left : nat -> nat -> nat
val shift_left : nat -> nat -> nat
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let shift_left: (nat, nat) -> nat
let shift_left: (nat, nat) => nat
</SyntaxTitle>
A bitwise shift left operation.
@ -63,7 +63,7 @@ function shift_right : nat -> nat -> nat
val shift_right : nat -> nat -> nat
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let shift_right: (nat, nat) -> nat
let shift_right: (nat, nat) => nat
</SyntaxTitle>
A bitwise shift right operation.

18
gitlab-pages/docs/reference/current.md
View File

@ -21,13 +21,13 @@ type timestamp
A date in the real world.
<SyntaxTitle syntax="pascaligo">
type mutez
type tez
</SyntaxTitle>
<SyntaxTitle syntax="cameligo">
type mutez
type tez
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
type mutez
type tez
</SyntaxTitle>
A specific type for tokens.
@ -83,13 +83,13 @@ type chain_id
The identifier of a chain, used to indicate test or main chains.
<SyntaxTitle syntax="pascaligo">
function balance : mutez
function balance : tez
</SyntaxTitle>
<SyntaxTitle syntax="cameligo">
val balance : mutez
val balance : tez
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let balance: mutez
let balance: tez
</SyntaxTitle>
Get the balance for the contract.
@ -263,13 +263,13 @@ let not_tomorrow: bool = (Tezos.now == in_24_hrs);
<SyntaxTitle syntax="pascaligo">
function amount : mutez
function amount : tez
</SyntaxTitle>
<SyntaxTitle syntax="cameligo">
val amount : mutez
val amount : tez
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let amount: mutez
let amount: tez
</SyntaxTitle>
Get the amount of tez provided by the sender to complete this

86
gitlab-pages/docs/reference/toplevel.md Normal file
View File

@ -0,0 +1,86 @@
---
id: toplevel
title: Toplevel
description: Available functions at the top level
hide_table_of_contents: true
---
import Syntax from '@theme/Syntax';
import SyntaxTitle from '@theme/SyntaxTitle';
These functions are available without any needed prefix.
<SyntaxTitle syntax="pascaligo">
function is_nat: int -> option(nat)
</SyntaxTitle>
<SyntaxTitle syntax="cameligo">
val is_nat: int -> nat option
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let is_nat: int => option(nat)
</SyntaxTitle>
Convert an `int` to a `nat` if possible.
<SyntaxTitle syntax="pascaligo">
function abs: int -> nat
</SyntaxTitle>
<SyntaxTitle syntax="cameligo">
val abs: int -> nat
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let abs: int => nat
</SyntaxTitle>
Cast an `int` to `nat`.
<SyntaxTitle syntax="pascaligo">
function int: nat -> int
</SyntaxTitle>
<SyntaxTitle syntax="cameligo">
val int: nat -> int
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let int: nat => int
</SyntaxTitle>
Cast an `nat` to `int`.
<SyntaxTitle syntax="pascaligo">
const unit: unit
</SyntaxTitle>
<SyntaxTitle syntax="cameligo">
val unit: unit
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let (): unit
</SyntaxTitle>
A helper to create a unit.
<SyntaxTitle syntax="pascaligo">
function failwith : string -> unit
</SyntaxTitle>
<SyntaxTitle syntax="cameligo">
val failwith : string -> unit
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let failwith : string => unit
</SyntaxTitle>
Cause the contract to fail with an error message.
> ⚠ Using this currently requires in general a type annotation on the
> `failwith` call.
<SyntaxTitle syntax="pascaligo">
function assert : bool -> unit
</SyntaxTitle>
<SyntaxTitle syntax="cameligo">
val assert : bool -> unit
</SyntaxTitle>
<SyntaxTitle syntax="reasonligo">
let assert : bool => unit
</SyntaxTitle>
Check if a certain condition has been met. If not the contract will fail.

16
gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.ligo
View File

@ -34,13 +34,21 @@ function buy_taco (const taco_kind_index : nat; var taco_shop_storage : taco_sho
// Update the storage with the refreshed taco_kind
taco_shop_storage[taco_kind_index] := taco_kind;
const receiver : contract (unit) = get_contract (ownerAddress);
const donationReceiver : contract (unit) = get_contract (donationAddress);
const receiver : contract (unit) =
case (Tezos.get_contract_opt (ownerAddress): option(contract (unit))) of
Some (contract) -> contract
| None -> (failwith ("Not a contract") : contract (unit))
end;
const donationReceiver : contract (unit) =
case (Tezos.get_contract_opt (donationAddress): option(contract (unit))) of
Some (contract) -> contract
| None -> (failwith ("Not a contract") : contract (unit))
end;
const donationAmount : tez = amount / 10n;
const operations : list (operation) = list [
transaction (unit, amount - donationAmount, receiver);
transaction (unit, donationAmount, donationReceiver);
Tezos.transaction (unit, amount - donationAmount, receiver);
Tezos.transaction (unit, donationAmount, donationReceiver);
]
} with (operations, taco_shop_storage)

29
gitlab-pages/docs/tutorials/get-started/tezos-taco-shop-payout.md
View File

@ -105,7 +105,11 @@ contract with no parameters, or an implicit account.
```pascaligo group=ex1
const ownerAddress : address = ("tz1TGu6TN5GSez2ndXXeDX6LgUDvLzPLqgYV" : address);
const receiver : contract (unit) = get_contract (ownerAddress);
const receiver : contract (unit) =
case (Tezos.get_contract_opt (ownerAddress): option(contract(unit))) of
Some (contract) -> contract
| None -> (failwith ("Not a contract") : (contract(unit)))
end;
```
> Would you like to learn more about addresses, contracts and
@ -120,7 +124,7 @@ receiver)` within a list of operations returned at the end of our
contract.
```pascaligo group=ex1
const payoutOperation : operation = transaction (unit, amount, receiver) ;
const payoutOperation : operation = Tezos.transaction (unit, amount, receiver) ;
const operations : list (operation) = list [payoutOperation];
```
@ -166,8 +170,13 @@ function buy_taco (const taco_kind_index : nat ; var taco_shop_storage : taco_sh
// Update the storage with the refreshed taco_kind
taco_shop_storage[taco_kind_index] := taco_kind;
const receiver : contract(unit) = get_contract (ownerAddress);
const payoutOperation : operation = transaction (unit, amount, receiver);
const receiver : contract (unit) =
case (Tezos.get_contract_opt (ownerAddress): option(contract(unit))) of
Some (contract) -> contract
| None -> (failwith ("Not a contract") : (contract(unit)))
end;
const payoutOperation : operation = Tezos.transaction (unit, amount, receiver);
const operations : list(operation) = list [payoutOperation]
} with ((operations : list (operation)), taco_shop_storage)
```
@ -214,8 +223,16 @@ sum from each taco purchase.
const ownerAddress : address = ("tz1TGu6TN5GSez2ndXXeDX6LgUDvLzPLqgYV" : address);
const donationAddress : address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address);
const receiver : contract (unit) = get_contract (ownerAddress);
const donationReceiver : contract(unit) = get_contract (donationAddress);
const receiver : contract (unit) =
case (Tezos.get_contract_opt (ownerAddress) : option(contract(unit))) of
Some (contract) -> contract
| None -> (failwith ("Not a contract") : contract (unit))
end;
const donationReceiver : contract (unit) =
case (Tezos.get_contract_opt (donationAddress) : option(contract(unit))) of
Some (contract) -> contract
| None -> (failwith ("Not a contract") : contract (unit))
end;
const donationAmount : tez = amount / 10n;

5
gitlab-pages/website/docusaurus.config.js
View File

@ -115,6 +115,11 @@ const siteConfig = {
plugins: [
'@ligo/syntax', {
},
'@docusaurus/plugin-sitemap', {
cacheTime: 600 * 1000, // 600 sec - cache purge period
changefreq: 'weekly',
priority: 0.5,
}
],

1
gitlab-pages/website/package.json
View File

@ -26,6 +26,7 @@
]
},
"dependencies": {
"@docusaurus/plugin-sitemap": "^2.0.0-alpha.37",
"@ligo/syntax": "file:src/@ligo/syntax"
}
}

4
gitlab-pages/website/sidebars.json
View File

@ -19,13 +19,15 @@
"advanced/entrypoints-contracts",
"advanced/include",
"advanced/first-contract",
"advanced/michelson-and-ligo"
"advanced/michelson-and-ligo",
"advanced/inline"
],
"Reference": [
"api/cli-commands",
"api/cheat-sheet"
],
"API":[
"reference/toplevel",
"reference/big-map-reference",
"reference/bitwise-reference",
"reference/bytes-reference",

8
gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/SyntaxSwitch.js
View File

@ -2,15 +2,15 @@ import React from 'react';
import styles from './styles.module.css';
function SyntaxSwitch(props) {
return React.createElement("select", {
return /*#__PURE__*/React.createElement("select", {
className: styles.syntaxSwitch,
defaultValue: props.syntax,
onChange: e => props.onSyntaxChange(e.target.value)
}, React.createElement("option", {
}, /*#__PURE__*/React.createElement("option", {
value: "pascaligo"
}, "PascaLIGO"), React.createElement("option", {
}, "PascaLIGO"), /*#__PURE__*/React.createElement("option", {
value: "cameligo"
}, "CameLIGO"), React.createElement("option", {
}, "CameLIGO"), /*#__PURE__*/React.createElement("option", {
value: "reasonligo"
}, "ReasonLIGO"));
}

4
gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/index.js
View File

@ -2,11 +2,11 @@ import React from 'react';
import SyntaxContext from './SyntaxContext';
function Syntax(props) {
return React.createElement(SyntaxContext.Consumer, null, syntax => {
return /*#__PURE__*/React.createElement(SyntaxContext.Consumer, null, syntax => {
if (syntax === props.syntax) {
return props.children;
} else {
return React.createElement(React.Fragment, null);
return /*#__PURE__*/React.createElement(React.Fragment, null);
}
});
}

1
gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/styles.module.css
View File

@ -32,6 +32,7 @@
.syntaxSwitch option {
color: var(--color-primary-text);
font-weight:normal;
background-color: var(--ifm-navbar-background-color);
}

12
gitlab-pages/website/src/@ligo/syntax/output/theme/SyntaxTitle/index.js
View File

@ -72,9 +72,9 @@ function SyntaxTitle(props) {
useEffect(() => {
setMounted(true);
}, []);
return React.createElement(SyntaxContext.Consumer, null, syntax => {
return /*#__PURE__*/React.createElement(SyntaxContext.Consumer, null, syntax => {
if (syntax === props.syntax) {
return React.createElement(Highlight, _extends({}, defaultProps, {
return /*#__PURE__*/React.createElement(Highlight, _extends({}, defaultProps, {
key: mounted,
language: props.syntax,
code: props.children,
@ -85,7 +85,7 @@ function SyntaxTitle(props) {
tokens,
getLineProps,
getTokenProps
}) => React.createElement("pre", {
}) => /*#__PURE__*/React.createElement("pre", {
className: className,
style: {
backgroundColor: 'var(--ifm-background-color)',
@ -95,15 +95,15 @@ function SyntaxTitle(props) {
whiteSpace: 'break-spaces',
marginTop: '3rem'
}
}, tokens.map((line, i) => React.createElement("div", getLineProps({
}, tokens.map((line, i) => /*#__PURE__*/React.createElement("div", getLineProps({
line,
key: i
}), line.map((token, key) => React.createElement("span", getTokenProps({
}), line.map((token, key) => /*#__PURE__*/React.createElement("span", getTokenProps({
token,
key
})))))));
} else {
return React.createElement("div", null);
return /*#__PURE__*/React.createElement("div", null);
}
});
}

1
gitlab-pages/website/src/@ligo/syntax/src/theme/Syntax/styles.module.css
View File

@ -32,6 +32,7 @@
.syntaxSwitch option {
color: var(--color-primary-text);
font-weight:normal;
background-color: var(--ifm-navbar-background-color);
}

14
gitlab-pages/website/src/pages/contact.js
View File

@ -10,13 +10,6 @@ const TEAM = [
link: 'https://github.com/rinderknecht',
pinned: true
},
{
firstName: 'Brice',
lastName: 'Aldrich',
image: 'img/brice.jpeg',
link: 'https://github.com/DefinitelyNotAGoat',
pinned: true
},
{
firstName: 'Gabriel',
lastName: 'Alfour',
@ -24,13 +17,6 @@ const TEAM = [
link: 'https://gitlab.com/gabriel.alfour',
pinned: true
},
{
firstName: 'Matej',
lastName: 'Sima',
image: 'img/matej.jpeg',
link: 'https://github.com/maht0rz',
pinned: true
},
{
firstName: 'Sander',
lastName: 'Spies',

29
gitlab-pages/website/static/css/custom.css
View File

@ -50,6 +50,7 @@
html[data-theme='dark'] {
--color-primary-text: white;
--blockquote-color: var(--ifm-navbar-background-color);
--light-blue: var(--ifm-navbar-background-color);
}
html {
@ -1029,3 +1030,31 @@ a:hover {
background-color: transparent;
}
.boolean-example-table {
display: grid;
grid-template-columns: 10% 30% 60%;
width: 100%;
}
.boolean-example-table .operation{
font-weight: bold;
display: flex;
align-items: center;
justify-content: center;
}
.boolean-example-table .description {
display: flex;
align-items: center;
}
.boolean-example-table > div:nth-child(6n+1),
.boolean-example-table > div:nth-child(6n+2),
.boolean-example-table > div:nth-child(6n+3) {
background-color: var(--ifm-table-stripe-background);
}
.boolean-example-table > .example pre,
.boolean-example-table > .example .codeBlockLines_src-theme-CodeBlock- {
background-color: transparent;
}

2
scripts/test_cli.sh
View File

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

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

@ -7,13 +7,13 @@ let bad_contract basename =
let%expect_test _ =
run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ;
[%expect {| 1870 bytes |}] ;
[%expect {| 1872 bytes |}] ;
run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ;
[%expect {| 1324 bytes |}] ;
[%expect {| 1294 bytes |}] ;
run_ligo_good [ "measure-contract" ; contract "multisig-v2.ligo" ; "main" ] ;
[%expect {| 3231 bytes |}] ;
[%expect {| 2974 bytes |}] ;
run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ;
[%expect {| 589 bytes |}] ;
@ -26,7 +26,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ;
[%expect {|
ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]"}
ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]"}
If you're not sure how to fix this error, you can
@ -39,7 +39,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ;
[%expect {|
ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]"}
ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]"}
If you're not sure how to fix this error, you can
@ -227,16 +227,17 @@ let%expect_test _ =
NIL operation ;
SWAP ;
CONS ;
DIP { DIP 4 { DUP } ;
DIG 4 ;
DIP 4 { DUP } ;
DIG 4 ;
DUP ;
DIP { DIP 5 { DUP } ;
DIG 5 ;
DIP 5 { DUP } ;
DIG 5 ;
DIP { DUP ; CDR ; SWAP ; CAR ; CAR } ;
SWAP ;
PAIR ;
PAIR } ;
PAIR ;
DIP { DROP 13 } } ;
DIP { DROP 14 } } ;
DIP { DROP } }
{ DUP ;
DIP { DIP { DUP } ; SWAP } ;
@ -312,11 +313,8 @@ let%expect_test _ =
SWAP ;
CAR ;
CDR ;
DUP ;
DIP { DIP 2 { DUP } ; DIG 2 } ;
PAIR ;
DIP { DIP { DUP } ; SWAP } ;
PAIR ;
DIP { DUP } ;
SWAP ;
DIP 3 { DUP } ;
DIG 3 ;
CAR ;
@ -333,31 +331,31 @@ let%expect_test _ =
PAIR ;
DUP ;
CAR ;
CAR ;
CDR ;
DIP { DUP } ;
SWAP ;
CAR ;
CDR ;
CAR ;
DIP 2 { DUP } ;
DIG 2 ;
CDR ;
DIP 2 { DUP } ;
DIG 2 ;
DIP { DIP { DUP } ; SWAP } ;
DIP { DUP } ;
SWAP ;
DIP { DIP 2 { DUP } ; DIG 2 } ;
PAIR ;
DIP 3 { DUP } ;
DIG 3 ;
DIP 2 { DUP } ;
DIG 2 ;
IF_CONS
{ DIP 4 { DUP } ;
DIG 4 ;
{ DIP 5 { DUP } ;
DIG 5 ;
DIP 4 { DUP } ;
DIG 4 ;
CAR ;
DIP { DIP { DUP } ; SWAP ; HASH_KEY } ;
COMPARE ;
EQ ;
IF { DIP 5 { DUP } ;
DIG 5 ;
IF { DIP 6 { DUP } ;
DIG 6 ;
DIP 2 { DUP } ;
DIG 2 ;
DIP { DIP 5 { DUP } ;
@ -371,8 +369,8 @@ let%expect_test _ =
PAIR ;
PACK } } ;
CHECK_SIGNATURE ;
IF { DIP 6 { DUP } ;
DIG 6 ;
IF { DIP 7 { DUP } ;
DIG 7 ;
PUSH nat 1 ;
ADD ;
DIP { DUP } ;
@ -407,9 +405,10 @@ let%expect_test _ =
CAR ;
DIP 2 { DUP } ;
DIG 2 ;
CAR ;
SWAP ;
CDR ;
SWAP ;
CAR ;
PAIR ;
SWAP ;
CDR ;
@ -421,10 +420,9 @@ let%expect_test _ =
CAR ;
DIP 3 { DUP } ;
DIG 3 ;
CAR ;
SWAP ;
CDR ;
SWAP ;
CAR ;
PAIR ;
SWAP ;
CDR ;
@ -460,16 +458,14 @@ let%expect_test _ =
DIP { DROP 2 } } ;
DIP 3 { DUP } ;
DIG 3 ;
CAR ;
DIP { DUP } ;
PAIR ;
DIP { DROP 3 } } ;
DUP ;
CAR ;
CAR ;
SWAP ;
DIP { DROP 4 } } ;
DIP 2 { DUP } ;
DIG 2 ;
UNIT ;
EXEC ;
DIP { DUP ; CDR } ;
DIP { DUP } ;
PAIR ;
DIP { DROP 7 } } } |} ]
@ -518,19 +514,19 @@ let%expect_test _ =
GT ;
IF { PUSH string "Message size exceed maximum limit" ; FAILWITH }
{ PUSH unit Unit } ;
DIP 4 { DUP } ;
DIG 4 ;
EMPTY_SET address ;
DUP ;
DIP { DIP 5 { DUP } ; DIG 5 } ;
PAIR ;
DIP 2 { DUP } ;
DIG 2 ;
DIP { DIP 5 { DUP } ; DIG 5 ; CAR ; CDR ; CDR } ;
DIP 3 { DUP } ;
DIG 3 ;
DIP { DIP 6 { DUP } ; DIG 6 ; CAR ; CDR ; CDR } ;
GET ;
IF_NONE
{ DIP 5 { DUP } ;
DIG 5 ;
DIP 6 { DUP } ;
{ DIP 6 { DUP } ;
DIG 6 ;
DIP 7 { DUP } ;
DIG 7 ;
CDR ;
CAR ;
CAR ;
@ -540,7 +536,7 @@ let%expect_test _ =
PUSH nat 1 ;
ADD ;
SOME ;
DIP { DIP 6 { DUP } ; DIG 6 ; CDR ; CAR ; CAR } ;
DIP { DIP 7 { DUP } ; DIG 7 ; CDR ; CAR ; CAR } ;
SENDER ;
UPDATE ;
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ;
@ -548,31 +544,33 @@ let%expect_test _ =
PAIR ;
SWAP ;
PAIR ;
DIP { DUP } ;
SWAP ;
CAR ;
DIP { DUP } ;
PAIR ;
EMPTY_SET address ;
PUSH bool True ;
SENDER ;
UPDATE ;
DIP 2 { DUP } ;
DIG 2 ;
DIP 2 { DUP } ;
DIG 2 ;
SWAP ;
CAR ;
PAIR ;
CDR ;
DIP { DUP } ;
SWAP ;
PAIR ;
DIP { DROP } }
{ DIP 6 { DUP } ;
DIG 6 ;
DIP { DROP 2 } }
{ DIP 7 { DUP } ;
DIG 7 ;
DIP { DUP } ;
SWAP ;
SENDER ;
MEM ;
IF { DUP }
{ DIP 7 { DUP } ;
DIG 7 ;
DIP 8 { DUP } ;
{ DIP 8 { DUP } ;
DIG 8 ;
DIP 9 { DUP } ;
DIG 9 ;
CDR ;
CAR ;
CAR ;
@ -582,7 +580,7 @@ let%expect_test _ =
PUSH nat 1 ;
ADD ;
SOME ;
DIP { DIP 8 { DUP } ; DIG 8 ; CDR ; CAR ; CAR } ;
DIP { DIP 9 { DUP } ; DIG 9 ; CDR ; CAR ; CAR } ;
SENDER ;
UPDATE ;
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ;
@ -628,25 +626,21 @@ let%expect_test _ =
GT ;
IF { PUSH string "Maximum number of proposal reached" ; FAILWITH }
{ PUSH unit Unit } ;
DIP 8 { DUP } ;
DIG 8 ;
NIL operation ;
DUP ;
DIP { DIP 3 { DUP } ; DIG 3 } ;
PAIR ;
DIP { DIP 7 { DUP } ; DIG 7 ; NIL operation ; SWAP ; PAIR } ;
PAIR ;
DIP { DIP 2 { DUP } ; DIG 2 } ;
PAIR ;
DIP 4 { DUP } ;
DIG 4 ;
DIP 5 { DUP } ;
DIG 5 ;
SIZE ;
DIP { DIP 3 { DUP } ; DIG 3 ; CDR ; CDR } ;
DIP { DIP 4 { DUP } ; DIG 4 ; CDR ; CDR } ;
COMPARE ;
GE ;
IF { DIP 3 { DUP } ;
DIG 3 ;
DIP 9 { DUP } ;
DIG 9 ;
DIP { DIP 4 { DUP } ; DIG 4 ; CAR ; CDR ; CDR ; NONE (set address) } ;
IF { DIP 4 { DUP } ;
DIG 4 ;
DIP 11 { DUP } ;
DIG 11 ;
DIP { DIP 5 { DUP } ; DIG 5 ; CAR ; CDR ; CDR ; NONE (set address) } ;
UPDATE ;
DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ;
SWAP ;
@ -658,7 +652,7 @@ let%expect_test _ =
CDR ;
CAR ;
CDR ;
DIP { DIP 10 { DUP } ; DIG 10 } ;
DIP { DIP 12 { DUP } ; DIG 12 } ;
EXEC ;
DIP { DUP } ;
SWAP ;
@ -667,7 +661,7 @@ let%expect_test _ =
CDR ;
CAR ;
CDR ;
DIP { DIP 11 { DUP } ; DIG 11 } ;
DIP { DIP 13 { DUP } ; DIG 13 } ;
CONCAT ;
SHA256 ;
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CAR } ;
@ -689,32 +683,26 @@ let%expect_test _ =
SWAP ;
CDR ;
CAR ;
DIP 2 { DUP } ;
DIG 2 ;
CDR ;
CDR ;
DIP { DUP } ;
SWAP ;
DIP { DUP } ;
PAIR ;
DIP { DIP 2 { DUP } ; DIG 2 } ;
PAIR ;
DIP 2 { DUP } ;
DIG 2 ;
SWAP ;
DIP { DIP 12 { DUP } ; DIG 12 } ;
MEM ;
IF { DIP 3 { DUP } ;
DIG 3 ;
DIP 3 { DUP } ;
DIG 3 ;
DIP { DIP 2 { DUP } ;
DIG 2 ;
IF { DIP 2 { DUP } ;
DIG 2 ;
DIP 2 { DUP } ;
DIG 2 ;
DIP { DIP 4 { DUP } ;
DIG 4 ;
CDR ;
CDR ;
PUSH nat 1 ;
SWAP ;
SUB ;
ABS ;
SOME ;
DIP { DIP 4 { DUP } ; DIG 4 ; CDR ; CAR ; CAR } } ;
DIP { DIP 3 { DUP } ; DIG 3 ; CDR ; CAR ; CAR } } ;
UPDATE ;
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ;
PAIR ;
@ -723,23 +711,21 @@ let%expect_test _ =
PAIR ;
DIP { DUP } ;
SWAP ;
CAR ;
DIP { DUP } ;
PAIR ;
DIP { DROP } }
SWAP ;
DIP { DROP 2 } }
{ DUP } ;
DIP 4 { DUP } ;
DIG 4 ;
DIP 5 { DUP } ;
DIG 5 ;
DIP 6 { DUP } ;
DIG 6 ;
CAR ;
DIP 2 { DUP } ;
DIG 2 ;
CDR ;
DIP { DROP ; CDR } ;
PAIR ;
CAR ;
DIP { DROP 6 } } ;
DIP { DROP 5 } } ;
DIP 4 { DUP } ;
DIG 4 ;
DIP 4 { DUP } ;
@ -749,12 +735,10 @@ let%expect_test _ =
PAIR ;
DIP 3 { DUP } ;
DIG 3 ;
DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ;
SWAP ;
PAIR ;
CDR ;
SWAP ;
PAIR ;
PAIR ;
DIP 2 { DUP } ;
DIG 2 ;
SWAP ;
@ -765,14 +749,14 @@ let%expect_test _ =
PAIR ;
DIP { DROP 4 } }
{ DUP ;
DIP 4 { DUP } ;
DIG 4 ;
DIP 10 { DUP } ;
DIG 10 ;
DIP { DIP 6 { DUP } ;
DIG 6 ;
DIP 5 { DUP } ;
DIG 5 ;
DIP 12 { DUP } ;
DIG 12 ;
DIP { DIP 7 { DUP } ;
DIG 7 ;
SOME ;
DIP { DIP 5 { DUP } ; DIG 5 ; CAR ; CDR ; CDR } } ;
DIP { DIP 6 { DUP } ; DIG 6 ; CAR ; CDR ; CDR } } ;
UPDATE ;
DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ;
SWAP ;
@ -785,11 +769,9 @@ let%expect_test _ =
PAIR } ;
DUP ;
CAR ;
CDR ;
CDR ;
DIP { DUP ; CDR } ;
PAIR ;
DIP { DROP 15 } } ;
DIP { DROP 17 } } ;
DIP { DROP } }
{ DUP ;
DIP { DIP { DUP } ; SWAP } ;
@ -800,9 +782,8 @@ let%expect_test _ =
SWAP ;
CAR ;
PACK ;
DUP ;
DIP { DIP { DUP } ; SWAP } ;
PAIR ;
DIP { DUP } ;
SWAP ;
DIP { DUP } ;
SWAP ;
DIP { DIP 2 { DUP } ; DIG 2 ; CAR ; CDR ; CDR } ;
@ -851,12 +832,7 @@ let%expect_test _ =
DIP { DROP 2 } }
{ DUP } ;
DUP ;
DIP 3 { DUP } ;
DIG 3 ;
DIP { DIP 6 { DUP } ; DIG 6 } ;
PAIR ;
DIP { DUP } ;
PAIR ;
DUP ;
DIP 4 { DUP } ;
DIG 4 ;
SIZE ;
@ -878,10 +854,9 @@ let%expect_test _ =
PAIR ;
DIP { DUP } ;
SWAP ;
CAR ;
DIP { DUP } ;
PAIR ;
DIP { DROP } }
SWAP ;
DIP { DROP 2 } }
{ DUP ;
DIP 2 { DUP } ;
DIG 2 ;
@ -898,47 +873,15 @@ let%expect_test _ =
SWAP ;
PAIR ;
PAIR ;
SWAP ;
CAR ;
PAIR } ;
DIP { DROP } } ;
DIP 7 { DUP } ;
DIG 7 ;
DIP 3 { DUP } ;
DIG 3 ;
DIP { DROP ; DUP } ;
SWAP ;
CAR ;
PAIR ;
DIP { DUP } ;
SWAP ;
CAR ;
CDR ;
SWAP ;
CDR ;
SWAP ;
PAIR ;
DIP { DUP } ;
SWAP ;
CDR ;
SWAP ;
CAR ;
PAIR ;
DIP { DUP } ;
SWAP ;
CAR ;
CDR ;
SWAP ;
CDR ;
SWAP ;
PAIR ;
DIP { DUP } ;
SWAP ;
CDR ;
SWAP ;
CAR ;
PAIR ;
DIP { DROP 7 } } ;
DIP { DROP 8 } } ;
DUP ;
CDR ;
NIL operation ;
PAIR ;
DIP { DROP 6 } } ;
@ -1093,11 +1036,11 @@ let%expect_test _ =
let%expect_test _ =
run_ligo_good [ "dry-run" ; contract "redeclaration.ligo" ; "main" ; "unit" ; "0" ] ;
[%expect {|( list[] , 0 ) |}]
[%expect {|( LIST_EMPTY() , 0 ) |}]
let%expect_test _ =
run_ligo_good [ "dry-run" ; contract "double_main.ligo" ; "main" ; "unit" ; "0" ] ;
[%expect {|( list[] , 2 ) |}]
[%expect {|( LIST_EMPTY() , 2 ) |}]
let%expect_test _ =
run_ligo_good [ "compile-contract" ; contract "subtle_nontail_fail.mligo" ; "main" ] ;
@ -1155,7 +1098,7 @@ let%expect_test _ =
let%expect_test _ =
run_ligo_good [ "dry-run" ; contract "super-counter.mligo" ; "main" ; "test_param" ; "test_storage" ] ;
[%expect {|
( list[] , 3 ) |}]
( LIST_EMPTY() , 3 ) |}]
let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "redundant_constructors.mligo" ; "main" ] ;
@ -1174,7 +1117,7 @@ let%expect_test _ =
let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
[%expect {|
ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#654 = #P in let p = rhs#654.0 in let s = rhs#654.1 in ( list[] : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return\n let rhs#705 = #P in\n let p = rhs#705.0 in\n let s = rhs#705.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , store ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
If you're not sure how to fix this error, you can
@ -1187,7 +1130,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8,
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
[%expect {|
ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#657 = #P in let p = rhs#657.0 in let s = rhs#657.1 in ( list[] : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return\n let rhs#708 = #P in\n let p = rhs#708.0 in\n let s = rhs#708.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , a ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
If you're not sure how to fix this error, you can
@ -1396,4 +1339,4 @@ let%expect_test _ =
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
* Ask a question on our Discord: https://discord.gg/9rhYaEt
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
* Check the changelog by running 'ligo changelog' |}]
* Check the changelog by running 'ligo changelog' |}]

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

@ -43,12 +43,12 @@ let%expect_test _ =
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 m = [ ; "one" : string -> 1 : int ; "three" : string -> 3 : int ; "two" : string -> 2 : 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_map = [ ; "one" : string -> 4 : int ; "three" : string -> 8 : int ; "two" : string -> 5 : 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_remove = { ; 0 = ([ ; "three" : string -> 3 : int ; "two" : string -> 2 : int]) ; 1 = ([ ; "one" : string -> 1 : int ; "three" : string -> 3 : int ; "two" : string -> 2 : 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}) }

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

@ -158,7 +158,9 @@ 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[controller -> address , owner -> address , profile -> bytes]
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:
@ -175,7 +177,7 @@ let%expect_test _ =
let%expect_test _ =
run_ligo_good [ "interpret" ; "Set.literal [ (1,(2,3)) ; (2,(3,4)) ]" ; "--syntax=cameligo" ] ;
[%expect {|
set[( 2 , ( 3 , 4 ) ) , ( 1 , ( 2 , 3 ) )] |}];
SET_ADD(( 2 , ( 3 , 4 ) ) , SET_ADD(( 1 , ( 2 , 3 ) ) , SET_EMPTY())) |}];
run_ligo_bad [ "interpret" ; "Set.literal [ (1,2,3) ; (2,3,4) ]" ; "--syntax=cameligo" ] ;
[%expect {|

2
src/passes/1-parser/pascaligo/Doc/pascaligo.md
View File

@ -823,7 +823,7 @@ example, in verbose style:
type store is
record
goal : mutez; // Millionth of a tez
goal : tez;
deadline : timestamp;
backers : map (address, nat);
funded : bool

14
src/passes/1-parser/reasonligo.ml
View File

@ -88,6 +88,18 @@ module Errors =
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)]
in error ~data title message
let invalid_wild (expr: AST.expr) =
let title () = "" in
let message () =
"It looks like you are using a wild pattern where it cannot be used."
in
let expression_loc = AST.expr_to_region expr in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)]
in error ~data title message
end
let apply parser =
@ -146,6 +158,8 @@ let apply parser =
| exception SyntaxError.Error (SyntaxError.WrongFunctionArguments expr) ->
Trace.fail @@ Errors.wrong_function_arguments expr
| exception SyntaxError.Error (SyntaxError.InvalidWild expr) ->
Trace.fail @@ Errors.wrong_function_arguments expr
(* Parsing a contract in a file *)

28
src/passes/1-parser/reasonligo/Parser.mly
View File

@ -41,6 +41,13 @@ let rec curry hd = function
in TFun {value; region}
| [] -> hd
let wild_error e =
match e with
| EVar { value = "_"; _} as e ->
let open! SyntaxError in
raise (Error (InvalidWild e))
| _ -> ()
(* END HEADER *)
%}
@ -263,24 +270,30 @@ let_declaration:
let_binding:
"<ident>" type_annotation? "=" expr {
wild_error $4;
Scoping.check_reserved_name $1;
{binders = PVar $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| "_" type_annotation? "=" expr {
wild_error $4;
{binders = PWild $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| unit type_annotation? "=" expr {
wild_error $4;
{binders = PUnit $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| record_pattern type_annotation? "=" expr {
wild_error $4;
Scoping.check_pattern (PRecord $1);
{binders = PRecord $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| par(closed_irrefutable) type_annotation? "=" expr {
wild_error $4;
Scoping.check_pattern $1.value.inside;
{binders = PPar $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| tuple(sub_irrefutable) type_annotation? "=" expr {
wild_error $4;
Utils.nsepseq_iter Scoping.check_pattern $1;
let hd, tl = $1 in
let start = pattern_to_region hd in
@ -409,7 +422,9 @@ expr:
base_cond__open(expr) | switch_expr(base_cond) { $1 }
base_cond__open(x):
base_expr(x) | conditional(expr_with_let_expr) { $1 }
base_expr(x) | conditional(expr_with_let_expr) {
wild_error $1;
$1 }
base_cond:
base_cond__open(base_cond) { $1 }
@ -445,9 +460,13 @@ fun_expr:
let region = cover start stop in
let rec arg_to_pattern = function
EVar v ->
Scoping.check_reserved_name v;
PVar v
EVar v ->
if v.value = "_" then
PWild v.region
else (
Scoping.check_reserved_name v;
PVar v
)
| EAnnot {region; value = {inside = EVar v, colon, typ; _}} ->
Scoping.check_reserved_name v;
let value = {pattern = PVar v; colon; type_expr = typ}
@ -780,6 +799,7 @@ common_expr:
| "<bytes>" { EBytes $1 }
| "<ident>" | module_field { EVar $1 }
| projection { EProj $1 }
| "_" { EVar {value = "_"; region = $1} }
| update_record { EUpdate $1 }
| "<string>" { EString (String $1) }
| unit { EUnit $1 }

1
src/passes/1-parser/reasonligo/SyntaxError.ml
View File

@ -1,4 +1,5 @@
type error =
| WrongFunctionArguments of AST.expr
| InvalidWild of AST.expr
exception Error of error

1
src/passes/1-parser/reasonligo/SyntaxError.mli
View File

@ -1,4 +1,5 @@
type error =
| WrongFunctionArguments of AST.expr
| InvalidWild of AST.expr
exception Error of error

2193
src/passes/1-parser/reasonligo/error.messages.checked-in
View File

File diff suppressed because it is too large Load Diff

28
src/passes/10-interpreter/interpreter.ml
View File

@ -119,6 +119,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
| ( 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_EMPTY, []) -> ok @@ V_List ([])
| ( C_LIST_MAP , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) ->
let%bind elts' = bind_map_list
(fun elt ->
@ -170,6 +171,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
eval body env'
)
init elts
| ( C_MAP_EMPTY , []) -> ok @@ V_Map ([])
| ( C_MAP_FOLD , [ V_Func_val (arg_name, body, env) ; V_Map kvs ; init ] ) ->
bind_fold_list
(fun prev kv ->
@ -188,6 +190,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
| "None" -> ok @@ V_Map (List.remove_assoc k kvs)
| _ -> simple_fail "update without an option"
)
| ( C_SET_EMPTY, []) -> ok @@ V_Set ([])
| ( 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
@ -289,22 +292,6 @@ and eval : Ast_typed.expression -> env -> value 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 ->
@ -316,12 +303,12 @@ and eval : Ast_typed.expression -> env -> value result
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
| E_record_accessor { record ; path} -> (
let%bind record' = eval record env in
match record' with
| V_Record recmap ->
let%bind a = trace_option (simple_error "unknown record field") @@
LMap.find_opt label recmap in
LMap.find_opt path recmap in
ok a
| _ -> simple_fail "trying to access a non-record"
)
@ -378,9 +365,6 @@ and eval : Ast_typed.expression -> env -> value result
)
| E_recursive {fun_name; fun_type=_; lambda} ->
ok @@ V_Func_rec (fun_name, lambda.binder, lambda.result, env)
| E_look_up _ ->
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 ->

72
src/passes/10-transpiler/transpiler.ml
View File

@ -141,6 +141,8 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
| T_operator (TC_big_map (key,value)) ->
let%bind kv' = bind_map_pair transpile_type (key, value) in
ok (T_big_map kv')
| T_operator (TC_map_or_big_map (_,_)) ->
fail @@ corner_case ~loc:"transpiler" "TC_map_or_big_map should have been resolved before transpilation"
| T_operator (TC_list t) ->
let%bind t' = transpile_type t in
ok (T_list t')
@ -170,7 +172,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
aux node in
ok @@ snd m'
| T_record m ->
let node = Append_tree.of_list @@ kv_list_of_lmap m in
let node = Append_tree.of_list @@ Stage_common.Helpers.kv_list_of_record_or_tuple m in
let aux a b : type_value annotated result =
let%bind a = a in
let%bind b = b in
@ -189,7 +191,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
)
let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
let tys = kv_list_of_lmap tym in
let tys = Stage_common.Helpers.kv_list_of_record_or_tuple tym in
let node_tv = Append_tree.of_list tys in
let%bind path =
let aux (i , _) = i = ind in
@ -234,7 +236,6 @@ and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression
and transpile_annotated_expression (ae:AST.expression) : expression result =
let%bind tv = transpile_type ae.type_expression in
let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
let f = transpile_annotated_expression in
let info =
let title () = "translating expression" in
let content () = Format.asprintf "%a" Location.pp ae.location in
@ -289,7 +290,8 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return ~tv ae
)
| E_record m -> (
let node = Append_tree.of_list @@ list_of_lmap m in
(*list_of_lmap to record_to_list*)
let node = Append_tree.of_list @@ Stage_common.Helpers.list_of_record_or_tuple m in
let aux a b : expression result =
let%bind a = a in
let%bind b = b in
@ -301,21 +303,21 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
trace_strong (corner_case ~loc:__LOC__ "record build") @@
Append_tree.fold_ne (transpile_annotated_expression) aux node
)
| E_record_accessor {expr; label} ->
let%bind ty' = transpile_type (get_type_expression expr) in
| E_record_accessor {record; path} ->
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_expression expr) in
get_t_record (get_type_expression record) in
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_lmap label in
record_access_to_lr ty' ty'_lmap path 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 {cons_name=c;arguments=[pred]} , ty) in
let%bind record' = transpile_annotated_expression expr in
let%bind record' = transpile_annotated_expression record in
let expr = List.fold_left aux record' path in
ok expr
| E_record_update {record; path; update} ->
@ -390,58 +392,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
transpile_lambda l io
| E_recursive r ->
transpile_recursive r
| E_list lst -> (
let%bind t =
trace_strong (corner_case ~loc:__LOC__ "not a list") @@
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 {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'
)
| E_set lst -> (
let%bind t =
trace_strong (corner_case ~loc:__LOC__ "not a set") @@
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 {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'
)
| E_map m -> (
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.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 {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
)
| E_big_map m -> (
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.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 {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 {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']}
)
| E_matching {matchee=expr; cases=m} -> (
let%bind expr' = transpile_annotated_expression expr in
match m with

41
src/passes/10-transpiler/untranspiler.ml
View File

@ -151,29 +151,41 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
ok (e_a_empty_some s')
)
| TC_map (k_ty,v_ty)-> (
let%bind lst =
let%bind map =
trace_strong (wrong_mini_c_value "map" v) @@
get_map v in
let%bind lst' =
let%bind map' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
bind_map_list aux lst in
return (E_map lst')
bind_map_list aux map in
let map' = List.sort_uniq compare map' in
let aux = fun prev (k, v) ->
let (k', v') = (k , v ) in
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]}
in
let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in
bind_fold_right_list aux init map'
)
| TC_big_map (k_ty, v_ty) -> (
let%bind lst =
let%bind big_map =
trace_strong (wrong_mini_c_value "big_map" v) @@
get_big_map v in
let%bind lst' =
let%bind big_map' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
bind_map_list aux lst in
return (E_big_map lst')
bind_map_list aux big_map in
let big_map' = List.sort_uniq compare big_map' in
let aux = fun prev (k, v) ->
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k ; v ; prev]}
in
let%bind init = return @@ E_constant {cons_name=C_BIG_MAP_EMPTY;arguments=[]} in
bind_fold_right_list aux init big_map'
)
| TC_map_or_big_map (_, _) -> fail @@ corner_case ~loc:"untranspiler" "TC_map_or_big_map t should not be present in mini-c"
| TC_list ty -> (
let%bind lst =
trace_strong (wrong_mini_c_value "list" v) @@
@ -181,7 +193,10 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
let%bind lst' =
let aux = fun e -> untranspile e ty in
bind_map_list aux lst in
return (E_list lst')
let aux = fun prev cur ->
return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in
let%bind init = return @@ E_constant {cons_name=C_LIST_EMPTY;arguments=[]} in
bind_fold_right_list aux init lst'
)
| TC_arrow _ -> (
let%bind n =
@ -196,7 +211,11 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
let%bind lst' =
let aux = fun e -> untranspile e ty in
bind_map_list aux lst in
return (E_set lst')
let lst' = List.sort_uniq compare lst' in
let aux = fun prev cur ->
return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in
let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in
bind_fold_list aux init lst'
)
| TC_contract _ ->
fail @@ bad_untranspile "contract" v
@ -213,7 +232,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
let%bind sub = untranspile v tv in
return (E_constructor {constructor=Constructor name;element=sub})
| T_record m ->
let lst = kv_list_of_lmap m in
let lst = Stage_common.Helpers.kv_list_of_record_or_tuple m in
let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
| Full t -> ok t in

11
src/passes/11-self_mini_c/helpers.ml
View File

@ -25,12 +25,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind init' = f init e in
match e.content with
| E_variable _ | E_skip | E_make_none _
| E_make_empty_map _
| E_make_empty_big_map _
| E_make_empty_list _
| E_make_empty_set _ -> (
ok init'
)
| E_literal _ -> ok init'
| E_constant (c) -> (
let%bind res = bind_fold_list self init' c.arguments in
@ -94,10 +88,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let return content = ok { e' with content } in
match e'.content with
| E_variable _ | E_literal _ | E_skip | E_make_none _
| E_make_empty_map _
| E_make_empty_big_map _
| E_make_empty_list _
| E_make_empty_set _ as em -> return em
as em -> return em
| E_constant (c) -> (
let%bind lst = bind_map_list self c.arguments in
return @@ E_constant {cons_name = c.cons_name; arguments = lst}

6
src/passes/11-self_mini_c/michelson_restrictions.ml
View File

@ -5,9 +5,9 @@ module Errors = struct
let bad_self_address cst () =
let title = thunk @@
Format.asprintf "Wrong %alocation" Mini_c.PP.expression' cst in
Format.asprintf "Wrong %a location" Stage_common.PP.constant cst in
let message = thunk @@
Format.asprintf "%ais only allowed at top-level" Mini_c.PP.expression' cst in
Format.asprintf "%a is only allowed at top-level" Stage_common.PP.constant cst in
error title message ()
end
@ -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 {cons_name=C_SELF_ADDRESS; _} as c -> fail (bad_self_address c)
| E_constant {cons_name=C_SELF_ADDRESS; _} -> fail (bad_self_address C_SELF_ADDRESS)
| _ -> ok e)
body in
ok e

4
src/passes/11-self_mini_c/self_mini_c.ml
View File

@ -47,10 +47,6 @@ let rec is_pure : expression -> bool = fun e ->
| E_closure _
| E_skip
| E_variable _
| E_make_empty_map _
| E_make_empty_big_map _
| E_make_empty_list _
| E_make_empty_set _
| E_make_none _
-> true

71
src/passes/11-self_mini_c/subst.ml
View File

@ -40,10 +40,6 @@ let rec replace : expression -> var_name -> var_name -> expression =
| E_variable z ->
let z = replace_var z in
return @@ E_variable z
| E_make_empty_map _ -> e
| E_make_empty_big_map _ -> e
| E_make_empty_list _ -> e
| E_make_empty_set _ -> e
| E_make_none _ -> e
| E_iterator (name, ((v, tv), body), expr) ->
let body = replace body in
@ -175,10 +171,7 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
)
(* All that follows is boilerplate *)
| E_literal _ | E_skip | E_make_none _
| E_make_empty_map (_,_)
| E_make_empty_big_map _
| E_make_empty_list _
| E_make_empty_set _ as em -> return em
as em -> return em
| E_constant (c) -> (
let lst = List.map self c.arguments in
return @@ E_constant {cons_name = c.cons_name; arguments = lst }
@ -232,7 +225,7 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(V(x))[x := L(unit)] =
(x)[x := L(unit)] =
L(unit) |}] ;
(* other var *)
@ -242,8 +235,8 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(V(y))[x := L(unit)] =
V(y)
(y)[x := L(unit)] =
y
|}] ;
(* closure shadowed *)
@ -253,8 +246,8 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(C(fun x -> (V(x))))[x := L(unit)] =
C(fun x -> (V(x)))
(fun x -> (x))[x := L(unit)] =
fun x -> (x)
|}] ;
(* closure not shadowed *)
@ -264,8 +257,8 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(C(fun y -> (V(x))))[x := L(unit)] =
C(fun y -> (L(unit)))
(fun y -> (x))[x := L(unit)] =
fun y -> (L(unit))
|}] ;
(* closure capture-avoidance *)
@ -275,8 +268,8 @@ let%expect_test _ =
~x:x
~expr:(wrap (E_variable y)) ;
[%expect{|
(C(fun y -> ((V(x))@(V(y)))))[x := V(y)] =
C(fun y#1 -> ((V(y))@(V(y#1))))
(fun y -> ((x)@(y)))[x := y] =
fun y#1 -> ((y)@(y#1))
|}] ;
(* let-in shadowed (not in rhs) *)
@ -286,8 +279,8 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(let x = V(x) in ( V(x) ))[x := L(unit)] =
let x = L(unit) in ( V(x) )
(let x = x in x)[x := L(unit)] =
let x = L(unit) in x
|}] ;
(* let-in not shadowed *)
@ -297,8 +290,8 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(let y = V(x) in ( V(x) ))[x := L(unit)] =
let y = L(unit) in ( L(unit) )
(let y = x in x)[x := L(unit)] =
let y = L(unit) in L(unit)
|}] ;
(* let-in capture avoidance *)
@ -309,8 +302,8 @@ let%expect_test _ =
~x:x
~expr:(var y) ;
[%expect{|
(let y = V(x) in ( (V(x))@(V(y)) ))[x := V(y)] =
let y#1 = V(y) in ( (V(y))@(V(y#1)) )
(let y = x in (x)@(y))[x := y] =
let y#1 = y in (y)@(y#1)
|}] ;
(* iter shadowed *)
@ -320,8 +313,8 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(for_ITER x of V(x) do ( V(x) ))[x := L(unit)] =
for_ITER x of L(unit) do ( V(x) )
(for_ITER x of x do ( x ))[x := L(unit)] =
for_ITER x of L(unit) do ( x )
|}] ;
(* iter not shadowed *)
@ -331,7 +324,7 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(for_ITER y of V(x) do ( V(x) ))[x := L(unit)] =
(for_ITER y of x do ( x ))[x := L(unit)] =
for_ITER y of L(unit) do ( L(unit) )
|}] ;
@ -342,8 +335,8 @@ let%expect_test _ =
~x:x
~expr:(var y) ;
[%expect{|
(for_ITER y of (V(x))@(V(y)) do ( (V(x))@(V(y)) ))[x := V(y)] =
for_ITER y#1 of (V(y))@(V(y)) do ( (V(y))@(V(y#1)) )
(for_ITER y of (x)@(y) do ( (x)@(y) ))[x := y] =
for_ITER y#1 of (y)@(y) do ( (y)@(y#1) )
|}] ;
(* if_cons shadowed 1 *)
@ -356,8 +349,8 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(V(x) ?? V(x) : (x :: y) -> V(x))[x := L(unit)] =
L(unit) ?? L(unit) : (x :: y) -> V(x)
(x ?? x : (x :: y) -> x)[x := L(unit)] =
L(unit) ?? L(unit) : (x :: y) -> x
|}] ;
(* if_cons shadowed 2 *)
@ -370,8 +363,8 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(V(x) ?? V(x) : (y :: x) -> V(x))[x := L(unit)] =
L(unit) ?? L(unit) : (y :: x) -> V(x)
(x ?? x : (y :: x) -> x)[x := L(unit)] =
L(unit) ?? L(unit) : (y :: x) -> x
|}] ;
(* if_cons not shadowed *)
@ -384,7 +377,7 @@ let%expect_test _ =
~x:x
~expr:unit ;
[%expect{|
(V(x) ?? V(x) : (y :: z) -> V(x))[x := L(unit)] =
(x ?? x : (y :: z) -> x)[x := L(unit)] =
L(unit) ?? L(unit) : (y :: z) -> L(unit)
|}] ;
@ -398,8 +391,8 @@ let%expect_test _ =
~x:x
~expr:(var y) ;
[%expect{|
(V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(y)] =
V(y) ?? V(y) : (y#1 :: z) -> (V(y))@((V(y#1))@(V(z)))
(x ?? x : (y :: z) -> (x)@((y)@(z)))[x := y] =
y ?? y : (y#1 :: z) -> (y)@((y#1)@(z))
|}] ;
(* if_cons capture avoidance 2 *)
@ -412,8 +405,8 @@ let%expect_test _ =
~x:x
~expr:(var z) ;
[%expect{|
(V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(z)] =
V(z) ?? V(z) : (y :: z#1) -> (V(z))@((V(y))@(V(z#1)))
(x ?? x : (y :: z) -> (x)@((y)@(z)))[x := z] =
z ?? z : (y :: z#1) -> (z)@((y)@(z#1))
|}] ;
(* old bug *)
@ -424,6 +417,6 @@ let%expect_test _ =
~x:x
~expr:(var y) ;
[%expect{|
(C(fun y -> (C(fun y#1 -> ((V(x))@((V(y))@(V(y#1))))))))[x := V(y)] =
C(fun y#2 -> (C(fun y#1 -> ((V(y))@((V(y#2))@(V(y#1)))))))
(fun y -> (fun y#1 -> ((x)@((y)@(y#1)))))[x := y] =
fun y#2 -> (fun y#1 -> ((y)@((y#2)@(y#1))))
|}] ;

29
src/passes/12-compiler/compiler_program.ml
View File

@ -66,10 +66,25 @@ let rec get_operator : constant' -> type_value -> expression list -> predicate r
let%bind m_ty = Compiler_type.type_ ty in
ok @@ simple_unary @@ prim ~children:[m_ty] I_RIGHT
)
| C_LIST_EMPTY -> (
let%bind ty' = Mini_c.get_t_list ty in
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_constant @@ i_nil m_ty
)
| C_SET_EMPTY -> (
let%bind ty' = Mini_c.get_t_set ty in
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_constant @@ prim ~children:[m_ty] I_EMPTY_SET
ok @@ simple_constant @@ i_empty_set m_ty
)
| C_MAP_EMPTY -> (
let%bind sd = Mini_c.get_t_map ty in
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
ok @@ simple_constant @@ i_empty_map src dst
)
| C_BIG_MAP_EMPTY -> (
let%bind sd = Mini_c.get_t_big_map ty in
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
ok @@ simple_constant @@ i_empty_big_map src dst
)
| C_BYTES_UNPACK -> (
let%bind ty' = Mini_c.get_t_option ty in
@ -297,18 +312,6 @@ and translate_expression (expr:expression) (env:environment) : michelson result
error title content in
trace error @@
return code
| E_make_empty_map sd ->
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
return @@ i_empty_map src dst
| E_make_empty_big_map sd ->
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
return @@ i_empty_big_map src dst
| E_make_empty_list t ->
let%bind t' = Compiler_type.type_ t in
return @@ i_nil t'
| E_make_empty_set t ->
let%bind t' = Compiler_type.type_ t in
return @@ i_empty_set t'
| E_make_none o ->
let%bind o' = Compiler_type.type_ o in
return @@ i_none o'

21
src/passes/2-concrete_to_imperative/cameligo.ml
View File

@ -294,7 +294,7 @@ let rec compile_expression :
| Component index -> Z.to_string (snd index.value)
in
List.map aux @@ npseq_to_list path in
return @@ List.fold_left (e_accessor ~loc ) var path'
return @@ List.fold_left (e_record_accessor ~loc ) var path'
in
let compile_path : Raw.path -> string * label list = fun p ->
match p with
@ -319,7 +319,7 @@ let rec compile_expression :
let record = match path with
| [] -> e_variable (Var.of_name name)
| _ ->
let aux expr (Label l) = e_accessor expr l in
let aux expr (Label l) = e_record_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' =
@ -333,10 +333,10 @@ let rec compile_expression :
let aux ur (path, expr) =
let rec aux record = function
| [] -> failwith "error in parsing"
| hd :: [] -> ok @@ e_update ~loc record hd expr
| hd :: [] -> ok @@ e_record_update ~loc record hd expr
| hd :: tl ->
let%bind expr = (aux (e_accessor ~loc record hd) tl) in
ok @@ e_update ~loc record hd expr
let%bind expr = (aux (e_record_accessor ~loc record hd) tl) in
ok @@ e_record_update ~loc record hd expr
in
aux ur path in
bind_fold_list aux record updates'
@ -383,13 +383,12 @@ let rec compile_expression :
match variables with
| hd :: [] ->
if (List.length prep_vars = 1)
then e_let_in hd false inline rhs_b_expr body
else e_let_in hd false inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body
then e_let_in hd inline rhs_b_expr body
else e_let_in hd inline (e_record_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 (string_of_int ((List.length prep_vars) - (List.length tl) - 1)))
(e_record_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
@ -408,7 +407,7 @@ let rec compile_expression :
let%bind ret_expr = 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) false inline rhs' (chain_let_in prep_vars body))
else ok (e_let_in (rhs_b, ty_opt) inline rhs' (chain_let_in prep_vars body))
in
let%bind ret_expr = match kwd_rec with
| None -> ok @@ ret_expr
@ -572,7 +571,7 @@ let rec compile_expression :
| Raw.PVar y ->
let var_name = Var.of_name y.value in
let%bind type_expr = compile_type_expression x'.type_expr in
return @@ e_let_in (var_name , Some type_expr) false false e rhs
return @@ e_let_in (var_name , Some type_expr) false e rhs
| _ -> default_action ()
)
| _ -> default_action ()

1
src/passes/2-concrete_to_imperative/dune
View File

@ -6,7 +6,6 @@
tezos-utils
parser
ast_imperative
self_ast_imperative
operators)
(modules cameligo pascaligo concrete_to_imperative)
(preprocess

375
src/passes/2-concrete_to_imperative/pascaligo.ml
View File

@ -14,92 +14,6 @@ let pseq_to_list = function
| Some lst -> npseq_to_list lst
let get_value : 'a Raw.reg -> 'a = fun x -> x.value
and repair_mutable_variable_in_matching (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
let%bind captured_names = Self_ast_imperative.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.to_name 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_in_loops (for_body : expression) (element_names : expression_variable list) (env : expression_variable) =
let%bind captured_names = Self_ast_imperative.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.to_name 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.to_name var, e_variable var) in
e_record_ez (List.map aux free_vars)
and restore_mutable_variable (expr : expression->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.to_name 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 @@ expr (ef (e_skip ()))
| Some expr' -> ok @@ expr (ef expr')
module Errors = struct
let unsupported_cst_constr p =
let title () = "" in
@ -218,10 +132,10 @@ let r_split = Location.r_split
[return_statement] is used for non-let-in statements.
*)
let return_let_in ?loc binder mut inline rhs = ok @@ fun expr'_opt ->
let return_let_in ?loc binder inline rhs = ok @@ fun expr'_opt ->
match expr'_opt with
| None -> ok @@ e_let_in ?loc binder mut inline rhs (e_skip ())
| Some expr' -> ok @@ e_let_in ?loc binder mut inline rhs expr'
| None -> ok @@ e_let_in ?loc binder inline rhs (e_skip ())
| Some expr' -> ok @@ e_let_in ?loc binder inline rhs expr'
let return_statement expr = ok @@ fun expr'_opt ->
match expr'_opt with
@ -306,7 +220,7 @@ let compile_projection : Raw.projection Region.reg -> _ = fun p ->
| Component index -> (Z.to_string (snd index.value))
in
List.map aux @@ npseq_to_list path in
ok @@ List.fold_left (e_accessor ~loc) var path'
ok @@ List.fold_left (e_record_accessor ~loc) var path'
let rec compile_expression (t:Raw.expr) : expr result =
@ -433,10 +347,7 @@ let rec compile_expression (t:Raw.expr) : expr result =
let%bind expr = compile_expression c.test in
let%bind match_true = compile_expression c.ifso in
let%bind match_false = compile_expression c.ifnot in
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_in_matching match_expr [] env in
return @@ match_expr
return @@ e_matching expr ~loc (Match_bool {match_true; match_false})
| ECase c -> (
let (c , loc) = r_split c in
@ -450,10 +361,7 @@ let rec compile_expression (t:Raw.expr) : expr result =
@@ List.map get_value
@@ npseq_to_list c.cases.value in
let%bind cases = compile_cases lst in
let match_expr = e_matching ~loc e cases in
let env = Var.fresh () in
let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in
return @@ match_expr
return @@ e_matching ~loc e cases
)
| EMap (MapInj mi) -> (
let (mi , loc) = r_split mi in
@ -515,10 +423,10 @@ and compile_update = fun (u:Raw.update Region.reg) ->
let aux ur (path, expr) =
let rec aux record = function
| [] -> failwith "error in parsing"
| hd :: [] -> ok @@ e_update ~loc record hd expr
| hd :: [] -> ok @@ e_record_update ~loc record hd expr
| hd :: tl ->
let%bind expr = (aux (e_accessor ~loc record hd) tl) in
ok @@ e_update ~loc record hd expr
let%bind expr = (aux (e_record_accessor ~loc record hd) tl) in
ok @@ e_record_update ~loc record hd expr
in
aux ur path in
bind_fold_list aux record updates'
@ -615,7 +523,7 @@ and compile_data_declaration : Raw.data_decl -> _ result =
let name = x.name.value in
let%bind t = compile_type_expression x.var_type in
let%bind expression = compile_expression x.init in
return_let_in ~loc (Var.of_name name, Some t) false false expression
return_let_in ~loc (Var.of_name name, Some t) false expression
| LocalConst x ->
let (x , loc) = r_split x in
let name = x.name.value in
@ -627,7 +535,7 @@ and compile_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) false inline expression
in return_let_in ~loc (Var.of_name name, Some t) inline expression
| LocalFun f ->
let (f , loc) = r_split f in
let%bind (binder, expr) = compile_fun_decl ~loc f in
@ -637,7 +545,7 @@ and compile_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 false inline expr
in return_let_in ~loc binder inline expr
and compile_param :
Raw.param_decl -> (string * type_expression) result =
@ -706,9 +614,9 @@ and compile_fun_decl :
let%bind tpl_declarations =
let aux = fun i (param, type_expr) ->
let expr =
e_accessor (e_variable arguments_name) (string_of_int i) in
e_record_accessor (e_variable arguments_name) (string_of_int i) in
let type_variable = Some type_expr in
let ass = return_let_in (Var.of_name param , type_variable) false inline expr in
let ass = return_let_in (Var.of_name param , type_variable) inline expr in
ass
in
bind_list @@ List.mapi aux params in
@ -769,9 +677,9 @@ and compile_fun_expression :
(arguments_name , type_expression) in
let%bind tpl_declarations =
let aux = fun i (param, param_type) ->
let expr = e_accessor (e_variable arguments_name) (string_of_int i) in
let expr = e_record_accessor (e_variable arguments_name) (string_of_int i) in
let type_variable = Some param_type in
let ass = return_let_in (Var.of_name param , type_variable) false false expr in
let ass = return_let_in (Var.of_name param , type_variable) false expr in
ass
in
bind_list @@ List.mapi aux params in
@ -819,35 +727,6 @@ and compile_statement_list statements =
hook (compile_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 compile_single_instruction : Raw.instruction -> (_ -> expression result) result =
fun t ->
match t with
@ -877,14 +756,33 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
return_statement @@ e_skip ~loc ()
)
| Loop (While l) ->
compile_while_loop l.value
let (wl, loc) = r_split l in
let%bind condition = compile_expression wl.cond in
let%bind body = compile_block wl.block.value in
let%bind body = body @@ None in
return_statement @@ e_while ~loc condition body
| Loop (For (ForInt fi)) -> (
let%bind loop = compile_for_int fi.value in
ok loop
let (fi,loc) = r_split fi in
let binder = Var.of_name fi.assign.value.name.value in
let%bind start = compile_expression fi.assign.value.expr in
let%bind bound = compile_expression fi.bound in
let increment = e_int 1 in
let%bind body = compile_block fi.block.value in
let%bind body = body @@ None in
return_statement @@ e_for ~loc binder start bound increment body
)
| Loop (For (ForCollect fc)) ->
let%bind loop = compile_for_collect fc.value in
ok loop
let (fc,loc) = r_split fc in
let binder = (Var.of_name fc.var.value, Option.map (fun x -> Var.of_name (snd x:string Raw.reg).value) fc.bind_to) in
let%bind collection = compile_expression fc.expr in
let collection_type = match fc.collection with
| Map _ -> Map
| Set _ -> Set
| List _ -> List
in
let%bind body = compile_block fc.block.value in
let%bind body = body @@ None in
return_statement @@ e_for_each ~loc binder collection collection_type body
| Cond c -> (
let (c , loc) = r_split c in
let%bind expr = compile_expression c.test in
@ -906,26 +804,10 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
compile_block value
| ShortBlock {value; _} ->
compile_statements @@ fst value.inside in
let env = Var.fresh () in
let%bind match_true' = match_true None in
let%bind match_false' = match_false None in
let%bind match_true = match_true @@ Some (e_variable env) in
let%bind match_false = match_false @@ Some (e_variable env) in
let%bind ((_,free_vars_true), match_true) = repair_mutable_variable_in_matching match_true [] env in
let%bind ((_,free_vars_false), match_false) = repair_mutable_variable_in_matching 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 = fun expr ->
e_let_in (env,None) false false (store_mutable_variable free_vars) @@
e_let_in (env,None) false false match_expr @@
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'})
let%bind match_true = match_true None in
let%bind match_false = match_false None in
return_statement @@ e_matching expr ~loc (Match_bool {match_true; match_false})
)
| Assign a -> (
let (a , loc) = r_split a in
@ -933,8 +815,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
match a.lhs with
| Path path -> (
let (name , path') = compile_path path in
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in
return_let_in let_binder mut inline rhs
return_statement @@ e_ez_assign ~loc name path' value_expr
)
| MapPath v -> (
let v' = v.value in
@ -947,16 +828,14 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in
let%bind key_expr = compile_expression v'.index.value.inside in
let expr' = e_map_add key_expr value_expr map in
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in
return_let_in let_binder mut inline rhs
return_statement @@ e_ez_assign ~loc varname path expr'
)
)
| CaseInstr c -> (
let (c , loc) = r_split c in
let%bind expr = compile_expression c.expr in
let env = Var.fresh () in
let%bind (fv,cases) =
let aux fv (x : Raw.if_clause Raw.case_clause Raw.reg) =
let%bind cases =
let aux (x : Raw.if_clause Raw.case_clause Raw.reg) =
let%bind case_clause =
match x.value.rhs with
ClauseInstr i ->
@ -967,28 +846,13 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
compile_block value
| ShortBlock {value; _} ->
compile_statements @@ fst value.inside in
let%bind case_clause'= case_clause @@ None in
let%bind case_clause = case_clause @@ Some(e_variable env) in
let%bind case_vars = get_case_variables x.value.pattern in
let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching case_clause case_vars env in
ok (free_vars::fv,(x.value.pattern, case_clause, case_clause')) in
bind_fold_map_list aux [] (npseq_to_list c.cases.value) in
let free_vars = List.concat fv in
if (List.length free_vars == 0) then (
let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
let%bind m = compile_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 = compile_cases cases in
let match_expr = e_matching ~loc expr m in
let return_expr = fun expr ->
e_let_in (env,None) false false (store_mutable_variable free_vars) @@
e_let_in (env,None) false false match_expr @@
expr
in
restore_mutable_variable return_expr free_vars env
)
let%bind case_clause = case_clause None in
ok (x.value.pattern, case_clause) in
bind_list
@@ List.map aux
@@ npseq_to_list c.cases.value in
let%bind m = compile_cases cases in
return_statement @@ e_matching ~loc expr m
)
| RecordPatch r -> (
let reg = r.region in
@ -1004,9 +868,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
let%bind expr = compile_update {value=u;region=reg} in
let (name , access_path) = compile_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
return_statement @@ e_ez_assign ~loc name access_path expr
)
| MapPatch patch -> (
@ -1029,8 +891,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
inj
(e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
return_let_in binder mut inline rhs
return_statement @@ e_ez_assign ~loc name access_path assigns
)
| SetPatch patch -> (
let (setp, loc) = r_split patch in
@ -1045,8 +906,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
let assigns = List.fold_right
(fun hd s -> e_constant C_SET_ADD [hd ; s])
inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
return_let_in binder mut inline rhs
return_statement @@ e_ez_assign ~loc name access_path assigns
)
| MapRemove r -> (
let (v , loc) = r_split r in
@ -1060,8 +920,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in
let%bind key' = compile_expression key in
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
return_let_in binder mut inline rhs
return_statement @@ e_ez_assign ~loc varname path expr
)
| SetRemove r -> (
let (set_rm, loc) = r_split r in
@ -1074,8 +933,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
in
let%bind removed' = compile_expression set_rm.element in
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
return_let_in binder mut inline rhs
return_statement @@ e_ez_assign ~loc varname path expr
)
and compile_path : Raw.path -> string * string list = fun p ->
@ -1204,121 +1062,6 @@ and compile_statements : Raw.statements -> (_ -> expression result) result =
and compile_block : Raw.block -> (_ -> expression result) result =
fun t -> compile_statements t.statements
and compile_while_loop : Raw.while_loop -> (_ -> expression result) result = fun wl ->
let env_rec = Var.fresh () in
let binder = Var.fresh () in
let%bind cond = compile_expression wl.cond in
let ctrl =
(e_variable binder)
in
let%bind for_body = compile_block wl.block.value in
let%bind for_body = for_body @@ Some( ctrl ) in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder 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 init_rec = e_tuple [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_FOLD_CONTINUE [for_body] in
let stop_expr = e_constant C_FOLD_STOP [e_variable binder] in
let aux_func =
e_lambda binder None None @@
restore @@
e_cond cond continue_expr stop_expr in
let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in
let return_expr = fun expr ->
e_let_in (env_rec,None) false false init_rec @@
e_let_in (env_rec,None) false false loop @@
e_let_in (env_rec,None) false false (e_accessor (e_variable env_rec) "0") @@
expr
in
restore_mutable_variable return_expr captured_name_list env_rec
and compile_for_int : Raw.for_int -> (_ -> expression result) result = fun fi ->
let env_rec = Var.fresh () in
let binder = Var.fresh () in
let name = fi.assign.value.name.value in
let it = Var.of_name name in
let var = e_variable it in
(*Make the cond and the step *)
let%bind value = compile_expression fi.assign.value.expr in
let%bind bound = compile_expression fi.bound in
let cond = e_annotation (e_constant C_LE [var ; bound]) t_bool in
let step = e_int 1 in
let continue_expr = e_constant C_FOLD_CONTINUE [(e_variable binder)] in
let ctrl =
e_let_in (it,Some t_int) false false (e_constant C_ADD [ var ; step ]) @@
e_let_in (binder, None) false false (e_update (e_variable binder) "1" var)@@
continue_expr
in
(* Modify the body loop*)
let%bind for_body = compile_block fi.block.value in
let%bind for_body = for_body @@ Some ctrl in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [it] binder 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
(* restores the initial value of the free_var*)
let restore = fun expr -> List.fold_right aux captured_name_list expr in
(*Prep the lambda for the fold*)
let stop_expr = e_constant C_FOLD_STOP [e_variable binder] in
let aux_func = e_lambda binder None None @@
e_let_in (it,Some t_int) false false (e_accessor (e_variable binder) "1") @@
e_cond cond (restore for_body) (stop_expr) in
(* Make the fold_while en precharge the vakye *)
let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in
let init_rec = e_pair (store_mutable_variable @@ captured_name_list) var in
let return_expr = fun expr ->
e_let_in (it, Some t_int) false false value @@
e_let_in (env_rec,None) false false init_rec @@
e_let_in (env_rec,None) false false loop @@
e_let_in (env_rec,None) false false (e_accessor (e_variable env_rec) "0") @@
expr
in
restore_mutable_variable return_expr captured_name_list env_rec
and compile_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc ->
let binder = Var.of_name "arguments" in
let%bind element_names = ok @@ match fc.bind_to with
| Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value]
| None -> [Var.of_name fc.var.value] in
let env = Var.fresh () in
let%bind for_body = compile_block fc.block.value in
let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in
let%bind ((_,free_vars), for_body) = repair_mutable_variable_in_loops for_body element_names binder in
let init_record = store_mutable_variable free_vars in
let%bind collect = compile_expression fc.expr 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 = fun expr ->
e_let_in (env,None) false false (e_constant op_name [lambda; collect ; init_record]) @@
expr
in
restore_mutable_variable fold free_vars env
and compile_declaration_list declarations : declaration Location.wrap list result =
let open Raw in

2
src/passes/3-self_ast_imperative/entrypoints_length_limit.ml
View File

@ -11,7 +11,7 @@ end
open Errors
let peephole_type_expression : type_expression -> type_expression result = fun e ->
let return type_content = ok { e with type_content } in
let return type_content = ok {type_content } in
match e.type_content with
| T_sum cmap ->
let%bind _uu = bind_map_cmapi

128
src/passes/3-self_ast_imperative/helpers.ml
View File

@ -47,8 +47,25 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = fold_expression self res update in
ok res
)
| E_record_accessor {expr} -> (
let%bind res = self init' expr in
| E_record_accessor {record} -> (
let%bind res = self init' record in
ok res
)
| E_tuple t -> (
let aux init'' expr =
let%bind res = fold_expression self init'' expr in
ok res
in
let%bind res = bind_fold_list aux (init') t in
ok res
)
| E_tuple_update {tuple;update} -> (
let%bind res = self init' tuple in
let%bind res = fold_expression self res update in
ok res
)
| E_tuple_accessor {tuple} -> (
let%bind res = self init' tuple in
ok res
)
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
@ -59,10 +76,30 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
| E_recursive { lambda={result=e;_}; _} ->
let%bind res = self init' e in
ok res
| E_cond {condition; then_clause; else_clause} ->
let%bind res = self init' condition in
let%bind res = self res then_clause in
let%bind res = self res else_clause in
ok res
| E_sequence {expr1;expr2} ->
let ab = (expr1,expr2) in
let%bind res = bind_fold_pair self init' ab in
ok res
| E_assign {variable=_;access_path=_;expression} ->
let%bind res = self init' expression in
ok res
| E_for {body; _} ->
let%bind res = self init' body in
ok res
| E_for_each {collection; body; _} ->
let%bind res = self init' collection in
let%bind res = self res body in
ok res
| E_while {condition; body} ->
let%bind res = self init' condition in
let%bind res = self res body in
ok res
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
@ -134,8 +171,8 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
return @@ E_matching {matchee=e';cases=cases'}
)
| E_record_accessor acc -> (
let%bind e' = self acc.expr in
return @@ E_record_accessor {acc with expr = e'}
let%bind e' = self acc.record in
return @@ E_record_accessor {acc with record = e'}
)
| E_record m -> (
let%bind m' = bind_map_lmap self m in
@ -146,6 +183,19 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind update = self update in
return @@ E_record_update {record;path;update}
)
| E_tuple t -> (
let%bind t' = bind_map_list self t in
return @@ E_tuple t'
)
| E_tuple_update {tuple; path; update} -> (
let%bind tuple = self tuple in
let%bind update = self update in
return @@ E_tuple_update {tuple; path; update}
)
| E_tuple_accessor {tuple;path} -> (
let%bind tuple = self tuple in
return @@ E_tuple_accessor {tuple;path}
)
| E_constructor c -> (
let%bind e' = self c.element in
return @@ E_constructor {c with element = e'}
@ -155,10 +205,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind (lamb,args) = bind_map_pair self ab in
return @@ E_application {lamb;args}
)
| E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
| E_let_in { let_binder ; rhs ; let_result; inline } -> (
let%bind rhs = self rhs in
let%bind let_result = self let_result in
return @@ E_let_in { let_binder ; mut; rhs ; let_result; inline }
return @@ E_let_in { let_binder ; rhs ; let_result; inline }
)
| E_lambda { binder ; input_type ; output_type ; result } -> (
let%bind result = self result in
@ -172,16 +222,37 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind args = bind_map_list self c.arguments in
return @@ E_constant {c with arguments=args}
)
| E_cond {condition; then_clause; else_clause} ->
let%bind condition = self condition in
let%bind then_clause = self then_clause in
let%bind else_clause = self else_clause in
return @@ E_cond {condition;then_clause;else_clause}
| E_sequence {expr1;expr2} -> (
let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in
return @@ E_sequence {expr1;expr2}
)
| E_assign {variable;access_path;expression} -> (
let%bind expression = self expression in
return @@ E_assign {variable;access_path;expression}
)
| E_for {binder; start; final; increment; body} ->
let%bind body = self body in
return @@ E_for {binder; start; final; increment; body}
| E_for_each {binder; collection; collection_type; body} ->
let%bind collection = self collection in
let%bind body = self body in
return @@ E_for_each {binder; collection; collection_type; body}
| E_while {condition; body} ->
let%bind condition = self condition in
let%bind body = self body in
return @@ E_while {condition; body}
| E_literal _ | E_variable _ | E_skip as e' -> return e'
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
let self = map_type_expression f in
let%bind te' = f te in
let return type_content = ok { te' with type_content } in
let return type_content = ok { type_content } in
match te'.type_content with
| T_sum temap ->
let%bind temap' = bind_map_cmap self temap in
@ -189,6 +260,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
| T_record temap ->
let%bind temap' = bind_map_lmap self temap in
return @@ (T_record temap')
| T_tuple telst ->
let%bind telst' = bind_map_list self telst in
return @@ (T_tuple telst')
| T_arrow {type1 ; type2} ->
let%bind type1' = self type1 in
let%bind type2' = self type2 in
@ -280,8 +354,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
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'})
let%bind (res, e') = self init' acc.record in
ok (res, return @@ E_record_accessor {acc with record = 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
@ -293,6 +367,19 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res, update) = self res update in
ok (res, return @@ E_record_update {record;path;update})
)
| E_tuple t -> (
let%bind (res, t') = bind_fold_map_list self init' t in
ok (res, return @@ E_tuple t')
)
| E_tuple_update {tuple; path; update} -> (
let%bind (res, tuple) = self init' tuple in
let%bind (res, update) = self res update in
ok (res, return @@ E_tuple_update {tuple;path;update})
)
| E_tuple_accessor {tuple; path} -> (
let%bind (res, tuple) = self init' tuple in
ok (res, return @@ E_tuple_accessor {tuple; path})
)
| E_constructor c -> (
let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'})
@ -302,10 +389,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
ok (res, return @@ E_application {lamb=a;args=b})
)
| E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
| E_let_in { let_binder ; rhs ; let_result; inline } -> (
let%bind (res,rhs) = self init' rhs in
let%bind (res,let_result) = self res let_result in
ok (res, return @@ E_let_in { let_binder ; mut; rhs ; let_result ; inline })
ok (res, return @@ E_let_in { let_binder ; rhs ; let_result ; inline })
)
| E_lambda { binder ; input_type ; output_type ; result } -> (
let%bind (res,result) = self init' result in
@ -319,10 +406,29 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,args) = bind_fold_map_list self init' c.arguments in
ok (res, return @@ E_constant {c with arguments=args})
)
| E_cond {condition; then_clause; else_clause} ->
let%bind res,condition = self init' condition in
let%bind res,then_clause = self res then_clause in
let%bind res,else_clause = self res else_clause in
ok (res, return @@ E_cond {condition;then_clause;else_clause})
| E_sequence {expr1;expr2} -> (
let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in
ok (res, return @@ E_sequence {expr1;expr2})
)
| E_assign {variable;access_path;expression} ->
let%bind (res, expression) = self init' expression in
ok (res, return @@ E_assign {variable;access_path;expression})
| E_for {binder; start; final; increment; body} ->
let%bind (res, body) = self init' body in
ok (res, return @@ E_for {binder; start; final; increment; body})
| E_for_each {binder; collection; collection_type; body} ->
let%bind res,collection = self init' collection in
let%bind res,body = self res body in
ok (res, return @@ E_for_each {binder; collection; collection_type; body})
| E_while {condition; body} ->
let%bind res,condition = self init' condition in
let%bind res,body = self res body in
ok (res, return @@ E_while {condition; body})
| 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 ->

1
src/passes/4-imperative_to_sugar/dune
View File

@ -5,6 +5,7 @@
simple-utils
ast_imperative
ast_sugar
self_ast_sugar
proto-alpha-utils
)
(preprocess

454
src/passes/4-imperative_to_sugar/imperative_to_sugar.ml
View File

@ -2,6 +2,105 @@ module I = Ast_imperative
module O = Ast_sugar
open Trace
module Errors = struct
let bad_collection expr =
let title () = "" in
let message () = Format.asprintf "\nCannot loop over this collection : %a\n" I.PP.expression expr in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp expr.location)
] in
error ~data title message
end
let rec add_to_end (expression: O.expression) to_add =
match expression.expression_content with
| O.E_let_in lt ->
let lt = {lt with let_result = add_to_end lt.let_result to_add} in
{expression with expression_content = O.E_let_in lt}
| O.E_sequence seq ->
let seq = {seq with expr2 = add_to_end seq.expr2 to_add} in
{expression with expression_content = O.E_sequence seq}
| _ -> O.e_sequence expression to_add
let repair_mutable_variable_in_matching (match_body : O.expression) (element_names : O.expression_variable list) (env : I.expression_variable) =
let%bind ((dv,fv),mb) = Self_ast_sugar.fold_map_expression
(* TODO : these should use Variables sets *)
(fun (decl_var,free_var : O.expression_variable list * O.expression_variable list) (ass_exp : O.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),O.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), O.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 = O.e_let_in (env,None) false false (O.e_record_update (O.e_variable env) (O.Label (Var.to_name name)) (O.e_variable name)) let_result in
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
)
| 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,[])
match_body in
ok @@ ((dv,fv),mb)
and repair_mutable_variable_in_loops (for_body : O.expression) (element_names : O.expression_variable list) (env : O.expression_variable) =
let%bind ((dv,fv),fb) = Self_ast_sugar.fold_map_expression
(* TODO : these should use Variables sets *)
(fun (decl_var,free_var : O.expression_variable list * O.expression_variable list) (ass_exp : O.expression) ->
(* Format.printf "debug: dv:%a; fv:%a; expr:%a \n%!"
(I.PP.list_sep_d I.PP.expression_variable) decl_var
(I.PP.list_sep_d I.PP.expression_variable) decl_var
O.PP.expression ass_exp
;*)
match ass_exp.expression_content with
| E_let_in {let_binder;mut=false;} ->
let (name,_) = let_binder in
ok (true,(name::decl_var, free_var),ass_exp)
| 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), O.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 = O.e_let_in (env,None) false false (
O.e_record_update (O.e_variable env) (Label "0")
(O.e_record_update (O.e_record_accessor (O.e_variable env) (Label "0")) (Label (Var.to_name name)) (O.e_variable name))
)
let_result in
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
)
| 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 @@ ((dv,fv),fb)
and store_mutable_variable (free_vars : I.expression_variable list) =
if (List.length free_vars == 0) then
O.e_unit ()
else
let aux var = (O.Label (Var.to_name var), O.e_variable var) in
O.e_record @@ O.LMap.of_list (List.map aux free_vars)
and restore_mutable_variable (expr : O.expression->O.expression_content) (free_vars : O.expression_variable list) (env : O.expression_variable) =
let aux (f: O.expression -> O.expression) (ev: O.expression_variable) =
fun expr -> f (O.e_let_in (ev,None) true false (O.e_record_accessor (O.e_variable env) (Label (Var.to_name ev))) expr)
in
let ef = List.fold_left aux (fun e -> e) free_vars in
expr (ef (O.e_skip ()))
let rec compile_type_expression : I.type_expression -> O.type_expression result =
fun te ->
let return te = ok @@ O.make_t te in
@ -24,6 +123,9 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
) record
in
return @@ O.T_record (O.LMap.of_list record)
| I.T_tuple tuple ->
let%bind tuple = bind_map_list compile_type_expression tuple in
return @@ O.T_tuple tuple
| I.T_arrow {type1;type2} ->
let%bind type1 = compile_type_expression type1 in
let%bind type2 = compile_type_expression type2 in
@ -61,7 +163,7 @@ and compile_type_operator : I.type_operator -> O.type_operator result =
let rec compile_expression : I.expression -> O.expression result =
fun e ->
let return expr = ok @@ O.make_expr ~loc:e.location expr in
let return expr = ok @@ O.make_e ~loc:e.location expr in
match e.expression_content with
| I.E_literal literal -> return @@ O.E_literal literal
| I.E_constant {cons_name;arguments} ->
@ -79,19 +181,18 @@ let rec compile_expression : I.expression -> O.expression result =
let%bind fun_type = compile_type_expression fun_type in
let%bind lambda = compile_lambda lambda in
return @@ O.E_recursive {fun_name;fun_type;lambda}
| I.E_let_in {let_binder;mut=_;inline;rhs;let_result} ->
| I.E_let_in {let_binder;inline;rhs;let_result} ->
let (binder,ty_opt) = let_binder in
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
let%bind rhs = compile_expression rhs in
let%bind let_result = compile_expression let_result in
return @@ O.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
return @@ O.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result}
| I.E_constructor {constructor;element} ->
let%bind element = compile_expression element in
return @@ O.E_constructor {constructor;element}
| I.E_matching {matchee; cases} ->
let%bind matchee = compile_expression matchee in
let%bind cases = compile_matching cases in
return @@ O.E_matching {matchee;cases}
| I.E_matching m ->
let%bind m = compile_matching m in
return @@ m
| I.E_record record ->
let record = I.LMap.to_kv_list record in
let%bind record =
@ -101,9 +202,9 @@ let rec compile_expression : I.expression -> O.expression result =
) record
in
return @@ O.E_record (O.LMap.of_list record)
| I.E_record_accessor {expr;label} ->
let%bind expr = compile_expression expr in
return @@ O.E_record_accessor {expr;label}
| I.E_record_accessor {record;path} ->
let%bind record = compile_expression record in
return @@ O.E_record_accessor {record;path}
| I.E_record_update {record;path;update} ->
let%bind record = compile_expression record in
let%bind update = compile_expression update in
@ -133,46 +234,305 @@ let rec compile_expression : I.expression -> O.expression result =
let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = compile_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation}
| I.E_cond {condition;then_clause;else_clause} ->
let%bind condition = compile_expression condition in
let%bind then_clause' = compile_expression then_clause in
let%bind else_clause' = compile_expression else_clause in
let env = Var.fresh () in
let%bind ((_,free_vars_true), then_clause) = repair_mutable_variable_in_matching then_clause' [] env in
let%bind ((_,free_vars_false), else_clause) = repair_mutable_variable_in_matching else_clause' [] env in
let then_clause = add_to_end then_clause (O.e_variable env) in
let else_clause = add_to_end else_clause (O.e_variable env) in
let free_vars = List.sort_uniq Var.compare @@ free_vars_true @ free_vars_false in
if (List.length free_vars != 0) then
let cond_expr = O.e_cond condition then_clause else_clause in
let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars);
let_result=O.e_let_in (env,None) false false cond_expr @@
expr
}
in
return @@ restore_mutable_variable return_expr free_vars env
else
return @@ O.E_cond {condition; then_clause=then_clause'; else_clause=else_clause'}
| I.E_sequence {expr1; expr2} ->
let%bind expr1 = compile_expression expr1 in
let%bind expr2 = compile_expression expr2 in
return @@ O.E_sequence {expr1; expr2}
ok @@ add_to_end expr1 expr2
| I.E_skip -> return @@ O.E_skip
| I.E_tuple tuple ->
let%bind tuple = bind_map_list compile_expression tuple in
return @@ O.E_tuple (tuple)
| I.E_tuple_accessor {tuple;path} ->
let%bind tuple = compile_expression tuple in
return @@ O.E_tuple_accessor {tuple;path}
| I.E_tuple_update {tuple;path;update} ->
let%bind tuple = compile_expression tuple in
let%bind update = compile_expression update in
return @@ O.E_tuple_update {tuple;path;update}
| I.E_assign ass ->
let%bind content = compile_assign ass @@ O.e_skip () in
return @@ content
| I.E_for f ->
let%bind f = compile_for f in
return @@ f
| I.E_for_each fe ->
let%bind fe = compile_for_each fe in
return @@ fe
| I.E_while w ->
let%bind w = compile_while w in
return @@ w
and compile_assign {variable; access_path; expression} expr =
let accessor ?loc s a =
match a with
I.Access_tuple _i -> failwith "adding tuple soon"
| I.Access_record a -> ok @@ O.e_record_accessor ?loc s (Label a)
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;s]
in
let update ?loc (s:O.expression) a e =
match a with
I.Access_tuple _i -> failwith "adding tuple soon"
| I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) e
| I.Access_map k ->
let%bind k = compile_expression k in
ok @@ O.e_constant ?loc C_UPDATE [k;O.e_some (e);s]
in
let aux (s, e : O.expression * _) lst =
let%bind s' = accessor ~loc:s.location s lst in
let e' = fun expr ->
let%bind u = update ~loc:s.location s lst (expr)
in e u
in
ok @@ (s',e')
in
let%bind (_,rhs) = bind_fold_list aux (O.e_variable variable, fun e -> ok @@ e) access_path in
let%bind expression = compile_expression expression in
let%bind rhs = rhs @@ expression in
ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false}
and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option compile_type_expression input_type in
let%bind output_type = bind_map_option compile_type_expression output_type in
let%bind result = compile_expression result in
ok @@ O.{binder;input_type;output_type;result}
and compile_matching : I.matching_expr -> O.matching_expr result =
fun m ->
match m with
and compile_matching : I.matching -> O.expression_content result =
fun {matchee;cases} ->
let%bind matchee = compile_expression matchee in
match cases with
| I.Match_bool {match_true;match_false} ->
let%bind match_true = compile_expression match_true in
let%bind match_false = compile_expression match_false in
ok @@ O.Match_bool {match_true;match_false}
| I.Match_list {match_nil;match_cons} ->
let%bind match_nil = compile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in
let%bind expr = compile_expression expr in
ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
let%bind match_true' = compile_expression match_true in
let%bind match_false' = compile_expression match_false in
let env = Var.fresh () in
let%bind ((_,free_vars_true), match_true) = repair_mutable_variable_in_matching match_true' [] env in
let%bind ((_,free_vars_false), match_false) = repair_mutable_variable_in_matching match_false' [] env in
let match_true = add_to_end match_true (O.e_variable env) in
let match_false = add_to_end match_false (O.e_variable env) in
let free_vars = List.sort_uniq Var.compare @@ free_vars_true @ free_vars_false in
if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_bool {match_true; match_false}) in
let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars);
let_result=O.e_let_in (env,None) false false match_expr @@
expr
}
in
ok @@ restore_mutable_variable return_expr free_vars env
else
ok @@ O.E_matching {matchee;cases=O.Match_bool {match_true=match_true';match_false=match_false'}}
| I.Match_option {match_none;match_some} ->
let%bind match_none = compile_expression match_none in
let%bind match_none' = compile_expression match_none in
let (n,expr,tv) = match_some in
let%bind expr = compile_expression expr in
ok @@ O.Match_option {match_none; match_some=(n,expr,tv)}
let%bind expr' = compile_expression expr in
let env = Var.fresh () in
let%bind ((_,free_vars_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in
let%bind ((_,free_vars_some), expr) = repair_mutable_variable_in_matching expr' [n] env in
let match_none = add_to_end match_none (O.e_variable env) in
let expr = add_to_end expr (O.e_variable env) in
let free_vars = List.sort_uniq Var.compare @@ free_vars_none @ free_vars_some in
if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr,tv)}) in
let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars);
let_result=O.e_let_in (env,None) false false match_expr @@
expr
}
in
ok @@ restore_mutable_variable return_expr free_vars env
else
ok @@ O.E_matching {matchee; cases=O.Match_option {match_none=match_none'; match_some=(n,expr',tv)}}
| I.Match_list {match_nil;match_cons} ->
let%bind match_nil' = compile_expression match_nil in
let (hd,tl,expr,tv) = match_cons in
let%bind expr' = compile_expression expr in
let env = Var.fresh () in
let%bind ((_,free_vars_nil), match_nil) = repair_mutable_variable_in_matching match_nil' [] env in
let%bind ((_,free_vars_cons), expr) = repair_mutable_variable_in_matching expr' [hd;tl] env in
let match_nil = add_to_end match_nil (O.e_variable env) in
let expr = add_to_end expr (O.e_variable env) in
let free_vars = List.sort_uniq Var.compare @@ free_vars_nil @ free_vars_cons in
if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}) in
let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars);
let_result=O.e_let_in (env,None) false false match_expr @@
expr
}
in
ok @@ restore_mutable_variable return_expr free_vars env
else
ok @@ O.E_matching {matchee;cases=O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)}}
| I.Match_tuple ((lst,expr), tv) ->
let%bind expr = compile_expression expr in
ok @@ O.Match_tuple ((lst,expr), tv)
ok @@ O.E_matching {matchee; cases=O.Match_tuple ((lst,expr), tv)}
| I.Match_variant (lst,tv) ->
let%bind lst = bind_map_list (
fun ((c,n),expr) ->
let%bind expr = compile_expression expr in
ok @@ ((c,n),expr)
) lst
in
ok @@ O.Match_variant (lst,tv)
let env = Var.fresh () in
let aux fv ((c,n),expr) =
let%bind expr = compile_expression expr in
let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching expr [n] env in
let case_clause'= expr in
let case_clause = add_to_end case_clause (O.e_variable env) in
ok (free_vars::fv,((c,n), case_clause, case_clause')) in
let%bind (fv,cases) = bind_fold_map_list aux [] lst in
let free_vars = List.sort_uniq Var.compare @@ 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
ok @@ O.E_matching{matchee; cases=O.Match_variant (cases,tv)}
) else (
let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in
let match_expr = O.e_matching matchee @@ O.Match_variant (cases,tv) in
let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false; rhs=(store_mutable_variable free_vars);
let_result=O.e_let_in (env,None) false false match_expr @@
expr
}
in
ok @@ restore_mutable_variable return_expr free_vars env
)
and compile_while I.{condition;body} =
let env_rec = Var.fresh () in
let binder = Var.fresh () in
let%bind cond = compile_expression condition in
let ctrl =
(O.e_variable binder)
in
let%bind for_body = compile_expression body in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in
let for_body = add_to_end for_body ctrl in
let aux name expr=
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable binder) (Label "0")) (Label (Var.to_name name))) expr
in
let init_rec = O.e_tuple [store_mutable_variable @@ captured_name_list] in
let restore = fun expr -> List.fold_right aux captured_name_list expr in
let continue_expr = O.e_constant C_FOLD_CONTINUE [for_body] in
let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable binder] in
let aux_func =
O.e_lambda binder None None @@
restore @@
O.e_cond cond continue_expr stop_expr in
let loop = O.e_constant C_FOLD_WHILE [aux_func; O.e_variable env_rec] in
let let_binder = (env_rec,None) in
let return_expr = fun expr ->
O.E_let_in {let_binder; mut=false; inline=false; rhs=init_rec; let_result=
O.e_let_in let_binder false false loop @@
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label"0")) @@
expr
}
in
ok @@ restore_mutable_variable return_expr captured_name_list env_rec
and compile_for I.{binder;start;final;increment;body} =
let env_rec = Var.fresh () in
(*Make the cond and the step *)
let cond = I.e_annotation (I.e_constant C_LE [I.e_variable binder ; final]) I.t_bool in
let%bind cond = compile_expression cond in
let%bind step = compile_expression increment in
let continue_expr = O.e_constant C_FOLD_CONTINUE [(O.e_variable env_rec)] in
let ctrl =
O.e_let_in (binder,Some O.t_int) false false (O.e_constant C_ADD [ O.e_variable binder ; step ]) @@
O.e_let_in (env_rec, None) false false (O.e_record_update (O.e_variable env_rec) (Label "1") @@ O.e_variable binder)@@
continue_expr
in
(* Modify the body loop*)
let%bind body = compile_expression body in
let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops body [binder] env_rec in
let for_body = add_to_end for_body ctrl in
let aux name expr=
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable env_rec) (Label "0")) (Label (Var.to_name name))) expr
in
(* restores the initial value of the free_var*)
let restore = fun expr -> List.fold_right aux captured_name_list expr in
(*Prep the lambda for the fold*)
let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable env_rec] in
let aux_func = O.e_lambda env_rec None None @@
O.e_let_in (binder,Some O.t_int) false false (O.e_record_accessor (O.e_variable env_rec) (Label "1")) @@
O.e_cond cond (restore for_body) (stop_expr) in
(* Make the fold_while en precharge the vakye *)
let loop = O.e_constant C_FOLD_WHILE [aux_func; O.e_variable env_rec] in
let init_rec = O.e_pair (store_mutable_variable captured_name_list) @@ O.e_variable binder in
let%bind start = compile_expression start in
let let_binder = (env_rec,None) in
let return_expr = fun expr ->
O.E_let_in {let_binder=(binder, Some O.t_int);mut=false; inline=false;rhs=start;let_result=
O.e_let_in let_binder false false init_rec @@
O.e_let_in let_binder false false loop @@
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label "0")) @@
expr
}
in
ok @@ restore_mutable_variable return_expr captured_name_list env_rec
and compile_for_each I.{binder;collection;collection_type; body} =
let args = Var.fresh () in
let%bind element_names = ok @@ match snd binder with
| Some v -> [fst binder;v]
| None -> [fst binder]
in
let env = Var.fresh () in
let%bind body = compile_expression body in
let%bind ((_,free_vars), body) = repair_mutable_variable_in_loops body element_names args in
let for_body = add_to_end body @@ (O.e_record_accessor (O.e_variable args) (Label "0")) in
let init_record = store_mutable_variable free_vars in
let%bind collect = compile_expression collection in
let aux name expr=
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "0")) (Label (Var.to_name name))) expr
in
let restore = fun expr -> List.fold_right aux free_vars expr in
let restore = match collection_type with
| Map -> (match snd binder with
| Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "1")) (Label "0"))
(O.e_let_in (v, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "1")) (Label "1")) expr))
| None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "1")) (Label "0")) expr)
)
| _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_variable args) (Label "1")) expr)
in
let lambda = O.e_lambda args None None (restore for_body) in
let%bind op_name = match collection_type with
| Map -> ok @@ O.C_MAP_FOLD | Set -> ok @@ O.C_SET_FOLD | List -> ok @@ O.C_LIST_FOLD
in
let fold = fun expr ->
O.E_let_in {let_binder=(env,None);mut=false; inline=false;rhs=(O.e_constant op_name [lambda; collect ; init_record]);
let_result=expr;}
in
ok @@ restore_mutable_variable fold free_vars env
let compile_declaration : I.declaration Location.wrap -> _ =
fun {wrap_content=declaration;location} ->
let return decl = ok @@ Location.wrap ~loc:location decl in
@ -212,6 +572,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
) record
in
return @@ I.T_record (O.LMap.of_list record)
| O.T_tuple tuple ->
let%bind tuple = bind_map_list uncompile_type_expression tuple in
return @@ I.T_tuple tuple
| O.T_arrow {type1;type2} ->
let%bind type1 = uncompile_type_expression type1 in
let%bind type2 = uncompile_type_expression type2 in
@ -249,7 +612,7 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
let rec uncompile_expression : O.expression -> I.expression result =
fun e ->
let return expr = ok @@ I.make_expr ~loc:e.location expr in
let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with
O.E_literal lit -> return @@ I.E_literal lit
| O.E_constant {cons_name;arguments} ->
@ -272,7 +635,7 @@ let rec uncompile_expression : O.expression -> I.expression result =
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
let%bind rhs = uncompile_expression rhs in
let%bind let_result = uncompile_expression let_result in
return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result}
return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
| O.E_constructor {constructor;element} ->
let%bind element = uncompile_expression element in
return @@ I.E_constructor {constructor;element}
@ -289,13 +652,23 @@ let rec uncompile_expression : O.expression -> I.expression result =
) record
in
return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {expr;label} ->
let%bind expr = uncompile_expression expr in
return @@ I.E_record_accessor {expr;label}
| O.E_record_accessor {record;path} ->
let%bind record = uncompile_expression record in
return @@ I.E_record_accessor {record;path}
| O.E_record_update {record;path;update} ->
let%bind record = uncompile_expression record in
let%bind update = uncompile_expression update in
return @@ I.E_record_update {record;path;update}
| O.E_tuple tuple ->
let%bind tuple = bind_map_list uncompile_expression tuple in
return @@ I.E_tuple tuple
| O.E_tuple_accessor {tuple;path} ->
let%bind tuple = uncompile_expression tuple in
return @@ I.E_tuple_accessor {tuple;path}
| O.E_tuple_update {tuple;path;update} ->
let%bind tuple = uncompile_expression tuple in
let%bind update = uncompile_expression update in
return @@ I.E_tuple_update {tuple;path;update}
| O.E_map map ->
let%bind map = bind_map_list (
bind_map_pair uncompile_expression
@ -321,6 +694,11 @@ let rec uncompile_expression : O.expression -> I.expression result =
let%bind anno_expr = uncompile_expression anno_expr in
let%bind type_annotation = uncompile_type_expression type_annotation in
return @@ I.E_ascription {anno_expr; type_annotation}
| O.E_cond {condition;then_clause;else_clause} ->
let%bind condition = uncompile_expression condition in
let%bind then_clause = uncompile_expression then_clause in
let%bind else_clause = uncompile_expression else_clause in
return @@ I.E_cond {condition; then_clause; else_clause}
| O.E_sequence {expr1; expr2} ->
let%bind expr1 = uncompile_expression expr1 in
let%bind expr2 = uncompile_expression expr2 in

417
src/passes/5-self_ast_sugar/helpers.ml Normal file
View File

@ -0,0 +1,417 @@
open Ast_sugar
open Trace
open Stage_common.Helpers
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
let self = fold_expression f in
let%bind init' = f init e in
match e.expression_content with
| E_literal _ | E_variable _ | E_skip -> ok init'
| E_list lst | E_set lst | E_constant {arguments=lst} -> (
let%bind res = bind_fold_list self init' lst in
ok res
)
| E_map lst | E_big_map lst -> (
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
ok res
)
| E_look_up ab ->
let%bind res = bind_fold_pair self init' ab in
ok res
| E_application {lamb;args} -> (
let ab = (lamb,args) in
let%bind res = bind_fold_pair self init' ab in
ok res
)
| E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e }
| E_ascription {anno_expr=e; _} | E_constructor {element=e} -> (
let%bind res = self init' e in
ok res
)
| E_matching {matchee=e; cases} -> (
let%bind res = self init' e in
let%bind res = fold_cases f res cases in
ok res
)
| E_record m -> (
let aux init'' _ expr =
let%bind res = fold_expression self init'' expr in
ok res
in
let%bind res = bind_fold_lmap aux (ok init') m in
ok res
)
| E_record_update {record;update} -> (
let%bind res = self init' record in
let%bind res = fold_expression self res update in
ok res
)
| E_record_accessor {record} -> (
let%bind res = self init' record in
ok res
)
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
let%bind res = self init' rhs in
let%bind res = self res let_result in
ok res
)
| E_cond {condition; then_clause; else_clause} ->
let%bind res = self init' condition in
let%bind res = self res then_clause in
let%bind res = self res else_clause in
ok res
| E_recursive { lambda={result=e;_}; _} ->
let%bind res = self init' e in
ok res
| E_sequence {expr1;expr2} ->
let ab = (expr1,expr2) in
let%bind res = bind_fold_pair self init' ab in
ok res
| E_tuple t -> (
let aux init'' expr =
let%bind res = fold_expression self init'' expr in
ok res
in
let%bind res = bind_fold_list aux (init') t in
ok res
)
| E_tuple_update {tuple;update} -> (
let%bind res = self init' tuple in
let%bind res = fold_expression self res update in
ok res
)
| E_tuple_accessor {tuple} -> (
let%bind res = self init' tuple in
ok res
)
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with
| Match_bool { match_true ; match_false } -> (
let%bind res = fold_expression f init match_true in
let%bind res = fold_expression f res match_false in
ok res
)
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
let%bind res = fold_expression f init match_nil in
let%bind res = fold_expression f res cons in
ok res
)
| Match_option { match_none ; match_some = (_ , some, _) } -> (
let%bind res = fold_expression f init match_none in
let%bind res = fold_expression f res some in
ok res
)
| Match_tuple ((_ , e), _) -> (
let%bind res = fold_expression f init e in
ok res
)
| Match_variant (lst, _) -> (
let aux init' ((_ , _) , e) =
let%bind res' = fold_expression f init' e in
ok res' in
let%bind res = bind_fold_list aux init lst in
ok res
)
type exp_mapper = expression -> expression result
type ty_exp_mapper = type_expression -> type_expression result
type abs_mapper =
| Expression of exp_mapper
| Type_expression of ty_exp_mapper
let rec map_expression : exp_mapper -> expression -> expression result = fun f e ->
let self = map_expression f in
let%bind e' = f e in
let return expression_content = ok { e' with expression_content } in
match e'.expression_content with
| E_list lst -> (
let%bind lst' = bind_map_list self lst in
return @@ E_list lst'
)
| E_set lst -> (
let%bind lst' = bind_map_list self lst in
return @@ E_set lst'
)
| E_map lst -> (
let%bind lst' = bind_map_list (bind_map_pair self) lst in
return @@ E_map lst'
)
| E_big_map lst -> (
let%bind lst' = bind_map_list (bind_map_pair self) lst in
return @@ E_big_map lst'
)
| E_look_up ab -> (
let%bind ab' = bind_map_pair self ab in
return @@ E_look_up ab'
)
| E_ascription ascr -> (
let%bind e' = self ascr.anno_expr in
return @@ E_ascription {ascr with anno_expr=e'}
)
| E_matching {matchee=e;cases} -> (
let%bind e' = self e in
let%bind cases' = map_cases f cases in
return @@ E_matching {matchee=e';cases=cases'}
)
| E_record_accessor acc -> (
let%bind e' = self acc.record in
return @@ E_record_accessor {acc with record = e'}
)
| E_record m -> (
let%bind m' = bind_map_lmap self m in
return @@ E_record m'
)
| E_record_update {record; path; update} -> (
let%bind record = self record in
let%bind update = self update in
return @@ E_record_update {record;path;update}
)
| E_constructor c -> (
let%bind e' = self c.element in
return @@ E_constructor {c with element = e'}
)
| E_application {lamb;args} -> (
let ab = (lamb,args) in
let%bind (lamb,args) = bind_map_pair self ab in
return @@ E_application {lamb;args}
)
| E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
let%bind rhs = self rhs in
let%bind let_result = self let_result in
return @@ E_let_in { let_binder ; mut; rhs ; let_result; inline }
)
| E_lambda { binder ; input_type ; output_type ; result } -> (
let%bind result = self result in
return @@ E_lambda { binder ; input_type ; output_type ; result }
)
| E_recursive { fun_name; fun_type; lambda} ->
let%bind result = self lambda.result in
let lambda = {lambda with result} in
return @@ E_recursive { fun_name; fun_type; lambda}
| E_constant c -> (
let%bind args = bind_map_list self c.arguments in
return @@ E_constant {c with arguments=args}
)
| E_cond {condition; then_clause; else_clause} ->
let%bind condition = self condition in
let%bind then_clause = self then_clause in
let%bind else_clause = self else_clause in
return @@ E_cond {condition;then_clause;else_clause}
| E_sequence {expr1;expr2} -> (
let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in
return @@ E_sequence {expr1;expr2}
)
| E_tuple t -> (
let%bind t' = bind_map_list self t in
return @@ E_tuple t'
)
| E_tuple_update {tuple; path; update} -> (
let%bind tuple = self tuple in
let%bind update = self update in
return @@ E_tuple_update {tuple; path; update}
)
| E_tuple_accessor {tuple;path} -> (
let%bind tuple = self tuple in
return @@ E_tuple_accessor {tuple;path}
)
| E_literal _ | E_variable _ | E_skip as e' -> return e'
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
let self = map_type_expression f in
let%bind te' = f te in
let return type_content = ok { type_content } in
match te'.type_content with
| T_sum temap ->
let%bind temap' = bind_map_cmap self temap in
return @@ (T_sum temap')
| T_record temap ->
let%bind temap' = bind_map_lmap self temap in
return @@ (T_record temap')
| T_tuple telst ->
let%bind telst' = bind_map_list self telst in
return @@ (T_tuple telst')
| T_arrow {type1 ; type2} ->
let%bind type1' = self type1 in
let%bind type2' = self type2 in
return @@ (T_arrow {type1=type1' ; type2=type2'})
| T_operator _
| T_variable _ | T_constant _ -> ok te'
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
match m with
| Match_bool { match_true ; match_false } -> (
let%bind match_true = map_expression f match_true in
let%bind match_false = map_expression f match_false in
ok @@ Match_bool { match_true ; match_false }
)
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
let%bind match_nil = map_expression f match_nil in
let%bind cons = map_expression f cons in
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }
)
| Match_option { match_none ; match_some = (name , some, _) } -> (
let%bind match_none = map_expression f match_none in
let%bind some = map_expression f some in
ok @@ Match_option { match_none ; match_some = (name , some, ()) }
)
| Match_tuple ((names , e), _) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple ((names , e'), [])
)
| Match_variant (lst, _) -> (
let aux ((a , b) , e) =
let%bind e' = map_expression f e in
ok ((a , b) , e')
in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant (lst', ())
)
and map_program : abs_mapper -> program -> program result = fun m p ->
let aux = fun (x : declaration) ->
match x,m with
| (Declaration_constant (t , o , i, e), Expression m') -> (
let%bind e' = map_expression m' e in
ok (Declaration_constant (t , o , i, e'))
)
| (Declaration_type (tv,te), Type_expression m') -> (
let%bind te' = map_type_expression m' te in
ok (Declaration_type (tv, te'))
)
| decl,_ -> ok decl
(* | Declaration_type of (type_variable * type_expression) *)
in
bind_map_list (bind_map_location aux) p
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_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.record in
ok (res, return @@ E_record_accessor {acc with record = 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_tuple t -> (
let%bind (res, t') = bind_fold_map_list self init' t in
ok (res, return @@ E_tuple t')
)
| E_tuple_update {tuple; path; update} -> (
let%bind (res, tuple) = self init' tuple in
let%bind (res, update) = self res update in
ok (res, return @@ E_tuple_update {tuple;path;update})
)
| E_tuple_accessor {tuple; path} -> (
let%bind (res, tuple) = self init' tuple in
ok (res, return @@ E_tuple_accessor {tuple; path})
)
| E_constructor c -> (
let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'})
)
| E_application {lamb;args} -> (
let ab = (lamb,args) in
let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
ok (res, return @@ E_application {lamb=a;args=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_recursive { fun_name; fun_type; lambda} ->
let%bind (res, result) = self init' lambda.result in
let lambda = {lambda with result} in
ok ( res, return @@ E_recursive { fun_name; fun_type; lambda})
| 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_cond {condition; then_clause; else_clause} ->
let%bind res,condition = self init' condition in
let%bind res,then_clause = self res then_clause in
let%bind res,else_clause = self res else_clause in
ok (res, return @@ E_cond {condition;then_clause;else_clause})
| E_sequence {expr1;expr2} -> (
let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in
ok (res, return @@ E_sequence {expr1;expr2})
)
| 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', ()))
)

25
src/passes/5-self_ast_sugar/self_ast_sugar.ml Normal file
View File

@ -0,0 +1,25 @@
open Trace
let all_expression_mapper = [
]
let all_type_expression_mapper = [
]
let all_exp = List.map (fun el -> Helpers.Expression el) all_expression_mapper
let all_ty = List.map (fun el -> Helpers.Type_expression el) all_type_expression_mapper
let all_program =
let all_p = List.map Helpers.map_program all_exp in
let all_p2 = List.map Helpers.map_program all_ty in
bind_chain (List.append all_p all_p2)
let all_expression =
let all_p = List.map Helpers.map_expression all_expression_mapper in
bind_chain all_p
let map_expression = Helpers.map_expression
let fold_expression = Helpers.fold_expression
let fold_map_expression = Helpers.fold_map_expression

116
src/passes/6-sugar_to_core/sugar_to_core.ml
View File

@ -24,6 +24,13 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
) record
in
return @@ O.T_record (O.LMap.of_list record)
| I.T_tuple tuple ->
let aux (i,acc) el =
let%bind el = idle_type_expression el in
ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in
let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in
let record = O.LMap.of_list lst in
return @@ O.T_record record
| I.T_arrow {type1;type2} ->
let%bind type1 = idle_type_expression type1 in
let%bind type2 = idle_type_expression type2 in
@ -61,7 +68,7 @@ and idle_type_operator : I.type_operator -> O.type_operator result =
let rec compile_expression : I.expression -> O.expression result =
fun e ->
let return expr = ok @@ O.make_expr ~loc:e.location expr in
let return expr = ok @@ O.make_e ~loc:e.location expr in
match e.expression_content with
| I.E_literal literal -> return @@ O.E_literal literal
| I.E_constant {cons_name;arguments} ->
@ -101,43 +108,78 @@ let rec compile_expression : I.expression -> O.expression result =
) record
in
return @@ O.E_record (O.LMap.of_list record)
| I.E_record_accessor {expr;label} ->
let%bind expr = compile_expression expr in
return @@ O.E_record_accessor {expr;label}
| I.E_record_accessor {record;path} ->
let%bind record = compile_expression record in
return @@ O.E_record_accessor {record;path}
| I.E_record_update {record;path;update} ->
let%bind record = compile_expression record in
let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update}
| I.E_map map ->
let%bind map = bind_map_list (
bind_map_pair compile_expression
) map
| I.E_map map -> (
let map = List.sort_uniq compare map in
let aux = fun prev (k, v) ->
let%bind (k', v') = bind_map_pair (compile_expression) (k, v) in
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]}
in
return @@ O.E_map map
| I.E_big_map big_map ->
let%bind big_map = bind_map_list (
bind_map_pair compile_expression
) big_map
let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in
bind_fold_right_list aux init map
)
| I.E_big_map big_map -> (
let big_map = List.sort_uniq compare big_map in
let aux = fun prev (k, v) ->
let%bind (k', v') = bind_map_pair (compile_expression) (k, v) in
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]}
in
return @@ O.E_big_map big_map
let%bind init = return @@ E_constant {cons_name=C_BIG_MAP_EMPTY;arguments=[]} in
bind_fold_right_list aux init big_map
)
| I.E_list lst ->
let%bind lst = bind_map_list compile_expression lst in
return @@ O.E_list lst
| I.E_set set ->
let%bind set = bind_map_list compile_expression set in
return @@ O.E_set set
let%bind lst' = bind_map_list (compile_expression) lst in
let aux = fun prev cur ->
return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in
let%bind init = return @@ E_constant {cons_name=C_LIST_EMPTY;arguments=[]} in
bind_fold_right_list aux init lst'
| I.E_set set -> (
let%bind lst' = bind_map_list (compile_expression) set in
let lst' = List.sort_uniq compare lst' in
let aux = fun prev cur ->
return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in
let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in
bind_fold_list aux init lst'
)
| I.E_look_up look_up ->
let%bind look_up = bind_map_pair compile_expression look_up in
return @@ O.E_look_up look_up
let%bind (path, index) = bind_map_pair compile_expression look_up in
return @@ O.E_constant {cons_name=C_MAP_FIND_OPT;arguments=[index;path]}
| I.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = idle_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation}
| I.E_cond {condition; then_clause; else_clause} ->
let%bind matchee = compile_expression condition in
let%bind match_true = compile_expression then_clause in
let%bind match_false = compile_expression else_clause in
return @@ O.E_matching {matchee; cases=Match_bool{match_true;match_false}}
| I.E_sequence {expr1; expr2} ->
let%bind expr1 = compile_expression expr1 in
let%bind expr2 = compile_expression expr2 in
return @@ O.E_let_in {let_binder=(Var.of_name "_", Some O.t_unit); rhs=expr1;let_result=expr2; inline=false}
| I.E_skip -> ok @@ O.e_unit ~loc:e.location ()
| I.E_tuple t ->
let aux (i,acc) el =
let%bind el = compile_expression el in
ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in
let%bind (_, lst ) = bind_fold_list aux (0,[]) t in
let m = O.LMap.of_list lst in
return @@ O.E_record m
| I.E_tuple_accessor {tuple;path} ->
let%bind record = compile_expression tuple in
let path = O.Label (string_of_int path) in
return @@ O.E_record_accessor {record;path}
| I.E_tuple_update {tuple;path;update} ->
let%bind record = compile_expression tuple in
let path = O.Label (string_of_int path) in
let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update}
and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}->
@ -244,13 +286,14 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
| TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_big_map (k,v)
| TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled"
| TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
ok @@ I.TC_arrow (i,o)
let rec uncompile_expression : O.expression -> I.expression result =
fun e ->
let return expr = ok @@ I.make_expr ~loc:e.location expr in
let return expr = ok @@ I.make_e ~loc:e.location expr in
match e.expression_content with
O.E_literal lit -> return @@ I.E_literal lit
| O.E_constant {cons_name;arguments} ->
@ -277,7 +320,7 @@ let rec uncompile_expression : O.expression -> I.expression result =
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
let%bind rhs = uncompile_expression rhs in
let%bind let_result = uncompile_expression let_result in
return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result}
| O.E_constructor {constructor;element} ->
let%bind element = uncompile_expression element in
return @@ I.E_constructor {constructor;element}
@ -294,34 +337,13 @@ let rec uncompile_expression : O.expression -> I.expression result =
) record
in
return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {expr;label} ->
let%bind expr = uncompile_expression expr in
return @@ I.E_record_accessor {expr;label}
| O.E_record_accessor {record;path} ->
let%bind record = uncompile_expression record in
return @@ I.E_record_accessor {record;path}
| O.E_record_update {record;path;update} ->
let%bind record = uncompile_expression record in
let%bind update = uncompile_expression update in
return @@ I.E_record_update {record;path;update}
| O.E_map map ->
let%bind map = bind_map_list (
bind_map_pair uncompile_expression
) map
in
return @@ I.E_map map
| O.E_big_map big_map ->
let%bind big_map = bind_map_list (
bind_map_pair uncompile_expression
) big_map
in
return @@ I.E_big_map big_map
| O.E_list lst ->
let%bind lst = bind_map_list uncompile_expression lst in
return @@ I.E_list lst
| O.E_set set ->
let%bind set = bind_map_list uncompile_expression set in
return @@ I.E_set set
| O.E_look_up look_up ->
let%bind look_up = bind_map_pair uncompile_expression look_up in
return @@ I.E_look_up look_up
| O.E_ascription {anno_expr; type_annotation} ->
let%bind anno_expr = uncompile_expression anno_expr in
let%bind type_annotation = uncompile_type_expression type_annotation in

2
src/passes/8-typer-new/solver.ml
View File

@ -70,6 +70,7 @@ 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_map_or_big_map ( k , v) -> (C_map, [k;v])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
| TC_list l -> (C_list, [l])
| TC_contract c -> (C_contract, [c])
@ -103,6 +104,7 @@ 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_map_or_big_map ( k , v) -> (C_map, [k;v])
| TC_contract c -> (C_contract, [c])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
)

198
src/passes/8-typer-new/typer.ml
View File

@ -163,7 +163,6 @@ end
open Errors
let swap (a,b) = ok (b,a)
(*
let rec type_program (p:I.program) : O.program result =
let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
@ -346,6 +345,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_big_map (k,v)
| TC_map_or_big_map (k,v) ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_map_or_big_map (k,v)
| TC_contract c ->
let%bind c = evaluate_type e c in
ok @@ O.TC_contract c
@ -364,7 +367,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
let%bind new_state = aggregate_constraints state constraints in
let tv = t_variable type_name () in
let location = ae.location in
let expr' = make_a_e ~location expr tv e in
let expr' = make_e ~location expr tv e in
ok @@ (expr' , new_state) in
let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
let main_error =
@ -452,10 +455,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
* | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ())
* | _ -> return (E_literal (Literal_string s)) (t_string ())
* ) *)
| E_record_accessor {expr;label} -> (
let%bind (base' , state') = type_expression e state expr in
let wrapped = Wrap.access_label ~base:base'.type_expression ~label in
return_wrapped (E_record_accessor {expr=base';label}) state' wrapped
| E_record_accessor {record;path} -> (
let%bind (base' , state') = type_expression e state record in
let wrapped = Wrap.access_label ~base:base'.type_expression ~label:path in
return_wrapped (E_record_accessor {record=base';path}) state' wrapped
)
(* Sum *)
@ -503,140 +506,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
(* Data-structure *)
(*
| E_list lst ->
let%bind lst' = bind_map_list (type_expression e) lst in
let%bind tv =
let aux opt c =
match opt with
| None -> ok (Some c)
| Some c' ->
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
ok (Some c') in
let%bind init = match tv_opt with
| None -> ok None
| Some ty ->
let%bind ty' = get_t_list ty in
ok (Some ty') in
let%bind ty =
let%bind opt = bind_fold_list aux init
@@ List.map get_type_annotation lst' in
trace_option (needs_annotation ae "empty list") opt in
ok (t_list ty ())
in
return (E_list lst') tv
| E_set lst ->
let%bind lst' = bind_map_list (type_expression e) lst in
let%bind tv =
let aux opt c =
match opt with
| None -> ok (Some c)
| Some c' ->
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
ok (Some c') in
let%bind init = match tv_opt with
| None -> ok None
| Some ty ->
let%bind ty' = get_t_set ty in
ok (Some ty') in
let%bind ty =
let%bind opt = bind_fold_list aux init
@@ List.map get_type_annotation lst' in
trace_option (needs_annotation ae "empty set") opt in
ok (t_set ty ())
in
return (E_set lst') tv
| E_map lst ->
let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in
let%bind tv =
let aux opt c =
match opt with
| None -> ok (Some c)
| Some c' ->
let%bind _eq = Ast_typed.assert_type_value_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 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") @@
O.merge_annotation annot sub (needs_annotation ae "this map literal")
in
let%bind value_type =
let%bind sub =
bind_fold_list aux None
@@ List.map get_type_annotation
@@ 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") @@
O.merge_annotation annot sub (needs_annotation ae "this map literal")
in
ok (t_map key_type value_type ())
in
return (E_map lst') tv
*)
| 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_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_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_expression , y.type_expression) in
let wrapped = Wrap.map (List.map aux map') in
return_wrapped (E_map map') state' wrapped
(* | E_big_map lst ->
* let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in
* let%bind tv =
* let aux opt c =
* match opt with
* | None -> ok (Some c)
* | Some c' ->
* let%bind _eq = Ast_typed.assert_type_value_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 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") @@
* O.merge_annotation annot sub (needs_annotation ae "this map literal")
* in
* let%bind value_type =
* let%bind sub =
* bind_fold_list aux None
* @@ List.map get_type_annotation
* @@ 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") @@
* O.merge_annotation annot sub (needs_annotation ae "this map literal")
* in
* ok (t_big_map key_type value_type ())
* in
* return (E_big_map lst') tv *)
| E_big_map big_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', big_map') =
bind_fold_map_list aux state big_map 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
(* | E_lambda {
* binder ;
* input_type ;
@ -685,17 +554,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
let wrapped = Wrap.application f'.type_expression args.type_expression in
return_wrapped (E_application {lamb=f';args}) state'' wrapped
(* | E_look_up dsi ->
* let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in
* let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in
* let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in
* return (E_look_up (ds , ind)) (t_option dst ()) *)
| 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_expression ind.type_expression in
return_wrapped (E_look_up (ds , ind)) state'' wrapped
(* Advanced *)
(* | E_matching (ex, m) -> (
@ -983,6 +841,10 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
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_map_or_big_map (k,v) ->
let%bind k = untype_type_expression k in
let%bind v = untype_type_expression v in
ok @@ I.TC_map_or_big_map (k,v)
| O.TC_arrow ( arg , ret ) ->
let%bind arg' = untype_type_expression arg in
let%bind ret' = untype_type_expression ret in
@ -1050,35 +912,17 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let Constructor n = constructor in
return (e_constructor n p')
| E_record r ->
let aux ( Label k ,v) = (k, v) in
let r = Map.String.of_list @@ List.map aux (LMap.to_kv_list r) in
let%bind r' = bind_smap
@@ Map.String.map untype_expression r in
return (e_record r')
| E_record_accessor {expr; label} ->
let%bind r' = untype_expression expr in
let Label s = label in
return (e_accessor r' s)
let r = LMap.to_kv_list r in
let%bind r' = bind_map_list (fun (k,e) -> let%bind e = untype_expression e in ok (k,e)) r in
return (e_record @@ LMap.of_list r')
| E_record_accessor {record; path} ->
let%bind r' = untype_expression record in
let Label s = path in
return (e_record_accessor r' s)
| E_record_update {record; path; update} ->
let%bind r' = untype_expression record in
let%bind e = untype_expression update in
let Label l = path in
return (e_update r' l e)
| E_map m ->
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
return (e_map m')
| E_big_map m ->
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
return (e_big_map m')
| E_list lst ->
let%bind lst' = bind_map_list untype_expression lst in
return (e_list lst')
| E_set lst ->
let%bind lst' = bind_map_list untype_expression lst in
return (e_set lst')
| E_look_up dsi ->
let%bind (a , b) = bind_map_pair untype_expression dsi in
return (e_look_up a b)
return (e_record_update r' path e)
| E_matching {matchee;cases} ->
let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression cases in

188
src/passes/8-typer-old/typer.ml
View File

@ -381,6 +381,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_big_map (k,v)
| TC_map_or_big_map (k,v) ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_map_or_big_map (k,v)
| TC_arrow ( arg , ret ) ->
let%bind arg' = evaluate_type e arg in
let%bind ret' = evaluate_type e ret in
@ -403,7 +407,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
| None -> ok ()
| Some tv' -> O.assert_type_expression_eq (tv' , tv) in
let location = ae.location in
ok @@ make_a_e ~location expr tv e in
ok @@ make_e ~location expr tv e in
let main_error =
let title () = "typing expression" in
let content () = "" in
@ -450,8 +454,8 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
return (e_address s) (t_address ())
| E_literal (Literal_operation op) ->
return (e_operation op) (t_operation ())
| E_record_accessor {expr;label} ->
let%bind e' = type_expression' e expr in
| E_record_accessor {record;path} ->
let%bind e' = type_expression' e record in
let aux (prev:O.expression) (a:I.label) : O.expression result =
let property = a in
let%bind r_tv = get_t_record prev.type_expression in
@ -459,10 +463,10 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
generic_try (bad_record_access property ae prev.type_expression ae.location)
@@ (fun () -> I.LMap.find property r_tv) in
let location = ae.location in
ok @@ make_a_e ~location (E_record_accessor {expr=prev; label=property}) tv e
ok @@ make_e ~location (E_record_accessor {record=prev; path=property}) tv e
in
let%bind ae =
trace (simple_info "accessing") @@ aux e' label in
trace (simple_info "accessing") @@ aux e' path in
(* check type annotation of the final accessed element *)
let%bind () =
match tv_opt with
@ -511,108 +515,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
return (E_record_update {record; path; update}) wrapped
(* Data-structure *)
| E_list lst ->
let%bind lst' = bind_map_list (type_expression' e) lst in
let%bind tv =
let aux opt c =
match opt with
| None -> ok (Some c)
| Some c' ->
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
| Some ty ->
let%bind ty' = get_t_list ty in
ok (Some ty') in
let%bind ty =
let%bind opt = bind_fold_list aux init
@@ List.map get_type_expression lst' in
trace_option (needs_annotation ae "empty list") opt in
ok (t_list ty ())
in
return (E_list lst') tv
| E_set lst ->
let%bind lst' = bind_map_list (type_expression' e) lst in
let%bind tv =
let aux opt c =
match opt with
| None -> ok (Some c)
| Some c' ->
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
| Some ty ->
let%bind ty' = get_t_set ty in
ok (Some ty') in
let%bind ty =
let%bind opt = bind_fold_list aux init
@@ List.map get_type_expression lst' in
trace_option (needs_annotation ae "empty set") opt in
ok (t_set ty ())
in
return (E_set lst') tv
| E_map lst ->
let%bind lst' = bind_map_list (bind_map_pair (type_expression' e)) lst in
let%bind tv =
let aux opt c =
match opt with
| None -> ok (Some c)
| Some c' ->
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_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") @@
O.merge_annotation annot sub (needs_annotation ae "this map literal")
in
let%bind value_type =
let%bind sub =
bind_fold_list aux None
@@ 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") @@
O.merge_annotation annot sub (needs_annotation ae "this map literal")
in
ok (t_map key_type value_type ())
in
return (E_map lst') tv
| E_big_map lst ->
let%bind lst' = bind_map_list (bind_map_pair (type_expression' e)) lst in
let%bind tv =
let aux opt c =
match opt with
| None -> ok (Some c)
| Some c' ->
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_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") @@
O.merge_annotation annot sub (needs_annotation ae "this map literal")
in
let%bind value_type =
let%bind sub =
bind_fold_list aux None
@@ 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") @@
O.merge_annotation annot sub (needs_annotation ae "this map literal")
in
ok (t_big_map key_type value_type ())
in
return (E_big_map lst') tv
| E_lambda lambda ->
let%bind (lambda, lambda_type) = type_lambda e lambda in
return (E_lambda lambda ) lambda_type
@ -642,7 +544,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
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_expression in
let lambda' = make_a_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in
let lambda' = make_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_expression lst' in
let%bind (opname', tv) =
@ -663,7 +565,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let e' = Environment.add_ez_binder lname input_type e in
let%bind body = type_expression' e' result in
let output_type = body.type_expression in
let lambda' = make_a_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in
let lambda' = make_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
let%bind (opname',tv) = type_constant opname tv_lst tv_opt in
@ -682,6 +584,35 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind (name', tv) =
type_constant cons_name tv_lst tv_opt in
return (E_constant {cons_name=name';arguments=lst'}) tv
| E_constant {cons_name=C_SET_ADD|C_CONS as cst;arguments=[key;set]} ->
let%bind key' = type_expression' e key in
let tv_key = get_type_expression key' in
let tv = match tv_opt with
Some tv -> tv
| None -> match cst with
C_SET_ADD -> t_set tv_key ()
| C_CONS -> t_list tv_key ()
| _ -> failwith "Only C_SET_ADD and C_CONS are possible because those were the two cases matched above"
in
let%bind set' = type_expression' e ~tv_opt:tv set in
let tv_set = get_type_expression set' in
let tv_lst = [tv_key;tv_set] in
let%bind (name', tv) = type_constant cst tv_lst tv_opt in
return (E_constant {cons_name=name';arguments=[key';set']}) tv
| E_constant {cons_name=C_MAP_ADD as cst; arguments=[key;value;map]} ->
let%bind key' = type_expression' e key in
let%bind val' = type_expression' e value in
let tv_key = get_type_expression key' in
let tv_val = get_type_expression val' in
let tv = match tv_opt with
Some tv -> tv
| None -> t_map_or_big_map tv_key tv_val ()
in
let%bind map' = type_expression' e ~tv_opt:tv map in
let tv_map = get_type_expression map' in
let tv_lst = [tv_key;tv_val;tv_map] in
let%bind (name', tv) = type_constant cst tv_lst tv_opt in
return (E_constant {cons_name=name';arguments=[key';val';map']}) 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
@ -703,11 +634,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
lamb'.location
in
return (E_application {lamb=lamb'; args=args'}) 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_expression in
let%bind _ = O.assert_type_expression_eq (ind.type_expression, src) in
return (E_look_up (ds , ind)) (t_option dst ())
(* Advanced *)
| E_matching {matchee;cases} -> (
let%bind ex' = type_expression' e matchee in
@ -856,35 +782,17 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let Constructor n = constructor in
return (e_constructor n p')
| E_record r ->
let aux ( Label k ,v) = (k, v) in
let r = Map.String.of_list @@ List.map aux (LMap.to_kv_list r) in
let%bind r' = bind_smap
@@ Map.String.map untype_expression r in
return (e_record r')
| E_record_accessor {expr; label} ->
let%bind r' = untype_expression expr in
let Label s = label in
return (e_accessor r' s)
let r = LMap.to_kv_list r in
let%bind r' = bind_map_list (fun (k,e) -> let%bind e = untype_expression e in ok (k,e)) r in
return (e_record @@ LMap.of_list r')
| E_record_accessor {record; path} ->
let%bind r' = untype_expression record in
let Label s = path in
return (e_record_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
return (e_update r' l e)
| E_map m ->
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
return (e_map m')
| E_big_map m ->
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
return (e_big_map m')
| E_list lst ->
let%bind lst' = bind_map_list untype_expression lst in
return (e_list lst')
| E_set lst ->
let%bind lst' = bind_map_list untype_expression lst in
return (e_set lst')
| E_look_up dsi ->
let%bind (a , b) = bind_map_pair untype_expression dsi in
return (e_look_up a b)
return (e_record_update r' l e)
| E_matching {matchee;cases} ->
let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression cases in

65
src/passes/9-self_ast_typed/helpers.ml
View File

@ -8,17 +8,10 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind init' = f init e in
match e.expression_content with
| E_literal _ | E_variable _ -> ok init'
| E_list lst | E_set lst | E_constant {arguments=lst} -> (
| E_constant {arguments=lst} -> (
let%bind res = bind_fold_list self init' lst in
ok res
)
| E_map lst | E_big_map lst -> (
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
ok res
)
| E_look_up ab ->
let%bind res = bind_fold_pair self init' ab in
ok res
| E_application {lamb; args} -> (
let ab = (lamb, args) in
let%bind res = bind_fold_pair self init' ab in
@ -48,8 +41,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = fold_expression self res update in
ok res
)
| E_record_accessor {expr} -> (
let%bind res = self init' expr in
| E_record_accessor {record} -> (
let%bind res = self init' record in
ok res
)
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
@ -93,34 +86,14 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind e' = f e in
let return expression_content = ok { e' with expression_content } in
match e'.expression_content with
| E_list lst -> (
let%bind lst' = bind_map_list self lst in
return @@ E_list lst'
)
| E_set lst -> (
let%bind lst' = bind_map_list self lst in
return @@ E_set lst'
)
| E_map lst -> (
let%bind lst' = bind_map_list (bind_map_pair self) lst in
return @@ E_map lst'
)
| E_big_map lst -> (
let%bind lst' = bind_map_list (bind_map_pair self) lst in
return @@ E_big_map lst'
)
| E_look_up ab -> (
let%bind ab' = bind_map_pair self ab in
return @@ E_look_up ab'
)
| E_matching {matchee=e;cases} -> (
let%bind e' = self e in
let%bind cases' = map_cases f cases in
return @@ E_matching {matchee=e';cases=cases'}
)
| E_record_accessor acc -> (
let%bind e' = self acc.expr in
return @@ E_record_accessor {acc with expr = e'}
| E_record_accessor {record; path} -> (
let%bind record = self record in
return @@ E_record_accessor {record; path}
)
| E_record m -> (
let%bind m' = bind_map_lmap self m in
@ -208,34 +181,14 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
else
let return expression_content = { e' with expression_content } in
match e'.expression_content with
| E_list lst -> (
let%bind (res, lst') = bind_fold_map_list self init' lst in
ok (res, return @@ E_list lst')
)
| E_set lst -> (
let%bind (res, lst') = bind_fold_map_list self init' lst in
ok (res, return @@ E_set lst')
)
| E_map lst -> (
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
ok (res, return @@ E_map lst')
)
| E_big_map lst -> (
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
ok (res, return @@ E_big_map lst')
)
| E_look_up ab -> (
let%bind (res, ab') = bind_fold_map_pair self init' ab in
ok (res, return @@ E_look_up ab')
)
| E_matching {matchee=e;cases} -> (
let%bind (res, e') = self init' e in
let%bind (res,cases') = fold_map_cases f res cases in
ok (res, return @@ E_matching {matchee=e';cases=cases'})
)
| E_record_accessor acc -> (
let%bind (res, e') = self init' acc.expr in
ok (res, return @@ E_record_accessor {acc with expr = e'})
| E_record_accessor {record; path} -> (
let%bind (res, record) = self init' record in
ok (res, return @@ E_record_accessor {record; path})
)
| 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

4
src/passes/9-self_ast_typed/no_nested_big_map.ml
View File

@ -21,6 +21,10 @@ let rec check_no_nested_bigmap is_in_bigmap e =
let%bind _ = check_no_nested_bigmap false key in
let%bind _ = check_no_nested_bigmap true value in
ok ()
| T_operator (TC_map_or_big_map (key, value)) ->
let%bind _ = check_no_nested_bigmap false key in
let%bind _ = check_no_nested_bigmap true value in
ok ()
| T_operator (TC_contract t)
| T_operator (TC_option t)
| T_operator (TC_list t)

19
src/passes/9-self_ast_typed/tail_recursion.ml
View File

@ -49,28 +49,13 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> unit
let es = LMap.to_list elm in
let%bind _ = bind_map_list (check_recursive_call n false) es in
ok ()
| E_record_accessor {expr;_} ->
let%bind _ = check_recursive_call n false expr in
| E_record_accessor {record;_} ->
let%bind _ = check_recursive_call n false record in
ok ()
| E_record_update {record;update;_} ->
let%bind _ = check_recursive_call n false record in
let%bind _ = check_recursive_call n false update in
ok ()
| E_map eel | E_big_map eel->
let aux (e1,e2) =
let%bind _ = check_recursive_call n false e1 in
let%bind _ = check_recursive_call n false e2 in
ok ()
in
let%bind _ = bind_map_list aux eel in
ok ()
| E_list el | E_set el ->
let%bind _ = bind_map_list (check_recursive_call n false) el in
ok ()
| E_look_up (e1,e2) ->
let%bind _ = check_recursive_call n false e1 in
let%bind _ = check_recursive_call n false e2 in
ok ()
and check_recursive_call_in_matching = fun n final_path c ->
match c with

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

@ -184,6 +184,7 @@ module Concrete_to_imperative = struct
| "is_nat" -> ok C_IS_NAT
| "int" -> ok C_INT
| "abs" -> ok C_ABS
| "ediv" -> ok C_EDIV
| "unit" -> ok C_UNIT
| "NEG" -> ok C_NEG
@ -311,6 +312,7 @@ module Concrete_to_imperative = struct
| "is_nat" -> ok C_IS_NAT
| "int" -> ok C_INT
| "abs" -> ok C_ABS
| "ediv" -> ok C_EDIV
| "unit" -> ok C_UNIT
| "NEG" -> ok C_NEG
@ -424,6 +426,7 @@ module Typer = struct
let tc_sizearg a = tc [a] [ [int] ]
let tc_packable a = tc [a] [ [int] ; [string] ; [bool] (*TODO…*) ]
let tc_timargs a b c = tc [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ]
let tc_edivargs a b c = tc [a;b;c] [ (*TODO…*) ]
let tc_divargs a b c = tc [a;b;c] [ (*TODO…*) ]
let tc_modargs a b c = tc [a;b;c] [ (*TODO…*) ]
let tc_addargs a b c = tc [a;b;c] [ (*TODO…*) ]
@ -474,6 +477,7 @@ module Typer = struct
let t_cons = forall "a" @@ fun a -> tuple2 a (list a) --> list a
let t_assertion = tuple1 bool --> unit
let t_times = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_timargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_ediv = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_edivargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_div = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_divargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_mod = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_modargs a b c] => tuple2 a b --> c (* TYPECLASS *)
let t_add = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_addargs a b c] => tuple2 a b --> c (* TYPECLASS *)
@ -522,7 +526,8 @@ module Typer = struct
| C_ABS -> ok @@ t_abs ;
| C_ADD -> ok @@ t_add ;
| C_SUB -> ok @@ t_sub ;
| C_MUL -> ok @@ t_times;
| C_MUL -> ok @@ t_times ;
| C_EDIV -> ok @@ t_ediv ;
| C_DIV -> ok @@ t_div ;
| C_MOD -> ok @@ t_mod ;
(* LOGIC *)
@ -621,6 +626,20 @@ module Typer = struct
let%bind () = assert_type_expression_eq (src , k) in
ok m
let map_empty = typer_0 "MAP_EMPTY" @@ fun tv_opt ->
match tv_opt with
| None -> simple_fail "untyped MAP_EMPTY"
| Some t ->
let%bind (src, dst) = get_t_map t in
ok @@ t_map src dst ()
let big_map_empty = typer_0 "BIG_MAP_EMPTY" @@ fun tv_opt ->
match tv_opt with
| None -> simple_fail "untyped BIG_MAP_EMPTY"
| Some t ->
let%bind (src, dst) = get_t_big_map t in
ok @@ t_big_map src dst ()
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_expression_eq (src, k) in
@ -867,6 +886,24 @@ module Typer = struct
]
[a; b] ()
let ediv = typer_2 "EDIV" @@ fun a b ->
if eq_2 (a , b) (t_nat ())
then ok @@ t_option (t_pair (t_nat ()) (t_nat ()) ()) () else
if eq_2 (a , b) (t_int ())
then ok @@ t_option (t_pair (t_int ()) (t_nat ()) ()) () else
if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ())
then ok @@ t_option (t_pair (t_nat ()) (t_mutez ()) ()) () else
if eq_1 a (t_mutez ()) && eq_1 b (t_nat ())
then ok @@ t_option (t_pair (t_mutez ()) (t_mutez ()) ()) () else
fail @@ Operator_errors.typeclass_error "Dividing with wrong types" "divide"
[
[t_nat();t_nat()] ;
[t_int();t_int()] ;
[t_mutez();t_nat()] ;
[t_mutez();t_mutez()] ;
]
[a; b] ()
let div = typer_2 "DIV" @@ fun a b ->
if eq_2 (a , b) (t_nat ())
then ok @@ t_nat () else
@ -949,6 +986,11 @@ module Typer = struct
then ok (t_unit ())
else fail @@ Operator_errors.type_error "bad set iter" key arg ()
let list_empty = typer_0 "LIST_EMPTY" @@ fun tv_opt ->
match tv_opt with
| None -> simple_fail "untyped LIST_EMPTY"
| Some t -> ok t
let list_iter = typer_2 "LIST_ITER" @@ fun body lst ->
let%bind (arg , res) = get_t_function body in
let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in
@ -1122,7 +1164,8 @@ module Typer = struct
| C_ABS -> ok @@ abs ;
| C_ADD -> ok @@ add ;
| C_SUB -> ok @@ sub ;
| C_MUL -> ok @@ times;
| C_MUL -> ok @@ times ;
| C_EDIV -> ok @@ ediv ;
| C_DIV -> ok @@ div ;
| C_MOD -> ok @@ mod_ ;
(* LOGIC *)
@ -1145,7 +1188,6 @@ module Typer = struct
| C_SLICE -> ok @@ slice ;
| C_BYTES_PACK -> ok @@ bytes_pack ;
| C_BYTES_UNPACK -> ok @@ bytes_unpack ;
| C_CONS -> ok @@ cons ;
(* SET *)
| C_SET_EMPTY -> ok @@ set_empty ;
| C_SET_ADD -> ok @@ set_add ;
@ -1155,10 +1197,14 @@ module Typer = struct
| C_SET_MEM -> ok @@ set_mem ;
(* LIST *)
| C_CONS -> ok @@ cons ;
| C_LIST_EMPTY -> ok @@ list_empty ;
| C_LIST_ITER -> ok @@ list_iter ;
| C_LIST_MAP -> ok @@ list_map ;
| C_LIST_FOLD -> ok @@ list_fold ;
(* MAP *)
| C_MAP_EMPTY -> ok @@ map_empty ;
| C_BIG_MAP_EMPTY -> ok @@ big_map_empty ;
| C_MAP_ADD -> ok @@ map_add ;
| C_MAP_REMOVE -> ok @@ map_remove ;
| C_MAP_UPDATE -> ok @@ map_update ;
@ -1222,6 +1268,7 @@ module Compiler = struct
| C_ADD -> ok @@ simple_binary @@ prim I_ADD
| C_SUB -> ok @@ simple_binary @@ prim I_SUB
| C_MUL -> ok @@ simple_binary @@ prim I_MUL
| C_EDIV -> ok @@ simple_binary @@ prim I_EDIV
| C_DIV -> ok @@ simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car]
| C_MOD -> ok @@ simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "MOD by 0") ; i_cdr]
| C_NEG -> ok @@ simple_unary @@ prim I_NEG

91
src/stages/1-ast_imperative/PP.ml
View File

@ -4,11 +4,45 @@ open Format
open PP_helpers
include Stage_common.PP
include Ast_PP_type(Ast_imperative_parameter)
let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev
let rec type_expression' :
(formatter -> type_expression -> unit)
-> formatter
-> 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}" (record_sep f (const ";")) m
| T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_operator :
(formatter -> type_expression -> unit)
-> formatter
-> type_operator
-> unit =
fun f ppf to_ ->
let s =
match to_ with
| TC_option te -> Format.asprintf "option(%a)" f te
| TC_list te -> Format.asprintf "list(%a)" f te
| TC_set te -> Format.asprintf "set(%a)" f te
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te
in
fprintf ppf "(TO_%s)" s
let rec expression ppf (e : expression) =
expression_content ppf e.expression_content
@ -26,11 +60,11 @@ and expression_content ppf (ec : expression_content) =
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
fprintf ppf "{%a}" (record_sep expression (const ";")) m
| E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.expr label ra.label
fprintf ppf "%a.%a" expression ra.record label ra.path
| E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression 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 ->
@ -57,15 +91,58 @@ and expression_content ppf (ec : expression_content) =
expression_variable fun_name
type_expression fun_type
expression_content (E_lambda lambda)
| 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_let_in { let_binder ; rhs ; let_result; inline } ->
fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result
| E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression
type_annotation
| E_cond {condition; then_clause; else_clause} ->
fprintf ppf "if %a then %a else %a"
expression condition
expression then_clause
expression else_clause
| E_sequence {expr1;expr2} ->
fprintf ppf "%a;\n%a" expression expr1 expression expr2
fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2
| E_skip ->
fprintf ppf "skip"
| E_tuple t ->
fprintf ppf "(%a)" (list_sep_d expression) t
| E_tuple_accessor ta ->
fprintf ppf "%a.%d" expression ta.tuple ta.path
| E_tuple_update {tuple; path; update} ->
fprintf ppf "{ %a with %d = %a }" expression tuple path expression update
| E_assign {variable; access_path; expression=e} ->
fprintf ppf "%a%a := %a"
expression_variable variable
(list_sep (fun ppf a -> fprintf ppf ".%a" accessor a) (fun ppf () -> fprintf ppf "")) access_path
expression e
| E_for {binder; start; final; increment; body} ->
fprintf ppf "for %a from %a to %a by %a do %a"
expression_variable binder
expression start
expression final
expression increment
expression body
| E_for_each {binder; collection; body; _} ->
fprintf ppf "for each %a in %a do %a"
option_map binder
expression collection
expression body
| E_while {condition; body} ->
fprintf ppf "while %a do %a"
expression condition
expression body
and accessor ppf a =
match a with
| Access_tuple i -> fprintf ppf "%d" i
| Access_record s -> fprintf ppf "%s" s
| Access_map e -> fprintf ppf "%a" expression e
and option_map ppf (k,v_opt) =
match v_opt with
| None -> fprintf ppf "%a" expression_variable k
| Some v -> fprintf ppf "%a -> %a" expression_variable k expression_variable v
and option_type_name ppf
((n, ty_opt) : expression_variable * type_expression option) =

187
src/stages/1-ast_imperative/combinators.ml
View File

@ -19,14 +19,9 @@ module Errors = struct
end
open Errors
let make_t type_content = {type_content; type_meta = ()}
let make_t type_content = {type_content}
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)
let t_bytes : type_expression = make_t @@ T_constant (TC_bytes)
@ -51,8 +46,8 @@ 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 t_tuple lst : type_expression = make_t @@ T_tuple lst
let t_pair (a , b) : type_expression = t_tuple [a; b]
let ez_t_sum (lst:(string * type_expression) list) : type_expression =
let aux prev (k, v) = CMap.add (Constructor k) v prev in
@ -79,61 +74,74 @@ let t_operator op lst: type_expression result =
| TC_contract _ , [t] -> ok @@ t_contract t
| _ , _ -> fail @@ bad_type_operator op
let make_expr ?(loc = Location.generated) expression_content =
let make_e ?(loc = Location.generated) expression_content =
let location = loc in
{ expression_content; location }
let e_var ?loc (n: string) : expression = make_expr ?loc @@ E_variable (Var.of_name n)
let e_literal ?loc l : expression = make_expr ?loc @@ E_literal l
let e_unit ?loc () : expression = make_expr ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = make_expr ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = make_expr ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = make_expr ?loc @@ E_literal (Literal_timestamp n)
let e_bool ?loc b : expression = make_expr ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = make_expr ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = make_expr ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = make_expr ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = make_expr ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = make_expr ?loc @@ E_literal (Literal_chain_id s)
let e_literal ?loc l : expression = make_e ?loc @@ E_literal l
let e_unit ?loc () : expression = make_e ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = make_e ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = make_e ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = make_e ?loc @@ E_literal (Literal_timestamp n)
let e_bool ?loc b : expression = make_e ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = make_e ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = make_e ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = make_e ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = make_e ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = make_e ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = make_e ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = make_e ?loc @@ E_literal (Literal_chain_id s)
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 =
let%bind e' = e'_bytes b in
ok @@ make_expr ?loc e'
ok @@ make_e ?loc e'
let e_bytes_raw ?loc (b: bytes) : expression =
make_expr ?loc @@ E_literal (Literal_bytes b)
make_e ?loc @@ E_literal (Literal_bytes b)
let e_bytes_string ?loc (s: string) : expression =
make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b}
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
let e_variable ?loc v = make_expr ?loc @@ E_variable v
let e_skip ?loc () = make_expr ?loc @@ E_skip
let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline }
let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y)
let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {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*)
*)
make_e ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_some ?loc s : expression = make_e ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = make_e ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc sl sr : expression = make_e ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc k v old : expression = make_e ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
let e_binop ?loc name a b = make_e ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_variable ?loc v = make_e ?loc @@ E_variable v
let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b}
let e_lambda ?loc binder input_type output_type result : expression = make_e ?loc @@ E_lambda {binder; input_type; output_type; result}
let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_let_in ?loc (binder, ascr) inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline }
let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = Label b}
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path=Label path; update}
let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst
let e_tuple_accessor ?loc tuple path : expression = make_e ?loc @@ E_tuple_accessor {tuple; path}
let e_tuple_update ?loc tuple path update : expression = make_e ?loc @@ E_tuple_update {tuple; path; update}
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause}
let e_sequence ?loc expr1 expr2 = make_e ?loc @@ E_sequence {expr1; expr2}
let e_skip ?loc () = make_e ?loc @@ E_skip
let e_list ?loc lst : expression = make_e ?loc @@ E_list lst
let e_set ?loc lst : expression = make_e ?loc @@ E_set lst
let e_map ?loc lst : expression = make_e ?loc @@ E_map lst
let e_big_map ?loc lst : expression = make_e ?loc @@ E_big_map lst
let e_look_up ?loc x y = make_e ?loc @@ E_look_up (x , y)
let e_while ?loc condition body = make_e ?loc @@ E_while {condition; body}
let e_for ?loc binder start final increment body = make_e ?loc @@ E_for {binder;start;final;increment;body}
let e_for_each ?loc binder collection collection_type body = make_e ?loc @@ E_for_each {binder;collection;collection_type;body}
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,())
@ -141,17 +149,12 @@ 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
make_expr ?loc @@ E_record map
make_e ?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
make_expr ?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
@ -163,8 +166,9 @@ let e_typed_none ?loc t_opt =
let type_annotation = t_option t_opt in
e_annotation ?loc (e_none ?loc ()) type_annotation
let e_typed_list ?loc lst t =
e_annotation ?loc (e_list lst) (t_list t)
let e_typed_list ?loc lst t = e_annotation ?loc (e_list lst) (t_list t)
let e_typed_list_literal ?loc lst t =
e_annotation ?loc (e_constant C_LIST_LITERAL lst) (t_list t)
let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v)
let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v)
@ -172,38 +176,18 @@ 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)
(result : expression)
: expression =
make_expr ?loc @@ E_lambda {
binder = binder ;
input_type = input_type ;
output_type = output_type ;
result ;
}
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_assign_with_let ?loc var access_path expr =
let var = Var.of_name (var) in
match access_path with
| [] -> (var, None), true, expr, false
| lst ->
let rec aux path record= match path with
| [] -> failwith "acces_path cannot be empty"
| [e] -> e_update ?loc record e expr
| elem::tail ->
let next_record = e_accessor record elem in
e_update ?loc record elem (aux tail next_record )
in
(var, None), true, (aux lst (e_variable var)), false
let e_assign ?loc variable access_path expression =
make_e ?loc @@ E_assign {variable;access_path;expression}
let e_ez_assign ?loc variable access_path expression =
let variable = Var.of_name variable in
let access_path = List.map (fun s -> Access_record s) access_path in
e_assign ?loc variable access_path expression
let get_e_accessor = fun t ->
match t with
| E_record_accessor {expr; label} -> ok (expr , label)
| E_record_accessor {record; path} -> ok (record , path)
| _ -> simple_fail "not an accessor"
let assert_e_accessor = fun t ->
@ -212,14 +196,7 @@ let assert_e_accessor = fun t ->
let get_e_pair = fun t ->
match t with
| E_record r -> (
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> simple_fail "not a pair"
)
| E_tuple [a ; b] -> ok (a , b)
| _ -> simple_fail "not a pair"
let get_e_list = fun t ->
@ -227,29 +204,15 @@ 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_record r -> ok @@ tuple_of_record r
| E_tuple t -> ok @@ t
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
(* Same as get_e_pair *)
let extract_pair : expression -> (expression * expression) result = fun e ->
match e.expression_content with
| E_record r -> (
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> fail @@ bad_kind "pair" e.location
)
| E_tuple [a;b] -> ok @@ (a,b)
| _ -> fail @@ bad_kind "pair" e.location
let extract_list : expression -> (expression list) result = fun e ->

72
src/stages/1-ast_imperative/combinators.mli
View File

@ -46,8 +46,8 @@ val t_map : type_expression -> type_expression -> type_expression
val t_operator : type_operator -> type_expression list -> type_expression result
val t_set : type_expression -> type_expression
val make_expr : ?loc:Location.t -> expression_content -> expression
val e_var : ?loc:Location.t -> string -> expression
val make_e : ?loc:Location.t -> expression_content -> expression
val e_literal : ?loc:Location.t -> literal -> expression
val e_unit : ?loc:Location.t -> unit -> expression
val e_int : ?loc:Location.t -> int -> expression
@ -65,56 +65,68 @@ 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_ez : ?loc:Location.t -> ( string * expr ) list -> expression
val e_tuple : ?loc:Location.t -> expression list -> expression
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
val e_some : ?loc:Location.t -> expression -> expression
val e_none : ?loc:Location.t -> unit -> expression
val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_set : ?loc:Location.t -> expression list -> expression
val e_list : ?loc:Location.t -> expression list -> expression
val e_pair : ?loc:Location.t -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> 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 -> string -> expression
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_skip : ?loc:Location.t -> unit -> expression
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_tuple : ?loc:Location.t -> expression list -> expression
val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression
val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression
val e_pair : ?loc:Location.t -> expression -> expression -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
val e_skip : ?loc:Location.t -> unit -> expression
val e_list : ?loc:Location.t -> expression list -> expression
val e_set : ?loc:Location.t -> expression list -> expression
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val e_assign : ?loc:Location.t -> expression_variable -> access list -> expression -> expression
val e_ez_assign : ?loc:Location.t -> string -> string list -> expression -> expression
val e_while : ?loc:Location.t -> expression -> expression -> expression
val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression
val e_for_each : ?loc:Location.t -> expression_variable * expression_variable option -> expression -> collect_type -> expression -> expression
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
val e_typed_none : ?loc:Location.t -> type_expression -> expression
val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression
val e_typed_list_literal : ?loc:Location.t -> expression list -> type_expression -> expression
val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> 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 get_e_accessor : expression' -> ( expression * access_path ) result
*)
val assert_e_accessor : expression_content -> unit result

31
src/stages/1-ast_imperative/misc.ml
View File

@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| E_record_update _, _ ->
simple_fail "comparing record update 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_tuple_update uta, E_tuple_update utb ->
let _ =
generic_try (simple_error "Updating different tuple") @@
fun () -> assert_value_eq (uta.tuple, utb.tuple) in
let () = assert (uta.path == utb.path) in
let%bind () = assert_value_eq (uta.update,utb.update) in
ok ()
| E_tuple_update _, _ ->
simple_fail "comparing tuple update with other expression"
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
let%bind lst = generic_try (simple_error "maps of different lengths")
(fun () ->
@ -182,9 +202,14 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
| (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _)
| (E_recursive _,_) | (E_record_accessor _, _)
| (E_look_up _, _) | (E_matching _, _)
| (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value"
| (E_recursive _,_)
| (E_record_accessor _, _) | (E_tuple_accessor _, _)
| (E_look_up _, _)
| (E_matching _, _) | (E_cond _, _)
| (E_sequence _, _) | (E_skip, _)
| (E_assign _, _)
| (E_for _, _) | (E_for_each _, _)
| (E_while _, _) -> simple_fail "comparing not a value"
let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)

97
src/stages/1-ast_imperative/types.ml
View File

@ -2,17 +2,31 @@
module Location = Simple_utils.Location
module Ast_imperative_parameter = struct
type type_meta = unit
end
include Stage_common.Types
(*include Ast_generic_type(Ast_core_parameter)
*)
include Ast_generic_type (Ast_imperative_parameter)
type type_content =
| T_sum of type_expression constructor_map
| T_record of type_expression label_map
| T_tuple of type_expression list
| T_arrow of arrow
| T_variable of type_variable
| T_constant of type_constant
| T_operator of type_operator
and arrow = {type1: type_expression; type2: type_expression}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| TC_list of type_expression
| TC_set of type_expression
| TC_map of type_expression * type_expression
| TC_big_map of type_expression * type_expression
| TC_arrow of type_expression * type_expression
and type_expression = {type_content: type_content}
type inline = bool
type program = declaration Location.wrap list
and declaration =
| Declaration_type of (type_variable * type_expression)
@ -22,7 +36,7 @@ and declaration =
* an optional type annotation
* a boolean indicating whether it should be inlined
* an expression *)
| Declaration_constant of (expression_variable * type_expression option * inline * expression)
| Declaration_constant of (expression_variable * type_expression option * bool * expression)
(* | Macro_declaration of macro_declaration *)
and expression = {expression_content: expression_content; location: Location.t}
@ -41,19 +55,28 @@ and expression_content =
| E_matching of matching
(* Record *)
| E_record of expression label_map
| E_record_accessor of accessor
| E_record_update of update
| E_record_accessor of record_accessor
| E_record_update of record_update
(* Advanced *)
| E_ascription of ascription
(* Sugar *)
| E_cond of conditional
| E_sequence of sequence
| E_skip
| E_tuple of expression list
| E_tuple_accessor of tuple_accessor
| E_tuple_update of tuple_update
(* Data Structures *)
| E_map of (expression * expression) list
| E_big_map of (expression * expression) list
| E_list of expression list
| E_set of expression list
| E_look_up of (expression * expression)
(* Imperative *)
| E_assign of assign
| E_for of for_
| E_for_each of for_each
| E_while of while_loop
and constant =
{ cons_name: constant' (* this is at the end because it is huge *)
@ -78,16 +101,16 @@ and recursive = {
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 record_accessor = {record: expression; path: label}
and record_update = {record: expression; path: label ; update: expression}
and update = {record: expression; path: label ; update: expression}
and matching_expr = (expr,unit) matching_content
and matching =
@ -96,11 +119,57 @@ and matching =
}
and ascription = {anno_expr: expression; type_annotation: type_expression}
and conditional = {
condition : expression ;
then_clause : expression ;
else_clause : expression ;
}
and sequence = {
expr1: expression ;
expr2: expression ;
}
and tuple_accessor = {tuple: expression; path: int}
and tuple_update = {tuple: expression; path: int ; update: expression}
and assign = {
variable : expression_variable;
access_path : access list;
expression : expression;
}
and access =
| Access_tuple of int
| Access_record of string
| Access_map of expr
and for_ = {
binder : expression_variable;
start : expression;
final : expression;
increment : expression;
body : expression;
}
and for_each = {
binder : expression_variable * expression_variable option;
collection : expression;
collection_type : collect_type;
body : expression;
}
and collect_type =
| Map
| Set
| List
and while_loop = {
condition : expression;
body : expression;
}
and environment_element_definition =
| ED_binder
| ED_declaration of (expression * free_variables)

62
src/stages/2-ast_sugar/PP.ml
View File

@ -4,11 +4,41 @@ open Format
open PP_helpers
include Stage_common.PP
include Ast_PP_type(Ast_sugar_parameter)
let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev
let rec type_expression' :
(formatter -> type_expression -> unit)
-> formatter
-> 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}" (record_sep f (const ";")) m
| T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator -> unit =
fun f ppf to_ ->
let s =
match to_ with
| TC_option te -> Format.asprintf "option(%a)" f te
| TC_list te -> Format.asprintf "list(%a)" f te
| TC_set te -> Format.asprintf "set(%a)" f te
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te
in
fprintf ppf "(TO_%s)" s
let rec expression ppf (e : expression) =
expression_content ppf e.expression_content
@ -26,11 +56,11 @@ and expression_content ppf (ec : expression_content) =
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
fprintf ppf "{%a}" (record_sep expression (const ";")) m
| E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.expr label ra.label
fprintf ppf "%a.%a" expression ra.record label ra.path
| E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression 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 ->
@ -56,14 +86,30 @@ and expression_content ppf (ec : expression_content) =
| E_matching {matchee; cases; _} ->
fprintf ppf "match %a with %a" expression matchee (matching expression)
cases
| E_let_in { let_binder ; rhs ; let_result; inline } ->
fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result
| E_sequence {expr1;expr2} ->
fprintf ppf "%a;\n%a" expression expr1 expression expr2
| E_let_in { let_binder ; rhs ; let_result; inline; mut} ->
fprintf ppf "let %a%a = %a%a in %a"
option_type_name let_binder
option_mut mut
expression rhs
option_inline inline
expression let_result
| E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation
| E_cond {condition; then_clause; else_clause} ->
fprintf ppf "if %a then %a else %a"
expression condition
expression then_clause
expression else_clause
| E_sequence {expr1;expr2} ->
fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2
| E_skip ->
fprintf ppf "skip"
| E_tuple t ->
fprintf ppf "(%a)" (list_sep_d expression) t
| E_tuple_accessor ta ->
fprintf ppf "%a.%d" expression ta.tuple ta.path
| E_tuple_update {tuple; path; update} ->
fprintf ppf "{ %a with %d = %a }" expression tuple path expression update
and option_type_name ppf
((n, ty_opt) : expression_variable * type_expression option) =

172
src/stages/2-ast_sugar/combinators.ml
View File

@ -19,7 +19,7 @@ module Errors = struct
end
open Errors
let make_t type_content = {type_content; type_meta = ()}
let make_t type_content = {type_content}
let tuple_to_record lst =
@ -79,80 +79,67 @@ let t_operator op lst: type_expression result =
| TC_contract _ , [t] -> ok @@ t_contract t
| _ , _ -> fail @@ bad_type_operator op
let make_expr ?(loc = Location.generated) expression_content =
let make_e ?(loc = Location.generated) expression_content =
let location = loc in
{ expression_content; location }
let e_var ?loc (n: string) : expression = make_expr ?loc @@ E_variable (Var.of_name n)
let e_literal ?loc l : expression = make_expr ?loc @@ E_literal l
let e_unit ?loc () : expression = make_expr ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = make_expr ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = make_expr ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = make_expr ?loc @@ E_literal (Literal_timestamp n)
let e_bool ?loc b : expression = make_expr ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = make_expr ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = make_expr ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = make_expr ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = make_expr ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = make_expr ?loc @@ E_literal (Literal_chain_id s)
let e_literal ?loc l : expression = make_e ?loc @@ E_literal l
let e_unit ?loc () : expression = make_e ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = make_e ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = make_e ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = make_e ?loc @@ E_literal (Literal_timestamp n)
let e_bool ?loc b : expression = make_e ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = make_e ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = make_e ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = make_e ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = make_e ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = make_e ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = make_e ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = make_e ?loc @@ E_literal (Literal_chain_id s)
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 =
let%bind e' = e'_bytes b in
ok @@ make_expr ?loc e'
ok @@ make_e ?loc e'
let e_bytes_raw ?loc (b: bytes) : expression =
make_expr ?loc @@ E_literal (Literal_bytes b)
make_e ?loc @@ E_literal (Literal_bytes b)
let e_bytes_string ?loc (s: string) : expression =
make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b}
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
let e_variable ?loc v = make_expr ?loc @@ E_variable v
let e_skip ?loc () = make_expr ?loc @@ E_skip
let e_let_in ?loc (binder, ascr) inline rhs let_result =
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline }
let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y)
let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {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
make_expr ?loc @@ E_record map
let e_record ?loc map =
let lst = Map.String.to_kv_list map in
e_record_ez ?loc lst
make_e ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_some ?loc s : expression = make_e ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = make_e ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_update ?loc record path update =
let path = Label path in
make_expr ?loc @@ E_record_update {record; path; update}
let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_variable ?loc v = make_e ?loc @@ E_variable v
let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b}
let e_lambda ?loc binder input_type output_type result : expression = make_e ?loc @@ E_lambda {binder; input_type; output_type; result}
let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_let_in ?loc (binder, ascr) mut inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut }
let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst)
let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
let e_record ?loc map : expression = make_e ?loc @@ E_record map
let e_record_accessor ?loc record path = make_e ?loc @@ E_record_accessor {record; path}
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update}
let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst
let e_tuple_accessor ?loc tuple path = make_e ?loc @@ E_tuple_accessor {tuple; path}
let e_tuple_update ?loc tuple path update = make_e ?loc @@ E_tuple_update {tuple; path; update}
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause}
let e_sequence ?loc expr1 expr2 = make_e ?loc @@ E_sequence {expr1; expr2}
let e_skip ?loc () = make_e ?loc @@ E_skip
let e_list ?loc lst : expression = make_e ?loc @@ E_list lst
let e_set ?loc lst : expression = make_e ?loc @@ E_set lst
let e_map ?loc lst : expression = make_e ?loc @@ E_map lst
let e_big_map ?loc lst : expression = make_e ?loc @@ E_big_map lst
let e_look_up ?loc a b : expression = make_e ?loc @@ E_look_up (a,b)
let make_option_typed ?loc e t_opt =
match t_opt with
| None -> e
@ -172,54 +159,19 @@ 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)
(result : expression)
: expression =
make_expr ?loc @@ E_lambda {
binder = binder ;
input_type = input_type ;
output_type = output_type ;
result ;
}
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_assign_with_let ?loc var access_path expr =
let var = Var.of_name (var) in
match access_path with
| [] -> (var, None), true, expr, false
| lst ->
let rec aux path record= match path with
| [] -> failwith "acces_path cannot be empty"
| [e] -> e_update ?loc record e expr
| elem::tail ->
let next_record = e_accessor record elem in
e_update ?loc record elem (aux tail next_record )
in
(var, None), true, (aux lst (e_variable var)), false
let get_e_accessor = fun t ->
let get_e_record_accessor = fun t ->
match t with
| E_record_accessor {expr; label} -> ok (expr , label)
| _ -> simple_fail "not an accessor"
| E_record_accessor {record; path} -> ok (record, path)
| _ -> simple_fail "not a record accessor"
let assert_e_accessor = fun t ->
let%bind _ = get_e_accessor t in
let%bind _ = get_e_record_accessor t in
ok ()
let get_e_pair = fun t ->
match t with
| E_record r -> (
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> simple_fail "not a pair"
)
| E_tuple [a ; b] -> ok (a , b)
| _ -> simple_fail "not a pair"
let get_e_list = fun t ->
@ -227,29 +179,15 @@ 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_record r -> ok @@ tuple_of_record r
| E_tuple t -> ok @@ t
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
(* Same as get_e_pair *)
let extract_pair : expression -> (expression * expression) result = fun e ->
match e.expression_content with
| E_record r -> (
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> fail @@ bad_kind "pair" e.location
)
| E_tuple [a;b] -> ok @@ (a,b)
| _ -> fail @@ bad_kind "pair" e.location
let extract_list : expression -> (expression list) result = fun e ->

66
src/stages/2-ast_sugar/combinators.mli
View File

@ -46,8 +46,7 @@ val t_map : type_expression -> type_expression -> type_expression
val t_operator : type_operator -> type_expression list -> type_expression result
val t_set : type_expression -> type_expression
val make_expr : ?loc:Location.t -> expression_content -> expression
val e_var : ?loc:Location.t -> string -> expression
val make_e : ?loc:Location.t -> expression_content -> expression
val e_literal : ?loc:Location.t -> literal -> expression
val e_unit : ?loc:Location.t -> unit -> expression
val e_int : ?loc:Location.t -> int -> expression
@ -65,35 +64,40 @@ 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_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
val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_set : ?loc:Location.t -> expression list -> expression
val e_list : ?loc:Location.t -> expression list -> expression
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 -> string -> expression
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_skip : ?loc:Location.t -> unit -> expression
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> 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_constructor : ?loc:Location.t -> string -> expression -> expression
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression
val e_record : ?loc:Location.t -> expr label_map -> expression
val e_record_accessor : ?loc:Location.t -> expression -> label -> expression
val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_tuple : ?loc:Location.t -> expression list -> expression
val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression
val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression
val e_pair : ?loc:Location.t -> expression -> expression -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
val e_skip : ?loc:Location.t -> unit -> expression
val e_list : ?loc:Location.t -> expression list -> expression
val e_set : ?loc:Location.t -> expression list -> expression
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
@ -103,18 +107,8 @@ val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expr
val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> 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 get_e_accessor : expression' -> ( expression * access_path ) result
*)
val assert_e_accessor : expression_content -> unit result

26
src/stages/2-ast_sugar/misc.ml
View File

@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| E_record_update _, _ ->
simple_fail "comparing record update 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_tuple_update uta, E_tuple_update utb ->
let _ =
generic_try (simple_error "Updating different tuple") @@
fun () -> assert_value_eq (uta.tuple, utb.tuple) in
let () = assert (uta.path == utb.path) in
let%bind () = assert_value_eq (uta.update,utb.update) in
ok ()
| E_tuple_update _, _ ->
simple_fail "comparing tuple update with other expression"
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
let%bind lst = generic_try (simple_error "maps of different lengths")
(fun () ->
@ -182,8 +202,10 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
| (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _)
| (E_recursive _,_) | (E_record_accessor _, _)
| (E_look_up _, _) | (E_matching _, _)
| (E_recursive _,_)
| (E_record_accessor _, _) | (E_tuple_accessor _, _)
| (E_look_up _, _)
| (E_matching _, _) | (E_cond _, _)
| (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value"
let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)

66
src/stages/2-ast_sugar/types.ml
View File

@ -2,17 +2,31 @@
module Location = Simple_utils.Location
module Ast_sugar_parameter = struct
type type_meta = unit
end
include Stage_common.Types
(*include Ast_generic_type(Ast_core_parameter)
*)
include Ast_generic_type (Ast_sugar_parameter)
type type_content =
| T_sum of type_expression constructor_map
| T_record of type_expression label_map
| T_tuple of type_expression list
| T_arrow of arrow
| T_variable of type_variable
| T_constant of type_constant
| T_operator of type_operator
and arrow = {type1: type_expression; type2: type_expression}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| TC_list of type_expression
| TC_set of type_expression
| TC_map of type_expression * type_expression
| TC_big_map of type_expression * type_expression
| TC_arrow of type_expression * type_expression
and type_expression = {type_content: type_content}
type inline = bool
type program = declaration Location.wrap list
and declaration =
| Declaration_type of (type_variable * type_expression)
@ -22,7 +36,7 @@ and declaration =
* an optional type annotation
* a boolean indicating whether it should be inlined
* an expression *)
| Declaration_constant of (expression_variable * type_expression option * inline * expression)
| Declaration_constant of (expression_variable * type_expression option * bool * expression)
(* | Macro_declaration of macro_declaration *)
and expression = {expression_content: expression_content; location: Location.t}
@ -41,13 +55,17 @@ and expression_content =
| E_matching of matching
(* Record *)
| E_record of expression label_map
| E_record_accessor of accessor
| E_record_update of update
| E_record_accessor of record_accessor
| E_record_update of record_update
(* Advanced *)
| E_ascription of ascription
(* Sugar *)
| E_cond of conditional
| E_sequence of sequence
| E_skip
| E_tuple of expression list
| E_tuple_accessor of tuple_accessor
| E_tuple_update of tuple_update
(* Data Structures *)
| E_map of (expression * expression) list
| E_big_map of (expression * expression) list
@ -76,17 +94,18 @@ and recursive = {
lambda : lambda;
}
and let_in =
{ let_binder: expression_variable * type_expression option
; rhs: expression
; let_result: expression
; inline: bool }
and let_in = {
let_binder: expression_variable * type_expression option ;
rhs: expression ;
let_result: expression ;
inline: bool ;
mut: bool;
}
and constructor = {constructor: constructor'; element: expression}
and accessor = {expr: expression; label: label}
and update = {record: expression; path: label ; update: expression}
and record_accessor = {record: expression; path: label}
and record_update = {record: expression; path: label ; update: expression}
and matching_expr = (expr,unit) matching_content
and matching =
@ -95,11 +114,20 @@ and matching =
}
and ascription = {anno_expr: expression; type_annotation: type_expression}
and conditional = {
condition : expression ;
then_clause : expression ;
else_clause : expression ;
}
and sequence = {
expr1: expression ;
expr2: expression ;
}
and tuple_accessor = {tuple: expression; path: int}
and tuple_update = {tuple: expression; path: int ; update: expression}
and environment_element_definition =
| ED_binder
| ED_declaration of (expression * free_variables)

48
src/stages/3-ast_core/PP.ml
View File

@ -19,30 +19,20 @@ and expression_content ppf (ec : expression_content) =
| E_variable n ->
fprintf ppf "%a" expression_variable n
| E_application {lamb;args} ->
fprintf ppf "(%a)@(%a)" expression lamb expression args
fprintf ppf "@[<hv>(%a)@@(%a)@]" expression lamb expression args
| E_constructor c ->
fprintf ppf "%a(%a)" constructor c.constructor expression c.element
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)
fprintf ppf "@[%a@[<hv 1>(%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
fprintf ppf "@[%a.%a@]" expression ra.record label ra.path
| 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
fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression record label path expression update
| E_lambda {binder; input_type; output_type; result} ->
fprintf ppf "lambda (%a:%a) : %a return %a"
fprintf ppf "@[lambda (%a:%a) : %a@ return@ %a@]"
expression_variable binder
(PP_helpers.option type_expression)
input_type
@ -54,10 +44,10 @@ and expression_content ppf (ec : expression_content) =
type_expression fun_type
expression_content (E_lambda lambda)
| E_matching {matchee; cases; _} ->
fprintf ppf "match %a with %a" expression matchee (matching expression)
fprintf ppf "@[match %a with@ %a@]" expression matchee (matching expression)
cases
| E_let_in { let_binder ;rhs ; let_result; inline } ->
fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result
fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" option_type_name let_binder expression rhs option_inline inline expression let_result
| E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression
type_annotation
@ -71,27 +61,27 @@ and option_type_name ppf
fprintf ppf "%a : %a" expression_variable n type_expression ty
and assoc_expression ppf : expr * expr -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
fun (a, b) -> fprintf ppf "@[<2>%a ->@;<1 2>%a@]" expression a expression b
and single_record_patch ppf ((p, expr) : label * expr) =
fprintf ppf "%a <- %a" label 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 expression_variable n f a
fprintf ppf "| %a %a ->@;<1 2>%a@ " constructor c expression_variable n f a
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 expression_variable) lst f b
fprintf ppf "@[<hv>| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
fprintf ppf "@[<hv>%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
fprintf ppf "@[<hv>| True ->@;<1 2>%a@ | False ->@;<1 2>%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 expression_variable hd expression_variable tl f match_cons
fprintf ppf "@[<hv>| Nil ->@;<1 2>%a@ | %a :: %a ->@;<1 2>%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 expression_variable some f match_some
fprintf ppf "@[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%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
@ -111,22 +101,22 @@ and matching_variant_case_type ppf ((c,n),_a) =
and option_mut ppf mut =
if mut then
fprintf ppf "[@mut]"
fprintf ppf "[@@mut]"
else
fprintf ppf ""
and option_inline ppf inline =
if inline then
fprintf ppf "[@inline]"
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
fprintf ppf "@[<2>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
fprintf ppf "@[<2>const %a =@ %a%a@]" option_type_name (name, ty_opt) expression
expr
option_inline i

179
src/stages/3-ast_core/combinators.ml
View File

@ -79,133 +79,71 @@ let t_operator op lst: type_expression result =
| TC_contract _ , [t] -> ok @@ t_contract t
| _ , _ -> fail @@ bad_type_operator op
let make_expr ?(loc = Location.generated) expression_content =
let location = loc in
{ expression_content; location }
let make_e ?(loc = Location.generated) expression_content = { expression_content; location=loc }
let e_var ?loc (n: string) : expression = make_expr ?loc @@ E_variable (Var.of_name n)
let e_literal ?loc l : expression = make_expr ?loc @@ E_literal l
let e_unit ?loc () : expression = make_expr ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = make_expr ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = make_expr ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = make_expr ?loc @@ E_literal (Literal_timestamp n)
let e_bool ?loc b : expression = make_expr ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = make_expr ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = make_expr ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = make_expr ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = make_expr ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = make_expr ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = make_expr ?loc @@ E_literal (Literal_chain_id s)
let e_var ?loc (n: string) : expression = make_e ?loc @@ E_variable (Var.of_name n)
let e_literal ?loc l : expression = make_e ?loc @@ E_literal l
let e_unit ?loc () : expression = make_e ?loc @@ E_literal (Literal_unit)
let e_int ?loc n : expression = make_e ?loc @@ E_literal (Literal_int n)
let e_nat ?loc n : expression = make_e ?loc @@ E_literal (Literal_nat n)
let e_timestamp ?loc n : expression = make_e ?loc @@ E_literal (Literal_timestamp n)
let e_bool ?loc b : expression = make_e ?loc @@ E_literal (Literal_bool b)
let e_string ?loc s : expression = make_e ?loc @@ E_literal (Literal_string s)
let e_address ?loc s : expression = make_e ?loc @@ E_literal (Literal_address s)
let e_mutez ?loc s : expression = make_e ?loc @@ E_literal (Literal_mutez s)
let e_signature ?loc s : expression = make_e ?loc @@ E_literal (Literal_signature s)
let e_key ?loc s : expression = make_e ?loc @@ E_literal (Literal_key s)
let e_key_hash ?loc s : expression = make_e ?loc @@ E_literal (Literal_key_hash s)
let e_chain_id ?loc s : expression = make_e ?loc @@ E_literal (Literal_chain_id s)
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 =
let%bind e' = e'_bytes b in
ok @@ make_expr ?loc e'
ok @@ make_e ?loc e'
let e_bytes_raw ?loc (b: bytes) : expression =
make_expr ?loc @@ E_literal (Literal_bytes b)
make_e ?loc @@ E_literal (Literal_bytes b)
let e_bytes_string ?loc (s: string) : expression =
make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b}
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
let e_variable ?loc v = make_expr ?loc @@ E_variable v
let e_let_in ?loc (binder, ascr) inline rhs let_result =
make_expr ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline }
let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y)
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
make_expr ?loc @@ E_record map
let e_record ?loc map =
let lst = Map.String.to_kv_list map in
e_record_ez ?loc lst
make_e ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
let e_some ?loc s : expression = make_e ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
let e_none ?loc () : expression = make_e ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
let e_string_cat ?loc sl sr : expression = make_e ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
let e_map_add ?loc k v old : expression = make_e ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
let e_update ?loc record path update =
let path = Label path in
make_expr ?loc @@ E_record_update {record; path; update}
let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_variable ?loc v = make_e ?loc @@ E_variable v
let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b}
let e_lambda ?loc binder input_type output_type result = make_e ?loc @@ E_lambda {binder; input_type; output_type; result ; }
let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_let_in ?loc (binder, ascr) inline rhs let_result = make_e ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline }
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 e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
let e_record ?loc map = make_e ?loc @@ E_record map
let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = Label b}
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update}
let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let make_option_typed ?loc e t_opt =
match t_opt with
| None -> e
| Some t -> e_annotation ?loc e t
let e_typed_none ?loc t_opt =
let type_annotation = t_option t_opt in
e_annotation ?loc (e_none ?loc ()) type_annotation
let e_typed_list ?loc lst t =
e_annotation ?loc (e_list lst) (t_list t)
let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v)
let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v)
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)
(result : expression)
: expression =
make_expr ?loc @@ E_lambda {
binder = binder ;
input_type = input_type ;
output_type = output_type ;
result ;
}
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_assign_with_let ?loc var access_path expr =
let var = Var.of_name (var) in
match access_path with
| [] -> (var, None), true, expr, false
| lst ->
let rec aux path record= match path with
| [] -> failwith "acces_path cannot be empty"
| [e] -> e_update ?loc record e expr
| elem::tail ->
let next_record = e_accessor record elem in
e_update ?loc record elem (aux tail next_record )
in
(var, None), true, (aux lst (e_variable var)), false
let get_e_accessor = fun t ->
let get_e_record_accessor = fun t ->
match t with
| E_record_accessor {expr; label} -> ok (expr , label)
| E_record_accessor {record; path} -> ok (record, path)
| _ -> simple_fail "not an accessor"
let assert_e_accessor = fun t ->
let%bind _ = get_e_accessor t in
let assert_e_record_accessor = fun t ->
let%bind _ = get_e_record_accessor t in
ok ()
let get_e_pair = fun t ->
@ -221,20 +159,20 @@ let get_e_pair = fun t ->
| _ -> simple_fail "not a pair"
let get_e_list = fun t ->
match t with
| 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
let rec aux t =
match t with
E_constant {cons_name=C_CONS;arguments=[key;lst]} ->
let%bind lst = aux lst.expression_content in
ok @@ key::(lst)
| E_constant {cons_name=C_LIST_EMPTY;arguments=[]} ->
ok @@ []
| _ -> simple_fail "not a list"
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
aux t
let get_e_tuple = fun t ->
match t with
| E_record r -> ok @@ tuple_of_record r
| E_record r -> ok @@ List.map snd @@ Stage_common.Helpers.tuple_of_record r
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
(* Same as get_e_pair *)
@ -250,17 +188,18 @@ let extract_pair : expression -> (expression * expression) result = fun e ->
)
| _ -> fail @@ bad_kind "pair" e.location
let extract_list : expression -> (expression list) result = fun e ->
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_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_content with
| E_map lst -> ok lst
| _ -> fail @@ bad_kind "map" e.location
let rec aux e =
match e.expression_content with
E_constant {cons_name=C_UPDATE|C_MAP_ADD; arguments=[k;v;map]} ->
let%bind map = aux map in
ok @@ (k,v)::map
| E_constant {cons_name=C_MAP_EMPTY|C_BIG_MAP_EMPTY; arguments=[]} -> ok @@ []
| _ -> fail @@ bad_kind "map" e.location
in
aux e

34
src/stages/3-ast_core/combinators.mli
View File

@ -46,7 +46,7 @@ val t_map : type_expression -> type_expression -> type_expression
val t_operator : type_operator -> type_expression list -> type_expression result
val t_set : type_expression -> type_expression
val make_expr : ?loc:Location.t -> expression_content -> expression
val make_e : ?loc:Location.t -> expression_content -> expression
val e_var : ?loc:Location.t -> string -> expression
val e_literal : ?loc:Location.t -> literal -> expression
val e_unit : ?loc:Location.t -> unit -> expression
@ -65,56 +65,34 @@ 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_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
val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_set : ?loc:Location.t -> expression list -> expression
val e_list : ?loc:Location.t -> expression list -> expression
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 -> string -> expression
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
val e_typed_none : ?loc:Location.t -> type_expression -> expression
val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression
val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> 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_record : ?loc:Location.t -> expr label_map-> expression
val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression
(*
val get_e_accessor : expression' -> ( expression * access_path ) result
*)
val assert_e_accessor : expression_content -> unit result
val assert_e_record_accessor : expression_content -> unit result
val get_e_pair : expression_content -> ( expression * expression ) result
@ -126,8 +104,6 @@ val is_e_failwith : expression -> bool
*)
val extract_pair : expression -> ( expression * expression ) result
val extract_list : expression -> (expression list) result
val extract_record : expression -> (label * expression) list result
val extract_map : expression -> (expression * expression) list result

43
src/stages/3-ast_core/misc.ml
View File

@ -139,52 +139,13 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
ok ()
| 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) -> (
let%bind lst = generic_try (simple_error "maps of different lengths")
(fun () ->
let lsta' = List.sort compare lsta in
let lstb' = List.sort compare lstb in
List.combine lsta' lstb') in
let aux = fun ((ka, va), (kb, vb)) ->
let%bind _ = assert_value_eq (ka, kb) in
let%bind _ = assert_value_eq (va, vb) in
ok () in
let%bind _all = bind_map_list aux lst in
ok ()
)
| (E_map _ | E_big_map _), _ ->
simple_fail "comparing map with other expression"
| E_list lsta, E_list lstb -> (
let%bind lst =
generic_try (simple_error "list of different lengths")
(fun () -> List.combine lsta lstb) in
let%bind _all = bind_map_list assert_value_eq lst in
ok ()
)
| E_list _, _ ->
simple_fail "comparing list with other expression"
| E_set lsta, E_set lstb -> (
let lsta' = List.sort (compare) lsta in
let lstb' = List.sort (compare) lstb in
let%bind lst =
generic_try (simple_error "set of different lengths")
(fun () -> List.combine lsta' lstb') in
let%bind _all = bind_map_list assert_value_eq lst in
ok ()
)
| E_set _, _ ->
simple_fail "comparing set with other expression"
| (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b)
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
| (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _)
| (E_recursive _,_) | (E_record_accessor _, _)
| (E_look_up _, _) | (E_matching _, _)
-> simple_fail "comparing not a value"
| (E_matching _, _)
-> simple_fail "comparing not a value"
let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)

16
src/stages/3-ast_core/types.ml
View File

@ -41,15 +41,8 @@ and expression_content =
| 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)
| E_record_accessor of record_accessor
| E_record_update of record_update
(* Advanced *)
| E_ascription of ascription
@ -82,9 +75,8 @@ and let_in =
and constructor = {constructor: constructor'; element: expression}
and accessor = {expr: expression; label: label}
and update = {record: expression; path: label ; update: expression}
and record_accessor = {record: expression; path: label}
and record_update = {record: expression; path: label ; update: expression}
and matching_expr = (expr,unit) matching_content
and matching =

12
src/stages/4-ast_typed/PP.ml
View File

@ -29,19 +29,9 @@ and expression_content ppf (ec: expression_content) =
| 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
fprintf ppf "%a.%a" expression ra.record label ra.path
| 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

44
src/stages/4-ast_typed/combinators.ml
View File

@ -24,7 +24,7 @@ module Errors = struct
end
let make_t type_content core = { type_content ; type_meta=core }
let make_a_e ?(location = Location.generated) expression_content type_expression environment = {
let make_e ?(location = Location.generated) expression_content type_expression environment = {
expression_content ;
type_expression ;
environment ;
@ -64,6 +64,7 @@ let t_pair a b ?s () : type_expression = ez_t_record [(Label "0",a) ; (Label "
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_map_or_big_map key value ?s () = make_t (T_operator (TC_map_or_big_map (key,value))) s
let t_sum m ?s () : type_expression = make_t (T_sum m) s
let make_t_ez_sum (lst:(constructor' * type_expression) list) : type_expression =
@ -190,11 +191,13 @@ let get_t_record (t:type_expression) : type_expression label_map result = match
let get_t_map (t:type_expression) : (type_expression * type_expression) result =
match t.type_content with
| T_operator (TC_map (k,v)) -> ok (k, v)
| T_operator (TC_map_or_big_map (k,v)) -> ok (k, v)
| _ -> fail @@ Errors.not_a_x_type "map" t ()
let get_t_big_map (t:type_expression) : (type_expression * type_expression) result =
match t.type_content with
| T_operator (TC_big_map (k,v)) -> ok (k, v)
| T_operator (TC_map_or_big_map (k,v)) -> ok (k, v)
| _ -> fail @@ Errors.not_a_x_type "big_map" t ()
let get_t_map_key : type_expression -> type_expression result = fun t ->
@ -276,8 +279,6 @@ let ez_e_record (lst : (label * expression) list) : expression_content =
let e_some s : expression_content = E_constant {cons_name=C_SOME;arguments=[s]}
let e_none (): expression_content = E_constant {cons_name=C_NONE; arguments=[]}
let e_map lst : expression_content = E_map lst
let e_unit () : expression_content = E_literal (Literal_unit)
let e_int n : expression_content = E_literal (Literal_int n)
let e_nat n : expression_content = E_literal (Literal_nat n)
@ -296,27 +297,24 @@ let e_lambda l : expression_content = E_lambda l
let e_pair a b : expression_content = ez_e_record [(Label "0",a);(Label "1", b)]
let e_application lamb args : expression_content = E_application {lamb;args}
let e_variable v : expression_content = E_variable v
let e_list lst : expression_content = E_list lst
let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; let_result; inline }
let e_a_unit = make_a_e (e_unit ()) (t_unit ())
let e_a_int n = make_a_e (e_int n) (t_int ())
let e_a_nat n = make_a_e (e_nat n) (t_nat ())
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_expression b.type_expression ())
let e_a_some s = make_a_e (e_some s) (t_option s.type_expression ())
let e_a_lambda l in_ty out_ty = make_a_e (e_lambda l) (t_function in_ty out_ty ())
let e_a_none t = make_a_e (e_none ()) (t_option t ())
let e_a_record r = make_a_e (e_record r) (t_record (LMap.map get_type_expression r) ())
let e_a_application a b = make_a_e (e_application a b) (get_type_expression b)
let e_a_variable v ty = make_a_e (e_variable v) ty
let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_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_expression body)
let e_a_unit = make_e (e_unit ()) (t_unit ())
let e_a_int n = make_e (e_int n) (t_int ())
let e_a_nat n = make_e (e_nat n) (t_nat ())
let e_a_mutez n = make_e (e_mutez n) (t_mutez ())
let e_a_bool b = make_e (e_bool b) (t_bool ())
let e_a_string s = make_e (e_string s) (t_string ())
let e_a_address s = make_e (e_address s) (t_address ())
let e_a_pair a b = make_e (e_pair a b) (t_pair a.type_expression b.type_expression ())
let e_a_some s = make_e (e_some s) (t_option s.type_expression ())
let e_a_lambda l in_ty out_ty = make_e (e_lambda l) (t_function in_ty out_ty ())
let e_a_none t = make_e (e_none ()) (t_option t ())
let e_a_record r = make_e (e_record r) (t_record (LMap.map get_type_expression r) ())
let e_a_application a b = make_e (e_application a b) (get_type_expression b)
let e_a_variable v ty = make_e (e_variable v) ty
let ez_e_a_record r = make_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_expression) r) ())
let e_a_let_in binder expr body attributes = make_e (e_let_in binder expr body attributes) (get_type_expression body)
let get_a_int (t:expression) =
@ -337,7 +335,7 @@ let get_a_bool (t:expression) =
let get_a_record_accessor = fun t ->
match t.expression_content with
| E_record_accessor {expr ; label} -> ok (expr , label)
| E_record_accessor {record; path} -> ok (record, path)
| _ -> simple_fail "not an accessor"
let get_declaration_by_name : program -> string -> declaration result = fun p name ->

7
src/stages/4-ast_typed/combinators.mli
View File

@ -3,7 +3,7 @@ open Types
val make_n_t : type_variable -> type_expression -> named_type_content
val make_t : type_content -> S.type_expression option -> type_expression
val make_a_e : ?location:Location.t -> expression_content -> type_expression -> full_environment -> expression
val make_e : ?location:Location.t -> expression_content -> type_expression -> full_environment -> expression
val t_bool : ?s:S.type_expression -> unit -> type_expression
val t_string : ?s:S.type_expression -> unit -> type_expression
@ -31,6 +31,7 @@ val ez_t_record : ( label * type_expression ) list -> ?s:S.type_expression -> un
val t_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_map_or_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
val t_sum : type_expression constructor_map -> ?s:S.type_expression -> unit -> type_expression
val make_t_ez_sum : ( constructor' * type_expression ) list -> type_expression
val t_function : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
@ -109,7 +110,6 @@ val ez_e_record : ( string * expression ) list -> expression
*)
val e_some : expression -> expression_content
val e_none : unit -> expression_content
val e_map : ( expression * expression ) list -> expression_content
val e_unit : unit -> expression_content
val e_int : int -> expression_content
val e_nat : int -> expression_content
@ -128,7 +128,6 @@ val e_lambda : lambda -> expression_content
val e_pair : expression -> expression -> expression_content
val e_application : expression -> expr -> expression_content
val e_variable : expression_variable -> expression_content
val e_list : expression list -> expression_content
val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
val e_a_unit : full_environment -> expression
@ -146,8 +145,6 @@ val e_a_record : expression label_map -> full_environment -> expression
val e_a_application : expression -> expression -> full_environment -> expression
val e_a_variable : expression_variable -> type_expression -> full_environment -> expression
val ez_e_a_record : ( label * expression ) list -> full_environment -> expression
val e_a_map : ( expression * expression ) list -> type_expression -> type_expression -> full_environment -> expression
val e_a_list : expression list -> type_expression -> full_environment -> expression
val e_a_let_in : expression_variable -> bool -> expression -> expression -> full_environment -> expression
val get_a_int : expression -> int result

4
src/stages/4-ast_typed/combinators_environment.ml
View File

@ -1,7 +1,7 @@
open Types
open Combinators
let make_a_e_empty expression type_annotation = make_a_e expression type_annotation Environment.full_empty
let make_a_e_empty expression type_annotation = make_e expression type_annotation Environment.full_empty
let e_a_empty_unit = e_a_unit Environment.full_empty
let e_a_empty_int n = e_a_int n Environment.full_empty
@ -14,8 +14,6 @@ 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_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
let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty
let e_a_empty_lambda l i o = e_a_lambda l i o Environment.full_empty

2
src/stages/4-ast_typed/combinators_environment.mli
View File

@ -13,8 +13,6 @@ val e_a_empty_pair : expression -> expression -> expression
val e_a_empty_some : expression -> expression
val e_a_empty_none : type_expression -> expression
val e_a_empty_record : expression label_map -> expression
val e_a_empty_map : (expression * expression ) list -> type_expression -> type_expression -> expression
val e_a_empty_list : expression list -> type_expression -> expression
val ez_e_a_empty_record : ( label * expression ) list -> expression
val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression

51
src/stages/4-ast_typed/misc.ml
View File

@ -209,12 +209,8 @@ module Free_variables = struct
| E_application {lamb;args} -> unions @@ List.map self [ lamb ; args ]
| E_constructor {element;_} -> self element
| E_record m -> unions @@ List.map self @@ LMap.to_list m
| E_record_accessor {expr;_} -> self expr
| E_record_accessor {record;_} -> self record
| E_record_update {record; update;_} -> union (self record) @@ self update
| E_list lst -> unions @@ List.map self lst
| E_set lst -> unions @@ List.map self lst
| (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
| E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
| E_matching {matchee; cases;_} -> union (self matchee) (matching_expression b cases)
| E_let_in { let_binder; rhs; let_result; _} ->
let b' = union (singleton let_binder) b in
@ -342,10 +338,11 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) :
| TC_list la, TC_list lb
| TC_contract la, TC_contract lb
| 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_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _),
(TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _ ) -> fail @@ different_operators opa opb
| (TC_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_map (kb,vb) | TC_map_or_big_map (kb,vb))
| (TC_big_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_big_map (kb,vb) | TC_map_or_big_map (kb,vb))
-> ok @@ ([ka;va] ,[kb;vb])
| (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _),
(TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ ) -> fail @@ different_operators opa opb
in
if List.length lsta <> List.length lstb then
fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb)
@ -497,44 +494,10 @@ let rec assert_value_eq (a, b: (expression*expression)) : unit result =
| E_record _, _ ->
fail @@ (different_values_because_different_types "record vs. non-record" a b)
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
let%bind lst = generic_try (different_size_values "maps of different lengths" a b)
(fun () ->
let lsta' = List.sort compare lsta in
let lstb' = List.sort compare lstb in
List.combine lsta' lstb') in
let aux = fun ((ka, va), (kb, vb)) ->
let%bind _ = assert_value_eq (ka, kb) in
let%bind _ = assert_value_eq (va, vb) in
ok () in
let%bind _all = bind_map_list aux lst in
ok ()
)
| (E_map _ | E_big_map _), _ ->
fail @@ different_values_because_different_types "map vs. non-map" a b
| E_list lsta, E_list lstb -> (
let%bind lst =
generic_try (different_size_values "lists of different lengths" a b)
(fun () -> List.combine lsta lstb) in
let%bind _all = bind_map_list assert_value_eq lst in
ok ()
)
| E_list _, _ ->
fail @@ different_values_because_different_types "list vs. non-list" a b
| E_set lsta, E_set lstb -> (
let%bind lst =
generic_try (different_size_values "sets of different lengths" a b)
(fun () -> List.combine lsta lstb) in
let%bind _all = bind_map_list assert_value_eq lst in
ok ()
)
| 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_recursive _, _)
| (E_record_accessor _, _) | (E_record_update _,_)
| (E_look_up _, _) | (E_matching _, _)
| (E_matching _, _)
-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result =

14
src/stages/4-ast_typed/misc_smart.ml
View File

@ -70,23 +70,11 @@ module Captured_variables = struct
| E_record m ->
let%bind lst' = bind_map_list self @@ LMap.to_list m in
ok @@ unions lst'
| E_record_accessor {expr;_} -> self expr
| E_record_accessor {record;_} -> self record
| E_record_update {record;update;_} ->
let%bind r = self record in
let%bind e = self update in
ok @@ union r e
| E_list lst ->
let%bind lst' = bind_map_list self lst in
ok @@ unions lst'
| E_set lst ->
let%bind lst' = bind_map_list self lst in
ok @@ unions lst'
| (E_map m | E_big_map m) ->
let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in
ok @@ unions lst'
| E_look_up (a , b) ->
let%bind lst' = bind_map_list self [ a ; b ] in
ok @@ unions lst'
| E_matching {matchee;cases;_} ->
let%bind a' = self matchee in
let%bind cs' = matching_expression b cases in

19
src/stages/4-ast_typed/types.ml
View File

@ -47,15 +47,8 @@ and expression_content =
| 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)
| E_record_accessor of record_accessor
| E_record_update of record_update
and constant =
{ cons_name: constant'
@ -91,12 +84,12 @@ and constructor = {
element: expression ;
}
and accessor = {
expr: expression ;
label: label ;
and record_accessor = {
record: expression ;
path: label ;
}
and update = {
and record_update = {
record: expression ;
path: label ;
update: expression ;

83
src/stages/5-mini_c/PP.ml
View File

@ -3,23 +3,21 @@ open Simple_utils.PP_helpers
open Types
open Format
let list_sep_d x = list_sep x (const " , ")
let space_sep ppf () = fprintf ppf " "
let list_sep_d x = list_sep x (tag " ,@ ")
let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R"
let rec type_variable ppf : type_value -> _ = function
| T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b
| T_pair(a, b) -> fprintf ppf "(%a) & (%a)" annotated a annotated b
| T_or(a, b) -> fprintf ppf "@[(%a) |@ (%a)@]" annotated a annotated b
| T_pair(a, b) -> fprintf ppf "@[(%a) &@ (%a)@]" annotated a annotated b
| T_base b -> type_constant ppf b
| T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_variable a type_variable b
| T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_variable k type_variable v
| T_big_map(k, v) -> fprintf ppf "big_map(%a -> %a)" type_variable k type_variable v
| T_list(t) -> fprintf ppf "list(%a)" type_variable t
| T_set(t) -> fprintf ppf "set(%a)" type_variable t
| T_option(o) -> fprintf ppf "option(%a)" type_variable o
| T_contract(t) -> fprintf ppf "contract(%a)" type_variable t
| T_function(a, b) -> fprintf ppf "@[(%a) ->@ (%a)@]" type_variable a type_variable b
| T_map(k, v) -> fprintf ppf "@[<4>map(%a -> %a)@]" type_variable k type_variable v
| T_big_map(k, v) -> fprintf ppf "@[<9>big_map(%a -> %a)@]" type_variable k type_variable v
| T_list(t) -> fprintf ppf "@[<5>list(%a)@]" type_variable t
| T_set(t) -> fprintf ppf "@[<4>set(%a)@]" type_variable t
| T_option(o) -> fprintf ppf "@[<7>option(%a)@]" type_variable o
| T_contract(t) -> fprintf ppf "@[<9>contract(%a)@]" type_variable t
and annotated ppf : type_value annotated -> _ = function
| (Some ann, a) -> fprintf ppf "(%a %%%s)" type_variable a ann
@ -80,34 +78,38 @@ and expression ppf (e:expression) =
and expression' ppf (e:expression') = match e with
| E_skip -> fprintf ppf "skip"
| E_closure x -> fprintf ppf "C(%a)" function_ x
| E_variable v -> fprintf ppf "V(%a)" Var.pp v
| E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b
| E_closure x -> function_ ppf x
| E_variable v -> fprintf ppf "%a" Var.pp v
| E_application(a, b) -> fprintf ppf "@[(%a)@(%a)@]" expression a expression b
| E_constant c -> fprintf ppf "%a %a" constant c.cons_name (pp_print_list ~pp_sep:space_sep expression) c.arguments
| E_literal v -> fprintf ppf "L(%a)" value v
| E_make_empty_map _ -> fprintf ppf "map[]"
| E_make_empty_big_map _ -> fprintf ppf "big_map[]"
| E_make_empty_list _ -> fprintf ppf "list[]"
| E_make_empty_set _ -> fprintf ppf "set[]"
| E_constant c -> fprintf ppf "@[%a@[<hv 1>(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments
| E_literal v -> fprintf ppf "@[L(%a)@]" value v
| E_make_none _ -> fprintf ppf "none"
| E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b
| E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Var.pp name expression s
| E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%a :: %a) -> %a" expression c expression n Var.pp hd_name Var.pp tl_name expression cons
| E_if_bool (c, a, b) ->
fprintf ppf
"@[match %a with@ @[<hv>| True ->@;<1 2>%a@ | False ->@;<1 2>%a@]@]"
expression c expression a expression b
| E_if_none (c, n, ((name, _) , s)) ->
fprintf ppf
"@[match %a with@ @[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]@]"
expression c expression n Var.pp name expression s
| E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "@[%a ?? %a : (%a :: %a) -> %a@]" expression c expression n Var.pp hd_name Var.pp tl_name expression cons
| E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Var.pp name_l expression l Var.pp name_r expression r
| E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b
fprintf ppf
"@[match %a with@ @[<hv>| Left %a ->@;<1 2>%a@ | Right %a ->@;<1 2>%a@]@]"
expression c Var.pp name_l expression l Var.pp name_r expression r
| E_sequence (a , b) -> fprintf ppf "@[%a ;; %a@]" expression a expression b
| E_let_in ((name , _) , inline, expr , body) ->
fprintf ppf "let %a = %a%a in ( %a )" Var.pp name expression expr option_inline inline expression body
fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" Var.pp name expression expr option_inline inline expression body
| E_iterator (b , ((name , _) , body) , expr) ->
fprintf ppf "for_%a %a of %a do ( %a )" constant b Var.pp name expression expr expression body
fprintf ppf "@[for_%a %a of %a do ( %a )@]" constant b Var.pp name expression expr expression body
| E_fold (((name , _) , body) , collection , initial) ->
fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Var.pp name expression body
fprintf ppf "@[fold %a on %a with %a do ( %a )@]" expression collection expression initial Var.pp name expression body
| E_record_update (r, path,update) ->
fprintf ppf "%a with { %a = %a }" expression r (list_sep lr (const ".")) path expression update
fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression r (list_sep lr (const ".")) path expression update
| E_while (e , b) ->
fprintf ppf "while %a do %a" expression e expression b
fprintf ppf "@[while %a do %a@]" expression e expression b
and expression_with_type : _ -> expression -> _ = fun ppf e ->
fprintf ppf "%a : %a"
@ -115,24 +117,22 @@ and expression_with_type : _ -> expression -> _ = fun ppf e ->
type_variable e.type_value
and function_ ppf ({binder ; body}:anon_function) =
fprintf ppf "fun %a -> (%a)"
fprintf ppf "@[fun %a ->@ (%a)@]"
Var.pp binder
expression body
and assignment ppf ((n, i, e):assignment) = fprintf ppf "%a = %a%a;" Var.pp n expression e option_inline i
and option_inline ppf inline =
if inline then
fprintf ppf "[@inline]"
fprintf ppf "[@@inline]"
else
fprintf ppf ""
and declaration ppf ((n,i, e):assignment) = fprintf ppf "let %a = %a%a;" Var.pp n expression e option_inline i
and declaration ppf ((n,i, e):assignment) = fprintf ppf "@[let %a =@;<1 2>%a%a@]" Var.pp n expression e option_inline i
and tl_statement ppf (ass, _) = assignment ppf ass
and tl_statement ppf (ass, _) = declaration ppf ass
and program ppf (p:program) =
fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p
fprintf ppf "@[<v>%a@]" (pp_print_list ~pp_sep:(tag "@ ") tl_statement) p
and constant ppf : constant' -> unit = function
| C_INT -> fprintf ppf "INT"
@ -161,6 +161,7 @@ and constant ppf : constant' -> unit = function
| C_ADD -> fprintf ppf "ADD"
| C_SUB -> fprintf ppf "SUB"
| C_MUL -> fprintf ppf "MUL"
| C_EDIV -> fprintf ppf "EDIV"
| C_DIV -> fprintf ppf "DIV"
| C_MOD -> fprintf ppf "MOD"
(* LOGIC *)
@ -199,6 +200,8 @@ and constant ppf : constant' -> unit = function
| C_SET_FOLD -> fprintf ppf "SET_FOLD"
| C_SET_MEM -> fprintf ppf "SET_MEM"
(* List *)
| C_LIST_EMPTY -> fprintf ppf "LIST_EMPTY"
| C_LIST_LITERAL -> fprintf ppf "LIST_LITERAL"
| C_LIST_ITER -> fprintf ppf "LIST_ITER"
| C_LIST_MAP -> fprintf ppf "LIST_MAP"
| C_LIST_FOLD -> fprintf ppf "LIST_FOLD"
@ -256,9 +259,9 @@ let%expect_test _ =
let wrap e = { content = e ; type_value = dummy_type } in
pp @@ E_closure { binder = Var.of_name "y" ; body = wrap (E_variable (Var.of_name "y")) } ;
[%expect{|
C(fun y -> (V(y)))
fun y -> (y)
|}] ;
pp @@ E_closure { binder = Var.of_name "z" ; body = wrap (E_variable (Var.of_name "z")) } ;
[%expect{|
C(fun z -> (V(z)))
fun z -> (z)
|}]

4
src/stages/5-mini_c/misc.ml
View File

@ -44,10 +44,6 @@ module Free_variables = struct
| E_constant (c) -> unions @@ List.map self c.arguments
| E_application (f, x) -> unions @@ [ self f ; self x ]
| E_variable n -> var_name b n
| E_make_empty_map _ -> empty
| E_make_empty_big_map _ -> empty
| E_make_empty_list _ -> empty
| E_make_empty_set _ -> empty
| E_make_none _ -> empty
| E_iterator (_, ((v, _), body), expr) ->
unions [ expression (union (singleton v) b) body ;

4
src/stages/5-mini_c/types.ml
View File

@ -59,10 +59,6 @@ and expression' =
| E_constant of constant
| E_application of (expression * expression)
| E_variable of var_name
| E_make_empty_map of (type_value * type_value)
| E_make_empty_big_map of (type_value * type_value)
| E_make_empty_list of type_value
| E_make_empty_set of type_value
| E_make_none of type_value
| E_iterator of constant' * ((var_name * type_value) * expression) * expression
| E_fold of (((var_name * type_value) * expression) * expression * expression)

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

@ -11,34 +11,33 @@ let label ppf (l:label) : unit =
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
let new_pp ppf (k, v) = fprintf ppf "@[<h>%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
let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "@[<h>%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
let lst = Helpers.tuple_of_record m in
let new_pp ppf (_, 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
fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m
else
fprintf ppf format_record (record_sep value (const sep_record)) m
fprintf ppf format_record (record_sep value (tag 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 list_sep_d x = list_sep x (tag " ,@ ")
let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let tuple_or_record_sep_expr value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " ,@ "
let tuple_or_record_sep_type value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " *@ "
let constant ppf : constant' -> unit = function
| C_INT -> fprintf ppf "INT"
@ -67,6 +66,7 @@ let constant ppf : constant' -> unit = function
| C_ADD -> fprintf ppf "ADD"
| C_SUB -> fprintf ppf "SUB"
| C_MUL -> fprintf ppf "MUL"
| C_EDIV -> fprintf ppf "EDIV"
| C_DIV -> fprintf ppf "DIV"
| C_MOD -> fprintf ppf "MOD"
(* LOGIC *)
@ -105,6 +105,8 @@ let constant ppf : constant' -> unit = function
| C_SET_FOLD -> fprintf ppf "SET_FOLD"
| C_SET_MEM -> fprintf ppf "SET_MEM"
(* List *)
| C_LIST_EMPTY -> fprintf ppf "LIST_EMPTY"
| C_LIST_LITERAL -> fprintf ppf "LIST_LITERAL"
| C_LIST_ITER -> fprintf ppf "LIST_ITER"
| C_LIST_MAP -> fprintf ppf "LIST_MAP"
| C_LIST_FOLD -> fprintf ppf "LIST_FOLD"
@ -154,43 +156,50 @@ let constant ppf : constant' -> unit = function
let literal ppf (l : literal) =
match l with
| Literal_unit ->
fprintf ppf "unit"
| Literal_void ->
fprintf ppf "void"
| Literal_bool b ->
fprintf ppf "%b" b
| Literal_int n ->
fprintf ppf "%d" n
| Literal_nat n ->
fprintf ppf "+%d" n
| Literal_timestamp n ->
fprintf ppf "+%d" n
| Literal_mutez n ->
fprintf ppf "%dmutez" n
| Literal_string s ->
fprintf ppf "%S" s
| Literal_bytes b ->
fprintf ppf "0x%a" Hex.pp (Hex.of_bytes 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
| Literal_unit -> fprintf ppf "unit"
| Literal_void -> fprintf ppf "void"
| Literal_bool b -> fprintf ppf "%b" b
| Literal_int n -> fprintf ppf "%d" n
| Literal_nat n -> fprintf ppf "+%d" n
| Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_mutez n -> fprintf ppf "%dmutez" n
| Literal_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes 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
let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
and type_constant ppf (tc : type_constant) : unit =
let s =
match tc with
| TC_unit -> "unit"
| TC_string -> "string"
| TC_bytes -> "bytes"
| TC_nat -> "nat"
| TC_int -> "int"
| TC_mutez -> "mutez"
| TC_bool -> "bool"
| TC_operation -> "operation"
| TC_address -> "address"
| TC_key -> "key"
| TC_key_hash -> "key_hash"
| TC_signature -> "signature"
| TC_timestamp -> "timestamp"
| TC_chain_id -> "chain_id"
| TC_void -> "void"
in
fprintf ppf "%s" s
module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
module Agt=Ast_generic_type(PARAMETER)
open Agt
open Format
let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
let rec type_expression' :
(formatter -> type_expression -> unit)
-> formatter
@ -198,58 +207,16 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
-> 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_
| T_sum m -> fprintf ppf "@[<hv 4>sum[%a]@]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_constant ppf (tc : type_constant) : unit =
let s =
match tc with
| TC_unit ->
"unit"
| TC_string ->
"string"
| TC_bytes ->
"bytes"
| TC_nat ->
"nat"
| TC_int ->
"int"
| TC_mutez ->
"mutez"
| TC_bool ->
"bool"
| TC_operation ->
"operation"
| TC_address ->
"address"
| TC_key ->
"key"
| TC_key_hash ->
"key_hash"
| TC_signature ->
"signature"
| TC_timestamp ->
"timestamp"
| TC_chain_id ->
"chain_id"
| TC_void ->
"void"
in
fprintf ppf "%s" s
and type_operator :
(formatter -> type_expression -> unit)
-> formatter
@ -263,6 +230,7 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_set te -> Format.asprintf "set(%a)" f te
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_map_or_big_map (k, v) -> Format.asprintf "Map Or 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

20
src/stages/common/helpers.ml
View File

@ -46,3 +46,23 @@ let get_pair m =
match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with
| Some e1, Some e2 -> ok (e1,e2)
| _ -> simple_fail "not a pair"
let tuple_of_record (m: _ LMap.t) =
let aux i =
let label = Label (string_of_int i) in
let opt = LMap.find_opt (label) m in
Option.bind (fun opt -> Some ((label,opt),i+1)) opt
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
let list_of_record_or_tuple (m: _ LMap.t) =
if (is_tuple_lmap m) then
List.map snd @@ tuple_of_record m
else
List.rev @@ LMap.to_list m
let kv_list_of_record_or_tuple (m: _ LMap.t) =
if (is_tuple_lmap m) then
tuple_of_record m
else
List.rev @@ LMap.to_kv_list m

5
src/stages/common/helpers.mli
View File

@ -1,3 +1,5 @@
open Types
val bind_lmap :
('a * 'b list, 'c) result Types.label_map ->
('a Types.label_map * 'b list, 'c) result
@ -19,6 +21,9 @@ val is_tuple_lmap : 'a Types.label_map -> bool
val get_pair :
'a Types.label_map ->
(('a * 'a) * 'b list, unit -> Trace.error) result
val tuple_of_record : 'a LMap.t -> (label * 'a) list
val list_of_record_or_tuple : 'a LMap.t -> 'a list
val kv_list_of_record_or_tuple : 'a LMap.t -> (label * 'a) list

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

@ -53,6 +53,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_set of type_expression
| TC_map of type_expression * type_expression
| TC_big_map of type_expression * type_expression
| TC_map_or_big_map of type_expression * type_expression
| TC_arrow of type_expression * type_expression
@ -66,6 +67,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_set x -> TC_set (f x)
| TC_map (x , y) -> TC_map (f x , f y)
| TC_big_map (x , y)-> TC_big_map (f x , f y)
| TC_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y)
| TC_arrow (x, y) -> TC_arrow (f x, f y)
let bind_map_type_operator f = function
@ -75,6 +77,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_set x -> let%bind x = f x in ok @@ TC_set x
| TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y)
| TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y)
| TC_map_or_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_map_or_big_map (x , y)
| TC_arrow (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y)
let type_operator_name = function
@ -84,6 +87,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_set _ -> "TC_set"
| TC_map _ -> "TC_map"
| TC_big_map _ -> "TC_big_map"
| TC_map_or_big_map _ -> "TC_map_or_big_map"
| TC_arrow _ -> "TC_arrow"
let type_expression'_of_string = function
@ -122,6 +126,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
| TC_set x -> "TC_set" , [x]
| TC_map (x , y) -> "TC_map" , [x ; y]
| TC_big_map (x , y) -> "TC_big_map" , [x ; y]
| TC_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y]
| TC_arrow (x , y) -> "TC_arrow" , [x ; y]
let string_of_type_constant = function
@ -209,6 +214,7 @@ and constant' =
| C_ADD
| C_SUB
| C_MUL
| C_EDIV
| C_DIV
| C_MOD
(* LOGIC *)
@ -247,6 +253,8 @@ and constant' =
| C_SET_FOLD
| C_SET_MEM
(* List *)
| C_LIST_EMPTY
| C_LIST_LITERAL
| C_LIST_ITER
| C_LIST_MAP
| C_LIST_FOLD

34
src/stages/typesystem/misc.ml
View File

@ -136,7 +136,7 @@ module Substitution = struct
and s_matching_expr : T.matching_expr w = fun ~substs _ ->
let _TODO = substs in
failwith "TODO: subst: unimplemented case s_matching"
and s_accessor : T.accessor w = fun ~substs _ ->
and s_accessor : T.record_accessor w = fun ~substs _ ->
let _TODO = substs in
failwith "TODO: subst: unimplemented case s_access_path"
@ -182,38 +182,14 @@ module Substitution = struct
* let val_ = s_expression ~v ~expr val_ in
* ok @@ (key , val_)) aemap in
* ok @@ T.E_record aemap *)
| T.E_record_accessor {expr=e;label} ->
let%bind expr = s_expression ~substs e in
let%bind label = s_label ~substs label in
ok @@ T.E_record_accessor {expr;label}
| T.E_record_accessor {record=e;path} ->
let%bind record = s_expression ~substs e in
let%bind path = s_label ~substs path in
ok @@ T.E_record_accessor {record;path}
| T.E_record_update {record;path;update}->
let%bind record = s_expression ~substs record in
let%bind update = s_expression ~substs update in
ok @@ T.E_record_update {record;path;update}
| T.E_map val_val_list ->
let%bind val_val_list = bind_map_list (fun (val1 , val2) ->
let%bind val1 = s_expression ~substs val1 in
let%bind val2 = s_expression ~substs val2 in
ok @@ (val1 , val2)
) val_val_list in
ok @@ T.E_map val_val_list
| T.E_big_map val_val_list ->
let%bind val_val_list = bind_map_list (fun (val1 , val2) ->
let%bind val1 = s_expression ~substs val1 in
let%bind val2 = s_expression ~substs val2 in
ok @@ (val1 , val2)
) val_val_list in
ok @@ T.E_big_map val_val_list
| T.E_list vals ->
let%bind vals = bind_map_list (s_expression ~substs) vals in
ok @@ T.E_list vals
| T.E_set vals ->
let%bind vals = bind_map_list (s_expression ~substs) vals in
ok @@ T.E_set vals
| T.E_look_up (val1, val2) ->
let%bind val1 = s_expression ~substs val1 in
let%bind val2 = s_expression ~substs val2 in
ok @@ T.E_look_up (val1 , val2)
| T.E_matching {matchee;cases} ->
let%bind matchee = s_expression ~substs matchee in
let%bind cases = s_matching_expr ~substs cases in

1
src/test/contracts/arithmetic.ligo
View File

@ -5,3 +5,4 @@ function times_op (const n : int) : int is n * 42
function div_op (const n : int) : int is n / 2
function int_op (const n : nat) : int is int (n)
function neg_op (const n : int) : int is -n
function ediv_op (const n : int) : option (int * nat) is ediv (n,2)

1
src/test/contracts/arithmetic.mligo
View File

@ -6,3 +6,4 @@ let div_op (n : int) : int = n / 2
let neg_op (n : int) : int = -n
let foo (n : int) : int = n + 10
let neg_op_2 (b : int) : int = -(foo b)
let ediv_op (n : int) : (int * nat) option = ediv n 2

7
src/test/contracts/arithmetic.religo
View File

@ -5,6 +5,7 @@ let plus_op = (n : int) : int => n + 42;
let minus_op = (n : int) : int => n - 42;
let times_op = (n : int) : int => n * 42;
let div_op = (n : int) : int => n / 2;
let neg_op = (n : int): int => - n;
let foo = (n : int): int => n + 10;
let neg_op_2 = (b : int): int => -foo(b);
let neg_op = (n : int) : int => - n;
let foo = (n : int) : int => n + 10;
let neg_op_2 = (b : int) : int => -foo(b);
let ediv_op = (n : int) : option ((int, nat)) => ediv (n,2)

2
src/test/contracts/loop.ligo
View File

@ -54,9 +54,9 @@ function for_collection_if_and_local_var (var nee : unit) : int is
block {
var acc : int := 0;
const theone : int = 1;
const thetwo : int = 2;
var myset : set (int) := set [1; 2; 3];
for x in set myset block {
const thetwo : int = 2;
if x = theone then acc := acc + x
else if x = thetwo then acc := acc + thetwo
else acc := acc + 10

2
src/test/contracts/negative/nested_bigmap_1.religo
View File

@ -5,6 +5,6 @@ type storage = big_map (int, bar);
type return = (list (operation), storage);
let main = ((ignore, store): (unit, storage)): return => {
let main = ((_, store): (unit, storage)): return => {
([]: list(operation), store)
};

2
src/test/contracts/negative/nested_bigmap_2.religo
View File

@ -3,7 +3,7 @@ type storage = big_map (nat, big_map (int, string));
type return = (list (operation), storage);
let main = ((ignore, store): (unit, storage)): return => {
let main = ((_, store): (unit, storage)): return => {
([]: list(operation), store)
};

2
src/test/contracts/negative/nested_bigmap_3.religo
View File

@ -10,6 +10,6 @@ type storage = big_map(nat, foo);
type return = (list (operation), storage);
let main = ((ignore, store): (unit, storage)): return => {
let main = ((_, store): (unit, storage)): return => {
([]: list(operation), store)
};

2
src/test/contracts/negative/nested_bigmap_4.religo
View File

@ -3,7 +3,7 @@ type storage = map (int, big_map (nat, big_map (int, string)));
type return = (list (operation), storage);
let main = ((ignore, store): (unit, storage)): return => {
let main = ((_, store): (unit, storage)): return => {
([]: list(operation), store)
};

9
src/test/contracts/tuple.ligo
View File

@ -13,6 +13,11 @@ const fb : foobar = (0,0)
function projection (const tpl : foobar) : int is tpl.0 + tpl.1
type big_tuple is int * int * int * int * int
type big_tuple is int * int * int * int * int * int * int * int * int * int * int * int
const br : big_tuple = (23, 23, 23, 23, 23)
const br : big_tuple = (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11)
function update (const tpl : big_tuple) : big_tuple is
block {
tpl.11 := 2048
} with tpl

8
src/test/contracts/tuple_type.religo
View File

@ -15,7 +15,7 @@ let arguments = (b: int, c: int) => { b + c; };
let arguments_type_def = (b: fun_type) => b (5, 3);
let arguments_test = (ignore: int) => arguments_type_def (arguments);
let arguments_test = (_: int) => arguments_type_def (arguments);
type tuple_type = ((int, int)) => int;
@ -23,7 +23,7 @@ let tuple = ((a, b): (int, int)) => { a + b; };
let tuple_type_def = (b: tuple_type) => b ((5, 3));
let tuple_test = (ignore: int) => tuple_type_def (tuple);
let tuple_test = (_: int) => tuple_type_def (tuple);
/* inline */
@ -32,12 +32,12 @@ let arguments_inline = (b: int, c: int) => { b + c; };
let arguments_type_def_inline = (b: (int, int) => int) => b (5, 3);
let arguments_test_inline = (ignore: int) =>
let arguments_test_inline = (_: int) =>
arguments_type_def_inline (arguments_inline);
let tuple_inline = ((a, b): (int, int)) => { a + b; };
let tuple_type_def_inline = (b: ((int, int)) => int) => b ((5, 3));
let tuple_test_inline = (ignore: int) =>
let tuple_test_inline = (_: int) =>
tuple_type_def_inline(tuple_inline);

10
src/test/integration_tests.ml
View File

@ -298,6 +298,7 @@ let arithmetic () : unit result =
let%bind () = expect_eq_n_pos program "int_op" e_nat e_int in
let%bind () = expect_eq_n_pos program "mod_op" e_int (fun n -> e_nat (n mod 42)) in
let%bind () = expect_eq_n_pos program "div_op" e_int (fun n -> e_int (n / 2)) in
let%bind () = expect_eq_n_pos program "ediv_op" e_int (fun n -> e_some (e_pair (e_int (n/2)) (e_nat (n mod 2)))) in
ok ()
let arithmetic_mligo () : unit result =
@ -313,6 +314,7 @@ let arithmetic_mligo () : unit result =
] in
let%bind () = expect_eq_n_pos program "mod_op" e_int (fun n -> e_nat (n mod 42)) in
let%bind () = expect_eq_n_pos program "div_op" e_int (fun n -> e_int (n / 2)) in
let%bind () = expect_eq_n_pos program "ediv_op" e_int (fun n -> e_some (e_pair (e_int (n/2)) (e_nat (n mod 2)))) in
ok ()
let arithmetic_religo () : unit result =
@ -328,6 +330,7 @@ let arithmetic_religo () : unit result =
] in
let%bind () = expect_eq_n_pos program "mod_op" e_int (fun n -> e_nat (n mod 42)) in
let%bind () = expect_eq_n_pos program "div_op" e_int (fun n -> e_int (n / 2)) in
let%bind () = expect_eq_n_pos program "ediv_op" e_int (fun n -> e_some (e_pair (e_int (n/2)) (e_nat (n mod 2)))) in
ok ()
let bitwise_arithmetic () : unit result =
@ -876,9 +879,14 @@ let tuple () : unit result =
expect_eq_n program "modify_abc" make_input make_expected
in
let%bind () =
let expected = ez [23 ; 23 ; 23 ; 23 ; 23] in
let expected = ez [0 ; 1 ; 2 ; 3 ; 4; 5; 6; 7; 8; 9; 10; 11] in
expect_eq_evaluate program "br" expected
in
let%bind () =
let make_input = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; n] in
let make_expected = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; 2048] in
expect_eq_n program "update" make_input make_expected
in
ok ()
let tuple_mligo () : unit result =

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