Merge branch 'dev' of https://gitlab.com/ligolang/ligo into doc-failwith
This commit is contained in:
Sander Spies
commit
8937b762cd
2
.gitignore
vendored
2
.gitignore
vendored
@ -3,6 +3,8 @@
|
|||||||
*.merlin
|
*.merlin
|
||||||
cache/*
|
cache/*
|
||||||
Version.ml
|
Version.ml
|
||||||
|
/result
|
||||||
|
/result-*
|
||||||
/_opam/
|
/_opam/
|
||||||
/*.pp.ligo
|
/*.pp.ligo
|
||||||
/*.pp.mligo
|
/*.pp.mligo
|
||||||
|
|||||||
170
gitlab-pages/docs/demo/ligo-snippet.md
Normal file
170
gitlab-pages/docs/demo/ligo-snippet.md
Normal file
@ -0,0 +1,170 @@
|
|||||||
|
---
|
||||||
|
id: ligo-snippets-demo
|
||||||
|
title: Ligo-Snippets Demo
|
||||||
|
---
|
||||||
|
|
||||||
|
import Tabs from '@theme/Tabs';
|
||||||
|
import TabItem from '@theme/TabItem';
|
||||||
|
|
||||||
|
“ligo-snippets” (https://www.npmjs.com/package/@ligolang/ligo-snippets) is a React component that can be included on any webpage to display Ligo source code to users.
|
||||||
|
|
||||||
|
The user will see Ligo code with syntax highlighting, and an action button allowing the user to open the source code in the Ligo Web IDE (https://ide.ligolang.org).
|
||||||
|
|
||||||
|
Each code snippet can have preset Ligo Web IDE configurations (e.g. entrypoint, parameters or storage). These configurations are optional and will be passed onto the Ligo Web IDE when present. This will allow examples to provide the proper configurations for the reader to experiment with.
|
||||||
|
|
||||||
|
The “ligo-snippets” React component uses the CodeJar editor (https://github.com/antonmedv/codejar), which is extremely lightweight (only 2kB). It currently supports syntax highlighting for PascaLigo, CameLigo and ReasonLigo. Additionally, it has both a light and dark theme mode.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
<Tabs
|
||||||
|
defaultValue="pascaligo"
|
||||||
|
values={[
|
||||||
|
{ label: 'PascaLIGO', value: 'pascaligo', },
|
||||||
|
{ label: 'CameLIGO', value: 'cameligo', },
|
||||||
|
{ label: 'ReasonLIGO', value: 'reasonligo', },
|
||||||
|
]
|
||||||
|
}>
|
||||||
|
<TabItem value="pascaligo">
|
||||||
|
|
||||||
|
```pascaligo {"name": "Ligo Introduction Example", "editor": true}
|
||||||
|
(*_*
|
||||||
|
name: PascaLIGO Contract
|
||||||
|
language: pascaligo
|
||||||
|
compile:
|
||||||
|
entrypoint: main
|
||||||
|
dryRun:
|
||||||
|
entrypoint: main
|
||||||
|
parameters: Increment (1)
|
||||||
|
storage: 999
|
||||||
|
deploy:
|
||||||
|
entrypoint: main
|
||||||
|
storage: 999
|
||||||
|
evaluateValue:
|
||||||
|
entrypoint: ""
|
||||||
|
evaluateFunction:
|
||||||
|
entrypoint: add
|
||||||
|
parameters: (5, 6)
|
||||||
|
generateDeployScript:
|
||||||
|
entrypoint: main
|
||||||
|
storage: 999
|
||||||
|
*_*)
|
||||||
|
// variant defining pseudo multi-entrypoint actions
|
||||||
|
type action is
|
||||||
|
| Increment of int
|
||||||
|
| Decrement of int
|
||||||
|
|
||||||
|
function add (const a : int ; const b : int) : int is
|
||||||
|
block { skip } with a + b
|
||||||
|
|
||||||
|
function subtract (const a : int ; const b : int) : int is
|
||||||
|
block { skip } with a - b
|
||||||
|
|
||||||
|
// real entrypoint that re-routes the flow based
|
||||||
|
// on the action provided
|
||||||
|
function main (const p : action ; const s : int) :
|
||||||
|
(list(operation) * int) is
|
||||||
|
block { skip } with ((nil : list(operation)),
|
||||||
|
case p of
|
||||||
|
| Increment(n) -> add(s, n)
|
||||||
|
| Decrement(n) -> subtract(s, n)
|
||||||
|
end)
|
||||||
|
|
||||||
|
```
|
||||||
|
|
||||||
|
</TabItem>
|
||||||
|
<TabItem value="cameligo">
|
||||||
|
|
||||||
|
```cameligo {"name": "Ligo Introduction Example", "editor": true}
|
||||||
|
(*_*
|
||||||
|
name: CameLIGO Contract
|
||||||
|
language: cameligo
|
||||||
|
compile:
|
||||||
|
entrypoint: main
|
||||||
|
dryRun:
|
||||||
|
entrypoint: main
|
||||||
|
parameters: Increment 1
|
||||||
|
storage: 999
|
||||||
|
deploy:
|
||||||
|
entrypoint: main
|
||||||
|
storage: 999
|
||||||
|
evaluateValue:
|
||||||
|
entrypoint: ""
|
||||||
|
evaluateFunction:
|
||||||
|
entrypoint: add
|
||||||
|
parameters: 5, 6
|
||||||
|
generateDeployScript:
|
||||||
|
entrypoint: main
|
||||||
|
storage: 999
|
||||||
|
*_*)
|
||||||
|
type storage = int
|
||||||
|
|
||||||
|
(* variant defining pseudo multi-entrypoint actions *)
|
||||||
|
|
||||||
|
type action =
|
||||||
|
| Increment of int
|
||||||
|
| Decrement of int
|
||||||
|
|
||||||
|
let add (a,b: int * int) : int = a + b
|
||||||
|
let sub (a,b: int * int) : int = a - b
|
||||||
|
|
||||||
|
(* real entrypoint that re-routes the flow based on the action provided *)
|
||||||
|
|
||||||
|
let main (p,s: action * storage) =
|
||||||
|
let storage =
|
||||||
|
match p with
|
||||||
|
| Increment n -> add (s, n)
|
||||||
|
| Decrement n -> sub (s, n)
|
||||||
|
in ([] : operation list), storage
|
||||||
|
|
||||||
|
```
|
||||||
|
|
||||||
|
</TabItem>
|
||||||
|
<TabItem value="reasonligo">
|
||||||
|
|
||||||
|
```reasonligo {"name": "Ligo Introduction Example", "editor": true}
|
||||||
|
(*_*
|
||||||
|
name: ReasonLIGO Contract
|
||||||
|
language: reasonligo
|
||||||
|
compile:
|
||||||
|
entrypoint: main
|
||||||
|
dryRun:
|
||||||
|
entrypoint: main
|
||||||
|
parameters: Increment (1)
|
||||||
|
storage: 999
|
||||||
|
deploy:
|
||||||
|
entrypoint: main
|
||||||
|
storage: 999
|
||||||
|
evaluateValue:
|
||||||
|
entrypoint: ""
|
||||||
|
evaluateFunction:
|
||||||
|
entrypoint: add
|
||||||
|
parameters: (5, 6)
|
||||||
|
generateDeployScript:
|
||||||
|
entrypoint: main
|
||||||
|
storage: 999
|
||||||
|
*_*)
|
||||||
|
type storage = int;
|
||||||
|
|
||||||
|
/* variant defining pseudo multi-entrypoint actions */
|
||||||
|
|
||||||
|
type action =
|
||||||
|
| Increment(int)
|
||||||
|
| Decrement(int);
|
||||||
|
|
||||||
|
let add = ((a,b): (int, int)): int => a + b;
|
||||||
|
let sub = ((a,b): (int, int)): int => a - b;
|
||||||
|
|
||||||
|
/* real entrypoint that re-routes the flow based on the action provided */
|
||||||
|
|
||||||
|
let main = ((p,storage): (action, storage)) => {
|
||||||
|
let storage =
|
||||||
|
switch (p) {
|
||||||
|
| Increment(n) => add((storage, n))
|
||||||
|
| Decrement(n) => sub((storage, n))
|
||||||
|
};
|
||||||
|
([]: list(operation), storage);
|
||||||
|
};
|
||||||
|
|
||||||
|
```
|
||||||
|
</TabItem>
|
||||||
|
</Tabs>
|
||||||
@ -9,17 +9,42 @@ import Syntax from '@theme/Syntax';
|
|||||||
import SyntaxTitle from '@theme/SyntaxTitle';
|
import SyntaxTitle from '@theme/SyntaxTitle';
|
||||||
|
|
||||||
<SyntaxTitle syntax="pascaligo">
|
<SyntaxTitle syntax="pascaligo">
|
||||||
function and : nat -> nat -> nat
|
function and : 'a -> nat -> nat
|
||||||
</SyntaxTitle>
|
</SyntaxTitle>
|
||||||
<SyntaxTitle syntax="cameligo">
|
<SyntaxTitle syntax="cameligo">
|
||||||
val and : nat -> nat -> nat
|
val and : 'a -> nat -> nat
|
||||||
</SyntaxTitle>
|
</SyntaxTitle>
|
||||||
<SyntaxTitle syntax="reasonligo">
|
<SyntaxTitle syntax="reasonligo">
|
||||||
let and: (nat, nat) => nat
|
let and: ('a, nat) => nat
|
||||||
</SyntaxTitle>
|
</SyntaxTitle>
|
||||||
|
|
||||||
|
`'a` can either be an `int` or `nat`.
|
||||||
|
|
||||||
A bitwise `and` operation.
|
A bitwise `and` operation.
|
||||||
|
|
||||||
|
<Syntax syntax="pascaligo">
|
||||||
|
|
||||||
|
```pascaligo
|
||||||
|
const zero: nat = Bitwise.and(2n, 1n)
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="cameligo">
|
||||||
|
|
||||||
|
```cameligo
|
||||||
|
let zero: nat = Bitwise.and 2n 1n
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="reasonligo">
|
||||||
|
|
||||||
|
```reasonligo
|
||||||
|
let zero: nat = Bitwise.and(2n, 1n);
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
|
||||||
|
|
||||||
<SyntaxTitle syntax="pascaligo">
|
<SyntaxTitle syntax="pascaligo">
|
||||||
function or : nat -> nat -> nat
|
function or : nat -> nat -> nat
|
||||||
</SyntaxTitle>
|
</SyntaxTitle>
|
||||||
@ -32,6 +57,28 @@ let or: (nat, nat) => nat
|
|||||||
|
|
||||||
A bitwise `or` operation.
|
A bitwise `or` operation.
|
||||||
|
|
||||||
|
<Syntax syntax="pascaligo">
|
||||||
|
|
||||||
|
```pascaligo
|
||||||
|
const three: nat = Bitwise.or(2n, 1n)
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="cameligo">
|
||||||
|
|
||||||
|
```cameligo
|
||||||
|
let three: nat = Bitwise.or 2n 1n
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="reasonligo">
|
||||||
|
|
||||||
|
```reasonligo
|
||||||
|
let three: nat = Bitwise.or(2n, 1n);
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
|
||||||
<SyntaxTitle syntax="pascaligo">
|
<SyntaxTitle syntax="pascaligo">
|
||||||
function xor : nat -> nat -> nat
|
function xor : nat -> nat -> nat
|
||||||
</SyntaxTitle>
|
</SyntaxTitle>
|
||||||
@ -44,6 +91,28 @@ let xor: (nat, nat) => nat
|
|||||||
|
|
||||||
A bitwise `xor` operation.
|
A bitwise `xor` operation.
|
||||||
|
|
||||||
|
<Syntax syntax="pascaligo">
|
||||||
|
|
||||||
|
```pascaligo
|
||||||
|
const three: nat = Bitwise.xor(2n, 1n)
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="cameligo">
|
||||||
|
|
||||||
|
```cameligo
|
||||||
|
let three: nat = Bitwise.xor 2n 1n
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="reasonligo">
|
||||||
|
|
||||||
|
```reasonligo
|
||||||
|
let three: nat = Bitwise.xor(2n, 1n);
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
|
||||||
<SyntaxTitle syntax="pascaligo">
|
<SyntaxTitle syntax="pascaligo">
|
||||||
function shift_left : nat -> nat -> nat
|
function shift_left : nat -> nat -> nat
|
||||||
</SyntaxTitle>
|
</SyntaxTitle>
|
||||||
@ -56,6 +125,28 @@ let shift_left: (nat, nat) => nat
|
|||||||
|
|
||||||
A bitwise shift left operation.
|
A bitwise shift left operation.
|
||||||
|
|
||||||
|
<Syntax syntax="pascaligo">
|
||||||
|
|
||||||
|
```pascaligo
|
||||||
|
const four: nat = Bitwise.shift_left(2n, 1n)
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="cameligo">
|
||||||
|
|
||||||
|
```cameligo
|
||||||
|
let four: nat = Bitwise.shift_left 2n 1n
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="reasonligo">
|
||||||
|
|
||||||
|
```reasonligo
|
||||||
|
let four: nat = Bitwise.shift_left(2n, 1n);
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
|
||||||
<SyntaxTitle syntax="pascaligo">
|
<SyntaxTitle syntax="pascaligo">
|
||||||
function shift_right : nat -> nat -> nat
|
function shift_right : nat -> nat -> nat
|
||||||
</SyntaxTitle>
|
</SyntaxTitle>
|
||||||
@ -67,3 +158,25 @@ let shift_right: (nat, nat) => nat
|
|||||||
</SyntaxTitle>
|
</SyntaxTitle>
|
||||||
|
|
||||||
A bitwise shift right operation.
|
A bitwise shift right operation.
|
||||||
|
|
||||||
|
<Syntax syntax="pascaligo">
|
||||||
|
|
||||||
|
```pascaligo
|
||||||
|
const one: nat = Bitwise.shift_right(2n, 1n)
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="cameligo">
|
||||||
|
|
||||||
|
```cameligo
|
||||||
|
let one: nat = Bitwise.shift_right 2n 1n
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
|
<Syntax syntax="reasonligo">
|
||||||
|
|
||||||
|
```reasonligo
|
||||||
|
let one: nat = Bitwise.shift_right(2n, 1n);
|
||||||
|
```
|
||||||
|
|
||||||
|
</Syntax>
|
||||||
86
gitlab-pages/website/package-lock.json
generated
86
gitlab-pages/website/package-lock.json
generated
@ -1535,6 +1535,20 @@
|
|||||||
"@ligo/syntax": {
|
"@ligo/syntax": {
|
||||||
"version": "file:src/@ligo/syntax"
|
"version": "file:src/@ligo/syntax"
|
||||||
},
|
},
|
||||||
|
"@ligolang/ligo-snippets": {
|
||||||
|
"version": "1.0.1",
|
||||||
|
"resolved": "https://registry.npmjs.org/@ligolang/ligo-snippets/-/ligo-snippets-1.0.1.tgz",
|
||||||
|
"integrity": "sha512-JJa69veCkdwOS+u7iUngRNHFlXBJ+3Wx5l+EfrQyhBXMGzH4Ii4onZPxghDQEiL6RzqRbhCIsOE+A8OX7NCYMA==",
|
||||||
|
"requires": {
|
||||||
|
"@types/prismjs": "^1.16.1",
|
||||||
|
"axios": "^0.19.2",
|
||||||
|
"ligo-snippets-css": "0.0.1",
|
||||||
|
"prism-react-renderer": "^1.1.1",
|
||||||
|
"prismjs": "^1.20.0",
|
||||||
|
"react-codejar": "^1.0.1",
|
||||||
|
"yaml": "^1.9.2"
|
||||||
|
}
|
||||||
|
},
|
||||||
"@mdx-js/mdx": {
|
"@mdx-js/mdx": {
|
||||||
"version": "1.6.5",
|
"version": "1.6.5",
|
||||||
"resolved": "https://registry.npmjs.org/@mdx-js/mdx/-/mdx-1.6.5.tgz",
|
"resolved": "https://registry.npmjs.org/@mdx-js/mdx/-/mdx-1.6.5.tgz",
|
||||||
@ -1621,6 +1635,11 @@
|
|||||||
"integrity": "sha512-ljr9hGQYW3kZY1NmQbmSe4yXvgq3KDRt0FMBOB5OaDWqi4X2WzEsp6SZ02KmVrieNW1cjWlj13pgvcf0towZPw==",
|
"integrity": "sha512-ljr9hGQYW3kZY1NmQbmSe4yXvgq3KDRt0FMBOB5OaDWqi4X2WzEsp6SZ02KmVrieNW1cjWlj13pgvcf0towZPw==",
|
||||||
"dev": true
|
"dev": true
|
||||||
},
|
},
|
||||||
|
"@medv/codejar": {
|
||||||
|
"version": "1.0.9",
|
||||||
|
"resolved": "https://registry.npmjs.org/@medv/codejar/-/codejar-1.0.9.tgz",
|
||||||
|
"integrity": "sha512-TxcSsq+TFcCvbsTDbVT5h4y9g86yBpEk+Da6tyIyd2OTJKWK0o7U5Olva4XMG4i+ExW5A9MfZAGFClwYokacIQ=="
|
||||||
|
},
|
||||||
"@mrmlnc/readdir-enhanced": {
|
"@mrmlnc/readdir-enhanced": {
|
||||||
"version": "2.2.1",
|
"version": "2.2.1",
|
||||||
"resolved": "https://registry.npmjs.org/@mrmlnc/readdir-enhanced/-/readdir-enhanced-2.2.1.tgz",
|
"resolved": "https://registry.npmjs.org/@mrmlnc/readdir-enhanced/-/readdir-enhanced-2.2.1.tgz",
|
||||||
@ -1859,6 +1878,11 @@
|
|||||||
"integrity": "sha512-//oorEZjL6sbPcKUaCdIGlIUeH26mgzimjBB77G6XRgnDl/L5wOnpyBGRe/Mmf5CVW3PwEBE1NjiMZ/ssFh4wA==",
|
"integrity": "sha512-//oorEZjL6sbPcKUaCdIGlIUeH26mgzimjBB77G6XRgnDl/L5wOnpyBGRe/Mmf5CVW3PwEBE1NjiMZ/ssFh4wA==",
|
||||||
"dev": true
|
"dev": true
|
||||||
},
|
},
|
||||||
|
"@types/prismjs": {
|
||||||
|
"version": "1.16.1",
|
||||||
|
"resolved": "https://registry.npmjs.org/@types/prismjs/-/prismjs-1.16.1.tgz",
|
||||||
|
"integrity": "sha512-RNgcK3FEc1GpeOkamGDq42EYkb6yZW5OWQwTS56NJIB8WL0QGISQglA7En7NUx9RGP8AC52DOe+squqbAckXlA=="
|
||||||
|
},
|
||||||
"@types/q": {
|
"@types/q": {
|
||||||
"version": "1.5.4",
|
"version": "1.5.4",
|
||||||
"resolved": "https://registry.npmjs.org/@types/q/-/q-1.5.4.tgz",
|
"resolved": "https://registry.npmjs.org/@types/q/-/q-1.5.4.tgz",
|
||||||
@ -2516,6 +2540,37 @@
|
|||||||
"integrity": "sha512-3YDiu347mtVtjpyV3u5kVqQLP242c06zwDOgpeRnybmXlYYsLbtTrUBUm8i8srONt+FWobl5aibnU1030PeeuA==",
|
"integrity": "sha512-3YDiu347mtVtjpyV3u5kVqQLP242c06zwDOgpeRnybmXlYYsLbtTrUBUm8i8srONt+FWobl5aibnU1030PeeuA==",
|
||||||
"dev": true
|
"dev": true
|
||||||
},
|
},
|
||||||
|
"axios": {
|
||||||
|
"version": "0.19.2",
|
||||||
|
"resolved": "https://registry.npmjs.org/axios/-/axios-0.19.2.tgz",
|
||||||
|
"integrity": "sha512-fjgm5MvRHLhx+osE2xoekY70AhARk3a6hkN+3Io1jc00jtquGvxYlKlsFUhmUET0V5te6CcZI7lcv2Ym61mjHA==",
|
||||||
|
"requires": {
|
||||||
|
"follow-redirects": "1.5.10"
|
||||||
|
},
|
||||||
|
"dependencies": {
|
||||||
|
"debug": {
|
||||||
|
"version": "3.1.0",
|
||||||
|
"resolved": "https://registry.npmjs.org/debug/-/debug-3.1.0.tgz",
|
||||||
|
"integrity": "sha512-OX8XqP7/1a9cqkxYw2yXss15f26NKWBpDXQd0/uK/KPqdQhxbPa994hnzjcE2VqQpDslf55723cKPUOGSmMY3g==",
|
||||||
|
"requires": {
|
||||||
|
"ms": "2.0.0"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"follow-redirects": {
|
||||||
|
"version": "1.5.10",
|
||||||
|
"resolved": "https://registry.npmjs.org/follow-redirects/-/follow-redirects-1.5.10.tgz",
|
||||||
|
"integrity": "sha512-0V5l4Cizzvqt5D44aTXbFZz+FtyXV1vrDN6qrelxtfYQKW0KO0W2T/hkE8xvGa/540LkZlkaUjO4ailYTFtHVQ==",
|
||||||
|
"requires": {
|
||||||
|
"debug": "=3.1.0"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"ms": {
|
||||||
|
"version": "2.0.0",
|
||||||
|
"resolved": "https://registry.npmjs.org/ms/-/ms-2.0.0.tgz",
|
||||||
|
"integrity": "sha1-VgiurfwAvmwpAd9fmGF4jeDVl8g="
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
"babel-code-frame": {
|
"babel-code-frame": {
|
||||||
"version": "6.26.0",
|
"version": "6.26.0",
|
||||||
"resolved": "https://registry.npmjs.org/babel-code-frame/-/babel-code-frame-6.26.0.tgz",
|
"resolved": "https://registry.npmjs.org/babel-code-frame/-/babel-code-frame-6.26.0.tgz",
|
||||||
@ -3418,7 +3473,6 @@
|
|||||||
"version": "2.0.6",
|
"version": "2.0.6",
|
||||||
"resolved": "https://registry.npmjs.org/clipboard/-/clipboard-2.0.6.tgz",
|
"resolved": "https://registry.npmjs.org/clipboard/-/clipboard-2.0.6.tgz",
|
||||||
"integrity": "sha512-g5zbiixBRk/wyKakSwCKd7vQXDjFnAMGHoEyBogG/bw9kTD9GvdAvaoRR1ALcEzt3pVKxZR0pViekPMIS0QyGg==",
|
"integrity": "sha512-g5zbiixBRk/wyKakSwCKd7vQXDjFnAMGHoEyBogG/bw9kTD9GvdAvaoRR1ALcEzt3pVKxZR0pViekPMIS0QyGg==",
|
||||||
"dev": true,
|
|
||||||
"requires": {
|
"requires": {
|
||||||
"good-listener": "^1.2.2",
|
"good-listener": "^1.2.2",
|
||||||
"select": "^1.1.2",
|
"select": "^1.1.2",
|
||||||
@ -4419,8 +4473,7 @@
|
|||||||
"delegate": {
|
"delegate": {
|
||||||
"version": "3.2.0",
|
"version": "3.2.0",
|
||||||
"resolved": "https://registry.npmjs.org/delegate/-/delegate-3.2.0.tgz",
|
"resolved": "https://registry.npmjs.org/delegate/-/delegate-3.2.0.tgz",
|
||||||
"integrity": "sha512-IofjkYBZaZivn0V8nnsMJGBr4jVLxHDheKSW88PyxS5QC4Vo9ZbZVvhzlSxY87fVq3STR6r+4cGepyHkcWOQSw==",
|
"integrity": "sha512-IofjkYBZaZivn0V8nnsMJGBr4jVLxHDheKSW88PyxS5QC4Vo9ZbZVvhzlSxY87fVq3STR6r+4cGepyHkcWOQSw=="
|
||||||
"dev": true
|
|
||||||
},
|
},
|
||||||
"depd": {
|
"depd": {
|
||||||
"version": "1.1.2",
|
"version": "1.1.2",
|
||||||
@ -5961,7 +6014,6 @@
|
|||||||
"version": "1.2.2",
|
"version": "1.2.2",
|
||||||
"resolved": "https://registry.npmjs.org/good-listener/-/good-listener-1.2.2.tgz",
|
"resolved": "https://registry.npmjs.org/good-listener/-/good-listener-1.2.2.tgz",
|
||||||
"integrity": "sha1-1TswzfkxPf+33JoNR3CWqm0UXFA=",
|
"integrity": "sha1-1TswzfkxPf+33JoNR3CWqm0UXFA=",
|
||||||
"dev": true,
|
|
||||||
"requires": {
|
"requires": {
|
||||||
"delegate": "^3.1.2"
|
"delegate": "^3.1.2"
|
||||||
}
|
}
|
||||||
@ -7367,6 +7419,11 @@
|
|||||||
"leven": "^3.1.0"
|
"leven": "^3.1.0"
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
|
"ligo-snippets-css": {
|
||||||
|
"version": "0.0.1",
|
||||||
|
"resolved": "https://registry.npmjs.org/ligo-snippets-css/-/ligo-snippets-css-0.0.1.tgz",
|
||||||
|
"integrity": "sha512-8qZ3TO198MX03HJw5YzTe5am63hacUtYzZEt2DlLtLP22Iri2UvLnckVXisZEVt0w18kM6aDhtMarAz127/z4g=="
|
||||||
|
},
|
||||||
"lines-and-columns": {
|
"lines-and-columns": {
|
||||||
"version": "1.1.6",
|
"version": "1.1.6",
|
||||||
"resolved": "https://registry.npmjs.org/lines-and-columns/-/lines-and-columns-1.1.6.tgz",
|
"resolved": "https://registry.npmjs.org/lines-and-columns/-/lines-and-columns-1.1.6.tgz",
|
||||||
@ -10042,14 +10099,12 @@
|
|||||||
"prism-react-renderer": {
|
"prism-react-renderer": {
|
||||||
"version": "1.1.1",
|
"version": "1.1.1",
|
||||||
"resolved": "https://registry.npmjs.org/prism-react-renderer/-/prism-react-renderer-1.1.1.tgz",
|
"resolved": "https://registry.npmjs.org/prism-react-renderer/-/prism-react-renderer-1.1.1.tgz",
|
||||||
"integrity": "sha512-MgMhSdHuHymNRqD6KM3eGS0PNqgK9q4QF5P0yoQQvpB6jNjeSAi3jcSAz0Sua/t9fa4xDOMar9HJbLa08gl9ug==",
|
"integrity": "sha512-MgMhSdHuHymNRqD6KM3eGS0PNqgK9q4QF5P0yoQQvpB6jNjeSAi3jcSAz0Sua/t9fa4xDOMar9HJbLa08gl9ug=="
|
||||||
"dev": true
|
|
||||||
},
|
},
|
||||||
"prismjs": {
|
"prismjs": {
|
||||||
"version": "1.20.0",
|
"version": "1.20.0",
|
||||||
"resolved": "https://registry.npmjs.org/prismjs/-/prismjs-1.20.0.tgz",
|
"resolved": "https://registry.npmjs.org/prismjs/-/prismjs-1.20.0.tgz",
|
||||||
"integrity": "sha512-AEDjSrVNkynnw6A+B1DsFkd6AVdTnp+/WoUixFRULlCLZVRZlVQMVWio/16jv7G1FscUxQxOQhWwApgbnxr6kQ==",
|
"integrity": "sha512-AEDjSrVNkynnw6A+B1DsFkd6AVdTnp+/WoUixFRULlCLZVRZlVQMVWio/16jv7G1FscUxQxOQhWwApgbnxr6kQ==",
|
||||||
"dev": true,
|
|
||||||
"requires": {
|
"requires": {
|
||||||
"clipboard": "^2.0.0"
|
"clipboard": "^2.0.0"
|
||||||
}
|
}
|
||||||
@ -10267,6 +10322,14 @@
|
|||||||
"prop-types": "^15.6.2"
|
"prop-types": "^15.6.2"
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
|
"react-codejar": {
|
||||||
|
"version": "1.0.1",
|
||||||
|
"resolved": "https://registry.npmjs.org/react-codejar/-/react-codejar-1.0.1.tgz",
|
||||||
|
"integrity": "sha512-t58v/YF4qV8w1yHi8Ylkte5tOU5ziYd5/4EIyyuJ6g/rS73ccaV113HhQBwvtoofSKTqOdKv3Rc4K5iMZ10IGg==",
|
||||||
|
"requires": {
|
||||||
|
"@medv/codejar": "^1.0.0"
|
||||||
|
}
|
||||||
|
},
|
||||||
"react-dev-utils": {
|
"react-dev-utils": {
|
||||||
"version": "10.2.1",
|
"version": "10.2.1",
|
||||||
"resolved": "https://registry.npmjs.org/react-dev-utils/-/react-dev-utils-10.2.1.tgz",
|
"resolved": "https://registry.npmjs.org/react-dev-utils/-/react-dev-utils-10.2.1.tgz",
|
||||||
@ -11452,8 +11515,7 @@
|
|||||||
"select": {
|
"select": {
|
||||||
"version": "1.1.2",
|
"version": "1.1.2",
|
||||||
"resolved": "https://registry.npmjs.org/select/-/select-1.1.2.tgz",
|
"resolved": "https://registry.npmjs.org/select/-/select-1.1.2.tgz",
|
||||||
"integrity": "sha1-DnNQrN7ICxEIUoeG7B1EGNEbOW0=",
|
"integrity": "sha1-DnNQrN7ICxEIUoeG7B1EGNEbOW0="
|
||||||
"dev": true
|
|
||||||
},
|
},
|
||||||
"select-hose": {
|
"select-hose": {
|
||||||
"version": "2.0.0",
|
"version": "2.0.0",
|
||||||
@ -12678,8 +12740,7 @@
|
|||||||
"tiny-emitter": {
|
"tiny-emitter": {
|
||||||
"version": "2.1.0",
|
"version": "2.1.0",
|
||||||
"resolved": "https://registry.npmjs.org/tiny-emitter/-/tiny-emitter-2.1.0.tgz",
|
"resolved": "https://registry.npmjs.org/tiny-emitter/-/tiny-emitter-2.1.0.tgz",
|
||||||
"integrity": "sha512-NB6Dk1A9xgQPMoGqC5CVXn123gWyte215ONT5Pp5a0yt4nlEoO1ZWeCwpncaekPHXO60i47ihFnZPiRPjRMq4Q==",
|
"integrity": "sha512-NB6Dk1A9xgQPMoGqC5CVXn123gWyte215ONT5Pp5a0yt4nlEoO1ZWeCwpncaekPHXO60i47ihFnZPiRPjRMq4Q=="
|
||||||
"dev": true
|
|
||||||
},
|
},
|
||||||
"tiny-invariant": {
|
"tiny-invariant": {
|
||||||
"version": "1.1.0",
|
"version": "1.1.0",
|
||||||
@ -14516,8 +14577,7 @@
|
|||||||
"yaml": {
|
"yaml": {
|
||||||
"version": "1.10.0",
|
"version": "1.10.0",
|
||||||
"resolved": "https://registry.npmjs.org/yaml/-/yaml-1.10.0.tgz",
|
"resolved": "https://registry.npmjs.org/yaml/-/yaml-1.10.0.tgz",
|
||||||
"integrity": "sha512-yr2icI4glYaNG+KWONODapy2/jDdMSDnrONSjblABjD9B4Z5LgiircSt8m8sRZFNi08kG9Sm0uSHtEmP3zaEGg==",
|
"integrity": "sha512-yr2icI4glYaNG+KWONODapy2/jDdMSDnrONSjblABjD9B4Z5LgiircSt8m8sRZFNi08kG9Sm0uSHtEmP3zaEGg=="
|
||||||
"dev": true
|
|
||||||
},
|
},
|
||||||
"yargs": {
|
"yargs": {
|
||||||
"version": "13.3.2",
|
"version": "13.3.2",
|
||||||
|
|||||||
@ -29,6 +29,10 @@
|
|||||||
},
|
},
|
||||||
"dependencies": {
|
"dependencies": {
|
||||||
"@docusaurus/plugin-sitemap": "^2.0.0-alpha.56",
|
"@docusaurus/plugin-sitemap": "^2.0.0-alpha.56",
|
||||||
"@ligo/syntax": "file:src/@ligo/syntax"
|
"@ligo/syntax": "file:src/@ligo/syntax",
|
||||||
|
"@ligolang/ligo-snippets": "^1.0.1",
|
||||||
|
"axios": "^0.19.2",
|
||||||
|
"react-codejar": "^1.0.1",
|
||||||
|
"yaml": "^1.10.0"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
@ -81,11 +81,13 @@ Prism.languages = {
|
|||||||
]
|
]
|
||||||
}
|
}
|
||||||
};
|
};
|
||||||
|
|
||||||
import defaultTheme from 'prism-react-renderer/themes/palenight';
|
import defaultTheme from 'prism-react-renderer/themes/palenight';
|
||||||
import Clipboard from 'clipboard';
|
import Clipboard from 'clipboard';
|
||||||
import rangeParser from 'parse-numeric-range';
|
import rangeParser from 'parse-numeric-range';
|
||||||
import useDocusaurusContext from '@docusaurus/useDocusaurusContext';
|
import useDocusaurusContext from '@docusaurus/useDocusaurusContext';
|
||||||
import useThemeContext from '@theme/hooks/useThemeContext';
|
import useThemeContext from '@theme/hooks/useThemeContext';
|
||||||
|
import { LigoSnippet } from '@ligolang/ligo-snippets'
|
||||||
|
|
||||||
import styles from './styles.module.css';
|
import styles from './styles.module.css';
|
||||||
|
|
||||||
@ -159,7 +161,8 @@ const highlightDirectiveRegex = (lang) => {
|
|||||||
};
|
};
|
||||||
const codeBlockTitleRegex = /title=".*"/;
|
const codeBlockTitleRegex = /title=".*"/;
|
||||||
|
|
||||||
export default ({children, className: languageClassName, metastring}) => {
|
export default ({ children, className: languageClassName, metastring }) => {
|
||||||
|
|
||||||
const {
|
const {
|
||||||
siteConfig: {
|
siteConfig: {
|
||||||
themeConfig: {prism = {}},
|
themeConfig: {prism = {}},
|
||||||
@ -277,6 +280,34 @@ export default ({children, className: languageClassName, metastring}) => {
|
|||||||
setTimeout(() => setShowCopied(false), 2000);
|
setTimeout(() => setShowCopied(false), 2000);
|
||||||
};
|
};
|
||||||
|
|
||||||
|
// ligo-snippets - begin
|
||||||
|
if (metastring) {
|
||||||
|
const theme = isDarkTheme ? 'dark' : 'light';
|
||||||
|
let isObject = true
|
||||||
|
let metadata
|
||||||
|
|
||||||
|
try {
|
||||||
|
metadata = JSON.parse(metastring)
|
||||||
|
} catch (e) {
|
||||||
|
isObject = false
|
||||||
|
}
|
||||||
|
|
||||||
|
if (isObject) {
|
||||||
|
const snippetData = {
|
||||||
|
"language": language,
|
||||||
|
"name": metadata.name,
|
||||||
|
"code": children,
|
||||||
|
"theme": theme,
|
||||||
|
"height": "" // Optional
|
||||||
|
}
|
||||||
|
|
||||||
|
if (metadata.editor) {
|
||||||
|
return <LigoSnippet data={snippetData} />
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
// ligo-snippets - end
|
||||||
|
|
||||||
return (
|
return (
|
||||||
<Highlight
|
<Highlight
|
||||||
{...defaultProps}
|
{...defaultProps}
|
||||||
|
|||||||
@ -242,6 +242,10 @@ p {
|
|||||||
border-top: none;
|
border-top: none;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
.tabs .tabs__item {
|
||||||
|
outline: 0;
|
||||||
|
}
|
||||||
|
|
||||||
.tabs .nav-tabs > div {
|
.tabs .nav-tabs > div {
|
||||||
font-size: 1em;
|
font-size: 1em;
|
||||||
font-weight: normal;
|
font-weight: normal;
|
||||||
|
|||||||
@ -9,11 +9,12 @@ let
|
|||||||
inherit (import sources."gitignore.nix" { inherit (self) lib; })
|
inherit (import sources."gitignore.nix" { inherit (self) lib; })
|
||||||
gitignoreSource;
|
gitignoreSource;
|
||||||
# Remove list of directories or files from source (to stop unneeded rebuilds)
|
# Remove list of directories or files from source (to stop unneeded rebuilds)
|
||||||
|
# Also, apply the gitignore here.
|
||||||
filterOut = xs:
|
filterOut = xs:
|
||||||
self.lib.cleanSourceWith {
|
gitignoreSource (self.lib.cleanSourceWith {
|
||||||
filter = p: type: !(builtins.elem (builtins.baseNameOf p) xs);
|
filter = p: type: !(builtins.elem (builtins.baseNameOf p) xs);
|
||||||
src = gitignoreSource ../.;
|
src = gitignoreSource ../.;
|
||||||
};
|
});
|
||||||
in {
|
in {
|
||||||
ocamlPackages = self.ocaml-ng.ocamlPackages_4_07.overrideScope'
|
ocamlPackages = self.ocaml-ng.ocamlPackages_4_07.overrideScope'
|
||||||
(builtins.foldl' self.lib.composeExtensions (_: _: { }) [
|
(builtins.foldl' self.lib.composeExtensions (_: _: { }) [
|
||||||
|
|||||||
@ -159,10 +159,22 @@ let preprocess =
|
|||||||
let doc = "Subcommand: Preprocess the source file.\nWarning: Intended for development of LIGO and can break at any time." in
|
let doc = "Subcommand: Preprocess the source file.\nWarning: Intended for development of LIGO and can break at any time." in
|
||||||
(Term.ret term, Term.info ~doc cmdname)
|
(Term.ret term, Term.info ~doc cmdname)
|
||||||
|
|
||||||
|
let pretty_print =
|
||||||
|
let f source_file syntax display_format = (
|
||||||
|
toplevel ~display_format @@
|
||||||
|
let%bind pp =
|
||||||
|
Compile.Of_source.pretty_print source_file (Syntax_name syntax) in
|
||||||
|
ok @@ Buffer.contents pp
|
||||||
|
) in
|
||||||
|
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
|
||||||
|
let cmdname = "pretty-print" in
|
||||||
|
let doc = "Subcommand: Pretty-print the source file."
|
||||||
|
in (Term.ret term, Term.info ~doc cmdname)
|
||||||
|
|
||||||
let print_cst =
|
let print_cst =
|
||||||
let f source_file syntax display_format = (
|
let f source_file syntax display_format = (
|
||||||
toplevel ~display_format @@
|
toplevel ~display_format @@
|
||||||
let%bind pp = Compile.Of_source.pretty_print source_file (Syntax_name syntax) in
|
let%bind pp = Compile.Of_source.pretty_print_cst source_file (Syntax_name syntax) in
|
||||||
ok @@ Format.asprintf "%s \n" (Buffer.contents pp)
|
ok @@ Format.asprintf "%s \n" (Buffer.contents pp)
|
||||||
)
|
)
|
||||||
in
|
in
|
||||||
@ -489,5 +501,6 @@ let run ?argv () =
|
|||||||
print_ast_typed ;
|
print_ast_typed ;
|
||||||
print_mini_c ;
|
print_mini_c ;
|
||||||
list_declarations ;
|
list_declarations ;
|
||||||
preprocess
|
preprocess;
|
||||||
|
pretty_print
|
||||||
]
|
]
|
||||||
|
|||||||
@ -57,6 +57,9 @@ let%expect_test _ =
|
|||||||
Subcommand: Preprocess the source file. Warning: Intended for
|
Subcommand: Preprocess the source file. Warning: Intended for
|
||||||
development of LIGO and can break at any time.
|
development of LIGO and can break at any time.
|
||||||
|
|
||||||
|
pretty-print
|
||||||
|
Subcommand: Pretty-print the source file.
|
||||||
|
|
||||||
print-ast
|
print-ast
|
||||||
Subcommand: Print the AST. Warning: Intended for development of
|
Subcommand: Print the AST. Warning: Intended for development of
|
||||||
LIGO and can break at any time.
|
LIGO and can break at any time.
|
||||||
@ -148,6 +151,9 @@ let%expect_test _ =
|
|||||||
Subcommand: Preprocess the source file. Warning: Intended for
|
Subcommand: Preprocess the source file. Warning: Intended for
|
||||||
development of LIGO and can break at any time.
|
development of LIGO and can break at any time.
|
||||||
|
|
||||||
|
pretty-print
|
||||||
|
Subcommand: Pretty-print the source file.
|
||||||
|
|
||||||
print-ast
|
print-ast
|
||||||
Subcommand: Print the AST. Warning: Intended for development of
|
Subcommand: Print the AST. Warning: Intended for development of
|
||||||
LIGO and can break at any time.
|
LIGO and can break at any time.
|
||||||
|
|||||||
@ -7,7 +7,7 @@ let%expect_test _ =
|
|||||||
let%expect_test _ =
|
let%expect_test _ =
|
||||||
run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
|
run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
|
||||||
[%expect {|
|
[%expect {|
|
||||||
ligo: in file "", line 0, characters 1-32. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 1-32"}
|
ligo: in file "", line 0, characters 0-33. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 0-33"}
|
||||||
|
|
||||||
|
|
||||||
If you're not sure how to fix this error, you can
|
If you're not sure how to fix this error, you can
|
||||||
@ -25,7 +25,7 @@ let%expect_test _ =
|
|||||||
let%expect_test _ =
|
let%expect_test _ =
|
||||||
run_ligo_bad ["interpret" ; "(\"thisisnotapublickey\":key)" ; "--syntax=pascaligo"] ;
|
run_ligo_bad ["interpret" ; "(\"thisisnotapublickey\":key)" ; "--syntax=pascaligo"] ;
|
||||||
[%expect {|
|
[%expect {|
|
||||||
ligo: in file "", line 0, characters 1-26. Badly formatted literal: key thisisnotapublickey {"location":"in file \"\", line 0, characters 1-26"}
|
ligo: in file "", line 0, characters 0-27. Badly formatted literal: key thisisnotapublickey {"location":"in file \"\", line 0, characters 0-27"}
|
||||||
|
|
||||||
|
|
||||||
If you're not sure how to fix this error, you can
|
If you're not sure how to fix this error, you can
|
||||||
|
|||||||
@ -129,7 +129,7 @@ let parsify_string syntax source =
|
|||||||
let%bind applied = Self_ast_imperative.all_program parsified
|
let%bind applied = Self_ast_imperative.all_program parsified
|
||||||
in ok applied
|
in ok applied
|
||||||
|
|
||||||
let pretty_print_pascaligo source =
|
let pretty_print_pascaligo_cst source =
|
||||||
let%bind ast = Parser.Pascaligo.parse_file source in
|
let%bind ast = Parser.Pascaligo.parse_file source in
|
||||||
let buffer = Buffer.create 59 in
|
let buffer = Buffer.create 59 in
|
||||||
let state =
|
let state =
|
||||||
@ -137,10 +137,10 @@ let pretty_print_pascaligo source =
|
|||||||
~offsets:true
|
~offsets:true
|
||||||
~mode:`Byte
|
~mode:`Byte
|
||||||
~buffer in
|
~buffer in
|
||||||
Parser_pascaligo.ParserLog.pp_ast state ast;
|
Parser_pascaligo.ParserLog.pp_cst state ast;
|
||||||
ok buffer
|
ok buffer
|
||||||
|
|
||||||
let pretty_print_cameligo source =
|
let pretty_print_cameligo_cst source =
|
||||||
let%bind ast = Parser.Cameligo.parse_file source in
|
let%bind ast = Parser.Cameligo.parse_file source in
|
||||||
let buffer = Buffer.create 59 in
|
let buffer = Buffer.create 59 in
|
||||||
let state = (* TODO: Should flow from the CLI *)
|
let state = (* TODO: Should flow from the CLI *)
|
||||||
@ -148,10 +148,10 @@ let pretty_print_cameligo source =
|
|||||||
~offsets:true
|
~offsets:true
|
||||||
~mode:`Point
|
~mode:`Point
|
||||||
~buffer in
|
~buffer in
|
||||||
Parser_cameligo.ParserLog.pp_ast state ast;
|
Parser_cameligo.ParserLog.pp_cst state ast;
|
||||||
ok buffer
|
ok buffer
|
||||||
|
|
||||||
let pretty_print_reasonligo source =
|
let pretty_print_reasonligo_cst source =
|
||||||
let%bind ast = Parser.Reasonligo.parse_file source in
|
let%bind ast = Parser.Reasonligo.parse_file source in
|
||||||
let buffer = Buffer.create 59 in
|
let buffer = Buffer.create 59 in
|
||||||
let state = (* TODO: Should flow from the CLI *)
|
let state = (* TODO: Should flow from the CLI *)
|
||||||
@ -159,16 +159,16 @@ let pretty_print_reasonligo source =
|
|||||||
~offsets:true
|
~offsets:true
|
||||||
~mode:`Point
|
~mode:`Point
|
||||||
~buffer in
|
~buffer in
|
||||||
Parser_cameligo.ParserLog.pp_ast state ast;
|
Parser_cameligo.ParserLog.pp_cst state ast;
|
||||||
ok buffer
|
ok buffer
|
||||||
|
|
||||||
let pretty_print syntax source =
|
let pretty_print_cst syntax source =
|
||||||
let%bind v_syntax =
|
let%bind v_syntax =
|
||||||
syntax_to_variant syntax (Some source) in
|
syntax_to_variant syntax (Some source) in
|
||||||
match v_syntax with
|
match v_syntax with
|
||||||
PascaLIGO -> pretty_print_pascaligo source
|
PascaLIGO -> pretty_print_pascaligo_cst source
|
||||||
| CameLIGO -> pretty_print_cameligo source
|
| CameLIGO -> pretty_print_cameligo_cst source
|
||||||
| ReasonLIGO -> pretty_print_reasonligo source
|
| ReasonLIGO -> pretty_print_reasonligo_cst source
|
||||||
|
|
||||||
let preprocess_pascaligo = Parser.Pascaligo.preprocess
|
let preprocess_pascaligo = Parser.Pascaligo.preprocess
|
||||||
|
|
||||||
@ -183,3 +183,44 @@ let preprocess syntax source =
|
|||||||
PascaLIGO -> preprocess_pascaligo source
|
PascaLIGO -> preprocess_pascaligo source
|
||||||
| CameLIGO -> preprocess_cameligo source
|
| CameLIGO -> preprocess_cameligo source
|
||||||
| ReasonLIGO -> preprocess_reasonligo source
|
| ReasonLIGO -> preprocess_reasonligo source
|
||||||
|
|
||||||
|
let pretty_print_pascaligo source =
|
||||||
|
let%bind ast = Parser.Pascaligo.parse_file source in
|
||||||
|
let doc = Parser_pascaligo.Pretty.print ast in
|
||||||
|
let buffer = Buffer.create 131 in
|
||||||
|
let width =
|
||||||
|
match Terminal_size.get_columns () with
|
||||||
|
None -> 60
|
||||||
|
| Some c -> c in
|
||||||
|
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
|
||||||
|
in Trace.ok buffer
|
||||||
|
|
||||||
|
let pretty_print_cameligo source =
|
||||||
|
let%bind ast = Parser.Cameligo.parse_file source in
|
||||||
|
let doc = Parser_cameligo.Pretty.print ast in
|
||||||
|
let buffer = Buffer.create 131 in
|
||||||
|
let width =
|
||||||
|
match Terminal_size.get_columns () with
|
||||||
|
None -> 60
|
||||||
|
| Some c -> c in
|
||||||
|
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
|
||||||
|
in Trace.ok buffer
|
||||||
|
|
||||||
|
let pretty_print_reasonligo source =
|
||||||
|
let%bind ast = Parser.Reasonligo.parse_file source in
|
||||||
|
let doc = Parser_reasonligo.Pretty.print ast in
|
||||||
|
let buffer = Buffer.create 131 in
|
||||||
|
let width =
|
||||||
|
match Terminal_size.get_columns () with
|
||||||
|
None -> 60
|
||||||
|
| Some c -> c in
|
||||||
|
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
|
||||||
|
in Trace.ok buffer
|
||||||
|
|
||||||
|
let pretty_print syntax source =
|
||||||
|
let%bind v_syntax =
|
||||||
|
syntax_to_variant syntax (Some source) in
|
||||||
|
match v_syntax with
|
||||||
|
PascaLIGO -> pretty_print_pascaligo source
|
||||||
|
| CameLIGO -> pretty_print_cameligo source
|
||||||
|
| ReasonLIGO -> pretty_print_reasonligo source
|
||||||
|
|||||||
@ -19,8 +19,11 @@ let compile_contract_input : string -> string -> v_syntax -> Ast_imperative.expr
|
|||||||
let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in
|
let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in
|
||||||
ok @@ Ast_imperative.e_pair storage parameter
|
ok @@ Ast_imperative.e_pair storage parameter
|
||||||
|
|
||||||
let pretty_print source_filename syntax =
|
let pretty_print_cst source_filename syntax =
|
||||||
Helpers.pretty_print syntax source_filename
|
Helpers.pretty_print_cst syntax source_filename
|
||||||
|
|
||||||
let preprocess source_filename syntax =
|
let preprocess source_filename syntax =
|
||||||
Helpers.preprocess syntax source_filename
|
Helpers.preprocess syntax source_filename
|
||||||
|
|
||||||
|
let pretty_print source_filename syntax =
|
||||||
|
Helpers.pretty_print syntax source_filename
|
||||||
|
|||||||
@ -5,6 +5,7 @@ module Scoping = Parser_cameligo.Scoping
|
|||||||
module Region = Simple_utils.Region
|
module Region = Simple_utils.Region
|
||||||
module ParErr = Parser_cameligo.ParErr
|
module ParErr = Parser_cameligo.ParErr
|
||||||
module SSet = Set.Make (String)
|
module SSet = Set.Make (String)
|
||||||
|
module Pretty = Parser_cameligo.Pretty
|
||||||
|
|
||||||
(* Mock IOs TODO: Fill them with CLI options *)
|
(* Mock IOs TODO: Fill them with CLI options *)
|
||||||
|
|
||||||
@ -19,7 +20,8 @@ module SubIO =
|
|||||||
ext : string; (* ".mligo" *)
|
ext : string; (* ".mligo" *)
|
||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : EvalOpt.command;
|
cmd : EvalOpt.command;
|
||||||
mono : bool
|
mono : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
let options : options =
|
let options : options =
|
||||||
@ -34,6 +36,7 @@ module SubIO =
|
|||||||
method mode = `Point
|
method mode = `Point
|
||||||
method cmd = EvalOpt.Quiet
|
method cmd = EvalOpt.Quiet
|
||||||
method mono = false
|
method mono = false
|
||||||
|
method pretty = false
|
||||||
end
|
end
|
||||||
|
|
||||||
let make =
|
let make =
|
||||||
@ -46,6 +49,7 @@ module SubIO =
|
|||||||
~mode:options#mode
|
~mode:options#mode
|
||||||
~cmd:options#cmd
|
~cmd:options#cmd
|
||||||
~mono:options#mono
|
~mono:options#mono
|
||||||
|
~pretty:options#mono
|
||||||
end
|
end
|
||||||
|
|
||||||
module Parser =
|
module Parser =
|
||||||
@ -146,3 +150,18 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
|
|||||||
(* Preprocessing a contract in a file *)
|
(* Preprocessing a contract in a file *)
|
||||||
|
|
||||||
let preprocess source = apply (fun () -> Unit.preprocess source)
|
let preprocess source = apply (fun () -> Unit.preprocess source)
|
||||||
|
|
||||||
|
(* Pretty-print a file (after parsing it). *)
|
||||||
|
|
||||||
|
let pretty_print source =
|
||||||
|
match parse_file source with
|
||||||
|
Stdlib.Error _ as e -> e
|
||||||
|
| Ok ast ->
|
||||||
|
let doc = Pretty.print (fst ast) in
|
||||||
|
let buffer = Buffer.create 131 in
|
||||||
|
let width =
|
||||||
|
match Terminal_size.get_columns () with
|
||||||
|
None -> 60
|
||||||
|
| Some c -> c in
|
||||||
|
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
|
||||||
|
in Trace.ok buffer
|
||||||
|
|||||||
@ -19,3 +19,6 @@ val parse_expression : string -> AST.expr Trace.result
|
|||||||
|
|
||||||
(** Preprocess a given CameLIGO file and preprocess it. *)
|
(** Preprocess a given CameLIGO file and preprocess it. *)
|
||||||
val preprocess : string -> Buffer.t Trace.result
|
val preprocess : string -> Buffer.t Trace.result
|
||||||
|
|
||||||
|
(** Pretty-print a given CameLIGO file (after parsing it). *)
|
||||||
|
val pretty_print : string -> Buffer.t Trace.result
|
||||||
|
|||||||
@ -19,5 +19,3 @@ $HOME/git/OCaml-build/Makefile
|
|||||||
../shared/LexerUnit.ml
|
../shared/LexerUnit.ml
|
||||||
../shared/ParserUnit.mli
|
../shared/ParserUnit.mli
|
||||||
../shared/ParserUnit.ml
|
../shared/ParserUnit.ml
|
||||||
|
|
||||||
$HOME/git/ligo/_build/default/src/passes/1-parser/cameligo/ParErr.ml
|
|
||||||
@ -137,11 +137,14 @@ and ast = t
|
|||||||
and attributes = attribute list
|
and attributes = attribute list
|
||||||
|
|
||||||
and declaration =
|
and declaration =
|
||||||
Let of (kwd_let * kwd_rec option * let_binding * attributes) reg
|
Let of let_decl
|
||||||
| TypeDecl of type_decl reg
|
| TypeDecl of type_decl reg
|
||||||
|
|
||||||
(* Non-recursive values *)
|
(* Non-recursive values *)
|
||||||
|
|
||||||
|
and let_decl =
|
||||||
|
(kwd_let * kwd_rec option * let_binding * attributes) reg
|
||||||
|
|
||||||
and let_binding = {
|
and let_binding = {
|
||||||
binders : pattern nseq;
|
binders : pattern nseq;
|
||||||
lhs_type : (colon * type_expr) option;
|
lhs_type : (colon * type_expr) option;
|
||||||
@ -225,7 +228,7 @@ and field_pattern = {
|
|||||||
and expr =
|
and expr =
|
||||||
ECase of expr case reg
|
ECase of expr case reg
|
||||||
| ECond of cond_expr reg
|
| ECond of cond_expr reg
|
||||||
| EAnnot of (expr * colon * type_expr) par reg
|
| EAnnot of annot_expr par reg
|
||||||
| ELogic of logic_expr
|
| ELogic of logic_expr
|
||||||
| EArith of arith_expr
|
| EArith of arith_expr
|
||||||
| EString of string_expr
|
| EString of string_expr
|
||||||
@ -244,6 +247,8 @@ and expr =
|
|||||||
| EFun of fun_expr reg
|
| EFun of fun_expr reg
|
||||||
| ESeq of expr injection reg
|
| ESeq of expr injection reg
|
||||||
|
|
||||||
|
and annot_expr = expr * colon * type_expr
|
||||||
|
|
||||||
and 'a injection = {
|
and 'a injection = {
|
||||||
compound : compound;
|
compound : compound;
|
||||||
elements : ('a, semi) sepseq;
|
elements : ('a, semi) sepseq;
|
||||||
@ -339,15 +344,16 @@ and update = {
|
|||||||
lbrace : lbrace;
|
lbrace : lbrace;
|
||||||
record : path;
|
record : path;
|
||||||
kwd_with : kwd_with;
|
kwd_with : kwd_with;
|
||||||
updates : field_path_assign reg ne_injection reg;
|
updates : field_path_assignment reg ne_injection reg;
|
||||||
rbrace : rbrace;
|
rbrace : rbrace
|
||||||
}
|
}
|
||||||
|
|
||||||
and field_path_assign = {
|
and field_path_assignment = {
|
||||||
field_path : (field_name, dot) nsepseq;
|
field_path : path;
|
||||||
assignment : equal;
|
assignment : equal;
|
||||||
field_expr : expr
|
field_expr : expr
|
||||||
}
|
}
|
||||||
|
|
||||||
and path =
|
and path =
|
||||||
Name of variable
|
Name of variable
|
||||||
| Path of projection reg
|
| Path of projection reg
|
||||||
|
|||||||
@ -431,7 +431,7 @@ type nat_err =
|
|||||||
| Non_canonical_zero_nat
|
| Non_canonical_zero_nat
|
||||||
|
|
||||||
let mk_nat lexeme region =
|
let mk_nat lexeme region =
|
||||||
match (String.index_opt lexeme 'n') with
|
match String.index_opt lexeme 'n' with
|
||||||
None -> Error Invalid_natural
|
None -> Error Invalid_natural
|
||||||
| Some _ -> let z =
|
| Some _ -> let z =
|
||||||
Str.(global_replace (regexp "_") "" lexeme) |>
|
Str.(global_replace (regexp "_") "" lexeme) |>
|
||||||
@ -442,8 +442,7 @@ let mk_nat lexeme region =
|
|||||||
else Ok (Nat Region.{region; value = lexeme,z})
|
else Ok (Nat Region.{region; value = lexeme,z})
|
||||||
|
|
||||||
let mk_mutez lexeme region =
|
let mk_mutez lexeme region =
|
||||||
let z =
|
let z = Str.(global_replace (regexp "_") "" lexeme) |>
|
||||||
Str.(global_replace (regexp "_") "" lexeme) |>
|
|
||||||
Str.(global_replace (regexp "mutez") "") |>
|
Str.(global_replace (regexp "mutez") "") |>
|
||||||
Z.of_string in
|
Z.of_string in
|
||||||
if Z.equal z Z.zero && lexeme <> "0mutez"
|
if Z.equal z Z.zero && lexeme <> "0mutez"
|
||||||
|
|||||||
@ -86,7 +86,7 @@ nsepseq(item,sep):
|
|||||||
(* Non-empty comma-separated values (at least two values) *)
|
(* Non-empty comma-separated values (at least two values) *)
|
||||||
|
|
||||||
tuple(item):
|
tuple(item):
|
||||||
item "," nsepseq(item,",") { let h,t = $3 in $1,($2,h)::t }
|
item "," nsepseq(item,",") { let h,t = $3 in $1, ($2,h)::t }
|
||||||
|
|
||||||
(* Possibly empty semicolon-separated values between brackets *)
|
(* Possibly empty semicolon-separated values between brackets *)
|
||||||
|
|
||||||
@ -236,10 +236,7 @@ type_annotation:
|
|||||||
irrefutable:
|
irrefutable:
|
||||||
sub_irrefutable { $1 }
|
sub_irrefutable { $1 }
|
||||||
| tuple(sub_irrefutable) {
|
| tuple(sub_irrefutable) {
|
||||||
let hd, tl = $1 in
|
let region = nsepseq_to_region pattern_to_region $1
|
||||||
let start = pattern_to_region hd in
|
|
||||||
let stop = last fst tl in
|
|
||||||
let region = cover start stop
|
|
||||||
in PTuple {region; value=$1} }
|
in PTuple {region; value=$1} }
|
||||||
|
|
||||||
sub_irrefutable:
|
sub_irrefutable:
|
||||||
@ -276,9 +273,7 @@ pattern:
|
|||||||
PList (PCons {region; value=$1,$2,$3})
|
PList (PCons {region; value=$1,$2,$3})
|
||||||
}
|
}
|
||||||
| tuple(sub_pattern) {
|
| tuple(sub_pattern) {
|
||||||
let start = pattern_to_region (fst $1) in
|
let region = nsepseq_to_region pattern_to_region $1
|
||||||
let stop = last fst (snd $1) in
|
|
||||||
let region = cover start stop
|
|
||||||
in PTuple {region; value=$1} }
|
in PTuple {region; value=$1} }
|
||||||
|
|
||||||
sub_pattern:
|
sub_pattern:
|
||||||
@ -333,10 +328,7 @@ constr_pattern:
|
|||||||
|
|
||||||
ptuple:
|
ptuple:
|
||||||
tuple(tail) {
|
tuple(tail) {
|
||||||
let hd, tl = $1 in
|
let region = nsepseq_to_region pattern_to_region $1
|
||||||
let start = pattern_to_region hd in
|
|
||||||
let stop = last fst tl in
|
|
||||||
let region = cover start stop
|
|
||||||
in PTuple {region; value=$1} }
|
in PTuple {region; value=$1} }
|
||||||
|
|
||||||
unit:
|
unit:
|
||||||
@ -372,9 +364,7 @@ base_expr(right_expr):
|
|||||||
|
|
||||||
tuple_expr:
|
tuple_expr:
|
||||||
tuple(disj_expr_level) {
|
tuple(disj_expr_level) {
|
||||||
let start = expr_to_region (fst $1) in
|
let region = nsepseq_to_region expr_to_region $1
|
||||||
let stop = last fst (snd $1) in
|
|
||||||
let region = cover start stop
|
|
||||||
in ETuple {region; value=$1} }
|
in ETuple {region; value=$1} }
|
||||||
|
|
||||||
conditional(right_expr):
|
conditional(right_expr):
|
||||||
@ -534,8 +524,7 @@ mult_expr_level:
|
|||||||
| unary_expr_level { $1 }
|
| unary_expr_level { $1 }
|
||||||
|
|
||||||
unary_expr_level:
|
unary_expr_level:
|
||||||
call_expr_level { $1 }
|
"-" call_expr_level {
|
||||||
| "-" call_expr_level {
|
|
||||||
let start = $1 in
|
let start = $1 in
|
||||||
let stop = expr_to_region $2 in
|
let stop = expr_to_region $2 in
|
||||||
let region = cover start stop
|
let region = cover start stop
|
||||||
@ -547,7 +536,9 @@ unary_expr_level:
|
|||||||
let stop = expr_to_region $2 in
|
let stop = expr_to_region $2 in
|
||||||
let region = cover start stop
|
let region = cover start stop
|
||||||
and value = {op=$1; arg=$2} in
|
and value = {op=$1; arg=$2} in
|
||||||
ELogic (BoolExpr (Not ({region; value}))) }
|
ELogic (BoolExpr (Not ({region; value})))
|
||||||
|
}
|
||||||
|
| call_expr_level { $1 }
|
||||||
|
|
||||||
call_expr_level:
|
call_expr_level:
|
||||||
call_expr | constr_expr | core_expr { $1 }
|
call_expr | constr_expr | core_expr { $1 }
|
||||||
@ -593,7 +584,10 @@ core_expr:
|
|||||||
| record_expr { ERecord $1 }
|
| record_expr { ERecord $1 }
|
||||||
| update_record { EUpdate $1 }
|
| update_record { EUpdate $1 }
|
||||||
| par(expr) { EPar $1 }
|
| par(expr) { EPar $1 }
|
||||||
| par(expr ":" type_expr {$1,$2,$3}) { EAnnot $1 }
|
| par(annot_expr) { EAnnot $1 }
|
||||||
|
|
||||||
|
annot_expr:
|
||||||
|
expr ":" type_expr { $1,$2,$3 }
|
||||||
|
|
||||||
module_field:
|
module_field:
|
||||||
module_name "." module_fun {
|
module_name "." module_fun {
|
||||||
@ -642,7 +636,7 @@ update_record:
|
|||||||
lbrace = $1;
|
lbrace = $1;
|
||||||
record = $2;
|
record = $2;
|
||||||
kwd_with = $3;
|
kwd_with = $3;
|
||||||
updates = {value = {compound = Braces($1,$5);
|
updates = {value = {compound = Braces (ghost, ghost);
|
||||||
ne_elements;
|
ne_elements;
|
||||||
terminator};
|
terminator};
|
||||||
region = cover $3 $5};
|
region = cover $3 $5};
|
||||||
@ -650,20 +644,15 @@ update_record:
|
|||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
field_path_assignment :
|
field_path_assignment :
|
||||||
nsepseq(field_name,".") "=" expr {
|
path "=" expr {
|
||||||
let start = nsepseq_to_region (fun x -> x.region) $1 in
|
let region = cover (path_to_region $1) (expr_to_region $3)
|
||||||
let region = cover start (expr_to_region $3) in
|
and value = {field_path=$1; assignment=$2; field_expr=$3}
|
||||||
let value = {field_path = $1;
|
in {region; value} }
|
||||||
assignment = $2;
|
|
||||||
field_expr = $3}
|
|
||||||
in {region; value}}
|
|
||||||
|
|
||||||
field_assignment:
|
field_assignment:
|
||||||
field_name "=" expr {
|
field_name "=" expr {
|
||||||
let start = $1.region in
|
let region = cover $1.region (expr_to_region $3)
|
||||||
let stop = expr_to_region $3 in
|
and value = {field_name = $1;
|
||||||
let region = cover start stop in
|
|
||||||
let value = {field_name = $1;
|
|
||||||
assignment = $2;
|
assignment = $2;
|
||||||
field_expr = $3}
|
field_expr = $3}
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|||||||
@ -136,11 +136,10 @@ let rec print_tokens state {decl;eof} =
|
|||||||
print_token state eof "EOF"
|
print_token state eof "EOF"
|
||||||
|
|
||||||
and print_attributes state attributes =
|
and print_attributes state attributes =
|
||||||
List.iter (
|
let apply {value = attribute; region} =
|
||||||
fun ({value = attribute; region}) ->
|
|
||||||
let attribute_formatted = sprintf "[@@%s]" attribute in
|
let attribute_formatted = sprintf "[@@%s]" attribute in
|
||||||
print_token state region attribute_formatted
|
print_token state region attribute_formatted
|
||||||
) attributes
|
in List.iter apply attributes
|
||||||
|
|
||||||
and print_statement state = function
|
and print_statement state = function
|
||||||
Let {value=kwd_let, kwd_rec, let_binding, attributes; _} ->
|
Let {value=kwd_let, kwd_rec, let_binding, attributes; _} ->
|
||||||
@ -527,7 +526,7 @@ and print_field_assign state {value; _} =
|
|||||||
|
|
||||||
and print_field_path_assign state {value; _} =
|
and print_field_path_assign state {value; _} =
|
||||||
let {field_path; assignment; field_expr} = value in
|
let {field_path; assignment; field_expr} = value in
|
||||||
print_nsepseq state "." print_var field_path;
|
print_path state field_path;
|
||||||
print_token state assignment "=";
|
print_token state assignment "=";
|
||||||
print_expr state field_expr
|
print_expr state field_expr
|
||||||
|
|
||||||
@ -616,12 +615,20 @@ let pp_node state name =
|
|||||||
let node = sprintf "%s%s\n" state#pad_path name
|
let node = sprintf "%s%s\n" state#pad_path name
|
||||||
in Buffer.add_string state#buffer node
|
in Buffer.add_string state#buffer node
|
||||||
|
|
||||||
let pp_string state = pp_ident state
|
let pp_string state {value=name; region} =
|
||||||
|
let reg = compact state region in
|
||||||
|
let node = sprintf "%s%S (%s)\n" state#pad_path name reg
|
||||||
|
in Buffer.add_string state#buffer node
|
||||||
|
|
||||||
|
let pp_verbatim state {value=name; region} =
|
||||||
|
let reg = compact state region in
|
||||||
|
let node = sprintf "%s{|%s|} (%s)\n" state#pad_path name reg
|
||||||
|
in Buffer.add_string state#buffer node
|
||||||
|
|
||||||
let pp_loc_node state name region =
|
let pp_loc_node state name region =
|
||||||
pp_ident state {value=name; region}
|
pp_ident state {value=name; region}
|
||||||
|
|
||||||
let rec pp_ast state {decl; _} =
|
let rec pp_cst state {decl; _} =
|
||||||
let apply len rank =
|
let apply len rank =
|
||||||
pp_declaration (state#pad len rank) in
|
pp_declaration (state#pad len rank) in
|
||||||
let decls = Utils.nseq_to_list decl in
|
let decls = Utils.nseq_to_list decl in
|
||||||
@ -704,7 +711,7 @@ and pp_pattern state = function
|
|||||||
pp_string (state#pad 1 0) s
|
pp_string (state#pad 1 0) s
|
||||||
| PVerbatim v ->
|
| PVerbatim v ->
|
||||||
pp_node state "PVerbatim";
|
pp_node state "PVerbatim";
|
||||||
pp_string (state#pad 1 0) v
|
pp_verbatim (state#pad 1 0) v
|
||||||
| PUnit {region; _} ->
|
| PUnit {region; _} ->
|
||||||
pp_loc_node state "PUnit" region
|
pp_loc_node state "PUnit" region
|
||||||
| PFalse region ->
|
| PFalse region ->
|
||||||
@ -938,7 +945,7 @@ and pp_projection state proj =
|
|||||||
List.iteri (apply len) selections
|
List.iteri (apply len) selections
|
||||||
|
|
||||||
and pp_update state update =
|
and pp_update state update =
|
||||||
pp_path state update.record;
|
pp_path (state#pad 2 0) update.record;
|
||||||
pp_ne_injection pp_field_path_assign state update.updates.value
|
pp_ne_injection pp_field_path_assign state update.updates.value
|
||||||
|
|
||||||
and pp_path state = function
|
and pp_path state = function
|
||||||
@ -963,10 +970,10 @@ and pp_field_assign state {value; _} =
|
|||||||
pp_expr (state#pad 2 1) value.field_expr
|
pp_expr (state#pad 2 1) value.field_expr
|
||||||
|
|
||||||
and pp_field_path_assign state {value; _} =
|
and pp_field_path_assign state {value; _} =
|
||||||
pp_node state "<field path for update>";
|
let {field_path; field_expr; _} = value in
|
||||||
let path = Utils.nsepseq_to_list value.field_path in
|
pp_node state "<update>";
|
||||||
List.iter (pp_ident (state#pad 2 0)) path;
|
pp_path (state#pad 2 0) field_path;
|
||||||
pp_expr (state#pad 2 1) value.field_expr
|
pp_expr (state#pad 2 1) field_expr
|
||||||
|
|
||||||
and pp_constr_expr state = function
|
and pp_constr_expr state = function
|
||||||
ENone region ->
|
ENone region ->
|
||||||
@ -987,11 +994,11 @@ and pp_constr_app_expr state (constr, expr_opt) =
|
|||||||
|
|
||||||
and pp_list_expr state = function
|
and pp_list_expr state = function
|
||||||
ECons {value; region} ->
|
ECons {value; region} ->
|
||||||
pp_loc_node state "Cons" region;
|
pp_loc_node state "ECons" region;
|
||||||
pp_expr (state#pad 2 0) value.arg1;
|
pp_expr (state#pad 2 0) value.arg1;
|
||||||
pp_expr (state#pad 2 1) value.arg2
|
pp_expr (state#pad 2 1) value.arg2
|
||||||
| EListComp {value; region} ->
|
| EListComp {value; region} ->
|
||||||
pp_loc_node state "List" region;
|
pp_loc_node state "EListComp" region;
|
||||||
if value.elements = None
|
if value.elements = None
|
||||||
then pp_node (state#pad 1 0) "<nil>"
|
then pp_node (state#pad 1 0) "<nil>"
|
||||||
else pp_injection pp_expr state value
|
else pp_injection pp_expr state value
|
||||||
@ -1134,13 +1141,13 @@ and pp_type_expr state = function
|
|||||||
pp_type_expr (state#pad len rank) in
|
pp_type_expr (state#pad len rank) in
|
||||||
let domain, _, range = value in
|
let domain, _, range = value in
|
||||||
List.iteri (apply 2) [domain; range]
|
List.iteri (apply 2) [domain; range]
|
||||||
| TPar {value={inside;_}; region} ->
|
| TPar {value={inside;_}; region} ->
|
||||||
pp_loc_node state "TPar" region;
|
pp_loc_node state "TPar" region;
|
||||||
pp_type_expr (state#pad 1 0) inside
|
pp_type_expr (state#pad 1 0) inside
|
||||||
| TVar v ->
|
| TVar v ->
|
||||||
pp_node state "TVar";
|
pp_node state "TVar";
|
||||||
pp_ident (state#pad 1 0) v
|
pp_ident (state#pad 1 0) v
|
||||||
| TString s ->
|
| TString s ->
|
||||||
pp_node state "TString";
|
pp_node state "TString";
|
||||||
pp_string (state#pad 1 0) s
|
pp_string (state#pad 1 0) s
|
||||||
|
|
||||||
|
|||||||
@ -27,5 +27,5 @@ val expr_to_string :
|
|||||||
|
|
||||||
(** {1 Pretty-printing of AST nodes} *)
|
(** {1 Pretty-printing of AST nodes} *)
|
||||||
|
|
||||||
val pp_ast : state -> AST.t -> unit
|
val pp_cst : state -> AST.t -> unit
|
||||||
val pp_expr : state -> AST.expr -> unit
|
val pp_expr : state -> AST.expr -> unit
|
||||||
|
|||||||
@ -22,7 +22,8 @@ module SubIO =
|
|||||||
ext : string;
|
ext : string;
|
||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : EvalOpt.command;
|
cmd : EvalOpt.command;
|
||||||
mono : bool
|
mono : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
let options : options =
|
let options : options =
|
||||||
@ -36,6 +37,7 @@ module SubIO =
|
|||||||
method mode = IO.options#mode
|
method mode = IO.options#mode
|
||||||
method cmd = IO.options#cmd
|
method cmd = IO.options#cmd
|
||||||
method mono = IO.options#mono
|
method mono = IO.options#mono
|
||||||
|
method pretty = IO.options#pretty
|
||||||
end
|
end
|
||||||
|
|
||||||
let make =
|
let make =
|
||||||
@ -48,6 +50,7 @@ module SubIO =
|
|||||||
~mode:options#mode
|
~mode:options#mode
|
||||||
~cmd:options#cmd
|
~cmd:options#cmd
|
||||||
~mono:options#mono
|
~mono:options#mono
|
||||||
|
~pretty:options#pretty
|
||||||
end
|
end
|
||||||
|
|
||||||
module Parser =
|
module Parser =
|
||||||
@ -67,14 +70,28 @@ module ParserLog =
|
|||||||
module Lexer = Lexer.Make (LexToken)
|
module Lexer = Lexer.Make (LexToken)
|
||||||
|
|
||||||
module Unit =
|
module Unit =
|
||||||
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
|
ParserUnit.Make (Lexer)(AST)(Parser)(Parser_msg)(ParserLog)(SubIO)
|
||||||
|
|
||||||
(* Main *)
|
(* Main *)
|
||||||
|
|
||||||
let wrap = function
|
let wrap = function
|
||||||
Stdlib.Ok _ -> flush_all ()
|
Stdlib.Ok ast ->
|
||||||
|
if IO.options#pretty then
|
||||||
|
begin
|
||||||
|
let doc = Pretty.print ast in
|
||||||
|
let width =
|
||||||
|
match Terminal_size.get_columns () with
|
||||||
|
None -> 60
|
||||||
|
| Some c -> c in
|
||||||
|
PPrint.ToChannel.pretty 1.0 width stdout doc;
|
||||||
|
print_newline ()
|
||||||
|
end;
|
||||||
|
flush_all ()
|
||||||
| Error msg ->
|
| Error msg ->
|
||||||
(flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)
|
begin
|
||||||
|
flush_all ();
|
||||||
|
Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value
|
||||||
|
end
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
match IO.options#input with
|
match IO.options#input with
|
||||||
|
|||||||
442
src/passes/01-parser/cameligo/Pretty.ml
Normal file
442
src/passes/01-parser/cameligo/Pretty.ml
Normal file
@ -0,0 +1,442 @@
|
|||||||
|
[@@@warning "-42"]
|
||||||
|
|
||||||
|
open AST
|
||||||
|
module Region = Simple_utils.Region
|
||||||
|
open! Region
|
||||||
|
open! PPrint
|
||||||
|
|
||||||
|
let pp_par printer {value; _} =
|
||||||
|
string "(" ^^ nest 1 (printer value.inside ^^ string ")")
|
||||||
|
|
||||||
|
let rec print ast =
|
||||||
|
let app decl = group (pp_declaration decl) in
|
||||||
|
let decl = Utils.nseq_to_list ast.decl in
|
||||||
|
separate_map (hardline ^^ hardline) app decl
|
||||||
|
|
||||||
|
and pp_declaration = function
|
||||||
|
Let decl -> pp_let_decl decl
|
||||||
|
| TypeDecl decl -> pp_type_decl decl
|
||||||
|
|
||||||
|
and pp_let_decl {value; _} =
|
||||||
|
let _, rec_opt, binding, attr = value in
|
||||||
|
let let_str =
|
||||||
|
match rec_opt with
|
||||||
|
None -> "let "
|
||||||
|
| Some _ -> "let rec " in
|
||||||
|
let binding = pp_let_binding binding
|
||||||
|
and attr = pp_attributes attr
|
||||||
|
in string let_str ^^ binding ^^ attr
|
||||||
|
|
||||||
|
and pp_attributes = function
|
||||||
|
[] -> empty
|
||||||
|
| attr ->
|
||||||
|
let make s = string "[@@" ^^ string s.value ^^ string "]" in
|
||||||
|
group (nest 2 (break 1 ^^ separate_map (break 0) make attr))
|
||||||
|
|
||||||
|
and pp_ident {value; _} = string value
|
||||||
|
|
||||||
|
and pp_string s = string "\"" ^^ pp_ident s ^^ string "\""
|
||||||
|
|
||||||
|
and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
|
||||||
|
|
||||||
|
and pp_let_binding (binding : let_binding) =
|
||||||
|
let {binders; lhs_type; let_rhs; _} = binding in
|
||||||
|
let head, tail = binders in
|
||||||
|
let patterns =
|
||||||
|
group (nest 2 (separate_map (break 1) pp_pattern (head::tail))) in
|
||||||
|
let lhs =
|
||||||
|
patterns ^^
|
||||||
|
match lhs_type with
|
||||||
|
None -> empty
|
||||||
|
| Some (_,e) -> group (break 1 ^^ string ": " ^^ pp_type_expr e)
|
||||||
|
in prefix 2 1 (lhs ^^ string " =") (pp_expr let_rhs)
|
||||||
|
|
||||||
|
and pp_pattern = function
|
||||||
|
PConstr p -> pp_pconstr p
|
||||||
|
| PUnit _ -> string "()"
|
||||||
|
| PFalse _ -> string "false"
|
||||||
|
| PTrue _ -> string "true"
|
||||||
|
| PVar v -> pp_ident v
|
||||||
|
| PInt i -> pp_int i
|
||||||
|
| PNat n -> pp_nat n
|
||||||
|
| PBytes b -> pp_bytes b
|
||||||
|
| PString s -> pp_string s
|
||||||
|
| PVerbatim s -> pp_verbatim s
|
||||||
|
| PWild _ -> string "_"
|
||||||
|
| PList l -> pp_plist l
|
||||||
|
| PTuple t -> pp_ptuple t
|
||||||
|
| PPar p -> pp_ppar p
|
||||||
|
| PRecord r -> pp_precord r
|
||||||
|
| PTyped t -> pp_ptyped t
|
||||||
|
|
||||||
|
and pp_pconstr = function
|
||||||
|
PNone _ -> string "None"
|
||||||
|
| PSomeApp p -> pp_patt_some p
|
||||||
|
| PConstrApp a -> pp_pconstr_app a
|
||||||
|
|
||||||
|
and pp_pconstr_app {value; _} =
|
||||||
|
match value with
|
||||||
|
constr, None -> pp_ident constr
|
||||||
|
| constr, Some pat ->
|
||||||
|
prefix 4 1 (pp_ident constr) (pp_pattern pat)
|
||||||
|
|
||||||
|
and pp_patt_some {value; _} =
|
||||||
|
prefix 4 1 (string "Some") (pp_pattern (snd value))
|
||||||
|
|
||||||
|
and pp_int {value; _} =
|
||||||
|
string (Z.to_string (snd value))
|
||||||
|
|
||||||
|
and pp_nat {value; _} =
|
||||||
|
string (Z.to_string (snd value) ^ "n")
|
||||||
|
|
||||||
|
and pp_bytes {value; _} =
|
||||||
|
string ("0x" ^ Hex.show (snd value))
|
||||||
|
|
||||||
|
and pp_ppar p = pp_par pp_pattern p
|
||||||
|
|
||||||
|
and pp_plist = function
|
||||||
|
PListComp cmp -> pp_list_comp cmp
|
||||||
|
| PCons cons -> pp_pcons cons
|
||||||
|
|
||||||
|
and pp_list_comp e = group (pp_injection pp_pattern e)
|
||||||
|
|
||||||
|
and pp_pcons {value; _} =
|
||||||
|
let patt1, _, patt2 = value in
|
||||||
|
prefix 2 1 (pp_pattern patt1 ^^ string " ::") (pp_pattern patt2)
|
||||||
|
|
||||||
|
and pp_ptuple {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [p] -> group (break 1 ^^ pp_pattern p)
|
||||||
|
| p::items ->
|
||||||
|
group (break 1 ^^ pp_pattern p ^^ string ",") ^^ app items
|
||||||
|
in if tail = []
|
||||||
|
then pp_pattern head
|
||||||
|
else pp_pattern head ^^ string "," ^^ app (List.map snd tail)
|
||||||
|
|
||||||
|
and pp_precord fields = pp_ne_injection pp_field_pattern fields
|
||||||
|
|
||||||
|
and pp_field_pattern {value; _} =
|
||||||
|
let {field_name; pattern; _} = value in
|
||||||
|
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_pattern pattern)
|
||||||
|
|
||||||
|
and pp_ptyped {value; _} =
|
||||||
|
let {pattern; type_expr; _} = value in
|
||||||
|
group (pp_pattern pattern ^^ string " :" ^/^ pp_type_expr type_expr)
|
||||||
|
|
||||||
|
and pp_type_decl decl =
|
||||||
|
let {name; type_expr; _} = decl.value in
|
||||||
|
let padding = match type_expr with TSum _ -> 0 | _ -> 2 in
|
||||||
|
string "type " ^^ string name.value ^^ string " ="
|
||||||
|
^^ group (nest padding (break 1 ^^ pp_type_expr type_expr))
|
||||||
|
|
||||||
|
and pp_expr = function
|
||||||
|
ECase e -> pp_case_expr e
|
||||||
|
| ECond e -> group (pp_cond_expr e)
|
||||||
|
| EAnnot e -> pp_annot_expr e
|
||||||
|
| ELogic e -> group (pp_logic_expr e)
|
||||||
|
| EArith e -> group (pp_arith_expr e)
|
||||||
|
| EString e -> pp_string_expr e
|
||||||
|
| EList e -> group (pp_list_expr e)
|
||||||
|
| EConstr e -> pp_constr_expr e
|
||||||
|
| ERecord e -> pp_record_expr e
|
||||||
|
| EProj e -> pp_projection e
|
||||||
|
| EUpdate e -> pp_update e
|
||||||
|
| EVar v -> pp_ident v
|
||||||
|
| ECall e -> pp_call_expr e
|
||||||
|
| EBytes e -> pp_bytes e
|
||||||
|
| EUnit _ -> string "()"
|
||||||
|
| ETuple e -> pp_tuple_expr e
|
||||||
|
| EPar e -> pp_par_expr e
|
||||||
|
| ELetIn e -> pp_let_in e
|
||||||
|
| EFun e -> pp_fun e
|
||||||
|
| ESeq e -> pp_seq e
|
||||||
|
|
||||||
|
and pp_case_expr {value; _} =
|
||||||
|
let {expr; cases; _} = value in
|
||||||
|
group (string "match " ^^ nest 6 (pp_expr expr) ^/^ string "with")
|
||||||
|
^^ hardline ^^ pp_cases cases
|
||||||
|
|
||||||
|
and pp_cases {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let head = pp_clause head in
|
||||||
|
let head = if tail = [] then head else blank 2 ^^ head in
|
||||||
|
let rest = List.map snd tail in
|
||||||
|
let app clause = break 1 ^^ string "| " ^^ pp_clause clause
|
||||||
|
in head ^^ concat_map app rest
|
||||||
|
|
||||||
|
and pp_clause {value; _} =
|
||||||
|
let {pattern; rhs; _} = value in
|
||||||
|
pp_pattern pattern ^^ prefix 4 1 (string " ->") (pp_expr rhs)
|
||||||
|
|
||||||
|
and pp_cond_expr {value; _} =
|
||||||
|
let {test; ifso; kwd_else; ifnot; _} = value in
|
||||||
|
let test = string "if " ^^ group (nest 3 (pp_expr test))
|
||||||
|
and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso))
|
||||||
|
and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot))
|
||||||
|
in if kwd_else#is_ghost
|
||||||
|
then test ^/^ ifso
|
||||||
|
else test ^/^ ifso ^/^ ifnot
|
||||||
|
|
||||||
|
and pp_annot_expr {value; _} =
|
||||||
|
let expr, _, type_expr = value.inside in
|
||||||
|
group (string "(" ^^ nest 1 (pp_expr expr ^/^ string ": "
|
||||||
|
^^ pp_type_expr type_expr ^^ string ")"))
|
||||||
|
|
||||||
|
and pp_logic_expr = function
|
||||||
|
BoolExpr e -> pp_bool_expr e
|
||||||
|
| CompExpr e -> pp_comp_expr e
|
||||||
|
|
||||||
|
and pp_bool_expr = function
|
||||||
|
Or e -> pp_bin_op "||" e
|
||||||
|
| And e -> pp_bin_op "&&" e
|
||||||
|
| Not e -> pp_un_op "not" e
|
||||||
|
| True _ -> string "true"
|
||||||
|
| False _ -> string "false"
|
||||||
|
|
||||||
|
and pp_bin_op op {value; _} =
|
||||||
|
let {arg1; arg2; _} = value
|
||||||
|
and length = String.length op + 1 in
|
||||||
|
pp_expr arg1 ^/^ string (op ^ " ") ^^ nest length (pp_expr arg2)
|
||||||
|
|
||||||
|
and pp_un_op op {value; _} =
|
||||||
|
string (op ^ " ") ^^ pp_expr value.arg
|
||||||
|
|
||||||
|
and pp_comp_expr = function
|
||||||
|
Lt e -> pp_bin_op "<" e
|
||||||
|
| Leq e -> pp_bin_op "<=" e
|
||||||
|
| Gt e -> pp_bin_op ">" e
|
||||||
|
| Geq e -> pp_bin_op ">=" e
|
||||||
|
| Equal e -> pp_bin_op "=" e
|
||||||
|
| Neq e -> pp_bin_op "<>" e
|
||||||
|
|
||||||
|
and pp_arith_expr = function
|
||||||
|
Add e -> pp_bin_op "+" e
|
||||||
|
| Sub e -> pp_bin_op "-" e
|
||||||
|
| Mult e -> pp_bin_op "*" e
|
||||||
|
| Div e -> pp_bin_op "/" e
|
||||||
|
| Mod e -> pp_bin_op "mod" e
|
||||||
|
| Neg e -> string "-" ^^ pp_expr e.value.arg
|
||||||
|
| Int e -> pp_int e
|
||||||
|
| Nat e -> pp_nat e
|
||||||
|
| Mutez e -> pp_mutez e
|
||||||
|
|
||||||
|
and pp_mutez {value; _} =
|
||||||
|
Z.to_string (snd value) ^ "mutez" |> string
|
||||||
|
|
||||||
|
and pp_string_expr = function
|
||||||
|
Cat e -> pp_bin_op "^" e
|
||||||
|
| String e -> pp_string e
|
||||||
|
| Verbatim e -> pp_verbatim e
|
||||||
|
|
||||||
|
and pp_list_expr = function
|
||||||
|
ECons e -> pp_bin_op "::" e
|
||||||
|
| EListComp e -> group (pp_injection pp_expr e)
|
||||||
|
|
||||||
|
and pp_injection :
|
||||||
|
'a.('a -> document) -> 'a injection reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
let {compound; elements; _} = value in
|
||||||
|
let sep = string ";" ^^ break 1 in
|
||||||
|
let elements = Utils.sepseq_to_list elements in
|
||||||
|
let elements = separate_map sep printer elements in
|
||||||
|
match pp_compound compound with
|
||||||
|
None -> elements
|
||||||
|
| Some (opening, closing) ->
|
||||||
|
string opening ^^ nest 1 elements ^^ string closing
|
||||||
|
|
||||||
|
and pp_compound = function
|
||||||
|
BeginEnd (start, _) ->
|
||||||
|
if start#is_ghost then None else Some ("begin","end")
|
||||||
|
| Braces (start, _) ->
|
||||||
|
if start#is_ghost then None else Some ("{","}")
|
||||||
|
| Brackets (start, _) ->
|
||||||
|
if start#is_ghost then None else Some ("[","]")
|
||||||
|
|
||||||
|
and pp_constr_expr = function
|
||||||
|
ENone _ -> string "None"
|
||||||
|
| ESomeApp a -> pp_some a
|
||||||
|
| EConstrApp a -> pp_constr_app a
|
||||||
|
|
||||||
|
and pp_some {value=_, e; _} =
|
||||||
|
prefix 4 1 (string "Some") (pp_expr e)
|
||||||
|
|
||||||
|
and pp_constr_app {value; _} =
|
||||||
|
let constr, arg = value in
|
||||||
|
let constr = string constr.value in
|
||||||
|
match arg with
|
||||||
|
None -> constr
|
||||||
|
| Some e -> prefix 2 1 constr (pp_expr e)
|
||||||
|
|
||||||
|
and pp_record_expr ne_inj = group (pp_ne_injection pp_field_assign ne_inj)
|
||||||
|
|
||||||
|
and pp_field_assign {value; _} =
|
||||||
|
let {field_name; field_expr; _} = value in
|
||||||
|
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_expr field_expr)
|
||||||
|
|
||||||
|
and pp_ne_injection :
|
||||||
|
'a.('a -> document) -> 'a ne_injection reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
let {compound; ne_elements; _} = value in
|
||||||
|
let elements = pp_nsepseq ";" printer ne_elements in
|
||||||
|
match pp_compound compound with
|
||||||
|
None -> elements
|
||||||
|
| Some (opening, closing) ->
|
||||||
|
string opening ^^ nest 1 elements ^^ string closing
|
||||||
|
|
||||||
|
and pp_nsepseq :
|
||||||
|
'a.string -> ('a -> document) -> ('a, t) Utils.nsepseq -> document =
|
||||||
|
fun sep printer elements ->
|
||||||
|
let elems = Utils.nsepseq_to_list elements
|
||||||
|
and sep = string sep ^^ break 1
|
||||||
|
in separate_map sep printer elems
|
||||||
|
|
||||||
|
and pp_nseq : 'a.('a -> document) -> 'a Utils.nseq -> document =
|
||||||
|
fun printer (head, tail) -> separate_map (break 1) printer (head::tail)
|
||||||
|
|
||||||
|
and pp_projection {value; _} =
|
||||||
|
let {struct_name; field_path; _} = value in
|
||||||
|
let fields = Utils.nsepseq_to_list field_path
|
||||||
|
and sep = string "." ^^ break 0 in
|
||||||
|
let fields = separate_map sep pp_selection fields in
|
||||||
|
group (pp_ident struct_name ^^ string "." ^^ break 0 ^^ fields)
|
||||||
|
|
||||||
|
and pp_selection = function
|
||||||
|
FieldName v -> string v.value
|
||||||
|
| Component cmp -> cmp.value |> snd |> Z.to_string |> string
|
||||||
|
|
||||||
|
and pp_update {value; _} =
|
||||||
|
let {record; updates; _} = value in
|
||||||
|
let updates = group (pp_ne_injection pp_field_path_assign updates)
|
||||||
|
and record = pp_path record in
|
||||||
|
string "{" ^^ record ^^ string " with"
|
||||||
|
^^ nest 2 (break 1 ^^ updates ^^ string "}")
|
||||||
|
|
||||||
|
and pp_field_path_assign {value; _} =
|
||||||
|
let {field_path; field_expr; _} = value in
|
||||||
|
let path = pp_path field_path in
|
||||||
|
prefix 2 1 (path ^^ string " =") (pp_expr field_expr)
|
||||||
|
|
||||||
|
and pp_path = function
|
||||||
|
Name v -> pp_ident v
|
||||||
|
| Path p -> pp_projection p
|
||||||
|
|
||||||
|
and pp_call_expr {value; _} =
|
||||||
|
let lambda, arguments = value in
|
||||||
|
let arguments = pp_nseq pp_expr arguments in
|
||||||
|
group (pp_expr lambda ^^ nest 2 (break 1 ^^ arguments))
|
||||||
|
|
||||||
|
and pp_tuple_expr {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_expr e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_expr e ^^ string ",") ^^ app items
|
||||||
|
in if tail = []
|
||||||
|
then pp_expr head
|
||||||
|
else pp_expr head ^^ string "," ^^ app (List.map snd tail)
|
||||||
|
|
||||||
|
and pp_par_expr e = pp_par pp_expr e
|
||||||
|
|
||||||
|
and pp_let_in {value; _} =
|
||||||
|
let {binding; kwd_rec; body; attributes; _} = value in
|
||||||
|
let let_str =
|
||||||
|
match kwd_rec with
|
||||||
|
None -> "let "
|
||||||
|
| Some _ -> "let rec " in
|
||||||
|
let binding = pp_let_binding binding
|
||||||
|
and attr = pp_attributes attributes
|
||||||
|
in string let_str ^^ binding ^^ attr
|
||||||
|
^^ hardline ^^ group (string "in " ^^ nest 3 (pp_expr body))
|
||||||
|
|
||||||
|
and pp_fun {value; _} =
|
||||||
|
let {binders; lhs_type; body; _} = value in
|
||||||
|
let binders = pp_nseq pp_pattern binders
|
||||||
|
and annot =
|
||||||
|
match lhs_type with
|
||||||
|
None -> empty
|
||||||
|
| Some (_,e) ->
|
||||||
|
group (break 1 ^^ string ": " ^^ nest 2 (break 1 ^^ pp_type_expr e))
|
||||||
|
in group (string "fun " ^^ nest 4 binders ^^ annot
|
||||||
|
^^ string " ->" ^^ nest 2 (break 1 ^^ pp_expr body))
|
||||||
|
|
||||||
|
and pp_seq {value; _} =
|
||||||
|
let {compound; elements; _} = value in
|
||||||
|
let sep = string ";" ^^ hardline in
|
||||||
|
let elements = Utils.sepseq_to_list elements in
|
||||||
|
let elements = separate_map sep pp_expr elements in
|
||||||
|
match pp_compound compound with
|
||||||
|
None -> elements
|
||||||
|
| Some (opening, closing) ->
|
||||||
|
string opening
|
||||||
|
^^ nest 2 (hardline ^^ elements) ^^ hardline
|
||||||
|
^^ string closing
|
||||||
|
|
||||||
|
and pp_type_expr = function
|
||||||
|
TProd t -> pp_cartesian t
|
||||||
|
| TSum t -> pp_variants t
|
||||||
|
| TRecord t -> pp_fields t
|
||||||
|
| TApp t -> pp_type_app t
|
||||||
|
| TFun t -> pp_fun_type t
|
||||||
|
| TPar t -> pp_type_par t
|
||||||
|
| TVar t -> pp_ident t
|
||||||
|
| TString s -> pp_string s
|
||||||
|
|
||||||
|
and pp_cartesian {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_type_expr e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_type_expr e ^^ string " *") ^^ app items
|
||||||
|
in pp_type_expr head ^^ string " *" ^^ app (List.map snd tail)
|
||||||
|
|
||||||
|
and pp_variants {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let head = pp_variant head in
|
||||||
|
let head = if tail = [] then head else ifflat head (blank 2 ^^ head) in
|
||||||
|
let rest = List.map snd tail in
|
||||||
|
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
|
||||||
|
in head ^^ concat_map app rest
|
||||||
|
|
||||||
|
and pp_variant {value; _} =
|
||||||
|
let {constr; arg} = value in
|
||||||
|
match arg with
|
||||||
|
None -> pp_ident constr
|
||||||
|
| Some (_, e) ->
|
||||||
|
prefix 4 1 (pp_ident constr ^^ string " of") (pp_type_expr e)
|
||||||
|
|
||||||
|
and pp_fields fields = group (pp_ne_injection pp_field_decl fields)
|
||||||
|
|
||||||
|
and pp_field_decl {value; _} =
|
||||||
|
let {field_name; field_type; _} = value in
|
||||||
|
let name = pp_ident field_name in
|
||||||
|
let t_expr = pp_type_expr field_type
|
||||||
|
in prefix 2 1 (name ^^ string " :") t_expr
|
||||||
|
|
||||||
|
and pp_type_app {value = ctor, tuple; _} =
|
||||||
|
pp_type_tuple tuple ^^ group (nest 2 (break 1 ^^ pp_type_constr ctor))
|
||||||
|
|
||||||
|
and pp_type_tuple {value; _} =
|
||||||
|
let head, tail = value.inside in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_type_expr e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items in
|
||||||
|
if tail = []
|
||||||
|
then pp_type_expr head
|
||||||
|
else
|
||||||
|
let components =
|
||||||
|
pp_type_expr head ^^ string "," ^^ app (List.map snd tail)
|
||||||
|
in string "(" ^^ nest 1 (components ^^ string ")")
|
||||||
|
|
||||||
|
and pp_type_constr ctor = string ctor.value
|
||||||
|
|
||||||
|
and pp_fun_type {value; _} =
|
||||||
|
let lhs, _, rhs = value in
|
||||||
|
group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
|
||||||
|
|
||||||
|
and pp_type_par t = pp_par pp_type_expr t
|
||||||
@ -1,29 +1,54 @@
|
|||||||
type q = {a: int; b: {c: string}}
|
let patch_ (m : foobar) : foobar = Map.literal [(0, 5); (1, 6); (2, 7)]
|
||||||
type r = int list
|
|
||||||
type s = (int, address) map
|
|
||||||
type t = int
|
|
||||||
type u = {a: int; b: t * char}
|
|
||||||
type v = int * (string * address)
|
|
||||||
type w = timestamp * nat -> (string, address) map
|
|
||||||
type x = A | B of t * int | C of int -> (string -> int)
|
|
||||||
|
|
||||||
let x = 4
|
let (greet_num : int), (greeting : string), one_more_component =
|
||||||
let y : t = (if true then -3 + f x x else 0) - 1
|
different_types of_many_things + ffffff 124312
|
||||||
let f (x: int) y = (x : int)
|
|
||||||
|
type storage = int * int
|
||||||
|
|
||||||
|
let main (n : int * storage)
|
||||||
|
: operation list * storage =
|
||||||
|
let x : int * int =
|
||||||
|
let x : int = 7
|
||||||
|
in x + n.0.asdasdasd.4, n.1.0 + n.1.1.1111111.aaaa.ddddddd.eeeeeee
|
||||||
|
in ([] : operation list), x
|
||||||
|
|
||||||
|
let y : t =
|
||||||
|
if true then ffffffffff (-30000 * 10000 - 100000 + f x x y y y y - ((x / 4000) * -5), 103+5) else (10000 + 100000) / 10000000000
|
||||||
|
type return = operation list * (storage * fsdgsdgf * sdfsdfsdf * ssdf)
|
||||||
|
let xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx =
|
||||||
|
ttttttttttttt <= (aaaaaaaaaaaaaaaaaaaaaaaa - bbbbbbbbbbbbbbbbbbbb)
|
||||||
|
let x = tttt * ((fffffffff /55555555) - 3455 * 5135664) - 134 * (-4)
|
||||||
|
type x = AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA | B
|
||||||
|
let or_true (b : bool) : bool = bbbbbbbbbbbbb || true && cccccccccccccccccc
|
||||||
|
type x = A | B of t * int | CCC of int -> (string -> int) -> (string, address, timestamp, int) map
|
||||||
|
let c = CCCCCCCCCCCC (aaaaa, BBBBBBBBB aaaaaaaaaaaa)
|
||||||
|
let e = Some (a, B b)
|
||||||
|
type w = timestamp * nat -> (string, address) map -> t
|
||||||
|
type v = int * (a_long_type_name * (another_long_one * address * and_so_on) * more_of_a_very_long_type)
|
||||||
|
|
||||||
|
type r = int list
|
||||||
|
type t = int
|
||||||
|
type s = (int,address,a_long_type_name, more_of_a_very_long_type * foo_bar_baz) t
|
||||||
|
type q = {a: int; b: {c: string}; c: timestamp * (address, string) big_map -> longer_type_name}
|
||||||
|
type u = {a: int; b: t * char; c: int * (a_long_type_name * (another_long_one * address * and_so_on) * more_of_a_very_long_type)}
|
||||||
|
let f xxxxxxxxxxxxxxxxxxxxxx yyyyyyyyyyyyyyyyyyyyy zzzzzzzzzzz ttttt : type_annotation_which_is_very_verbose = this_too_short_a_variable
|
||||||
|
let g : type_annotation_which_is_very_verbose = fun x y z t -> this_too_short_a_variable [@@inline]
|
||||||
|
let yyyyyyyyyyy : a_very_long_and_specific_type_of_string = "foo and bar"
|
||||||
|
let rec x (_, (yyyyyyyyyyyyyyyy: tttttttttttttttttttttttt), very_long_variable_to_trigger_a_break) = 4
|
||||||
|
let y {xxxxxxxxx=(_,yyyyyyyy,more_components,another_one); zzzzzzz=34444444; ttttttt=3n} = xxxxxx
|
||||||
let z : (t) = y
|
let z : (t) = y
|
||||||
let w =
|
let f (xxxxxxxxxxx: tttttttttttttt) y = (xxxxxxxxxxxx : tttttttttttttttttt)
|
||||||
match f 3 with
|
|
||||||
None -> []
|
|
||||||
| Some (1::[2;3]) -> [4;5]::[]
|
|
||||||
let n : nat = 0n
|
let n : nat = 0n
|
||||||
let a = A
|
let a = A
|
||||||
let b = B a
|
let b = B a
|
||||||
let c = C (a, B (a))
|
|
||||||
let d = None
|
let d = None
|
||||||
let e = Some (a, B b)
|
let z = let v = "hello" ^ "world" ^ "!" in v
|
||||||
let z = z.1.2
|
let r = { field = 0; another = 11111111111111111; and_another_one = "dddddd"}
|
||||||
let v = "hello" ^ "world" ^ "!"
|
let r = { r with field = 42; another = 11111111111111111; and_another_one = "dddddddddddddddddddddd"}
|
||||||
let w = Map.literal [(1,"1"); (2,"2")]
|
let w = Map.literal [(11111111111111,"11111111111111"); (22222222222,"22222222222222222"); (1234567890,"1234567890")]
|
||||||
|
let z = z.1.a.0.4.c.6.7.8.9.cccccccccccc.ccccccccccccccccc.ddddddddddddddddd.0.1.2
|
||||||
let r = { field = 0}
|
let y : t = (if true then -30000000000000 + f x x y y y y else 10000000000000000000) - 1
|
||||||
let r = { r with field = 42}
|
let w =
|
||||||
|
match f 3 with
|
||||||
|
None -> []
|
||||||
|
| Some (1::[2;3;4;5;6]) -> [4;5]::[]
|
||||||
|
|||||||
@ -15,8 +15,10 @@
|
|||||||
(name parser_cameligo)
|
(name parser_cameligo)
|
||||||
(public_name ligo.parser.cameligo)
|
(public_name ligo.parser.cameligo)
|
||||||
(modules
|
(modules
|
||||||
Scoping AST cameligo Parser ParserLog LexToken ParErr)
|
Scoping AST cameligo Parser ParserLog LexToken ParErr Pretty)
|
||||||
(libraries
|
(libraries
|
||||||
|
pprint
|
||||||
|
terminal_size
|
||||||
menhirLib
|
menhirLib
|
||||||
parser_shared
|
parser_shared
|
||||||
str
|
str
|
||||||
@ -26,8 +28,8 @@
|
|||||||
(pps bisect_ppx --conditional))
|
(pps bisect_ppx --conditional))
|
||||||
(flags (:standard -open Parser_shared -open Simple_utils)))
|
(flags (:standard -open Parser_shared -open Simple_utils)))
|
||||||
|
|
||||||
;; Build of the unlexer (for covering the
|
;; Build of the unlexer (for covering the error states of the LR
|
||||||
;; error states of the LR automaton)
|
;; automaton)
|
||||||
|
|
||||||
(executable
|
(executable
|
||||||
(name Unlexer)
|
(name Unlexer)
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@ -19,7 +19,8 @@ module SubIO =
|
|||||||
ext : string; (* ".ligo" *)
|
ext : string; (* ".ligo" *)
|
||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : EvalOpt.command;
|
cmd : EvalOpt.command;
|
||||||
mono : bool
|
mono : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
let options : options =
|
let options : options =
|
||||||
@ -34,6 +35,7 @@ module SubIO =
|
|||||||
method mode = `Point
|
method mode = `Point
|
||||||
method cmd = EvalOpt.Quiet
|
method cmd = EvalOpt.Quiet
|
||||||
method mono = false
|
method mono = false
|
||||||
|
method pretty = false
|
||||||
end
|
end
|
||||||
|
|
||||||
let make =
|
let make =
|
||||||
@ -46,6 +48,7 @@ module SubIO =
|
|||||||
~mode:options#mode
|
~mode:options#mode
|
||||||
~cmd:options#cmd
|
~cmd:options#cmd
|
||||||
~mono:options#mono
|
~mono:options#mono
|
||||||
|
~pretty:options#pretty
|
||||||
end
|
end
|
||||||
|
|
||||||
module Parser =
|
module Parser =
|
||||||
|
|||||||
@ -21,5 +21,3 @@ $HOME/git/OCaml-build/Makefile
|
|||||||
../shared/ParserUnit.mli
|
../shared/ParserUnit.mli
|
||||||
../shared/ParserUnit.ml
|
../shared/ParserUnit.ml
|
||||||
../shared/LexerLib.ml
|
../shared/LexerLib.ml
|
||||||
|
|
||||||
$HOME/git/ligo/_build/default/src/passes/1-parser/pascaligo/ParErr.ml
|
|
||||||
|
|||||||
@ -109,6 +109,7 @@ type eof = Region.t
|
|||||||
type variable = string reg
|
type variable = string reg
|
||||||
type fun_name = string reg
|
type fun_name = string reg
|
||||||
type type_name = string reg
|
type type_name = string reg
|
||||||
|
type type_constr = string reg
|
||||||
type field_name = string reg
|
type field_name = string reg
|
||||||
type map_name = string reg
|
type map_name = string reg
|
||||||
type set_name = string reg
|
type set_name = string reg
|
||||||
@ -181,11 +182,11 @@ and type_expr =
|
|||||||
TProd of cartesian
|
TProd of cartesian
|
||||||
| TSum of (variant reg, vbar) nsepseq reg
|
| TSum of (variant reg, vbar) nsepseq reg
|
||||||
| TRecord of field_decl reg ne_injection reg
|
| TRecord of field_decl reg ne_injection reg
|
||||||
| TApp of (type_name * type_tuple) reg
|
| TApp of (type_constr * type_tuple) reg
|
||||||
| TFun of (type_expr * arrow * type_expr) reg
|
| TFun of (type_expr * arrow * type_expr) reg
|
||||||
| TPar of type_expr par reg
|
| TPar of type_expr par reg
|
||||||
| TVar of variable
|
| TVar of variable
|
||||||
| TStringLiteral of Lexer.lexeme reg
|
| TString of Lexer.lexeme reg
|
||||||
|
|
||||||
and cartesian = (type_expr, times) nsepseq reg
|
and cartesian = (type_expr, times) nsepseq reg
|
||||||
|
|
||||||
@ -205,7 +206,6 @@ and type_tuple = (type_expr, comma) nsepseq par reg
|
|||||||
(* Function and procedure declarations *)
|
(* Function and procedure declarations *)
|
||||||
|
|
||||||
and fun_expr = {
|
and fun_expr = {
|
||||||
kwd_recursive: kwd_recursive option;
|
|
||||||
kwd_function : kwd_function;
|
kwd_function : kwd_function;
|
||||||
param : parameters;
|
param : parameters;
|
||||||
colon : colon;
|
colon : colon;
|
||||||
@ -215,7 +215,7 @@ and fun_expr = {
|
|||||||
}
|
}
|
||||||
|
|
||||||
and fun_decl = {
|
and fun_decl = {
|
||||||
kwd_recursive: kwd_recursive option;
|
kwd_recursive : kwd_recursive option;
|
||||||
kwd_function : kwd_function;
|
kwd_function : kwd_function;
|
||||||
fun_name : variable;
|
fun_name : variable;
|
||||||
param : parameters;
|
param : parameters;
|
||||||
@ -249,19 +249,14 @@ and param_var = {
|
|||||||
}
|
}
|
||||||
|
|
||||||
and block = {
|
and block = {
|
||||||
opening : block_opening;
|
enclosing : block_enclosing;
|
||||||
statements : statements;
|
statements : statements;
|
||||||
terminator : semi option;
|
terminator : semi option
|
||||||
closing : block_closing
|
|
||||||
}
|
}
|
||||||
|
|
||||||
and block_opening =
|
and block_enclosing =
|
||||||
Block of kwd_block * lbrace
|
Block of kwd_block * lbrace * rbrace
|
||||||
| Begin of kwd_begin
|
| BeginEnd of kwd_begin * kwd_end
|
||||||
|
|
||||||
and block_closing =
|
|
||||||
Block of rbrace
|
|
||||||
| End of kwd_end
|
|
||||||
|
|
||||||
and statements = (statement, semi) nsepseq
|
and statements = (statement, semi) nsepseq
|
||||||
|
|
||||||
@ -378,10 +373,10 @@ and set_membership = {
|
|||||||
and 'a case = {
|
and 'a case = {
|
||||||
kwd_case : kwd_case;
|
kwd_case : kwd_case;
|
||||||
expr : expr;
|
expr : expr;
|
||||||
opening : opening;
|
kwd_of : kwd_of;
|
||||||
|
enclosing : enclosing;
|
||||||
lead_vbar : vbar option;
|
lead_vbar : vbar option;
|
||||||
cases : ('a case_clause reg, vbar) nsepseq reg;
|
cases : ('a case_clause reg, vbar) nsepseq reg
|
||||||
closing : closing
|
|
||||||
}
|
}
|
||||||
|
|
||||||
and 'a case_clause = {
|
and 'a case_clause = {
|
||||||
@ -421,8 +416,7 @@ and for_int = {
|
|||||||
assign : var_assign reg;
|
assign : var_assign reg;
|
||||||
kwd_to : kwd_to;
|
kwd_to : kwd_to;
|
||||||
bound : expr;
|
bound : expr;
|
||||||
kwd_step : kwd_step option;
|
step : (kwd_step * expr) option;
|
||||||
step : expr option;
|
|
||||||
block : block reg
|
block : block reg
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -452,7 +446,7 @@ and collection =
|
|||||||
and expr =
|
and expr =
|
||||||
ECase of expr case reg
|
ECase of expr case reg
|
||||||
| ECond of cond_expr reg
|
| ECond of cond_expr reg
|
||||||
| EAnnot of annot_expr reg
|
| EAnnot of annot_expr par reg
|
||||||
| ELogic of logic_expr
|
| ELogic of logic_expr
|
||||||
| EArith of arith_expr
|
| EArith of arith_expr
|
||||||
| EString of string_expr
|
| EString of string_expr
|
||||||
@ -471,34 +465,12 @@ and expr =
|
|||||||
| EPar of expr par reg
|
| EPar of expr par reg
|
||||||
| EFun of fun_expr reg
|
| EFun of fun_expr reg
|
||||||
|
|
||||||
and annot_expr = (expr * type_expr)
|
and annot_expr = expr * colon * type_expr
|
||||||
|
|
||||||
and set_expr =
|
and set_expr =
|
||||||
SetInj of expr injection reg
|
SetInj of expr injection reg
|
||||||
| SetMem of set_membership reg
|
| SetMem of set_membership reg
|
||||||
|
|
||||||
and 'a injection = {
|
|
||||||
opening : opening;
|
|
||||||
elements : ('a, semi) sepseq;
|
|
||||||
terminator : semi option;
|
|
||||||
closing : closing
|
|
||||||
}
|
|
||||||
|
|
||||||
and 'a ne_injection = {
|
|
||||||
opening : opening;
|
|
||||||
ne_elements : ('a, semi) nsepseq;
|
|
||||||
terminator : semi option;
|
|
||||||
closing : closing
|
|
||||||
}
|
|
||||||
|
|
||||||
and opening =
|
|
||||||
Kwd of keyword
|
|
||||||
| KwdBracket of keyword * lbracket
|
|
||||||
|
|
||||||
and closing =
|
|
||||||
End of kwd_end
|
|
||||||
| RBracket of rbracket
|
|
||||||
|
|
||||||
and map_expr =
|
and map_expr =
|
||||||
MapLookUp of map_lookup reg
|
MapLookUp of map_lookup reg
|
||||||
| MapInj of binding reg injection reg
|
| MapInj of binding reg injection reg
|
||||||
@ -569,13 +541,13 @@ and constr_expr =
|
|||||||
| NoneExpr of c_None
|
| NoneExpr of c_None
|
||||||
| ConstrApp of (constr * arguments option) reg
|
| ConstrApp of (constr * arguments option) reg
|
||||||
|
|
||||||
and field_assign = {
|
and field_assignment = {
|
||||||
field_name : field_name;
|
field_name : field_name;
|
||||||
equal : equal;
|
assignment : equal;
|
||||||
field_expr : expr
|
field_expr : expr
|
||||||
}
|
}
|
||||||
|
|
||||||
and record = field_assign reg ne_injection
|
and record = field_assignment reg ne_injection
|
||||||
|
|
||||||
and projection = {
|
and projection = {
|
||||||
struct_name : variable;
|
struct_name : variable;
|
||||||
@ -586,12 +558,12 @@ and projection = {
|
|||||||
and update = {
|
and update = {
|
||||||
record : path;
|
record : path;
|
||||||
kwd_with : kwd_with;
|
kwd_with : kwd_with;
|
||||||
updates : field_path_assign reg ne_injection reg
|
updates : field_path_assignment reg ne_injection reg
|
||||||
}
|
}
|
||||||
|
|
||||||
and field_path_assign = {
|
and field_path_assignment = {
|
||||||
field_path : (field_name, dot) nsepseq;
|
field_path : path;
|
||||||
equal : equal;
|
assignment : equal;
|
||||||
field_expr : expr
|
field_expr : expr
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -605,6 +577,38 @@ and fun_call = (expr * arguments) reg
|
|||||||
|
|
||||||
and arguments = tuple_expr
|
and arguments = tuple_expr
|
||||||
|
|
||||||
|
(* Injections *)
|
||||||
|
|
||||||
|
and 'a injection = {
|
||||||
|
kind : injection_kwd;
|
||||||
|
enclosing : enclosing;
|
||||||
|
elements : ('a, semi) sepseq;
|
||||||
|
terminator : semi option
|
||||||
|
}
|
||||||
|
|
||||||
|
and injection_kwd =
|
||||||
|
InjSet of keyword
|
||||||
|
| InjMap of keyword
|
||||||
|
| InjBigMap of keyword
|
||||||
|
| InjList of keyword
|
||||||
|
|
||||||
|
and enclosing =
|
||||||
|
Brackets of lbracket * rbracket
|
||||||
|
| End of kwd_end
|
||||||
|
|
||||||
|
and 'a ne_injection = {
|
||||||
|
kind : ne_injection_kwd;
|
||||||
|
enclosing : enclosing;
|
||||||
|
ne_elements : ('a, semi) nsepseq;
|
||||||
|
terminator : semi option
|
||||||
|
}
|
||||||
|
|
||||||
|
and ne_injection_kwd =
|
||||||
|
NEInjAttr of keyword
|
||||||
|
| NEInjSet of keyword
|
||||||
|
| NEInjMap of keyword
|
||||||
|
| NEInjRecord of keyword
|
||||||
|
|
||||||
(* Patterns *)
|
(* Patterns *)
|
||||||
|
|
||||||
and pattern =
|
and pattern =
|
||||||
@ -635,7 +639,7 @@ and list_pattern =
|
|||||||
| PCons of (pattern, cons) nsepseq reg
|
| PCons of (pattern, cons) nsepseq reg
|
||||||
|
|
||||||
|
|
||||||
(* Projecting regions *)
|
(* PROJECTING REGIONS *)
|
||||||
|
|
||||||
let rec last to_region = function
|
let rec last to_region = function
|
||||||
[] -> Region.ghost
|
[] -> Region.ghost
|
||||||
@ -660,7 +664,7 @@ let type_expr_to_region = function
|
|||||||
| TApp {region; _}
|
| TApp {region; _}
|
||||||
| TFun {region; _}
|
| TFun {region; _}
|
||||||
| TPar {region; _}
|
| TPar {region; _}
|
||||||
| TStringLiteral {region; _}
|
| TString {region; _}
|
||||||
| TVar {region; _} -> region
|
| TVar {region; _} -> region
|
||||||
|
|
||||||
let rec expr_to_region = function
|
let rec expr_to_region = function
|
||||||
|
|||||||
@ -122,7 +122,8 @@ attr_decl:
|
|||||||
open_attr_decl ";"? { $1 }
|
open_attr_decl ";"? { $1 }
|
||||||
|
|
||||||
open_attr_decl:
|
open_attr_decl:
|
||||||
ne_injection("attributes","<string>") { $1 }
|
ne_injection("attributes","<string>") {
|
||||||
|
$1 (fun region -> NEInjAttr region) }
|
||||||
|
|
||||||
(* Type declarations *)
|
(* Type declarations *)
|
||||||
|
|
||||||
@ -161,7 +162,7 @@ cartesian:
|
|||||||
|
|
||||||
core_type:
|
core_type:
|
||||||
type_name { TVar $1 }
|
type_name { TVar $1 }
|
||||||
| "<string>" { TStringLiteral $1 }
|
| "<string>" { TString $1 }
|
||||||
| par(type_expr) { TPar $1 }
|
| par(type_expr) { TPar $1 }
|
||||||
| type_name type_tuple {
|
| type_name type_tuple {
|
||||||
let region = cover $1.region $2.region
|
let region = cover $1.region $2.region
|
||||||
@ -214,19 +215,19 @@ record_type:
|
|||||||
let () = Utils.nsepseq_to_list ne_elements
|
let () = Utils.nsepseq_to_list ne_elements
|
||||||
|> Scoping.check_fields in
|
|> Scoping.check_fields in
|
||||||
let region = cover $1 $3
|
let region = cover $1 $3
|
||||||
and value = {opening = Kwd $1;
|
and value = {kind = NEInjRecord $1;
|
||||||
|
enclosing = End $3;
|
||||||
ne_elements;
|
ne_elements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = End $3}
|
|
||||||
in TRecord {region; value}
|
in TRecord {region; value}
|
||||||
}
|
}
|
||||||
| "record" "[" sep_or_term_list(field_decl,";") "]" {
|
| "record" "[" sep_or_term_list(field_decl,";") "]" {
|
||||||
let ne_elements, terminator = $3 in
|
let ne_elements, terminator = $3 in
|
||||||
let region = cover $1 $4
|
let region = cover $1 $4
|
||||||
and value = {opening = KwdBracket ($1,$2);
|
and value = {kind = NEInjRecord $1;
|
||||||
|
enclosing = Brackets ($2,$4);
|
||||||
ne_elements;
|
ne_elements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = RBracket $4}
|
|
||||||
in TRecord {region; value} }
|
in TRecord {region; value} }
|
||||||
|
|
||||||
field_decl:
|
field_decl:
|
||||||
@ -238,16 +239,15 @@ field_decl:
|
|||||||
|
|
||||||
|
|
||||||
fun_expr:
|
fun_expr:
|
||||||
| ioption ("recursive") "function" parameters ":" type_expr "is" expr {
|
"function" parameters ":" type_expr "is" expr {
|
||||||
let stop = expr_to_region $7 in
|
let stop = expr_to_region $6 in
|
||||||
let region = cover $2 stop
|
let region = cover $1 stop
|
||||||
and value = {kwd_recursive= $1;
|
and value = {kwd_function = $1;
|
||||||
kwd_function = $2;
|
param = $2;
|
||||||
param = $3;
|
colon = $3;
|
||||||
colon = $4;
|
ret_type = $4;
|
||||||
ret_type = $5;
|
kwd_is = $5;
|
||||||
kwd_is = $6;
|
return = $6}
|
||||||
return = $7}
|
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
(* Function declarations *)
|
(* Function declarations *)
|
||||||
@ -271,7 +271,8 @@ open_fun_decl:
|
|||||||
attributes = None}
|
attributes = None}
|
||||||
in {region; value}
|
in {region; value}
|
||||||
}
|
}
|
||||||
| ioption ("recursive") "function" fun_name parameters ":" type_expr "is" expr {
|
| ioption ("recursive") "function" fun_name parameters ":" type_expr "is"
|
||||||
|
expr {
|
||||||
Scoping.check_reserved_name $3;
|
Scoping.check_reserved_name $3;
|
||||||
let stop = expr_to_region $8 in
|
let stop = expr_to_region $8 in
|
||||||
let region = cover $2 stop
|
let region = cover $2 stop
|
||||||
@ -326,19 +327,17 @@ block:
|
|||||||
"begin" sep_or_term_list(statement,";") "end" {
|
"begin" sep_or_term_list(statement,";") "end" {
|
||||||
let statements, terminator = $2 in
|
let statements, terminator = $2 in
|
||||||
let region = cover $1 $3
|
let region = cover $1 $3
|
||||||
and value = {opening = Begin $1;
|
and value = {enclosing = BeginEnd ($1,$3);
|
||||||
statements;
|
statements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = End $3}
|
|
||||||
in {region; value}
|
in {region; value}
|
||||||
}
|
}
|
||||||
| "block" "{" sep_or_term_list(statement,";") "}" {
|
| "block" "{" sep_or_term_list(statement,";") "}" {
|
||||||
let statements, terminator = $3 in
|
let statements, terminator = $3 in
|
||||||
let region = cover $1 $4
|
let region = cover $1 $4
|
||||||
and value = {opening = Block ($1,$2);
|
and value = {enclosing = Block ($1,$2,$4);
|
||||||
statements;
|
statements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = Block $4}
|
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
statement:
|
statement:
|
||||||
@ -404,8 +403,7 @@ instruction:
|
|||||||
set_remove:
|
set_remove:
|
||||||
"remove" expr "from" "set" path {
|
"remove" expr "from" "set" path {
|
||||||
let region = cover $1 (path_to_region $5) in
|
let region = cover $1 (path_to_region $5) in
|
||||||
let value = {
|
let value = {kwd_remove = $1;
|
||||||
kwd_remove = $1;
|
|
||||||
element = $2;
|
element = $2;
|
||||||
kwd_from = $3;
|
kwd_from = $3;
|
||||||
kwd_set = $4;
|
kwd_set = $4;
|
||||||
@ -415,8 +413,7 @@ set_remove:
|
|||||||
map_remove:
|
map_remove:
|
||||||
"remove" expr "from" "map" path {
|
"remove" expr "from" "map" path {
|
||||||
let region = cover $1 (path_to_region $5) in
|
let region = cover $1 (path_to_region $5) in
|
||||||
let value = {
|
let value = {kwd_remove = $1;
|
||||||
kwd_remove = $1;
|
|
||||||
key = $2;
|
key = $2;
|
||||||
kwd_from = $3;
|
kwd_from = $3;
|
||||||
kwd_map = $4;
|
kwd_map = $4;
|
||||||
@ -425,82 +422,83 @@ map_remove:
|
|||||||
|
|
||||||
set_patch:
|
set_patch:
|
||||||
"patch" path "with" ne_injection("set",expr) {
|
"patch" path "with" ne_injection("set",expr) {
|
||||||
let region = cover $1 $4.region in
|
let set_inj = $4 (fun region -> NEInjSet region) in
|
||||||
let value = {
|
let region = cover $1 set_inj.region in
|
||||||
kwd_patch = $1;
|
let value = {kwd_patch = $1;
|
||||||
path = $2;
|
path = $2;
|
||||||
kwd_with = $3;
|
kwd_with = $3;
|
||||||
set_inj = $4}
|
set_inj}
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
map_patch:
|
map_patch:
|
||||||
"patch" path "with" ne_injection("map",binding) {
|
"patch" path "with" ne_injection("map",binding) {
|
||||||
let region = cover $1 $4.region in
|
let map_inj = $4 (fun region -> NEInjMap region) in
|
||||||
let value = {
|
let region = cover $1 map_inj.region in
|
||||||
kwd_patch = $1;
|
let value = {kwd_patch = $1;
|
||||||
path = $2;
|
path = $2;
|
||||||
kwd_with = $3;
|
kwd_with = $3;
|
||||||
map_inj = $4}
|
map_inj}
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
injection(Kind,element):
|
injection(Kind,element):
|
||||||
Kind sep_or_term_list(element,";") "end" {
|
Kind sep_or_term_list(element,";") "end" {
|
||||||
|
fun mk_kwd ->
|
||||||
let elements, terminator = $2 in
|
let elements, terminator = $2 in
|
||||||
let region = cover $1 $3
|
let region = cover $1 $3
|
||||||
and value = {
|
and value = {
|
||||||
opening = Kwd $1;
|
kind = mk_kwd $1;
|
||||||
|
enclosing = End $3;
|
||||||
elements = Some elements;
|
elements = Some elements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = End $3}
|
|
||||||
in {region; value}
|
in {region; value}
|
||||||
}
|
}
|
||||||
| Kind "end" {
|
| Kind "end" {
|
||||||
|
fun mk_kwd ->
|
||||||
let region = cover $1 $2
|
let region = cover $1 $2
|
||||||
and value = {
|
and value = {kind = mk_kwd $1;
|
||||||
opening = Kwd $1;
|
enclosing = End $2;
|
||||||
elements = None;
|
elements = None;
|
||||||
terminator = None;
|
terminator = None}
|
||||||
closing = End $2}
|
|
||||||
in {region; value}
|
in {region; value}
|
||||||
}
|
}
|
||||||
| Kind "[" sep_or_term_list(element,";") "]" {
|
| Kind "[" sep_or_term_list(element,";") "]" {
|
||||||
|
fun mk_kwd ->
|
||||||
let elements, terminator = $3 in
|
let elements, terminator = $3 in
|
||||||
let region = cover $1 $4
|
let region = cover $1 $4
|
||||||
and value = {
|
and value = {kind = mk_kwd $1;
|
||||||
opening = KwdBracket ($1,$2);
|
enclosing = Brackets ($2,$4);
|
||||||
elements = Some elements;
|
elements = Some elements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = RBracket $4}
|
|
||||||
in {region; value}
|
in {region; value}
|
||||||
}
|
}
|
||||||
| Kind "[" "]" {
|
| Kind "[" "]" {
|
||||||
|
fun mk_kwd ->
|
||||||
let region = cover $1 $3
|
let region = cover $1 $3
|
||||||
and value = {
|
and value = {kind = mk_kwd $1;
|
||||||
opening = KwdBracket ($1,$2);
|
enclosing = Brackets ($2,$3);
|
||||||
elements = None;
|
elements = None;
|
||||||
terminator = None;
|
terminator = None}
|
||||||
closing = RBracket $3}
|
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
ne_injection(Kind,element):
|
ne_injection(Kind,element):
|
||||||
Kind sep_or_term_list(element,";") "end" {
|
Kind sep_or_term_list(element,";") "end" {
|
||||||
|
fun mk_kwd ->
|
||||||
let ne_elements, terminator = $2 in
|
let ne_elements, terminator = $2 in
|
||||||
let region = cover $1 $3
|
let region = cover $1 $3
|
||||||
and value = {
|
and value = {kind = mk_kwd $1;
|
||||||
opening = Kwd $1;
|
enclosing = End $3;
|
||||||
ne_elements;
|
ne_elements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = End $3}
|
|
||||||
in {region; value}
|
in {region; value}
|
||||||
}
|
}
|
||||||
| Kind "[" sep_or_term_list(element,";") "]" {
|
| Kind "[" sep_or_term_list(element,";") "]" {
|
||||||
|
fun mk_kwd ->
|
||||||
let ne_elements, terminator = $3 in
|
let ne_elements, terminator = $3 in
|
||||||
let region = cover $1 $4
|
let region = cover $1 $4
|
||||||
and value = {
|
and value = {kind = mk_kwd $1;
|
||||||
opening = KwdBracket ($1,$2);
|
enclosing = Brackets ($2,$4);
|
||||||
ne_elements;
|
ne_elements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = RBracket $4}
|
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
binding:
|
binding:
|
||||||
@ -508,20 +506,19 @@ binding:
|
|||||||
let start = expr_to_region $1
|
let start = expr_to_region $1
|
||||||
and stop = expr_to_region $3 in
|
and stop = expr_to_region $3 in
|
||||||
let region = cover start stop
|
let region = cover start stop
|
||||||
and value = {
|
and value = {source = $1;
|
||||||
source = $1;
|
|
||||||
arrow = $2;
|
arrow = $2;
|
||||||
image = $3}
|
image = $3}
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
record_patch:
|
record_patch:
|
||||||
"patch" path "with" ne_injection("record",field_assignment) {
|
"patch" path "with" ne_injection("record",field_assignment) {
|
||||||
let region = cover $1 $4.region in
|
let record_inj = $4 (fun region -> NEInjRecord region) in
|
||||||
let value = {
|
let region = cover $1 record_inj.region in
|
||||||
kwd_patch = $1;
|
let value = {kwd_patch = $1;
|
||||||
path = $2;
|
path = $2;
|
||||||
kwd_with = $3;
|
kwd_with = $3;
|
||||||
record_inj = $4}
|
record_inj}
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
proc_call:
|
proc_call:
|
||||||
@ -547,12 +544,9 @@ if_clause:
|
|||||||
clause_block:
|
clause_block:
|
||||||
block { LongBlock $1 }
|
block { LongBlock $1 }
|
||||||
| "{" sep_or_term_list(statement,";") "}" {
|
| "{" sep_or_term_list(statement,";") "}" {
|
||||||
let statements, terminator = $2 in
|
|
||||||
let region = cover $1 $3 in
|
let region = cover $1 $3 in
|
||||||
let value = {lbrace = $1;
|
let value = {lbrace=$1; inside=$2; rbrace=$3}
|
||||||
inside = statements, terminator;
|
in ShortBlock {value; region} }
|
||||||
rbrace = $3} in
|
|
||||||
ShortBlock {value; region} }
|
|
||||||
|
|
||||||
case_instr:
|
case_instr:
|
||||||
case(if_clause) { $1 if_clause_to_region }
|
case(if_clause) { $1 if_clause_to_region }
|
||||||
@ -563,10 +557,10 @@ case(rhs):
|
|||||||
let region = cover $1 $6 in
|
let region = cover $1 $6 in
|
||||||
let value = {kwd_case = $1;
|
let value = {kwd_case = $1;
|
||||||
expr = $2;
|
expr = $2;
|
||||||
opening = Kwd $3;
|
kwd_of = $3;
|
||||||
|
enclosing = End $6;
|
||||||
lead_vbar = $4;
|
lead_vbar = $4;
|
||||||
cases = $5 rhs_to_region;
|
cases = $5 rhs_to_region}
|
||||||
closing = End $6}
|
|
||||||
in {region; value}
|
in {region; value}
|
||||||
}
|
}
|
||||||
| "case" expr "of" "[" "|"? cases(rhs) "]" {
|
| "case" expr "of" "[" "|"? cases(rhs) "]" {
|
||||||
@ -574,10 +568,10 @@ case(rhs):
|
|||||||
let region = cover $1 $7 in
|
let region = cover $1 $7 in
|
||||||
let value = {kwd_case = $1;
|
let value = {kwd_case = $1;
|
||||||
expr = $2;
|
expr = $2;
|
||||||
opening = KwdBracket ($3,$4);
|
kwd_of = $3;
|
||||||
|
enclosing = Brackets ($4,$7);
|
||||||
lead_vbar = $5;
|
lead_vbar = $5;
|
||||||
cases = $6 rhs_to_region;
|
cases = $6 rhs_to_region}
|
||||||
closing = RBracket $7}
|
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
cases(rhs):
|
cases(rhs):
|
||||||
@ -628,7 +622,6 @@ for_loop:
|
|||||||
assign = $2;
|
assign = $2;
|
||||||
kwd_to = $3;
|
kwd_to = $3;
|
||||||
bound = $4;
|
bound = $4;
|
||||||
kwd_step = None;
|
|
||||||
step = None;
|
step = None;
|
||||||
block = $5}
|
block = $5}
|
||||||
in For (ForInt {region; value})
|
in For (ForInt {region; value})
|
||||||
@ -639,8 +632,7 @@ for_loop:
|
|||||||
assign = $2;
|
assign = $2;
|
||||||
kwd_to = $3;
|
kwd_to = $3;
|
||||||
bound = $4;
|
bound = $4;
|
||||||
kwd_step = Some $5;
|
step = Some ($5, $6);
|
||||||
step = Some $6;
|
|
||||||
block = $7}
|
block = $7}
|
||||||
in For (ForInt {region; value})
|
in For (ForInt {region; value})
|
||||||
}
|
}
|
||||||
@ -854,7 +846,7 @@ core_expr:
|
|||||||
| "False" { ELogic (BoolExpr (False $1)) }
|
| "False" { ELogic (BoolExpr (False $1)) }
|
||||||
| "True" { ELogic (BoolExpr (True $1)) }
|
| "True" { ELogic (BoolExpr (True $1)) }
|
||||||
| "Unit" { EUnit $1 }
|
| "Unit" { EUnit $1 }
|
||||||
| annot_expr { EAnnot $1 }
|
| par(annot_expr) { EAnnot $1 }
|
||||||
| tuple_expr { ETuple $1 }
|
| tuple_expr { ETuple $1 }
|
||||||
| list_expr { EList $1 }
|
| list_expr { EList $1 }
|
||||||
| "None" { EConstr (NoneExpr $1) }
|
| "None" { EConstr (NoneExpr $1) }
|
||||||
@ -896,20 +888,20 @@ fun_call_or_par_or_projection:
|
|||||||
| fun_call { ECall $1 }
|
| fun_call { ECall $1 }
|
||||||
|
|
||||||
annot_expr:
|
annot_expr:
|
||||||
"(" disj_expr ":" type_expr ")" {
|
disj_expr ":" type_expr { $1,$2,$3 }
|
||||||
let start = expr_to_region $2
|
|
||||||
and stop = type_expr_to_region $4 in
|
|
||||||
let region = cover start stop
|
|
||||||
and value = $2, $4
|
|
||||||
in {region; value} }
|
|
||||||
|
|
||||||
set_expr:
|
set_expr:
|
||||||
injection("set",expr) { SetInj $1 }
|
injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) }
|
||||||
|
|
||||||
map_expr:
|
map_expr:
|
||||||
map_lookup { MapLookUp $1 }
|
map_lookup {
|
||||||
| injection("map",binding) { MapInj $1 }
|
MapLookUp $1
|
||||||
| injection("big_map",binding) { BigMapInj $1 }
|
}
|
||||||
|
| injection("map",binding) {
|
||||||
|
MapInj ($1 (fun region -> InjMap region))
|
||||||
|
}
|
||||||
|
| injection("big_map",binding) {
|
||||||
|
BigMapInj ($1 (fun region -> InjBigMap region)) }
|
||||||
|
|
||||||
map_lookup:
|
map_lookup:
|
||||||
path brackets(expr) {
|
path brackets(expr) {
|
||||||
@ -957,41 +949,40 @@ record_expr:
|
|||||||
"record" sep_or_term_list(field_assignment,";") "end" {
|
"record" sep_or_term_list(field_assignment,";") "end" {
|
||||||
let ne_elements, terminator = $2 in
|
let ne_elements, terminator = $2 in
|
||||||
let region = cover $1 $3
|
let region = cover $1 $3
|
||||||
and value : field_assign AST.reg ne_injection = {
|
and value : field_assignment AST.reg ne_injection = {
|
||||||
opening = Kwd $1;
|
kind = NEInjRecord $1;
|
||||||
|
enclosing = End $3;
|
||||||
ne_elements;
|
ne_elements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = End $3}
|
|
||||||
in {region; value}
|
in {region; value}
|
||||||
}
|
}
|
||||||
| "record" "[" sep_or_term_list(field_assignment,";") "]" {
|
| "record" "[" sep_or_term_list(field_assignment,";") "]" {
|
||||||
let ne_elements, terminator = $3 in
|
let ne_elements, terminator = $3 in
|
||||||
let region = cover $1 $4
|
let region = cover $1 $4
|
||||||
and value : field_assign AST.reg ne_injection = {
|
and value : field_assignment AST.reg ne_injection = {
|
||||||
opening = KwdBracket ($1,$2);
|
kind = NEInjRecord $1;
|
||||||
|
enclosing = Brackets ($2,$4);
|
||||||
ne_elements;
|
ne_elements;
|
||||||
terminator;
|
terminator}
|
||||||
closing = RBracket $4}
|
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
update_record:
|
update_record:
|
||||||
path "with" ne_injection("record",field_path_assignment){
|
path "with" ne_injection("record",field_path_assignment) {
|
||||||
let region = cover (path_to_region $1) $3.region in
|
let updates = $3 (fun region -> NEInjRecord region) in
|
||||||
let value = {record=$1; kwd_with=$2; updates=$3}
|
let region = cover (path_to_region $1) updates.region in
|
||||||
|
let value = {record=$1; kwd_with=$2; updates}
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
field_assignment:
|
field_assignment:
|
||||||
field_name "=" expr {
|
field_name "=" expr {
|
||||||
let region = cover $1.region (expr_to_region $3)
|
let region = cover $1.region (expr_to_region $3)
|
||||||
and value = {field_name=$1; equal=$2; field_expr=$3}
|
and value = {field_name=$1; assignment=$2; field_expr=$3}
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
field_path_assignment:
|
field_path_assignment:
|
||||||
nsepseq(field_name,".") "=" expr {
|
path "=" expr {
|
||||||
let start = nsepseq_to_region (fun x -> x.region) $1
|
let region = cover (path_to_region $1) (expr_to_region $3)
|
||||||
and stop = expr_to_region $3 in
|
and value = {field_path=$1; assignment=$2; field_expr=$3}
|
||||||
let region = cover start stop
|
|
||||||
and value = {field_path=$1; equal=$2; field_expr=$3}
|
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
fun_call:
|
fun_call:
|
||||||
@ -1010,7 +1001,7 @@ arguments:
|
|||||||
par(nsepseq(expr,",")) { $1 }
|
par(nsepseq(expr,",")) { $1 }
|
||||||
|
|
||||||
list_expr:
|
list_expr:
|
||||||
injection("list",expr) { EListComp $1 }
|
injection("list",expr) { EListComp ($1 (fun region -> InjList region)) }
|
||||||
| "nil" { ENil $1 }
|
| "nil" { ENil $1 }
|
||||||
|
|
||||||
(* Patterns *)
|
(* Patterns *)
|
||||||
@ -1034,9 +1025,10 @@ core_pattern:
|
|||||||
| constr_pattern { PConstr $1 }
|
| constr_pattern { PConstr $1 }
|
||||||
|
|
||||||
list_pattern:
|
list_pattern:
|
||||||
injection("list",core_pattern) { PListComp $1 }
|
"nil" { PNil $1 }
|
||||||
| "nil" { PNil $1 }
|
|
||||||
| par(cons_pattern) { PParCons $1 }
|
| par(cons_pattern) { PParCons $1 }
|
||||||
|
| injection("list",core_pattern) {
|
||||||
|
PListComp ($1 (fun region -> InjList region)) }
|
||||||
|
|
||||||
cons_pattern:
|
cons_pattern:
|
||||||
core_pattern "#" pattern { $1,$2,$3 }
|
core_pattern "#" pattern { $1,$2,$3 }
|
||||||
|
|||||||
@ -27,7 +27,7 @@ let mk_state ~offsets ~mode ~buffer =
|
|||||||
val pad_node = ""
|
val pad_node = ""
|
||||||
method pad_node = pad_node
|
method pad_node = pad_node
|
||||||
|
|
||||||
(** The method [pad] updates the current padding, which is
|
(* The method [pad] updates the current padding, which is
|
||||||
comprised of two components: the padding to reach the new node
|
comprised of two components: the padding to reach the new node
|
||||||
(space before reaching a subtree, then a vertical bar for it)
|
(space before reaching a subtree, then a vertical bar for it)
|
||||||
and the padding for the new node itself (Is it the last child
|
and the padding for the new node itself (Is it the last child
|
||||||
@ -44,7 +44,7 @@ let mk_state ~offsets ~mode ~buffer =
|
|||||||
let compact state (region: Region.t) =
|
let compact state (region: Region.t) =
|
||||||
region#compact ~offsets:state#offsets state#mode
|
region#compact ~offsets:state#offsets state#mode
|
||||||
|
|
||||||
(** {1 Printing the tokens with their source regions} *)
|
(* Printing the tokens with their source regions *)
|
||||||
|
|
||||||
let print_nsepseq :
|
let print_nsepseq :
|
||||||
state -> string -> (state -> 'a -> unit) ->
|
state -> string -> (state -> 'a -> unit) ->
|
||||||
@ -117,7 +117,7 @@ let rec print_tokens state ast =
|
|||||||
print_token state eof "EOF"
|
print_token state eof "EOF"
|
||||||
|
|
||||||
and print_attr_decl state =
|
and print_attr_decl state =
|
||||||
print_ne_injection state "attributes" print_string
|
print_ne_injection state print_string
|
||||||
|
|
||||||
and print_decl state = function
|
and print_decl state = function
|
||||||
TypeDecl decl -> print_type_decl state decl
|
TypeDecl decl -> print_type_decl state decl
|
||||||
@ -153,7 +153,7 @@ and print_type_expr state = function
|
|||||||
| TFun type_fun -> print_type_fun state type_fun
|
| TFun type_fun -> print_type_fun state type_fun
|
||||||
| TPar par_type -> print_par_type state par_type
|
| TPar par_type -> print_par_type state par_type
|
||||||
| TVar type_var -> print_var state type_var
|
| TVar type_var -> print_var state type_var
|
||||||
| TStringLiteral s -> print_string state s
|
| TString str -> print_string state str
|
||||||
|
|
||||||
and print_cartesian state {value; _} =
|
and print_cartesian state {value; _} =
|
||||||
print_nsepseq state "*" print_type_expr value
|
print_nsepseq state "*" print_type_expr value
|
||||||
@ -170,8 +170,8 @@ and print_variant state ({value; _}: variant reg) =
|
|||||||
and print_sum_type state {value; _} =
|
and print_sum_type state {value; _} =
|
||||||
print_nsepseq state "|" print_variant value
|
print_nsepseq state "|" print_variant value
|
||||||
|
|
||||||
and print_record_type state record_type =
|
and print_record_type state =
|
||||||
print_ne_injection state "record" print_field_decl record_type
|
print_ne_injection state print_field_decl
|
||||||
|
|
||||||
and print_type_app state {value; _} =
|
and print_type_app state {value; _} =
|
||||||
let type_name, type_tuple = value in
|
let type_name, type_tuple = value in
|
||||||
@ -221,9 +221,8 @@ and print_fun_decl state {value; _} =
|
|||||||
print_terminator state terminator;
|
print_terminator state terminator;
|
||||||
|
|
||||||
and print_fun_expr state {value; _} =
|
and print_fun_expr state {value; _} =
|
||||||
let {kwd_recursive; kwd_function; param; colon;
|
let {kwd_function; param; colon;
|
||||||
ret_type; kwd_is; return} : fun_expr = value in
|
ret_type; kwd_is; return} : fun_expr = value in
|
||||||
print_token_opt state kwd_recursive "recursive";
|
|
||||||
print_token state kwd_function "function";
|
print_token state kwd_function "function";
|
||||||
print_parameters state param;
|
print_parameters state param;
|
||||||
print_token state colon ":";
|
print_token state colon ":";
|
||||||
@ -256,22 +255,19 @@ and print_param_var state {value; _} =
|
|||||||
print_type_expr state param_type
|
print_type_expr state param_type
|
||||||
|
|
||||||
and print_block state block =
|
and print_block state block =
|
||||||
let {opening; statements; terminator; closing} = block.value in
|
let {enclosing; statements; terminator} = block.value in
|
||||||
print_block_opening state opening;
|
match enclosing with
|
||||||
|
Block (kwd_block, lbrace, rbrace) ->
|
||||||
|
print_token state kwd_block "block";
|
||||||
|
print_token state lbrace "{";
|
||||||
print_statements state statements;
|
print_statements state statements;
|
||||||
print_terminator state terminator;
|
print_terminator state terminator;
|
||||||
print_block_closing state closing
|
print_token state rbrace "}"
|
||||||
|
| BeginEnd (kwd_begin, kwd_end) ->
|
||||||
and print_block_opening state = function
|
print_token state kwd_begin "begin";
|
||||||
Block (kwd_block, lbrace) ->
|
print_statements state statements;
|
||||||
print_token state kwd_block "block";
|
print_terminator state terminator;
|
||||||
print_token state lbrace "{"
|
print_token state kwd_end "end"
|
||||||
| Begin kwd_begin ->
|
|
||||||
print_token state kwd_begin "begin"
|
|
||||||
|
|
||||||
and print_block_closing state = function
|
|
||||||
Block rbrace -> print_token state rbrace "}"
|
|
||||||
| End kwd_end -> print_token state kwd_end "end"
|
|
||||||
|
|
||||||
and print_data_decl state = function
|
and print_data_decl state = function
|
||||||
LocalConst decl -> print_const_decl state decl
|
LocalConst decl -> print_const_decl state decl
|
||||||
@ -344,14 +340,20 @@ and print_clause_block state = function
|
|||||||
print_token state rbrace "}"
|
print_token state rbrace "}"
|
||||||
|
|
||||||
and print_case_instr state (node : if_clause case) =
|
and print_case_instr state (node : if_clause case) =
|
||||||
let {kwd_case; expr; opening;
|
let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
|
||||||
lead_vbar; cases; closing} = node in
|
|
||||||
print_token state kwd_case "case";
|
print_token state kwd_case "case";
|
||||||
print_expr state expr;
|
print_expr state expr;
|
||||||
print_opening state "of" opening;
|
print_token state kwd_of "of";
|
||||||
|
match enclosing with
|
||||||
|
Brackets (lbracket, rbracket) ->
|
||||||
|
print_token state lbracket "[";
|
||||||
print_token_opt state lead_vbar "|";
|
print_token_opt state lead_vbar "|";
|
||||||
print_cases_instr state cases;
|
print_cases_instr state cases;
|
||||||
print_closing state closing
|
print_token state rbracket "]"
|
||||||
|
| End kwd_end ->
|
||||||
|
print_token_opt state lead_vbar "|";
|
||||||
|
print_cases_instr state cases;
|
||||||
|
print_token state kwd_end "end"
|
||||||
|
|
||||||
and print_token_opt state = function
|
and print_token_opt state = function
|
||||||
None -> fun _ -> ()
|
None -> fun _ -> ()
|
||||||
@ -393,19 +395,16 @@ and print_for_loop state = function
|
|||||||
| ForCollect for_collect -> print_for_collect state for_collect
|
| ForCollect for_collect -> print_for_collect state for_collect
|
||||||
|
|
||||||
and print_for_int state ({value; _} : for_int reg) =
|
and print_for_int state ({value; _} : for_int reg) =
|
||||||
let {kwd_for; assign; kwd_to; bound; kwd_step; step; block} = value in
|
let {kwd_for; assign; kwd_to; bound; step; block} = value in
|
||||||
print_token state kwd_for "for";
|
print_token state kwd_for "for";
|
||||||
print_var_assign state assign;
|
print_var_assign state assign;
|
||||||
print_token state kwd_to "to";
|
print_token state kwd_to "to";
|
||||||
print_expr state bound;
|
print_expr state bound;
|
||||||
match kwd_step with
|
(match step with
|
||||||
| None -> ();
|
None -> ();
|
||||||
| Some kwd_step ->
|
| Some (kwd_step, expr) ->
|
||||||
print_token state kwd_step "step";
|
print_token state kwd_step "step";
|
||||||
match step with
|
print_expr state expr);
|
||||||
| None -> ();
|
|
||||||
| Some step ->
|
|
||||||
print_expr state step;
|
|
||||||
print_block state block
|
print_block state block
|
||||||
|
|
||||||
and print_var_assign state {value; _} =
|
and print_var_assign state {value; _} =
|
||||||
@ -461,19 +460,27 @@ and print_expr state = function
|
|||||||
| EPar e -> print_par_expr state e
|
| EPar e -> print_par_expr state e
|
||||||
| EFun e -> print_fun_expr state e
|
| EFun e -> print_fun_expr state e
|
||||||
|
|
||||||
and print_annot_expr state (expr , type_expr) =
|
and print_annot_expr state node =
|
||||||
|
let {inside; _} : annot_expr par = node in
|
||||||
|
let expr, _, type_expr = inside in
|
||||||
print_expr state expr;
|
print_expr state expr;
|
||||||
print_type_expr state type_expr
|
print_type_expr state type_expr
|
||||||
|
|
||||||
and print_case_expr state (node : expr case) =
|
and print_case_expr state (node : expr case) =
|
||||||
let {kwd_case; expr; opening;
|
let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
|
||||||
lead_vbar; cases; closing} = node in
|
|
||||||
print_token state kwd_case "case";
|
print_token state kwd_case "case";
|
||||||
print_expr state expr;
|
print_expr state expr;
|
||||||
print_opening state "of" opening;
|
print_token state kwd_of "of";
|
||||||
|
match enclosing with
|
||||||
|
Brackets (lbracket, rbracket) ->
|
||||||
|
print_token state lbracket "[";
|
||||||
print_token_opt state lead_vbar "|";
|
print_token_opt state lead_vbar "|";
|
||||||
print_cases_expr state cases;
|
print_cases_expr state cases;
|
||||||
print_closing state closing
|
print_token state rbracket "]"
|
||||||
|
| End kwd_end ->
|
||||||
|
print_token_opt state lead_vbar "|";
|
||||||
|
print_cases_expr state cases;
|
||||||
|
print_token state kwd_end "end"
|
||||||
|
|
||||||
and print_cases_expr state {value; _} =
|
and print_cases_expr state {value; _} =
|
||||||
print_nsepseq state "|" print_case_clause_expr value
|
print_nsepseq state "|" print_case_clause_expr value
|
||||||
@ -486,11 +493,11 @@ and print_case_clause_expr state {value; _} =
|
|||||||
|
|
||||||
and print_map_expr state = function
|
and print_map_expr state = function
|
||||||
MapLookUp {value; _} -> print_map_lookup state value
|
MapLookUp {value; _} -> print_map_lookup state value
|
||||||
| MapInj inj -> print_injection state "map" print_binding inj
|
| MapInj inj -> print_injection state print_binding inj
|
||||||
| BigMapInj inj -> print_injection state "big_map" print_binding inj
|
| BigMapInj inj -> print_injection state print_binding inj
|
||||||
|
|
||||||
and print_set_expr state = function
|
and print_set_expr state = function
|
||||||
SetInj inj -> print_injection state "set" print_expr inj
|
SetInj inj -> print_injection state print_expr inj
|
||||||
| SetMem mem -> print_set_membership state mem
|
| SetMem mem -> print_set_membership state mem
|
||||||
|
|
||||||
and print_set_membership state {value; _} =
|
and print_set_membership state {value; _} =
|
||||||
@ -600,7 +607,7 @@ and print_list_expr state = function
|
|||||||
print_expr state arg1;
|
print_expr state arg1;
|
||||||
print_token state op "#";
|
print_token state op "#";
|
||||||
print_expr state arg2
|
print_expr state arg2
|
||||||
| EListComp e -> print_injection state "list" print_expr e
|
| EListComp e -> print_injection state print_expr e
|
||||||
| ENil e -> print_nil state e
|
| ENil e -> print_nil state e
|
||||||
|
|
||||||
and print_constr_expr state = function
|
and print_constr_expr state = function
|
||||||
@ -608,27 +615,26 @@ and print_constr_expr state = function
|
|||||||
| NoneExpr e -> print_none_expr state e
|
| NoneExpr e -> print_none_expr state e
|
||||||
| ConstrApp e -> print_constr_app state e
|
| ConstrApp e -> print_constr_app state e
|
||||||
|
|
||||||
and print_record_expr state e =
|
and print_record_expr state =
|
||||||
print_ne_injection state "record" print_field_assign e
|
print_ne_injection state print_field_assignment
|
||||||
|
|
||||||
and print_field_assign state {value; _} =
|
and print_field_assignment state {value; _} =
|
||||||
let {field_name; equal; field_expr} = value in
|
let {field_name; assignment; field_expr} = value in
|
||||||
print_var state field_name;
|
print_var state field_name;
|
||||||
print_token state equal "=";
|
print_token state assignment "=";
|
||||||
print_expr state field_expr
|
print_expr state field_expr
|
||||||
|
|
||||||
and print_field_path_assign state {value; _} =
|
and print_field_path_assignment state {value; _} =
|
||||||
let {field_path; equal; field_expr} = value in
|
let {field_path; assignment; field_expr} = value in
|
||||||
print_nsepseq state "field_path" print_var field_path;
|
print_path state field_path;
|
||||||
print_token state equal "=";
|
print_token state assignment "=";
|
||||||
print_expr state field_expr
|
print_expr state field_expr
|
||||||
|
|
||||||
and print_update_expr state {value; _} =
|
and print_update_expr state {value; _} =
|
||||||
let {record; kwd_with; updates} = value in
|
let {record; kwd_with; updates} = value in
|
||||||
print_path state record;
|
print_path state record;
|
||||||
print_token state kwd_with "with";
|
print_token state kwd_with "with";
|
||||||
print_ne_injection state "updates field" print_field_path_assign updates
|
print_ne_injection state print_field_path_assignment updates
|
||||||
|
|
||||||
|
|
||||||
and print_projection state {value; _} =
|
and print_projection state {value; _} =
|
||||||
let {struct_name; selector; field_path} = value in
|
let {struct_name; selector; field_path} = value in
|
||||||
@ -648,21 +654,21 @@ and print_record_patch state node =
|
|||||||
print_token state kwd_patch "patch";
|
print_token state kwd_patch "patch";
|
||||||
print_path state path;
|
print_path state path;
|
||||||
print_token state kwd_with "with";
|
print_token state kwd_with "with";
|
||||||
print_ne_injection state "record" print_field_assign record_inj
|
print_ne_injection state print_field_assignment record_inj
|
||||||
|
|
||||||
and print_set_patch state node =
|
and print_set_patch state node =
|
||||||
let {kwd_patch; path; kwd_with; set_inj} = node in
|
let {kwd_patch; path; kwd_with; set_inj} = node in
|
||||||
print_token state kwd_patch "patch";
|
print_token state kwd_patch "patch";
|
||||||
print_path state path;
|
print_path state path;
|
||||||
print_token state kwd_with "with";
|
print_token state kwd_with "with";
|
||||||
print_ne_injection state "set" print_expr set_inj
|
print_ne_injection state print_expr set_inj
|
||||||
|
|
||||||
and print_map_patch state node =
|
and print_map_patch state node =
|
||||||
let {kwd_patch; path; kwd_with; map_inj} = node in
|
let {kwd_patch; path; kwd_with; map_inj} = node in
|
||||||
print_token state kwd_patch "patch";
|
print_token state kwd_patch "patch";
|
||||||
print_path state path;
|
print_path state path;
|
||||||
print_token state kwd_with "with";
|
print_token state kwd_with "with";
|
||||||
print_ne_injection state "map" print_binding map_inj
|
print_ne_injection state print_binding map_inj
|
||||||
|
|
||||||
and print_map_remove state node =
|
and print_map_remove state node =
|
||||||
let {kwd_remove; key; kwd_from; kwd_map; map} = node in
|
let {kwd_remove; key; kwd_from; kwd_map; map} = node in
|
||||||
@ -681,35 +687,48 @@ and print_set_remove state node =
|
|||||||
print_path state set
|
print_path state set
|
||||||
|
|
||||||
and print_injection :
|
and print_injection :
|
||||||
'a.state -> string -> (state -> 'a -> unit) ->
|
'a.state -> (state -> 'a -> unit) -> 'a injection reg -> unit =
|
||||||
'a injection reg -> unit =
|
fun state print {value; _} ->
|
||||||
fun state kwd print {value; _} ->
|
let {kind; enclosing; elements; terminator} = value in
|
||||||
let {opening; elements; terminator; closing} = value in
|
print_injection_kwd state kind;
|
||||||
print_opening state kwd opening;
|
match enclosing with
|
||||||
|
Brackets (lbracket, rbracket) ->
|
||||||
|
print_token state lbracket "[";
|
||||||
print_sepseq state ";" print elements;
|
print_sepseq state ";" print elements;
|
||||||
print_terminator state terminator;
|
print_terminator state terminator;
|
||||||
print_closing state closing
|
print_token state rbracket "]"
|
||||||
|
| End kwd_end ->
|
||||||
|
print_sepseq state ";" print elements;
|
||||||
|
print_terminator state terminator;
|
||||||
|
print_token state kwd_end "end"
|
||||||
|
|
||||||
|
and print_injection_kwd state = function
|
||||||
|
InjSet kwd_set -> print_token state kwd_set "set"
|
||||||
|
| InjMap kwd_map -> print_token state kwd_map "map"
|
||||||
|
| InjBigMap kwd_big_map -> print_token state kwd_big_map "big_map"
|
||||||
|
| InjList kwd_list -> print_token state kwd_list "list"
|
||||||
|
|
||||||
and print_ne_injection :
|
and print_ne_injection :
|
||||||
'a.state -> string -> (state -> 'a -> unit) ->
|
'a.state -> (state -> 'a -> unit) -> 'a ne_injection reg -> unit =
|
||||||
'a ne_injection reg -> unit =
|
fun state print {value; _} ->
|
||||||
fun state kwd print {value; _} ->
|
let {kind; enclosing; ne_elements; terminator} = value in
|
||||||
let {opening; ne_elements; terminator; closing} = value in
|
print_ne_injection_kwd state kind;
|
||||||
print_opening state kwd opening;
|
match enclosing with
|
||||||
|
Brackets (lbracket, rbracket) ->
|
||||||
|
print_token state lbracket "[";
|
||||||
print_nsepseq state ";" print ne_elements;
|
print_nsepseq state ";" print ne_elements;
|
||||||
print_terminator state terminator;
|
print_terminator state terminator;
|
||||||
print_closing state closing
|
print_token state rbracket "]"
|
||||||
|
| End kwd_end ->
|
||||||
|
print_nsepseq state ";" print ne_elements;
|
||||||
|
print_terminator state terminator;
|
||||||
|
print_token state kwd_end "end"
|
||||||
|
|
||||||
and print_opening state lexeme = function
|
and print_ne_injection_kwd state = function
|
||||||
Kwd kwd ->
|
NEInjAttr kwd_attributes -> print_token state kwd_attributes "attributes"
|
||||||
print_token state kwd lexeme
|
| NEInjSet kwd_set -> print_token state kwd_set "set"
|
||||||
| KwdBracket (kwd, lbracket) ->
|
| NEInjMap kwd_map -> print_token state kwd_map "map"
|
||||||
print_token state kwd lexeme;
|
| NEInjRecord kwd_record -> print_token state kwd_record "record"
|
||||||
print_token state lbracket "["
|
|
||||||
|
|
||||||
and print_closing state = function
|
|
||||||
RBracket rbracket -> print_token state rbracket "]"
|
|
||||||
| End kwd_end -> print_token state kwd_end "end"
|
|
||||||
|
|
||||||
and print_binding state {value; _} =
|
and print_binding state {value; _} =
|
||||||
let {source; arrow; image} = value in
|
let {source; arrow; image} = value in
|
||||||
@ -787,7 +806,7 @@ and print_patterns state {value; _} =
|
|||||||
|
|
||||||
and print_list_pattern state = function
|
and print_list_pattern state = function
|
||||||
PListComp comp ->
|
PListComp comp ->
|
||||||
print_injection state "list" print_pattern comp
|
print_injection state print_pattern comp
|
||||||
| PNil kwd_nil ->
|
| PNil kwd_nil ->
|
||||||
print_token state kwd_nil "nil"
|
print_token state kwd_nil "nil"
|
||||||
| PParCons cons ->
|
| PParCons cons ->
|
||||||
@ -831,7 +850,7 @@ let pattern_to_string ~offsets ~mode =
|
|||||||
let instruction_to_string ~offsets ~mode =
|
let instruction_to_string ~offsets ~mode =
|
||||||
to_string ~offsets ~mode print_instruction
|
to_string ~offsets ~mode print_instruction
|
||||||
|
|
||||||
(** {1 Pretty-printing the AST} *)
|
(* Pretty-printing the AST *)
|
||||||
|
|
||||||
let pp_ident state {value=name; region} =
|
let pp_ident state {value=name; region} =
|
||||||
let reg = compact state region in
|
let reg = compact state region in
|
||||||
@ -842,12 +861,20 @@ let pp_node state name =
|
|||||||
let node = sprintf "%s%s\n" state#pad_path name
|
let node = sprintf "%s%s\n" state#pad_path name
|
||||||
in Buffer.add_string state#buffer node
|
in Buffer.add_string state#buffer node
|
||||||
|
|
||||||
let pp_string state = pp_ident state
|
let pp_string state {value=name; region} =
|
||||||
|
let reg = compact state region in
|
||||||
|
let node = sprintf "%s%S (%s)\n" state#pad_path name reg
|
||||||
|
in Buffer.add_string state#buffer node
|
||||||
|
|
||||||
|
let pp_verbatim state {value=name; region} =
|
||||||
|
let reg = compact state region in
|
||||||
|
let node = sprintf "%s{|%s|} (%s)\n" state#pad_path name reg
|
||||||
|
in Buffer.add_string state#buffer node
|
||||||
|
|
||||||
let pp_loc_node state name region =
|
let pp_loc_node state name region =
|
||||||
pp_ident state {value=name; region}
|
pp_ident state {value=name; region}
|
||||||
|
|
||||||
let rec pp_ast state {decl; _} =
|
let rec pp_cst state {decl; _} =
|
||||||
let apply len rank =
|
let apply len rank =
|
||||||
pp_declaration (state#pad len rank) in
|
pp_declaration (state#pad len rank) in
|
||||||
let decls = Utils.nseq_to_list decl in
|
let decls = Utils.nseq_to_list decl in
|
||||||
@ -943,8 +970,8 @@ and pp_type_expr state = function
|
|||||||
field_decl.value in
|
field_decl.value in
|
||||||
let fields = Utils.nsepseq_to_list value.ne_elements in
|
let fields = Utils.nsepseq_to_list value.ne_elements in
|
||||||
List.iteri (List.length fields |> apply) fields
|
List.iteri (List.length fields |> apply) fields
|
||||||
| TStringLiteral s ->
|
| TString s ->
|
||||||
pp_node state "String";
|
pp_node state "TString";
|
||||||
pp_string (state#pad 1 0) s
|
pp_string (state#pad 1 0) s
|
||||||
|
|
||||||
and pp_cartesian state {value; _} =
|
and pp_cartesian state {value; _} =
|
||||||
@ -1244,8 +1271,8 @@ and pp_projection state proj =
|
|||||||
List.iteri (apply len) selections
|
List.iteri (apply len) selections
|
||||||
|
|
||||||
and pp_update state update =
|
and pp_update state update =
|
||||||
pp_path state update.record;
|
pp_path (state#pad 2 0) update.record;
|
||||||
pp_ne_injection pp_field_path_assign state update.updates.value
|
pp_ne_injection pp_field_path_assignment state update.updates.value
|
||||||
|
|
||||||
and pp_selection state = function
|
and pp_selection state = function
|
||||||
FieldName name ->
|
FieldName name ->
|
||||||
@ -1285,17 +1312,27 @@ and pp_for_loop state = function
|
|||||||
pp_for_collect state value
|
pp_for_collect state value
|
||||||
|
|
||||||
and pp_for_int state for_int =
|
and pp_for_int state for_int =
|
||||||
|
let {assign; bound; step; block; _} = for_int in
|
||||||
|
let arity =
|
||||||
|
match step with None -> 3 | Some _ -> 4 in
|
||||||
let () =
|
let () =
|
||||||
let state = state#pad 3 0 in
|
let state = state#pad arity 0 in
|
||||||
pp_node state "<init>";
|
pp_node state "<init>";
|
||||||
pp_var_assign state for_int.assign.value in
|
pp_var_assign state assign.value in
|
||||||
let () =
|
let () =
|
||||||
let state = state#pad 3 1 in
|
let state = state#pad arity 1 in
|
||||||
pp_node state "<bound>";
|
pp_node state "<bound>";
|
||||||
pp_expr (state#pad 1 0) for_int.bound in
|
pp_expr (state#pad 1 0) bound in
|
||||||
let () =
|
let () =
|
||||||
let state = state#pad 3 2 in
|
match step with
|
||||||
let statements = for_int.block.value.statements in
|
None -> ()
|
||||||
|
| Some (_, expr) ->
|
||||||
|
let state = state#pad arity 2 in
|
||||||
|
pp_node state "<step>";
|
||||||
|
pp_expr (state#pad 1 0) expr in
|
||||||
|
let () =
|
||||||
|
let state = state#pad arity (arity-1) in
|
||||||
|
let statements = block.value.statements in
|
||||||
pp_node state "<statements>";
|
pp_node state "<statements>";
|
||||||
pp_statements state statements
|
pp_statements state statements
|
||||||
in ()
|
in ()
|
||||||
@ -1343,18 +1380,18 @@ and pp_fun_call state (expr, args) =
|
|||||||
|
|
||||||
and pp_record_patch state patch =
|
and pp_record_patch state patch =
|
||||||
pp_path (state#pad 2 0) patch.path;
|
pp_path (state#pad 2 0) patch.path;
|
||||||
pp_ne_injection pp_field_assign state patch.record_inj.value
|
pp_ne_injection pp_field_assignment state patch.record_inj.value
|
||||||
|
|
||||||
and pp_field_assign state {value; _} =
|
and pp_field_assignment state {value; _} =
|
||||||
pp_node state "<field assignment>";
|
pp_node state "<field assignment>";
|
||||||
pp_ident (state#pad 2 0) value.field_name;
|
pp_ident (state#pad 2 0) value.field_name;
|
||||||
pp_expr (state#pad 2 1) value.field_expr
|
pp_expr (state#pad 2 1) value.field_expr
|
||||||
|
|
||||||
and pp_field_path_assign state {value; _} =
|
and pp_field_path_assignment state {value; _} =
|
||||||
pp_node state "<field path for update>";
|
let {field_path; field_expr; _} = value in
|
||||||
let path = Utils.nsepseq_to_list value.field_path in
|
pp_node state "<update>";
|
||||||
List.iter (pp_ident (state#pad 2 0)) path;
|
pp_path (state#pad 2 0) field_path;
|
||||||
pp_expr (state#pad 2 1) value.field_expr
|
pp_expr (state#pad 2 1) field_expr
|
||||||
|
|
||||||
and pp_map_patch state patch =
|
and pp_map_patch state patch =
|
||||||
pp_path (state#pad 2 0) patch.path;
|
pp_path (state#pad 2 0) patch.path;
|
||||||
@ -1403,7 +1440,7 @@ and pp_expr state = function
|
|||||||
pp_cond_expr state value
|
pp_cond_expr state value
|
||||||
| EAnnot {value; region} ->
|
| EAnnot {value; region} ->
|
||||||
pp_loc_node state "EAnnot" region;
|
pp_loc_node state "EAnnot" region;
|
||||||
pp_annotated state value
|
pp_annotated state value.inside
|
||||||
| ELogic e_logic ->
|
| ELogic e_logic ->
|
||||||
pp_node state "ELogic";
|
pp_node state "ELogic";
|
||||||
pp_e_logic (state#pad 1 0) e_logic
|
pp_e_logic (state#pad 1 0) e_logic
|
||||||
@ -1424,7 +1461,7 @@ and pp_expr state = function
|
|||||||
pp_constr_expr (state#pad 1 0) e_constr
|
pp_constr_expr (state#pad 1 0) e_constr
|
||||||
| ERecord {value; region} ->
|
| ERecord {value; region} ->
|
||||||
pp_loc_node state "ERecord" region;
|
pp_loc_node state "ERecord" region;
|
||||||
pp_ne_injection pp_field_assign state value
|
pp_ne_injection pp_field_assignment state value
|
||||||
| EProj {value; region} ->
|
| EProj {value; region} ->
|
||||||
pp_loc_node state "EProj" region;
|
pp_loc_node state "EProj" region;
|
||||||
pp_projection state value
|
pp_projection state value
|
||||||
@ -1576,9 +1613,9 @@ and pp_string_expr state = function
|
|||||||
pp_string (state#pad 1 0) s
|
pp_string (state#pad 1 0) s
|
||||||
| Verbatim v ->
|
| Verbatim v ->
|
||||||
pp_node state "Verbatim";
|
pp_node state "Verbatim";
|
||||||
pp_string (state#pad 1 0) v
|
pp_verbatim (state#pad 1 0) v
|
||||||
|
|
||||||
and pp_annotated state (expr, t_expr) =
|
and pp_annotated state (expr, _, t_expr) =
|
||||||
pp_expr (state#pad 2 0) expr;
|
pp_expr (state#pad 2 0) expr;
|
||||||
pp_type_expr (state#pad 2 1) t_expr
|
pp_type_expr (state#pad 2 1) t_expr
|
||||||
|
|
||||||
|
|||||||
@ -33,5 +33,5 @@ val instruction_to_string :
|
|||||||
|
|
||||||
(** {1 Pretty-printing of AST nodes} *)
|
(** {1 Pretty-printing of AST nodes} *)
|
||||||
|
|
||||||
val pp_ast : state -> AST.t -> unit
|
val pp_cst : state -> AST.t -> unit
|
||||||
val pp_expr : state -> AST.expr -> unit
|
val pp_expr : state -> AST.expr -> unit
|
||||||
|
|||||||
@ -22,7 +22,8 @@ module SubIO =
|
|||||||
ext : string;
|
ext : string;
|
||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : EvalOpt.command;
|
cmd : EvalOpt.command;
|
||||||
mono : bool
|
mono : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
let options : options =
|
let options : options =
|
||||||
@ -36,6 +37,7 @@ module SubIO =
|
|||||||
method mode = IO.options#mode
|
method mode = IO.options#mode
|
||||||
method cmd = IO.options#cmd
|
method cmd = IO.options#cmd
|
||||||
method mono = IO.options#mono
|
method mono = IO.options#mono
|
||||||
|
method pretty = IO.options#pretty
|
||||||
end
|
end
|
||||||
|
|
||||||
let make =
|
let make =
|
||||||
@ -48,6 +50,7 @@ module SubIO =
|
|||||||
~mode:options#mode
|
~mode:options#mode
|
||||||
~cmd:options#cmd
|
~cmd:options#cmd
|
||||||
~mono:options#mono
|
~mono:options#mono
|
||||||
|
~pretty:options#pretty
|
||||||
end
|
end
|
||||||
|
|
||||||
module Parser =
|
module Parser =
|
||||||
@ -67,14 +70,28 @@ module ParserLog =
|
|||||||
module Lexer = Lexer.Make (LexToken)
|
module Lexer = Lexer.Make (LexToken)
|
||||||
|
|
||||||
module Unit =
|
module Unit =
|
||||||
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
|
ParserUnit.Make (Lexer)(AST)(Parser)(Parser_msg)(ParserLog)(SubIO)
|
||||||
|
|
||||||
(* Main *)
|
(* Main *)
|
||||||
|
|
||||||
let wrap = function
|
let wrap = function
|
||||||
Stdlib.Ok _ -> flush_all ()
|
Stdlib.Ok ast ->
|
||||||
|
if IO.options#pretty then
|
||||||
|
begin
|
||||||
|
let doc = Pretty.print ast in
|
||||||
|
let width =
|
||||||
|
match Terminal_size.get_columns () with
|
||||||
|
None -> 60
|
||||||
|
| Some c -> c in
|
||||||
|
PPrint.ToChannel.pretty 1.0 width stdout doc;
|
||||||
|
print_newline ()
|
||||||
|
end;
|
||||||
|
flush_all ()
|
||||||
| Error msg ->
|
| Error msg ->
|
||||||
(flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)
|
begin
|
||||||
|
flush_all ();
|
||||||
|
Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value
|
||||||
|
end
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
match IO.options#input with
|
match IO.options#input with
|
||||||
|
|||||||
632
src/passes/01-parser/pascaligo/Pretty.ml
Normal file
632
src/passes/01-parser/pascaligo/Pretty.ml
Normal file
@ -0,0 +1,632 @@
|
|||||||
|
[@@@warning "-42"]
|
||||||
|
[@@@warning "-27"]
|
||||||
|
[@@@warning "-26"]
|
||||||
|
|
||||||
|
open AST
|
||||||
|
module Region = Simple_utils.Region
|
||||||
|
open! Region
|
||||||
|
open! PPrint
|
||||||
|
|
||||||
|
let pp_par : ('a -> document) -> 'a par reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
string "(" ^^ nest 1 (printer value.inside ^^ string ")")
|
||||||
|
|
||||||
|
let pp_brackets : ('a -> document) -> 'a brackets reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
string "[" ^^ nest 1 (printer value.inside ^^ string "]")
|
||||||
|
|
||||||
|
let pp_braces : ('a -> document) -> 'a braces reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
string "{" ^^ nest 1 (printer value.inside ^^ string "}")
|
||||||
|
|
||||||
|
let rec print ast =
|
||||||
|
let app decl = group (pp_declaration decl) in
|
||||||
|
let decl = Utils.nseq_to_list ast.decl in
|
||||||
|
separate_map (hardline ^^ hardline) app decl
|
||||||
|
|
||||||
|
and pp_declaration = function
|
||||||
|
TypeDecl d -> pp_type_decl d
|
||||||
|
| ConstDecl d -> pp_const_decl d
|
||||||
|
| FunDecl d -> pp_fun_decl d
|
||||||
|
| AttrDecl d -> pp_attr_decl d
|
||||||
|
|
||||||
|
and pp_attr_decl decl = pp_ne_injection pp_string decl
|
||||||
|
|
||||||
|
and pp_const_decl {value; _} =
|
||||||
|
let {name; const_type; init; attributes; _} = value in
|
||||||
|
let start = string ("const " ^ name.value) in
|
||||||
|
let t_expr = pp_type_expr const_type in
|
||||||
|
let attr = match attributes with
|
||||||
|
None -> empty
|
||||||
|
| Some a -> hardline ^^ pp_attr_decl a in
|
||||||
|
group (start ^/^ nest 2 (string ": " ^^ t_expr))
|
||||||
|
^^ group (break 1 ^^ nest 2 (string "= " ^^ pp_expr init))
|
||||||
|
^^ attr
|
||||||
|
|
||||||
|
(* Type declarations *)
|
||||||
|
|
||||||
|
and pp_type_decl decl =
|
||||||
|
let {name; type_expr; _} = decl.value in
|
||||||
|
string "type " ^^ string name.value ^^ string " is"
|
||||||
|
^^ group (nest 2 (break 1 ^^ pp_type_expr type_expr))
|
||||||
|
|
||||||
|
and pp_type_expr = function
|
||||||
|
TProd t -> pp_cartesian t
|
||||||
|
| TSum t -> pp_variants t
|
||||||
|
| TRecord t -> pp_fields t
|
||||||
|
| TApp t -> pp_type_app t
|
||||||
|
| TFun t -> pp_fun_type t
|
||||||
|
| TPar t -> pp_type_par t
|
||||||
|
| TVar t -> pp_ident t
|
||||||
|
| TString s -> pp_string s
|
||||||
|
|
||||||
|
and pp_cartesian {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_type_expr e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_type_expr e ^^ string " *") ^^ app items
|
||||||
|
in pp_type_expr head ^^ string " *" ^^ app (List.map snd tail)
|
||||||
|
|
||||||
|
and pp_variants {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let head = pp_variant head in
|
||||||
|
let head = if tail = [] then head
|
||||||
|
else ifflat head (string " " ^^ head) in
|
||||||
|
let rest = List.map snd tail in
|
||||||
|
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
|
||||||
|
in head ^^ concat_map app rest
|
||||||
|
|
||||||
|
and pp_variant {value; _} =
|
||||||
|
let {constr; arg} = value in
|
||||||
|
match arg with
|
||||||
|
None -> pp_ident constr
|
||||||
|
| Some (_, e) ->
|
||||||
|
prefix 4 1 (pp_ident constr ^^ string " of") (pp_type_expr e)
|
||||||
|
|
||||||
|
and pp_fields fields = pp_ne_injection pp_field_decl fields
|
||||||
|
|
||||||
|
and pp_field_decl {value; _} =
|
||||||
|
let {field_name; field_type; _} = value in
|
||||||
|
let name = pp_ident field_name in
|
||||||
|
let t_expr = pp_type_expr field_type
|
||||||
|
in prefix 2 1 (name ^^ string " :") t_expr
|
||||||
|
|
||||||
|
and pp_fun_type {value; _} =
|
||||||
|
let lhs, _, rhs = value in
|
||||||
|
group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
|
||||||
|
|
||||||
|
and pp_type_par t = pp_par pp_type_expr t
|
||||||
|
|
||||||
|
and pp_type_app {value = ctor, tuple; _} =
|
||||||
|
prefix 2 1 (pp_type_constr ctor) (pp_type_tuple tuple)
|
||||||
|
|
||||||
|
and pp_type_constr ctor = string ctor.value
|
||||||
|
|
||||||
|
and pp_type_tuple {value; _} =
|
||||||
|
let head, tail = value.inside in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_type_expr e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items in
|
||||||
|
let components =
|
||||||
|
if tail = []
|
||||||
|
then pp_type_expr head
|
||||||
|
else pp_type_expr head ^^ string "," ^^ app (List.map snd tail)
|
||||||
|
in string "(" ^^ nest 1 (components ^^ string ")")
|
||||||
|
|
||||||
|
(* Function and procedure declarations *)
|
||||||
|
|
||||||
|
and pp_fun_expr {value; _} =
|
||||||
|
let {param; ret_type; return; _} : fun_expr = value in
|
||||||
|
let start = string "function" in
|
||||||
|
let parameters = pp_par pp_parameters param in
|
||||||
|
let return_t = pp_type_expr ret_type in
|
||||||
|
let expr = pp_expr return in
|
||||||
|
group (start ^^ nest 2 (break 1 ^^ parameters))
|
||||||
|
^^ group (break 1 ^^ nest 2 (string ": " ^^ return_t))
|
||||||
|
^^ string " is" ^^ group (nest 4 (break 1 ^^ expr))
|
||||||
|
|
||||||
|
and pp_fun_decl {value; _} =
|
||||||
|
let {kwd_recursive; fun_name; param;
|
||||||
|
ret_type; block_with; return; attributes; _} = value in
|
||||||
|
let start =
|
||||||
|
match kwd_recursive with
|
||||||
|
None -> string "function"
|
||||||
|
| Some _ -> string "recursive" ^/^ string "function" in
|
||||||
|
let start = start ^^ group (break 1 ^^ nest 2 (pp_ident fun_name)) in
|
||||||
|
let parameters = pp_par pp_parameters param in
|
||||||
|
let return_t = pp_type_expr ret_type in
|
||||||
|
let expr = pp_expr return in
|
||||||
|
let body =
|
||||||
|
match block_with with
|
||||||
|
None -> group (nest 2 (break 1 ^^ expr))
|
||||||
|
| Some (b,_) -> hardline ^^ pp_block b ^^ string " with"
|
||||||
|
^^ group (nest 4 (break 1 ^^ expr))
|
||||||
|
and attr =
|
||||||
|
match attributes with
|
||||||
|
None -> empty
|
||||||
|
| Some a -> hardline ^^ pp_attr_decl a in
|
||||||
|
prefix 2 1 start parameters
|
||||||
|
^^ group (nest 2 (break 1 ^^ string ": " ^^ nest 2 return_t ^^ string " is"))
|
||||||
|
^^ body ^^ attr
|
||||||
|
|
||||||
|
and pp_parameters p = pp_nsepseq ";" pp_param_decl p
|
||||||
|
|
||||||
|
and pp_param_decl = function
|
||||||
|
ParamConst c -> pp_param_const c
|
||||||
|
| ParamVar v -> pp_param_var v
|
||||||
|
|
||||||
|
and pp_param_const {value; _} =
|
||||||
|
let {var; param_type; _} : param_const = value in
|
||||||
|
let name = string ("const " ^ var.value) in
|
||||||
|
let t_expr = pp_type_expr param_type
|
||||||
|
in prefix 2 1 (name ^^ string " :") t_expr
|
||||||
|
|
||||||
|
and pp_param_var {value; _} =
|
||||||
|
let {var; param_type; _} : param_var = value in
|
||||||
|
let name = string ("var " ^ var.value) in
|
||||||
|
let t_expr = pp_type_expr param_type
|
||||||
|
in prefix 2 1 (name ^^ string " :") t_expr
|
||||||
|
|
||||||
|
and pp_block {value; _} =
|
||||||
|
string "block {"
|
||||||
|
^^ nest 2 (hardline ^^ pp_statements value.statements)
|
||||||
|
^^ hardline ^^ string "}"
|
||||||
|
|
||||||
|
and pp_statements s = pp_nsepseq ";" pp_statement s
|
||||||
|
|
||||||
|
and pp_statement = function
|
||||||
|
Instr s -> pp_instruction s
|
||||||
|
| Data s -> pp_data_decl s
|
||||||
|
| Attr s -> pp_attr_decl s
|
||||||
|
|
||||||
|
and pp_data_decl = function
|
||||||
|
LocalConst d -> pp_const_decl d
|
||||||
|
| LocalVar d -> pp_var_decl d
|
||||||
|
| LocalFun d -> pp_fun_decl d
|
||||||
|
|
||||||
|
and pp_var_decl {value; _} =
|
||||||
|
let {name; var_type; init; _} = value in
|
||||||
|
let start = string ("var " ^ name.value) in
|
||||||
|
let t_expr = pp_type_expr var_type in
|
||||||
|
group (start ^/^ nest 2 (string ": " ^^ t_expr))
|
||||||
|
^^ group (break 1 ^^ nest 2 (string ":= " ^^ pp_expr init))
|
||||||
|
|
||||||
|
and pp_instruction = function
|
||||||
|
Cond i -> group (pp_conditional i)
|
||||||
|
| CaseInstr i -> pp_case pp_if_clause i
|
||||||
|
| Assign i -> pp_assignment i
|
||||||
|
| Loop i -> pp_loop i
|
||||||
|
| ProcCall i -> pp_fun_call i
|
||||||
|
| Skip _ -> string "skip"
|
||||||
|
| RecordPatch i -> pp_record_patch i
|
||||||
|
| MapPatch i -> pp_map_patch i
|
||||||
|
| SetPatch i -> pp_set_patch i
|
||||||
|
| MapRemove i -> pp_map_remove i
|
||||||
|
| SetRemove i -> pp_set_remove i
|
||||||
|
|
||||||
|
and pp_set_remove {value; _} =
|
||||||
|
let {element; set; _} : set_remove = value in
|
||||||
|
string "remove" ^^ group (nest 2 (break 1 ^^ pp_expr element))
|
||||||
|
^^ group (break 1 ^^ prefix 2 1 (string "from set") (pp_path set))
|
||||||
|
|
||||||
|
and pp_map_remove {value; _} =
|
||||||
|
let {key; map; _} = value in
|
||||||
|
string "remove" ^^ group (nest 2 (break 1 ^^ pp_expr key))
|
||||||
|
^^ group (break 1 ^^ prefix 2 1 (string "from map") (pp_path map))
|
||||||
|
|
||||||
|
and pp_set_patch {value; _} =
|
||||||
|
let {path; set_inj; _} = value in
|
||||||
|
let inj = pp_ne_injection pp_expr set_inj in
|
||||||
|
string "patch"
|
||||||
|
^^ group (nest 2 (break 1 ^^ pp_path path) ^/^ string "with")
|
||||||
|
^^ group (nest 2 (break 1 ^^ inj))
|
||||||
|
|
||||||
|
and pp_map_patch {value; _} =
|
||||||
|
let {path; map_inj; _} = value in
|
||||||
|
let inj = pp_ne_injection pp_binding map_inj in
|
||||||
|
string "patch"
|
||||||
|
^^ group (nest 2 (break 1 ^^ pp_path path) ^/^ string "with")
|
||||||
|
^^ group (nest 2 (break 1 ^^ inj))
|
||||||
|
|
||||||
|
and pp_binding {value; _} =
|
||||||
|
let {source; image; _} = value in
|
||||||
|
pp_expr source
|
||||||
|
^^ string " ->" ^^ group (nest 2 (break 1 ^^ pp_expr image))
|
||||||
|
|
||||||
|
and pp_record_patch {value; _} =
|
||||||
|
let {path; record_inj; _} = value in
|
||||||
|
let inj = pp_record record_inj in
|
||||||
|
string "patch"
|
||||||
|
^^ group (nest 2 (break 1 ^^ pp_path path) ^/^ string "with")
|
||||||
|
^^ group (nest 2 (break 1 ^^ inj))
|
||||||
|
|
||||||
|
and pp_cond_expr {value; _} =
|
||||||
|
let {test; ifso; ifnot; _} : cond_expr = value in
|
||||||
|
let test = string "if " ^^ group (nest 3 (pp_expr test))
|
||||||
|
and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso))
|
||||||
|
and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot))
|
||||||
|
in test ^/^ ifso ^/^ ifnot
|
||||||
|
|
||||||
|
and pp_conditional {value; _} =
|
||||||
|
let {test; ifso; ifnot; _} : conditional = value in
|
||||||
|
let test = string "if " ^^ group (nest 3 (pp_expr test))
|
||||||
|
and ifso = match ifso with
|
||||||
|
ClauseInstr _ | ClauseBlock LongBlock _ ->
|
||||||
|
string "then"
|
||||||
|
^^ group (nest 2 (break 1 ^^ pp_if_clause ifso))
|
||||||
|
| ClauseBlock ShortBlock _ ->
|
||||||
|
string "then {"
|
||||||
|
^^ group (nest 2 (hardline ^^ pp_if_clause ifso))
|
||||||
|
^^ hardline ^^ string "}"
|
||||||
|
and ifnot = match ifnot with
|
||||||
|
ClauseInstr _ | ClauseBlock LongBlock _ ->
|
||||||
|
string "else"
|
||||||
|
^^ group (nest 2 (break 1 ^^ pp_if_clause ifnot))
|
||||||
|
| ClauseBlock ShortBlock _ ->
|
||||||
|
string "else {"
|
||||||
|
^^ group (nest 2 (hardline ^^ pp_if_clause ifnot))
|
||||||
|
^^ hardline ^^ string "}"
|
||||||
|
in test ^/^ ifso ^/^ ifnot
|
||||||
|
|
||||||
|
and pp_if_clause = function
|
||||||
|
ClauseInstr i -> pp_instruction i
|
||||||
|
| ClauseBlock b -> pp_clause_block b
|
||||||
|
|
||||||
|
and pp_clause_block = function
|
||||||
|
LongBlock b -> pp_block b
|
||||||
|
| ShortBlock b -> Utils.(pp_statements <@ fst) b.value.inside
|
||||||
|
|
||||||
|
and pp_set_membership {value; _} =
|
||||||
|
let {set; element; _} : set_membership = value in
|
||||||
|
group (pp_expr set ^/^ string "contains" ^/^ pp_expr element)
|
||||||
|
|
||||||
|
and pp_case : 'a.('a -> document) -> 'a case Region.reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
let {expr; cases; _} = value in
|
||||||
|
group (string "case " ^^ nest 5 (pp_expr expr) ^/^ string "of [")
|
||||||
|
^^ hardline ^^ pp_cases printer cases
|
||||||
|
^^ hardline ^^ string "]"
|
||||||
|
|
||||||
|
and pp_cases :
|
||||||
|
'a.('a -> document) ->
|
||||||
|
('a case_clause reg, vbar) Utils.nsepseq Region.reg ->
|
||||||
|
document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
let head, tail = value in
|
||||||
|
let head = pp_case_clause printer head in
|
||||||
|
let head = blank 2 ^^ head in
|
||||||
|
let rest = List.map snd tail in
|
||||||
|
let app clause = break 1 ^^ string "| " ^^ pp_case_clause printer clause
|
||||||
|
in head ^^ concat_map app rest
|
||||||
|
|
||||||
|
and pp_case_clause :
|
||||||
|
'a.('a -> document) -> 'a case_clause Region.reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
let {pattern; rhs; _} = value in
|
||||||
|
pp_pattern pattern ^^ prefix 4 1 (string " ->") (printer rhs)
|
||||||
|
|
||||||
|
and pp_assignment {value; _} =
|
||||||
|
let {lhs; rhs; _} = value in
|
||||||
|
prefix 2 1 (pp_lhs lhs ^^ string " :=") (pp_expr rhs)
|
||||||
|
|
||||||
|
and pp_lhs : lhs -> document = function
|
||||||
|
Path p -> pp_path p
|
||||||
|
| MapPath p -> pp_map_lookup p
|
||||||
|
|
||||||
|
and pp_loop = function
|
||||||
|
While l -> pp_while_loop l
|
||||||
|
| For f -> pp_for_loop f
|
||||||
|
|
||||||
|
and pp_while_loop {value; _} =
|
||||||
|
let {cond; block; _} = value in
|
||||||
|
prefix 2 1 (string "while") (pp_expr cond) ^^ hardline ^^ pp_block block
|
||||||
|
|
||||||
|
and pp_for_loop = function
|
||||||
|
ForInt l -> pp_for_int l
|
||||||
|
| ForCollect l -> pp_for_collect l
|
||||||
|
|
||||||
|
and pp_for_int {value; _} =
|
||||||
|
let {assign; bound; step; block; _} = value in
|
||||||
|
let step =
|
||||||
|
match step with
|
||||||
|
None -> empty
|
||||||
|
| Some (_, e) -> prefix 2 1 (string " step") (pp_expr e) in
|
||||||
|
prefix 2 1 (string "for") (pp_var_assign assign)
|
||||||
|
^^ prefix 2 1 (string " to") (pp_expr bound)
|
||||||
|
^^ step ^^ hardline ^^ pp_block block
|
||||||
|
|
||||||
|
and pp_var_assign {value; _} =
|
||||||
|
let {name; expr; _} = value in
|
||||||
|
prefix 2 1 (pp_ident name ^^ string " :=") (pp_expr expr)
|
||||||
|
|
||||||
|
and pp_for_collect {value; _} =
|
||||||
|
let {var; bind_to; collection; expr; block; _} = value in
|
||||||
|
let binding =
|
||||||
|
match bind_to with
|
||||||
|
None -> pp_ident var
|
||||||
|
| Some (_, dest) -> pp_ident var ^^ string " -> " ^^ pp_ident dest in
|
||||||
|
prefix 2 1 (string "for") binding
|
||||||
|
^^ prefix 2 1 (string " in") (pp_collection collection ^/^ pp_expr expr)
|
||||||
|
^^ hardline ^^ pp_block block
|
||||||
|
|
||||||
|
and pp_collection = function
|
||||||
|
Map _ -> string "map"
|
||||||
|
| Set _ -> string "set"
|
||||||
|
| List _ -> string "list"
|
||||||
|
|
||||||
|
(* Expressions *)
|
||||||
|
|
||||||
|
and pp_expr = function
|
||||||
|
ECase e -> pp_case pp_expr e
|
||||||
|
| ECond e -> group (pp_cond_expr e)
|
||||||
|
| EAnnot e -> pp_annot_expr e
|
||||||
|
| ELogic e -> group (pp_logic_expr e)
|
||||||
|
| EArith e -> group (pp_arith_expr e)
|
||||||
|
| EString e -> pp_string_expr e
|
||||||
|
| EList e -> group (pp_list_expr e)
|
||||||
|
| ESet e -> pp_set_expr e
|
||||||
|
| EConstr e -> pp_constr_expr e
|
||||||
|
| ERecord e -> pp_record e
|
||||||
|
| EProj e -> pp_projection e
|
||||||
|
| EUpdate e -> pp_update e
|
||||||
|
| EMap e -> pp_map_expr e
|
||||||
|
| EVar e -> pp_ident e
|
||||||
|
| ECall e -> pp_fun_call e
|
||||||
|
| EBytes e -> pp_bytes e
|
||||||
|
| EUnit _ -> string "Unit"
|
||||||
|
| ETuple e -> pp_tuple_expr e
|
||||||
|
| EPar e -> pp_par pp_expr e
|
||||||
|
| EFun e -> pp_fun_expr e
|
||||||
|
|
||||||
|
and pp_annot_expr {value; _} =
|
||||||
|
let expr, _, type_expr = value.inside in
|
||||||
|
group (string "(" ^^ nest 1 (pp_expr expr ^/^ string ": "
|
||||||
|
^^ pp_type_expr type_expr ^^ string ")"))
|
||||||
|
|
||||||
|
and pp_set_expr = function
|
||||||
|
SetInj inj -> pp_injection pp_expr inj
|
||||||
|
| SetMem mem -> pp_set_membership mem
|
||||||
|
|
||||||
|
and pp_map_expr = function
|
||||||
|
MapLookUp fetch -> pp_map_lookup fetch
|
||||||
|
| MapInj inj -> pp_injection pp_binding inj
|
||||||
|
| BigMapInj inj -> pp_injection pp_binding inj
|
||||||
|
|
||||||
|
and pp_map_lookup {value; _} =
|
||||||
|
prefix 2 1 (pp_path value.path) (pp_brackets pp_expr value.index)
|
||||||
|
|
||||||
|
and pp_path = function
|
||||||
|
Name v -> pp_ident v
|
||||||
|
| Path p -> pp_projection p
|
||||||
|
|
||||||
|
and pp_logic_expr = function
|
||||||
|
BoolExpr e -> pp_bool_expr e
|
||||||
|
| CompExpr e -> pp_comp_expr e
|
||||||
|
|
||||||
|
and pp_bool_expr = function
|
||||||
|
Or e -> pp_bin_op "or" e
|
||||||
|
| And e -> pp_bin_op "and" e
|
||||||
|
| Not e -> pp_un_op "not" e
|
||||||
|
| True _ -> string "True"
|
||||||
|
| False _ -> string "False"
|
||||||
|
|
||||||
|
and pp_bin_op op {value; _} =
|
||||||
|
let {arg1; arg2; _} = value
|
||||||
|
and length = String.length op + 1 in
|
||||||
|
pp_expr arg1 ^/^ string (op ^ " ") ^^ nest length (pp_expr arg2)
|
||||||
|
|
||||||
|
and pp_un_op op {value; _} =
|
||||||
|
string (op ^ " ") ^^ pp_expr value.arg
|
||||||
|
|
||||||
|
and pp_comp_expr = function
|
||||||
|
Lt e -> pp_bin_op "<" e
|
||||||
|
| Leq e -> pp_bin_op "<=" e
|
||||||
|
| Gt e -> pp_bin_op ">" e
|
||||||
|
| Geq e -> pp_bin_op ">=" e
|
||||||
|
| Equal e -> pp_bin_op "=" e
|
||||||
|
| Neq e -> pp_bin_op "=/=" e
|
||||||
|
|
||||||
|
and pp_arith_expr = function
|
||||||
|
Add e -> pp_bin_op "+" e
|
||||||
|
| Sub e -> pp_bin_op "-" e
|
||||||
|
| Mult e -> pp_bin_op "*" e
|
||||||
|
| Div e -> pp_bin_op "/" e
|
||||||
|
| Mod e -> pp_bin_op "mod" e
|
||||||
|
| Neg e -> string "-" ^^ pp_expr e.value.arg
|
||||||
|
| Int e -> pp_int e
|
||||||
|
| Nat e -> pp_nat e
|
||||||
|
| Mutez e -> pp_mutez e
|
||||||
|
|
||||||
|
and pp_mutez {value; _} =
|
||||||
|
Z.to_string (snd value) ^ "mutez" |> string
|
||||||
|
|
||||||
|
and pp_string_expr = function
|
||||||
|
Cat e -> pp_bin_op "^" e
|
||||||
|
| String e -> pp_string e
|
||||||
|
| Verbatim e -> pp_verbatim e
|
||||||
|
|
||||||
|
and pp_ident {value; _} = string value
|
||||||
|
|
||||||
|
and pp_string s = string "\"" ^^ pp_ident s ^^ string "\""
|
||||||
|
|
||||||
|
and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
|
||||||
|
|
||||||
|
and pp_list_expr = function
|
||||||
|
ECons e -> pp_bin_op "#" e
|
||||||
|
| EListComp e -> pp_injection pp_expr e
|
||||||
|
| ENil _ -> string "nil"
|
||||||
|
|
||||||
|
and pp_constr_expr = function
|
||||||
|
SomeApp a -> pp_some_app a
|
||||||
|
| NoneExpr _ -> string "None"
|
||||||
|
| ConstrApp a -> pp_constr_app a
|
||||||
|
|
||||||
|
and pp_some_app {value; _} =
|
||||||
|
prefix 4 1 (string "Some") (pp_arguments (snd value))
|
||||||
|
|
||||||
|
and pp_constr_app {value; _} =
|
||||||
|
let constr, args = value in
|
||||||
|
let constr = string constr.value in
|
||||||
|
match args with
|
||||||
|
None -> constr
|
||||||
|
| Some tuple -> prefix 2 1 constr (pp_tuple_expr tuple)
|
||||||
|
|
||||||
|
|
||||||
|
and pp_field_assign {value; _} =
|
||||||
|
let {field_name; field_expr; _} = value in
|
||||||
|
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_expr field_expr)
|
||||||
|
|
||||||
|
and pp_record ne_inj = group (pp_ne_injection pp_field_assign ne_inj)
|
||||||
|
|
||||||
|
and pp_projection {value; _} =
|
||||||
|
let {struct_name; field_path; _} = value in
|
||||||
|
let fields = Utils.nsepseq_to_list field_path
|
||||||
|
and sep = string "." ^^ break 0 in
|
||||||
|
let fields = separate_map sep pp_selection fields in
|
||||||
|
group (pp_ident struct_name ^^ string "." ^^ break 0 ^^ fields)
|
||||||
|
|
||||||
|
and pp_update {value; _} =
|
||||||
|
let {record; updates; _} = value in
|
||||||
|
let updates = group (pp_ne_injection pp_field_path_assign updates)
|
||||||
|
and record = pp_path record in
|
||||||
|
record ^^ string " with" ^^ nest 2 (break 1 ^^ updates)
|
||||||
|
|
||||||
|
and pp_field_path_assign {value; _} =
|
||||||
|
let {field_path; field_expr; _} = value in
|
||||||
|
let path = pp_path field_path in
|
||||||
|
prefix 2 1 (path ^^ string " =") (pp_expr field_expr)
|
||||||
|
|
||||||
|
and pp_selection = function
|
||||||
|
FieldName v -> string v.value
|
||||||
|
| Component cmp -> cmp.value |> snd |> Z.to_string |> string
|
||||||
|
|
||||||
|
and pp_tuple_expr {value; _} =
|
||||||
|
let head, tail = value.inside in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_expr e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_expr e ^^ string ",") ^^ app items in
|
||||||
|
let components =
|
||||||
|
if tail = []
|
||||||
|
then pp_expr head
|
||||||
|
else pp_expr head ^^ string "," ^^ app (List.map snd tail)
|
||||||
|
in string "(" ^^ nest 1 (components ^^ string ")")
|
||||||
|
|
||||||
|
and pp_fun_call {value; _} =
|
||||||
|
let lambda, arguments = value in
|
||||||
|
let arguments = pp_tuple_expr arguments in
|
||||||
|
group (pp_expr lambda ^^ nest 2 (break 1 ^^ arguments))
|
||||||
|
|
||||||
|
and pp_arguments v = pp_tuple_expr v
|
||||||
|
|
||||||
|
(* Injections *)
|
||||||
|
|
||||||
|
and pp_injection :
|
||||||
|
'a.('a -> document) -> 'a injection reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
let {kind; elements; _} = value in
|
||||||
|
let sep = string ";" ^^ break 1 in
|
||||||
|
let elements = Utils.sepseq_to_list elements in
|
||||||
|
let elements = separate_map sep printer elements in
|
||||||
|
let kwd = pp_injection_kwd kind in
|
||||||
|
group (string (kwd ^ " [")
|
||||||
|
^^ nest 2 (break 0 ^^ elements) ^^ break 0 ^^ string "]")
|
||||||
|
|
||||||
|
and pp_injection_kwd = function
|
||||||
|
InjSet _ -> "set"
|
||||||
|
| InjMap _ -> "map"
|
||||||
|
| InjBigMap _ -> "big_map"
|
||||||
|
| InjList _ -> "list"
|
||||||
|
|
||||||
|
and pp_ne_injection :
|
||||||
|
'a.('a -> document) -> 'a ne_injection reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
let {kind; ne_elements; _} = value in
|
||||||
|
let elements = pp_nsepseq ";" printer ne_elements in
|
||||||
|
let kwd = pp_ne_injection_kwd kind in
|
||||||
|
group (string (kwd ^ " [")
|
||||||
|
^^ group (nest 2 (break 0 ^^ elements ))
|
||||||
|
^^ break 0 ^^ string "]")
|
||||||
|
|
||||||
|
and pp_ne_injection_kwd = function
|
||||||
|
NEInjAttr _ -> "attributes"
|
||||||
|
| NEInjSet _ -> "set"
|
||||||
|
| NEInjMap _ -> "map"
|
||||||
|
| NEInjRecord _ -> "record"
|
||||||
|
|
||||||
|
and pp_nsepseq :
|
||||||
|
'a.string -> ('a -> document) -> ('a, t) Utils.nsepseq -> document =
|
||||||
|
fun sep printer elements ->
|
||||||
|
let elems = Utils.nsepseq_to_list elements
|
||||||
|
and sep = string sep ^^ break 1
|
||||||
|
in separate_map sep printer elems
|
||||||
|
|
||||||
|
(* Patterns *)
|
||||||
|
|
||||||
|
and pp_pattern = function
|
||||||
|
PConstr p -> pp_constr_pattern p
|
||||||
|
| PVar v -> pp_ident v
|
||||||
|
| PWild _ -> string "_"
|
||||||
|
| PInt i -> pp_int i
|
||||||
|
| PNat n -> pp_nat n
|
||||||
|
| PBytes b -> pp_bytes b
|
||||||
|
| PString s -> pp_string s
|
||||||
|
| PList l -> pp_list_pattern l
|
||||||
|
| PTuple t -> pp_tuple_pattern t
|
||||||
|
|
||||||
|
and pp_int {value; _} =
|
||||||
|
string (Z.to_string (snd value))
|
||||||
|
|
||||||
|
and pp_nat {value; _} =
|
||||||
|
string (Z.to_string (snd value) ^ "n")
|
||||||
|
|
||||||
|
and pp_bytes {value; _} =
|
||||||
|
string ("0x" ^ Hex.show (snd value))
|
||||||
|
|
||||||
|
and pp_constr_pattern = function
|
||||||
|
PUnit _ -> string "Unit"
|
||||||
|
| PFalse _ -> string "False"
|
||||||
|
| PTrue _ -> string "True"
|
||||||
|
| PNone _ -> string "None"
|
||||||
|
| PSomeApp a -> pp_psome a
|
||||||
|
| PConstrApp a -> pp_pconstr_app a
|
||||||
|
|
||||||
|
and pp_psome {value=_, p; _} =
|
||||||
|
prefix 4 1 (string "Some") (pp_par pp_pattern p)
|
||||||
|
|
||||||
|
and pp_pconstr_app {value; _} =
|
||||||
|
match value with
|
||||||
|
constr, None -> pp_ident constr
|
||||||
|
| constr, Some ptuple ->
|
||||||
|
prefix 4 1 (pp_ident constr) (pp_tuple_pattern ptuple)
|
||||||
|
|
||||||
|
and pp_tuple_pattern {value; _} =
|
||||||
|
let head, tail = value.inside in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_pattern e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_pattern e ^^ string ",") ^^ app items in
|
||||||
|
let components =
|
||||||
|
if tail = []
|
||||||
|
then pp_pattern head
|
||||||
|
else pp_pattern head ^^ string "," ^^ app (List.map snd tail)
|
||||||
|
in string "(" ^^ nest 1 (components ^^ string ")")
|
||||||
|
|
||||||
|
and pp_list_pattern = function
|
||||||
|
PListComp cmp -> pp_list_comp cmp
|
||||||
|
| PNil _ -> string "nil"
|
||||||
|
| PParCons p -> pp_ppar_cons p
|
||||||
|
| PCons p -> nest 4 (pp_nsepseq " #" pp_pattern p.value)
|
||||||
|
|
||||||
|
and pp_list_comp e = pp_injection pp_pattern e
|
||||||
|
|
||||||
|
and pp_ppar_cons {value; _} =
|
||||||
|
let patt1, _, patt2 = value.inside in
|
||||||
|
let comp = prefix 2 1 (pp_pattern patt1 ^^ string " ::") (pp_pattern patt2)
|
||||||
|
in string "(" ^^ nest 1 (comp ^^ string ")")
|
||||||
@ -1,10 +1,14 @@
|
|||||||
|
function incr_map (const l : list (int)) : list (int) is
|
||||||
|
List.map (function (const i : int) : int is i + 1, l)
|
||||||
|
|
||||||
type t is timestamp * nat -> map (string, address)
|
type t is timestamp * nat -> map (string, address)
|
||||||
type u is A | B of t * int | C of int -> (string -> int)
|
type u is A | B of t * int | C of int -> (string -> int)
|
||||||
type v is record a : t; b : record c : string end end
|
type v is record aaaaaa : ttttttt; bbbbbb : record ccccccccc : string end end
|
||||||
|
|
||||||
function back (var store : store) : list (operation) * store is
|
function back (var store : store) : list (operation) * store is
|
||||||
begin
|
begin
|
||||||
var operations : list (operation) := list [];
|
var operations : list (operation) := list [];
|
||||||
|
const operations : list (operation) = list [];
|
||||||
const a : nat = 0n;
|
const a : nat = 0n;
|
||||||
x0 := record foo = "1"; bar = 4n end;
|
x0 := record foo = "1"; bar = 4n end;
|
||||||
x1 := nil;
|
x1 := nil;
|
||||||
@ -13,7 +17,7 @@ function back (var store : store) : list (operation) * store is
|
|||||||
case foo of
|
case foo of
|
||||||
10n -> skip
|
10n -> skip
|
||||||
end;
|
end;
|
||||||
if s contains x then skip else skip;
|
if saaa.0.1.2.a.b.b.x contains xxxxxxxxxxxxxxx[123] then skip else skip;
|
||||||
s := set [3_000mutez; -2; 1n];
|
s := set [3_000mutez; -2; 1n];
|
||||||
a := A;
|
a := A;
|
||||||
b := B (a);
|
b := B (a);
|
||||||
@ -21,12 +25,12 @@ function back (var store : store) : list (operation) * store is
|
|||||||
d := None;
|
d := None;
|
||||||
e := Some (a, B (b));
|
e := Some (a, B (b));
|
||||||
z := z.1.2;
|
z := z.1.2;
|
||||||
x := map [1 -> "1"; 2 -> "2"];
|
x := if true then map [1 -> "1"; 2 -> "2"; 3 -> "3"; 4 -> "4"; 5 -> "5555555555555555"] else Unit;
|
||||||
y := a.b.c[3];
|
y := a.b.c[3];
|
||||||
a := "hello " ^ "world" ^ "!";
|
a := "hello " ^ "world" ^ "!";
|
||||||
r := record a = 0 end;
|
r := record aaaaaaaaaaaa = 100000000; bbbbbbb = ffffff (2, aa, x, y) + 1 end;
|
||||||
r := r with record a = 42 end;
|
r := r with record aaaaaaaaaaa = 444442; bbbbbbbbb = 43 + f (z) / 234 end;
|
||||||
patch store.backers with set [(1); f(2*3)];
|
patch store.backers.8.aa.33333.5 with set [(1); f(2*3); 123124234/2345];
|
||||||
remove (1,2,3) from set foo.bar;
|
remove (1,2,3) from set foo.bar;
|
||||||
remove 3 from map foo.bar;
|
remove 3 from map foo.bar;
|
||||||
patch store.backers with map [sender -> amount];
|
patch store.backers with map [sender -> amount];
|
||||||
@ -39,7 +43,7 @@ function back (var store : store) : list (operation) * store is
|
|||||||
begin
|
begin
|
||||||
acc := 2 - (if toggle then f(x) else Unit);
|
acc := 2 - (if toggle then f(x) else Unit);
|
||||||
end;
|
end;
|
||||||
for i := 1n to 10n
|
for i := 1n to 10n step 2n
|
||||||
begin
|
begin
|
||||||
acc := acc + i;
|
acc := acc + i;
|
||||||
end;
|
end;
|
||||||
@ -52,27 +56,32 @@ function back (var store : store) : list (operation) * store is
|
|||||||
| B (x, C (y,z)) -> skip
|
| B (x, C (y,z)) -> skip
|
||||||
| False#True#Unit#0xAA#"hi"#4#nil -> skip
|
| False#True#Unit#0xAA#"hi"#4#nil -> skip
|
||||||
]
|
]
|
||||||
end with (operations, store)
|
end with (operations, store, (more_stuff, and_here_too))
|
||||||
|
|
||||||
function claim (var store : store) : list (operation) * store is
|
function claim (var store : store; const bar : t; const baz : u; var z : operations * store * (more_stuff * and_here_too)) : list (operation) * store * timestamp * nat -> map (string, address) is
|
||||||
begin
|
begin
|
||||||
var operations : list (operation) := nil;
|
const operations : list (operation * map (address, map (longname, domain))) = nilllllllllll;
|
||||||
|
var operations : list (operation * map (address, map (longname, domain))) := nilllllllllll;
|
||||||
|
attributes ["foo"; "inline"];
|
||||||
if now <= store.deadline then
|
if now <= store.deadline then
|
||||||
failwith ("Too soon.")
|
failwith ("Too soon.")
|
||||||
else
|
else
|
||||||
case store.backers[sender] of
|
case store.backers[sender] of
|
||||||
None ->
|
None ->
|
||||||
failwith ("Not a backer.")
|
failwith ("Not a backer.")
|
||||||
|
| Some (0) -> skip
|
||||||
| Some (quantity) ->
|
| Some (quantity) ->
|
||||||
if balance >= store.goal or store.funded then
|
if balance >= store.goal or store.funded then
|
||||||
failwith ("Goal reached: no refund.")
|
failwith ("Goal reached: no refund.")
|
||||||
else
|
else
|
||||||
begin
|
begin
|
||||||
operations.0.foo := list [transaction (unit, sender, quantity)];
|
operations.0.foo := list [transaction (unit, sender, quantity); transaction (foo, bar, bazzzzzzzzzzzzzzz)];
|
||||||
remove sender from map store.backers
|
remove sender.0099999.fffff [fiar (abaxxasfdf)] from map store.backers.foooooo.barrrrr.01.bazzzzzzz
|
||||||
end
|
end
|
||||||
end
|
end
|
||||||
end with (operations, store)
|
end with long_function_name (operations, store, (more_stuff, (and_here_too, well_in_here_too), hello))
|
||||||
|
|
||||||
|
attributes ["inline"; "foo"]
|
||||||
|
|
||||||
function withdraw (var store : store) : list (operation) * store is
|
function withdraw (var store : store) : list (operation) * store is
|
||||||
begin
|
begin
|
||||||
|
|||||||
@ -15,8 +15,10 @@
|
|||||||
(name parser_pascaligo)
|
(name parser_pascaligo)
|
||||||
(public_name ligo.parser.pascaligo)
|
(public_name ligo.parser.pascaligo)
|
||||||
(modules
|
(modules
|
||||||
Scoping AST pascaligo Parser ParserLog LexToken ParErr)
|
Scoping AST pascaligo Parser ParserLog LexToken ParErr Pretty)
|
||||||
(libraries
|
(libraries
|
||||||
|
pprint
|
||||||
|
terminal_size
|
||||||
menhirLib
|
menhirLib
|
||||||
parser_shared
|
parser_shared
|
||||||
hex
|
hex
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@ -8,6 +8,7 @@ module Region = Simple_utils.Region
|
|||||||
module ParErr = Parser_reasonligo.ParErr
|
module ParErr = Parser_reasonligo.ParErr
|
||||||
module SyntaxError = Parser_reasonligo.SyntaxError
|
module SyntaxError = Parser_reasonligo.SyntaxError
|
||||||
module SSet = Set.Make (String)
|
module SSet = Set.Make (String)
|
||||||
|
module Pretty = Parser_reasonligo.Pretty
|
||||||
|
|
||||||
(* Mock IOs TODO: Fill them with CLI options *)
|
(* Mock IOs TODO: Fill them with CLI options *)
|
||||||
|
|
||||||
@ -22,7 +23,8 @@ module SubIO =
|
|||||||
ext : string; (* ".religo" *)
|
ext : string; (* ".religo" *)
|
||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : EvalOpt.command;
|
cmd : EvalOpt.command;
|
||||||
mono : bool
|
mono : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
let options : options =
|
let options : options =
|
||||||
@ -37,6 +39,7 @@ module SubIO =
|
|||||||
method mode = `Point
|
method mode = `Point
|
||||||
method cmd = EvalOpt.Quiet
|
method cmd = EvalOpt.Quiet
|
||||||
method mono = false
|
method mono = false
|
||||||
|
method pretty = false
|
||||||
end
|
end
|
||||||
|
|
||||||
let make =
|
let make =
|
||||||
@ -49,6 +52,7 @@ module SubIO =
|
|||||||
~mode:options#mode
|
~mode:options#mode
|
||||||
~cmd:options#cmd
|
~cmd:options#cmd
|
||||||
~mono:options#mono
|
~mono:options#mono
|
||||||
|
~pretty:options#pretty
|
||||||
end
|
end
|
||||||
|
|
||||||
module Parser =
|
module Parser =
|
||||||
@ -178,3 +182,18 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
|
|||||||
(* Preprocessing a contract in a file *)
|
(* Preprocessing a contract in a file *)
|
||||||
|
|
||||||
let preprocess source = apply (fun () -> Unit.preprocess source)
|
let preprocess source = apply (fun () -> Unit.preprocess source)
|
||||||
|
|
||||||
|
(* Pretty-print a file (after parsing it). *)
|
||||||
|
|
||||||
|
let pretty_print source =
|
||||||
|
match parse_file source with
|
||||||
|
Stdlib.Error _ as e -> e
|
||||||
|
| Ok ast ->
|
||||||
|
let doc = Pretty.print (fst ast) in
|
||||||
|
let buffer = Buffer.create 131 in
|
||||||
|
let width =
|
||||||
|
match Terminal_size.get_columns () with
|
||||||
|
None -> 60
|
||||||
|
| Some c -> c in
|
||||||
|
let () = PPrint.ToBuffer.pretty 1.0 width buffer doc
|
||||||
|
in Trace.ok buffer
|
||||||
|
|||||||
@ -19,3 +19,6 @@ val parse_expression : string -> AST.expr Trace.result
|
|||||||
|
|
||||||
(** Preprocess a given ReasonLIGO file and preprocess it. *)
|
(** Preprocess a given ReasonLIGO file and preprocess it. *)
|
||||||
val preprocess : string -> Buffer.t Trace.result
|
val preprocess : string -> Buffer.t Trace.result
|
||||||
|
|
||||||
|
(** Pretty-print a given CameLIGO file (after parsing it). *)
|
||||||
|
val pretty_print : string -> Buffer.t Trace.result
|
||||||
|
|||||||
@ -27,5 +27,3 @@ Stubs/Parser_cameligo.ml
|
|||||||
../cameligo/ParserLog.ml
|
../cameligo/ParserLog.ml
|
||||||
../cameligo/Scoping.mli
|
../cameligo/Scoping.mli
|
||||||
../cameligo/Scoping.ml
|
../cameligo/Scoping.ml
|
||||||
|
|
||||||
$HOME/git/ligo/_build/default/src/passes/1-parser/reasonligo/ParErr.ml
|
|
||||||
|
|||||||
@ -125,7 +125,7 @@ nsepseq(item,sep):
|
|||||||
(* Non-empty comma-separated values (at least two values) *)
|
(* Non-empty comma-separated values (at least two values) *)
|
||||||
|
|
||||||
tuple(item):
|
tuple(item):
|
||||||
item "," nsepseq(item,",") { let h,t = $3 in $1,($2,h)::t }
|
item "," nsepseq(item,",") { let h,t = $3 in $1, ($2,h)::t }
|
||||||
|
|
||||||
(* Possibly empty semicolon-separated values between brackets *)
|
(* Possibly empty semicolon-separated values between brackets *)
|
||||||
|
|
||||||
@ -279,15 +279,12 @@ let_binding:
|
|||||||
| par(closed_irrefutable) type_annotation? "=" expr {
|
| par(closed_irrefutable) type_annotation? "=" expr {
|
||||||
wild_error $4;
|
wild_error $4;
|
||||||
Scoping.check_pattern $1.value.inside;
|
Scoping.check_pattern $1.value.inside;
|
||||||
{binders = PPar $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
|
{binders = $1.value.inside, []; lhs_type=$2; eq=$3; let_rhs=$4}
|
||||||
}
|
}
|
||||||
| tuple(sub_irrefutable) type_annotation? "=" expr {
|
| tuple(sub_irrefutable) type_annotation? "=" expr {
|
||||||
wild_error $4;
|
wild_error $4;
|
||||||
Utils.nsepseq_iter Scoping.check_pattern $1;
|
Utils.nsepseq_iter Scoping.check_pattern $1;
|
||||||
let hd, tl = $1 in
|
let region = nsepseq_to_region pattern_to_region $1 in
|
||||||
let start = pattern_to_region hd in
|
|
||||||
let stop = last fst tl in
|
|
||||||
let region = cover start stop in
|
|
||||||
let binders = PTuple {value=$1; region}, [] in
|
let binders = PTuple {value=$1; region}, [] in
|
||||||
{binders; lhs_type=$2; eq=$3; let_rhs=$4} }
|
{binders; lhs_type=$2; eq=$3; let_rhs=$4} }
|
||||||
|
|
||||||
@ -433,7 +430,18 @@ type_expr_simple:
|
|||||||
TProd {region = cover $1 $3; value=$2}
|
TProd {region = cover $1 $3; value=$2}
|
||||||
}
|
}
|
||||||
| "(" type_expr_simple "=>" type_expr_simple ")" {
|
| "(" type_expr_simple "=>" type_expr_simple ")" {
|
||||||
TFun {region = cover $1 $5; value=$2,$3,$4} }
|
TPar {
|
||||||
|
value = {
|
||||||
|
lpar = $1;
|
||||||
|
rpar = $5;
|
||||||
|
inside = TFun {
|
||||||
|
region = cover (type_expr_to_region $2) (type_expr_to_region $4);
|
||||||
|
value=$2,$3,$4
|
||||||
|
}
|
||||||
|
};
|
||||||
|
region = cover $1 $5;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
type_annotation_simple:
|
type_annotation_simple:
|
||||||
":" type_expr_simple { $1,$2 }
|
":" type_expr_simple { $1,$2 }
|
||||||
@ -456,8 +464,15 @@ fun_expr(right_expr):
|
|||||||
)
|
)
|
||||||
| EAnnot {region; value = {inside = EVar v, colon, typ; _}} ->
|
| EAnnot {region; value = {inside = EVar v, colon, typ; _}} ->
|
||||||
Scoping.check_reserved_name v;
|
Scoping.check_reserved_name v;
|
||||||
let value = {pattern = PVar v; colon; type_expr = typ}
|
let value = {pattern = PVar v; colon; type_expr = typ} in
|
||||||
in PTyped {region; value}
|
PPar {
|
||||||
|
value = {
|
||||||
|
lpar = Region.ghost;
|
||||||
|
rpar = Region.ghost;
|
||||||
|
inside = PTyped {region; value}
|
||||||
|
};
|
||||||
|
region
|
||||||
|
}
|
||||||
| EPar p ->
|
| EPar p ->
|
||||||
let value =
|
let value =
|
||||||
{p.value with inside = arg_to_pattern p.value.inside}
|
{p.value with inside = arg_to_pattern p.value.inside}
|
||||||
@ -497,7 +512,13 @@ fun_expr(right_expr):
|
|||||||
(arg_to_pattern fun_arg, [])
|
(arg_to_pattern fun_arg, [])
|
||||||
| EPar {value = {inside = EFun {
|
| EPar {value = {inside = EFun {
|
||||||
value = {
|
value = {
|
||||||
binders = PTyped { value = { pattern; colon; type_expr }; region = fun_region }, [];
|
binders = PPar {
|
||||||
|
value = {
|
||||||
|
inside = PTyped { value = { pattern; colon; type_expr }; region = fun_region };
|
||||||
|
_
|
||||||
|
};
|
||||||
|
_
|
||||||
|
}, [];
|
||||||
arrow;
|
arrow;
|
||||||
body;
|
body;
|
||||||
_
|
_
|
||||||
@ -656,7 +677,7 @@ disj_expr_level:
|
|||||||
disj_expr
|
disj_expr
|
||||||
| conj_expr_level { $1 }
|
| conj_expr_level { $1 }
|
||||||
| par(tuple(disj_expr_level)) type_annotation_simple? {
|
| par(tuple(disj_expr_level)) type_annotation_simple? {
|
||||||
let region = $1.region in
|
let region = nsepseq_to_region expr_to_region $1.value.inside in
|
||||||
let tuple = ETuple {value=$1.value.inside; region} in
|
let tuple = ETuple {value=$1.value.inside; region} in
|
||||||
let region =
|
let region =
|
||||||
match $2 with
|
match $2 with
|
||||||
@ -891,7 +912,7 @@ update_record:
|
|||||||
lbrace = $1;
|
lbrace = $1;
|
||||||
record = $3;
|
record = $3;
|
||||||
kwd_with = $4;
|
kwd_with = $4;
|
||||||
updates = {value = {compound = Braces($1,$6);
|
updates = {value = {compound = Braces (ghost, ghost);
|
||||||
ne_elements;
|
ne_elements;
|
||||||
terminator};
|
terminator};
|
||||||
region = cover $4 $6};
|
region = cover $4 $6};
|
||||||
@ -921,10 +942,9 @@ exprs:
|
|||||||
in
|
in
|
||||||
let sequence = ESeq {
|
let sequence = ESeq {
|
||||||
value = {
|
value = {
|
||||||
compound = BeginEnd(Region.ghost, Region.ghost);
|
compound = BeginEnd (ghost, ghost);
|
||||||
elements = Some val_;
|
elements = Some val_;
|
||||||
terminator = (snd c)
|
terminator = snd c};
|
||||||
};
|
|
||||||
region = sequence_region
|
region = sequence_region
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
@ -959,9 +979,8 @@ sequence:
|
|||||||
let value = {compound;
|
let value = {compound;
|
||||||
elements = Some elts;
|
elements = Some elts;
|
||||||
terminator = None} in
|
terminator = None} in
|
||||||
let region = cover $1 $3 in
|
let region = cover $1 $3
|
||||||
{region; value}
|
in {region; value} }
|
||||||
}
|
|
||||||
|
|
||||||
record:
|
record:
|
||||||
"{" field_assignment more_field_assignments? "}" {
|
"{" field_assignment more_field_assignments? "}" {
|
||||||
@ -986,46 +1005,29 @@ record:
|
|||||||
let ne_elements = Utils.nsepseq_cons field_name comma elts in
|
let ne_elements = Utils.nsepseq_cons field_name comma elts in
|
||||||
let compound = Braces ($1,$4) in
|
let compound = Braces ($1,$4) in
|
||||||
let region = cover $1 $4 in
|
let region = cover $1 $4 in
|
||||||
{ value = {compound; ne_elements; terminator = None}; region }
|
{value = {compound; ne_elements; terminator = None}; region} }
|
||||||
}
|
|
||||||
|
|
||||||
field_assignment_punning:
|
field_assignment_punning:
|
||||||
(* This can only happen with multiple fields -
|
(* This can only happen with multiple fields -
|
||||||
one item punning does NOT work in ReasonML *)
|
one item punning does NOT work in ReasonML *)
|
||||||
field_name {
|
field_name {
|
||||||
let value = {
|
let value = {field_name = $1;
|
||||||
field_name = $1;
|
|
||||||
assignment = ghost;
|
assignment = ghost;
|
||||||
field_expr = EVar $1 }
|
field_expr = EVar $1}
|
||||||
in {$1 with value}
|
in {$1 with value}
|
||||||
}
|
}
|
||||||
| field_assignment { $1 }
|
| field_assignment { $1 }
|
||||||
|
|
||||||
field_assignment:
|
field_assignment:
|
||||||
field_name ":" expr {
|
field_name ":" expr {
|
||||||
let start = $1.region in
|
let region = cover $1.region (expr_to_region $3)
|
||||||
let stop = expr_to_region $3 in
|
and value = {field_name = $1;
|
||||||
let region = cover start stop in
|
|
||||||
let value = {
|
|
||||||
field_name = $1;
|
|
||||||
assignment = $2;
|
assignment = $2;
|
||||||
field_expr = $3}
|
field_expr = $3}
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|
||||||
field_path_assignment:
|
field_path_assignment:
|
||||||
field_name {
|
path ":" expr {
|
||||||
let value = {
|
let region = cover (path_to_region $1) (expr_to_region $3)
|
||||||
field_path = ($1,[]);
|
and value = {field_path=$1; assignment=$2; field_expr=$3}
|
||||||
assignment = ghost;
|
|
||||||
field_expr = EVar $1 }
|
|
||||||
in {$1 with value}
|
|
||||||
}
|
|
||||||
| nsepseq(field_name,".") ":" expr {
|
|
||||||
let start = nsepseq_to_region (fun x -> x.region) $1 in
|
|
||||||
let stop = expr_to_region $3 in
|
|
||||||
let region = cover start stop in
|
|
||||||
let value = {
|
|
||||||
field_path = $1;
|
|
||||||
assignment = $2;
|
|
||||||
field_expr = $3}
|
|
||||||
in {region; value} }
|
in {region; value} }
|
||||||
|
|||||||
@ -22,7 +22,8 @@ module SubIO =
|
|||||||
ext : string;
|
ext : string;
|
||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : EvalOpt.command;
|
cmd : EvalOpt.command;
|
||||||
mono : bool
|
mono : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
let options : options =
|
let options : options =
|
||||||
@ -36,6 +37,7 @@ module SubIO =
|
|||||||
method mode = IO.options#mode
|
method mode = IO.options#mode
|
||||||
method cmd = IO.options#cmd
|
method cmd = IO.options#cmd
|
||||||
method mono = IO.options#mono
|
method mono = IO.options#mono
|
||||||
|
method pretty = IO.options#pretty
|
||||||
end
|
end
|
||||||
|
|
||||||
let make =
|
let make =
|
||||||
@ -48,6 +50,7 @@ module SubIO =
|
|||||||
~mode:options#mode
|
~mode:options#mode
|
||||||
~cmd:options#cmd
|
~cmd:options#cmd
|
||||||
~mono:options#mono
|
~mono:options#mono
|
||||||
|
~pretty:options#pretty
|
||||||
end
|
end
|
||||||
|
|
||||||
module Parser =
|
module Parser =
|
||||||
@ -67,12 +70,23 @@ module ParserLog =
|
|||||||
module Lexer = Lexer.Make (LexToken)
|
module Lexer = Lexer.Make (LexToken)
|
||||||
|
|
||||||
module Unit =
|
module Unit =
|
||||||
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
|
ParserUnit.Make (Lexer)(AST)(Parser)(Parser_msg)(ParserLog)(SubIO)
|
||||||
|
|
||||||
(* Main *)
|
(* Main *)
|
||||||
|
|
||||||
let wrap = function
|
let wrap = function
|
||||||
Stdlib.Ok _ -> flush_all ()
|
Stdlib.Ok ast ->
|
||||||
|
if IO.options#pretty then
|
||||||
|
begin
|
||||||
|
let doc = Pretty.print ast in
|
||||||
|
let width =
|
||||||
|
match Terminal_size.get_columns () with
|
||||||
|
None -> 60
|
||||||
|
| Some c -> c in
|
||||||
|
PPrint.ToChannel.pretty 1.0 width stdout doc;
|
||||||
|
print_newline ()
|
||||||
|
end;
|
||||||
|
flush_all ()
|
||||||
| Error msg ->
|
| Error msg ->
|
||||||
(flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)
|
(flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)
|
||||||
|
|
||||||
|
|||||||
471
src/passes/01-parser/reasonligo/Pretty.ml
Normal file
471
src/passes/01-parser/reasonligo/Pretty.ml
Normal file
@ -0,0 +1,471 @@
|
|||||||
|
[@@@warning "-42"]
|
||||||
|
|
||||||
|
open AST
|
||||||
|
module Region = Simple_utils.Region
|
||||||
|
open! Region
|
||||||
|
open! PPrint
|
||||||
|
|
||||||
|
let rec print ast =
|
||||||
|
let app decl = group (pp_declaration decl) in
|
||||||
|
separate_map (hardline ^^ hardline) app (Utils.nseq_to_list ast.decl)
|
||||||
|
|
||||||
|
and pp_declaration = function
|
||||||
|
Let decl -> pp_let_decl decl
|
||||||
|
| TypeDecl decl -> pp_type_decl decl
|
||||||
|
|
||||||
|
and pp_let_decl = function
|
||||||
|
| {value = (_,rec_opt, binding, attr); _} ->
|
||||||
|
let let_str =
|
||||||
|
match rec_opt with
|
||||||
|
None -> "let "
|
||||||
|
| Some _ -> "let rec " in
|
||||||
|
let bindings = pp_let_binding let_str binding
|
||||||
|
and attr = pp_attributes attr
|
||||||
|
in group (attr ^^ bindings ^^ string ";")
|
||||||
|
|
||||||
|
and pp_attributes = function
|
||||||
|
[] -> empty
|
||||||
|
| attr ->
|
||||||
|
let make s = string "[@" ^^ string s.value ^^ string "]" in
|
||||||
|
group (break 0 ^^ separate_map (break 0) make attr) ^^ hardline
|
||||||
|
|
||||||
|
and pp_ident {value; _} = string value
|
||||||
|
|
||||||
|
and pp_string s = string "\"" ^^ pp_ident s ^^ string "\""
|
||||||
|
|
||||||
|
and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
|
||||||
|
|
||||||
|
and pp_let_binding let_ (binding : let_binding) =
|
||||||
|
let {binders; lhs_type; let_rhs; _} = binding in
|
||||||
|
let patterns = Utils.nseq_to_list binders in
|
||||||
|
let patterns = group (separate_map (break 0) pp_pattern patterns) in
|
||||||
|
let lhs =
|
||||||
|
string let_ ^^
|
||||||
|
match lhs_type with
|
||||||
|
None -> patterns ^^ string " = "
|
||||||
|
| Some (_,e) ->
|
||||||
|
patterns ^^ group (break 0 ^^ string ": " ^^ pp_type_expr e ^^ string " = ")
|
||||||
|
in
|
||||||
|
let rhs = pp_expr let_rhs in
|
||||||
|
match let_rhs with
|
||||||
|
| EFun _
|
||||||
|
| ESeq _
|
||||||
|
| ERecord _ -> lhs ^^ rhs
|
||||||
|
| _ -> prefix 2 0 lhs rhs
|
||||||
|
|
||||||
|
and pp_pattern = function
|
||||||
|
PConstr p -> pp_pconstr p
|
||||||
|
| PUnit _ -> string "()"
|
||||||
|
| PFalse _ -> string "false"
|
||||||
|
| PTrue _ -> string "true"
|
||||||
|
| PVar v -> pp_ident v
|
||||||
|
| PInt i -> pp_int i
|
||||||
|
| PNat n -> pp_nat n
|
||||||
|
| PBytes b -> pp_bytes b
|
||||||
|
| PString s -> pp_string s
|
||||||
|
| PVerbatim s -> pp_verbatim s
|
||||||
|
| PWild _ -> string "_"
|
||||||
|
| PList l -> pp_plist l
|
||||||
|
| PTuple t -> pp_ptuple t
|
||||||
|
| PPar p -> pp_ppar p
|
||||||
|
| PRecord r -> pp_precord r
|
||||||
|
| PTyped t -> pp_ptyped t
|
||||||
|
|
||||||
|
and pp_pconstr = function
|
||||||
|
PNone _ -> string "None"
|
||||||
|
| PSomeApp p -> pp_patt_some p
|
||||||
|
| PConstrApp a -> pp_patt_c_app a
|
||||||
|
|
||||||
|
and pp_patt_c_app {value; _} =
|
||||||
|
match value with
|
||||||
|
constr, None -> pp_ident constr
|
||||||
|
| constr, Some (PVar _ as pat) ->
|
||||||
|
prefix 2 1 (pp_ident constr) (pp_pattern pat)
|
||||||
|
| constr, Some (_ as pat)->
|
||||||
|
prefix 2 0 (pp_ident constr) (pp_pattern pat)
|
||||||
|
|
||||||
|
and pp_patt_some {value; _} =
|
||||||
|
prefix 2 0 (string "Some") (pp_pattern (snd value))
|
||||||
|
|
||||||
|
and pp_int {value; _} =
|
||||||
|
string (Z.to_string (snd value))
|
||||||
|
|
||||||
|
and pp_nat {value; _} =
|
||||||
|
string (Z.to_string (snd value) ^ "n")
|
||||||
|
|
||||||
|
and pp_bytes {value; _} =
|
||||||
|
string ("0x" ^ Hex.show (snd value))
|
||||||
|
|
||||||
|
and pp_ppar {value; _} =
|
||||||
|
if value.lpar = Region.ghost then
|
||||||
|
nest 1 (pp_pattern value.inside)
|
||||||
|
else
|
||||||
|
string "(" ^^ nest 1 (pp_pattern value.inside) ^^ string ")"
|
||||||
|
|
||||||
|
and pp_plist = function
|
||||||
|
PListComp cmp -> pp_list_comp cmp
|
||||||
|
| PCons cons -> pp_cons cons
|
||||||
|
|
||||||
|
and pp_list_comp e = group (pp_injection pp_pattern e)
|
||||||
|
|
||||||
|
and pp_cons {value; _} =
|
||||||
|
let patt1, _, patt2 = value in
|
||||||
|
string "[" ^^ (pp_pattern patt1 ^^ string ", ") ^^ group ( break 0 ^^ string "..." ^^ pp_pattern patt2) ^^ string "]"
|
||||||
|
|
||||||
|
and pp_ptuple {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [p] -> group (break 1 ^^ pp_pattern p)
|
||||||
|
| p::items ->
|
||||||
|
group (break 1 ^^ pp_pattern p ^^ string ",") ^^ app items
|
||||||
|
in if tail = []
|
||||||
|
then string "(" ^^ nest 1 (pp_pattern head) ^^ string ")"
|
||||||
|
else string "(" ^^ nest 1 (pp_pattern head ^^ string "," ^^ app (List.map snd tail)) ^^ string ")"
|
||||||
|
|
||||||
|
and pp_precord fields = pp_ne_injection pp_field_pattern fields
|
||||||
|
|
||||||
|
and pp_field_pattern {value; _} =
|
||||||
|
let {field_name; pattern; _} = value in
|
||||||
|
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_pattern pattern)
|
||||||
|
|
||||||
|
and pp_ptyped {value; _} =
|
||||||
|
let {pattern; type_expr; _} = value in
|
||||||
|
group (pp_pattern pattern ^^ string ": " ^^ pp_type_expr type_expr)
|
||||||
|
|
||||||
|
and pp_type_decl decl =
|
||||||
|
let {name; type_expr; _} = decl.value in
|
||||||
|
string "type " ^^ string name.value ^^ string " = "
|
||||||
|
^^ group (pp_type_expr type_expr) ^^ string ";"
|
||||||
|
|
||||||
|
and pp_expr = function
|
||||||
|
ECase e -> pp_case_expr e
|
||||||
|
| ECond e -> group (pp_cond_expr e)
|
||||||
|
| EAnnot e -> pp_annot_expr e
|
||||||
|
| ELogic e -> pp_logic_expr e
|
||||||
|
| EArith e -> group (pp_arith_expr e)
|
||||||
|
| EString e -> pp_string_expr e
|
||||||
|
| EList e -> group (pp_list_expr e)
|
||||||
|
| EConstr e -> pp_constr_expr e
|
||||||
|
| ERecord e -> pp_record_expr e
|
||||||
|
| EProj e -> pp_projection e
|
||||||
|
| EUpdate e -> pp_update e
|
||||||
|
| EVar v -> pp_ident v
|
||||||
|
| ECall e -> pp_call_expr e
|
||||||
|
| EBytes e -> pp_bytes e
|
||||||
|
| EUnit _ -> string "()"
|
||||||
|
| ETuple e -> pp_tuple_expr e
|
||||||
|
| EPar e -> pp_par_expr e
|
||||||
|
| ELetIn e -> pp_let_in e
|
||||||
|
| EFun e -> pp_fun e
|
||||||
|
| ESeq e -> pp_seq e
|
||||||
|
|
||||||
|
and pp_case_expr {value; _} =
|
||||||
|
let {expr; cases; _} = value in
|
||||||
|
group (string "switch" ^^ string "(" ^^ nest 1 (pp_expr expr)
|
||||||
|
^^ string ") " ^^ string "{"
|
||||||
|
^^ pp_cases cases ^^ hardline ^^ string "}")
|
||||||
|
|
||||||
|
and pp_cases {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let rest = List.map snd tail in
|
||||||
|
let app clause = break 1 ^^ string "| " ^^ pp_clause clause
|
||||||
|
in concat_map app (head :: rest)
|
||||||
|
|
||||||
|
and pp_clause {value; _} =
|
||||||
|
let {pattern; rhs; _} = value in
|
||||||
|
prefix 4 1 (pp_pattern pattern ^^ string " =>") (pp_expr rhs)
|
||||||
|
|
||||||
|
and pp_cond_expr {value; _} =
|
||||||
|
let {test; ifso; kwd_else; ifnot; _} = value in
|
||||||
|
let if_then =
|
||||||
|
string "if" ^^ string " (" ^^ pp_expr test ^^ string ")" ^^ string " {" ^^ break 0
|
||||||
|
^^ group (nest 2 (break 2 ^^ pp_expr ifso)) ^^ hardline ^^ string "}" in
|
||||||
|
if kwd_else#is_ghost then
|
||||||
|
if_then
|
||||||
|
else
|
||||||
|
if_then
|
||||||
|
^^ string " else" ^^ string " {" ^^ break 0 ^^ group (nest 2 (break 2 ^^ pp_expr ifnot)) ^^ hardline ^^ string "}"
|
||||||
|
|
||||||
|
and pp_annot_expr {value; _} =
|
||||||
|
let expr, _, type_expr = value.inside in
|
||||||
|
group (nest 1 (pp_expr expr ^/^ string ": "
|
||||||
|
^^ pp_type_expr type_expr))
|
||||||
|
|
||||||
|
and pp_logic_expr = function
|
||||||
|
BoolExpr e -> pp_bool_expr e
|
||||||
|
| CompExpr e -> pp_comp_expr e
|
||||||
|
|
||||||
|
and pp_bool_expr = function
|
||||||
|
Or e -> pp_bin_op "||" e
|
||||||
|
| And e -> pp_bin_op "&&" e
|
||||||
|
| Not e -> pp_un_op "!" e
|
||||||
|
| True _ -> string "true"
|
||||||
|
| False _ -> string "false"
|
||||||
|
|
||||||
|
and pp_bin_op op {value; _} =
|
||||||
|
let {arg1; arg2; _} = value
|
||||||
|
and length = String.length op + 1 in
|
||||||
|
pp_expr arg1 ^^ string " " ^^ string (op ^ " ") ^^ nest length (pp_expr arg2)
|
||||||
|
|
||||||
|
and pp_un_op op {value; _} =
|
||||||
|
string (op ^ " ") ^^ pp_expr value.arg
|
||||||
|
|
||||||
|
and pp_comp_expr = function
|
||||||
|
Lt e -> pp_bin_op "<" e
|
||||||
|
| Leq e -> pp_bin_op "<=" e
|
||||||
|
| Gt e -> pp_bin_op ">" e
|
||||||
|
| Geq e -> pp_bin_op ">=" e
|
||||||
|
| Equal e -> pp_bin_op "==" e
|
||||||
|
| Neq e -> pp_bin_op "!=" e
|
||||||
|
|
||||||
|
and pp_arith_expr = function
|
||||||
|
Add e -> pp_bin_op "+" e
|
||||||
|
| Sub e -> pp_bin_op "-" e
|
||||||
|
| Mult e -> pp_bin_op "*" e
|
||||||
|
| Div e -> pp_bin_op "/" e
|
||||||
|
| Mod e -> pp_bin_op "mod" e
|
||||||
|
| Neg e -> string "-" ^^ pp_expr e.value.arg
|
||||||
|
| Int e -> pp_int e
|
||||||
|
| Nat e -> pp_nat e
|
||||||
|
| Mutez e -> pp_mutez e
|
||||||
|
|
||||||
|
and pp_mutez {value; _} =
|
||||||
|
Z.to_string (snd value) ^ "mutez" |> string
|
||||||
|
|
||||||
|
and pp_string_expr = function
|
||||||
|
Cat e -> pp_bin_op "++" e
|
||||||
|
| String e -> pp_string e
|
||||||
|
| Verbatim e -> pp_verbatim e
|
||||||
|
|
||||||
|
and pp_list_expr = function
|
||||||
|
| ECons {value = {arg1; arg2; _}; _ } ->
|
||||||
|
string "[" ^^ pp_expr arg1 ^^ string "," ^^ break 1 ^^ string "..." ^^ pp_expr arg2 ^^ string "]"
|
||||||
|
| EListComp e -> group (pp_injection pp_expr e)
|
||||||
|
|
||||||
|
and pp_injection :
|
||||||
|
'a.('a -> document) -> 'a injection reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
let {compound; elements; _} = value in
|
||||||
|
let sep = (string ",") ^^ break 1 in
|
||||||
|
let elements = Utils.sepseq_to_list elements in
|
||||||
|
let elements = separate_map sep printer elements in
|
||||||
|
match pp_compound compound with
|
||||||
|
None -> elements
|
||||||
|
| Some (opening, closing) ->
|
||||||
|
string opening ^^ nest 1 elements ^^ string closing
|
||||||
|
|
||||||
|
and pp_compound = function
|
||||||
|
BeginEnd (start, _) ->
|
||||||
|
if start#is_ghost then None else Some ("begin","end")
|
||||||
|
| Braces (start, _) ->
|
||||||
|
if start#is_ghost then None else Some ("{","}")
|
||||||
|
| Brackets (start, _) ->
|
||||||
|
if start#is_ghost then None else Some ("[","]")
|
||||||
|
|
||||||
|
and pp_constr_expr = function
|
||||||
|
ENone _ -> string "None"
|
||||||
|
| ESomeApp a -> pp_some a
|
||||||
|
| EConstrApp a -> pp_constr_app a
|
||||||
|
|
||||||
|
and pp_some {value=_, e; _} =
|
||||||
|
prefix 4 1 (string "Some") (pp_expr e)
|
||||||
|
|
||||||
|
and pp_constr_app {value; _} =
|
||||||
|
let constr, arg = value in
|
||||||
|
let constr = string constr.value in
|
||||||
|
match arg with
|
||||||
|
None -> constr
|
||||||
|
| Some e -> prefix 2 1 constr (pp_expr e)
|
||||||
|
|
||||||
|
and pp_record_expr ne_inj = pp_ne_injection pp_field_assign ne_inj
|
||||||
|
|
||||||
|
and pp_field_assign {value; _} =
|
||||||
|
let {field_name; field_expr; _} = value in
|
||||||
|
prefix 2 1 (pp_ident field_name ^^ string ":") (pp_expr field_expr)
|
||||||
|
|
||||||
|
and pp_ne_injection :
|
||||||
|
'a.('a -> document) -> 'a ne_injection reg -> document =
|
||||||
|
fun printer {value; _} ->
|
||||||
|
let {compound; ne_elements; _} = value in
|
||||||
|
let elements = pp_nsepseq "," printer ne_elements in
|
||||||
|
match pp_compound compound with
|
||||||
|
None -> elements
|
||||||
|
| Some (opening, closing) ->
|
||||||
|
string opening ^^ nest 2 (break 0 ^^ elements) ^^ break 1 ^^ string closing
|
||||||
|
|
||||||
|
and pp_nsepseq :
|
||||||
|
'a.string -> ('a -> document) -> ('a, t) Utils.nsepseq -> document =
|
||||||
|
fun sep printer elements ->
|
||||||
|
let elems = Utils.nsepseq_to_list elements
|
||||||
|
and sep = string sep ^^ break 1
|
||||||
|
in separate_map sep printer elems
|
||||||
|
|
||||||
|
and pp_projection {value; _} =
|
||||||
|
let {struct_name; field_path; _} = value in
|
||||||
|
let subpath = Utils.nsepseq_to_list field_path in
|
||||||
|
let subpath = concat_map pp_selection subpath in
|
||||||
|
group (pp_ident struct_name ^^ subpath)
|
||||||
|
|
||||||
|
and pp_selection = function
|
||||||
|
FieldName v -> string "." ^^ break 0 ^^ string v.value
|
||||||
|
| Component cmp ->
|
||||||
|
string "[" ^^ (cmp.value |> snd |> Z.to_string |> string) ^^ string "]"
|
||||||
|
|
||||||
|
and pp_update {value; _} =
|
||||||
|
let {record; updates; _} = value in
|
||||||
|
let updates = group (pp_ne_injection pp_field_path_assign updates)
|
||||||
|
and record = pp_path record in
|
||||||
|
string "{..." ^^ record ^^ string ","
|
||||||
|
^^ nest 2 (break 1 ^^ updates ^^ string "}")
|
||||||
|
|
||||||
|
and pp_field_path_assign {value; _} =
|
||||||
|
let {field_path; field_expr; _} = value in
|
||||||
|
let path = pp_path field_path in
|
||||||
|
prefix 2 1 (path ^^ string ":") (pp_expr field_expr)
|
||||||
|
|
||||||
|
and pp_path = function
|
||||||
|
Name v -> pp_ident v
|
||||||
|
| Path p -> pp_projection p
|
||||||
|
|
||||||
|
and pp_call_expr {value; _} =
|
||||||
|
let lambda, arguments = value in
|
||||||
|
let arguments = Utils.nseq_to_list arguments in
|
||||||
|
let arguments = string "(" ^^ group (separate_map (string "," ^^ break 0 ^^ string " ") pp_expr arguments) ^^ string ")" in
|
||||||
|
group (break 0 ^^ pp_expr lambda ^^ nest 2 arguments)
|
||||||
|
|
||||||
|
and pp_tuple_expr {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_expr e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_expr e ^^ string ",") ^^ app items
|
||||||
|
in if tail = []
|
||||||
|
then string "(" ^^ nest 1 (pp_expr head) ^^ string ")"
|
||||||
|
else string "(" ^^ nest 1 (pp_expr head ^^ string "," ^^ app (List.map snd tail)) ^^ string ")"
|
||||||
|
|
||||||
|
and pp_par_expr {value; _} =
|
||||||
|
string "(" ^^ nest 1 (pp_expr value.inside ^^ string ")")
|
||||||
|
|
||||||
|
and pp_let_in {value; _} =
|
||||||
|
let {binding; kwd_rec; body; attributes; _} = value in
|
||||||
|
let let_str =
|
||||||
|
match kwd_rec with
|
||||||
|
None -> "let "
|
||||||
|
| Some _ -> "let rec " in
|
||||||
|
let bindings = pp_let_binding let_str binding
|
||||||
|
and attr = pp_attributes attributes
|
||||||
|
in attr ^^ bindings
|
||||||
|
^^ string ";" ^^ hardline ^^ pp_expr body
|
||||||
|
|
||||||
|
and pp_fun {value; _} =
|
||||||
|
let {binders; lhs_type; body; _} = value in
|
||||||
|
let patterns = Utils.nseq_to_list binders in
|
||||||
|
let binders = group (separate_map (string "," ^^ break 0 ^^ string " ") pp_pattern patterns)
|
||||||
|
and annot =
|
||||||
|
match lhs_type with
|
||||||
|
None -> empty
|
||||||
|
| Some (_,e) ->
|
||||||
|
group (break 0 ^^ string ": " ^^ nest 2 (pp_type_expr e))
|
||||||
|
in
|
||||||
|
match body with
|
||||||
|
| ESeq _ -> string "(" ^^ nest 1 binders ^^ string ")" ^^ annot ^^ string " => " ^^ pp_expr body
|
||||||
|
| _ -> (prefix 2 0 (string "(" ^^ nest 1 binders ^^ string ")" ^^ annot
|
||||||
|
^^ string " => ") (pp_expr body))
|
||||||
|
|
||||||
|
and pp_seq {value; _} =
|
||||||
|
let {compound; elements; _} = value in
|
||||||
|
let sep = string ";" ^^ hardline in
|
||||||
|
let elements = Utils.sepseq_to_list elements in
|
||||||
|
let elements = separate_map sep pp_expr elements in
|
||||||
|
match pp_compound compound with
|
||||||
|
None -> elements
|
||||||
|
| Some (opening, closing) ->
|
||||||
|
string opening
|
||||||
|
^^ nest 2 (hardline ^^ elements) ^^ hardline
|
||||||
|
^^ string closing
|
||||||
|
|
||||||
|
and pp_type_expr = function
|
||||||
|
TProd t -> pp_cartesian t
|
||||||
|
| TSum t -> break 0 ^^ pp_variants t
|
||||||
|
| TRecord t -> pp_fields t
|
||||||
|
| TApp t -> pp_type_app t
|
||||||
|
| TFun t -> pp_fun_type t
|
||||||
|
| TPar t -> pp_type_par t
|
||||||
|
| TVar t -> pp_ident t
|
||||||
|
| TString s -> pp_string s
|
||||||
|
|
||||||
|
and pp_cartesian {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_type_expr e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items
|
||||||
|
in
|
||||||
|
string "(" ^^ nest 1 (pp_type_expr head ^^ (if tail <> [] then string "," else empty) ^^ app (List.map snd tail)) ^^ string ")"
|
||||||
|
|
||||||
|
and pp_variants {value; _} =
|
||||||
|
let head, tail = value in
|
||||||
|
let head = pp_variant head in
|
||||||
|
let head = if tail = [] then head
|
||||||
|
else ifflat head (string " " ^^ head) in
|
||||||
|
let rest = List.map snd tail in
|
||||||
|
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
|
||||||
|
in head ^^ concat_map app rest
|
||||||
|
|
||||||
|
and pp_variant {value; _} =
|
||||||
|
let {constr; arg} = value in
|
||||||
|
match arg with
|
||||||
|
None -> pp_ident constr
|
||||||
|
| Some (_, e) ->
|
||||||
|
prefix 2 0 (pp_ident constr) (string "(" ^^ pp_type_expr e ^^ string ")")
|
||||||
|
|
||||||
|
and pp_fields fields = group (pp_ne_injection pp_field_decl fields)
|
||||||
|
|
||||||
|
and pp_field_decl {value; _} =
|
||||||
|
let {field_name; field_type; _} = value in
|
||||||
|
let name = pp_ident field_name in
|
||||||
|
match field_type with
|
||||||
|
| TVar v when v = field_name ->
|
||||||
|
name
|
||||||
|
| _ ->
|
||||||
|
let t_expr = pp_type_expr field_type
|
||||||
|
in prefix 2 1 (name ^^ string ":") t_expr
|
||||||
|
|
||||||
|
and pp_type_app {value; _} =
|
||||||
|
let ctor, tuple = value in
|
||||||
|
prefix 2 0 (pp_type_constr ctor) (string "(" ^^ nest 1 (pp_type_tuple tuple) ^^ string ")")
|
||||||
|
|
||||||
|
and pp_type_tuple {value; _} =
|
||||||
|
let head, tail = value.inside in
|
||||||
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
|
| [e] -> group (break 1 ^^ pp_type_expr e)
|
||||||
|
| e::items ->
|
||||||
|
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items in
|
||||||
|
if tail = []
|
||||||
|
then pp_type_expr head
|
||||||
|
else
|
||||||
|
let components =
|
||||||
|
pp_type_expr head ^^ string "," ^^ app (List.map snd tail)
|
||||||
|
in components
|
||||||
|
|
||||||
|
and pp_type_constr ctor = string ctor.value
|
||||||
|
|
||||||
|
and pp_fun_args {value; _} =
|
||||||
|
let lhs, _, rhs = value in
|
||||||
|
match rhs with
|
||||||
|
| TFun tf -> group (pp_type_expr lhs ^^ string ", " ^^ pp_fun_args tf)
|
||||||
|
| _ -> group (pp_type_expr lhs ^^ string ")" ^^ string " =>" ^/^ pp_type_expr rhs)
|
||||||
|
|
||||||
|
and pp_fun_type {value; _} =
|
||||||
|
let lhs, _, rhs = value in
|
||||||
|
match lhs, rhs with
|
||||||
|
| _, TFun tf -> string "(" ^^ pp_type_expr lhs ^^ string ", " ^^ pp_fun_args tf
|
||||||
|
| TVar _ , _ -> group (pp_type_expr lhs ^^ string " =>" ^/^ pp_type_expr rhs)
|
||||||
|
| _ -> group (string "(" ^^ nest 1 (pp_type_expr lhs) ^^ string ")" ^^ string " =>" ^/^ pp_type_expr rhs)
|
||||||
|
|
||||||
|
and pp_type_par {value; _} =
|
||||||
|
string "(" ^^ nest 1 (pp_type_expr value.inside ^^ string ")")
|
||||||
@ -15,7 +15,7 @@
|
|||||||
(name parser_reasonligo)
|
(name parser_reasonligo)
|
||||||
(public_name ligo.parser.reasonligo)
|
(public_name ligo.parser.reasonligo)
|
||||||
(modules
|
(modules
|
||||||
SyntaxError reasonligo LexToken ParErr Parser)
|
SyntaxError reasonligo LexToken ParErr Parser Pretty)
|
||||||
(libraries
|
(libraries
|
||||||
menhirLib
|
menhirLib
|
||||||
parser_shared
|
parser_shared
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@ -29,11 +29,12 @@ type options = <
|
|||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : command;
|
cmd : command;
|
||||||
mono : bool;
|
mono : bool;
|
||||||
expr : bool
|
expr : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
let make ~input ~libs ~verbose ~offsets ?block
|
let make ~input ~libs ~verbose ~offsets ?block
|
||||||
?line ~ext ~mode ~cmd ~mono ~expr : options =
|
?line ~ext ~mode ~cmd ~mono ~expr ~pretty : options =
|
||||||
object
|
object
|
||||||
method input = input
|
method input = input
|
||||||
method libs = libs
|
method libs = libs
|
||||||
@ -46,6 +47,7 @@ let make ~input ~libs ~verbose ~offsets ?block
|
|||||||
method cmd = cmd
|
method cmd = cmd
|
||||||
method mono = mono
|
method mono = mono
|
||||||
method expr = expr
|
method expr = expr
|
||||||
|
method pretty = pretty
|
||||||
end
|
end
|
||||||
|
|
||||||
(* Auxiliary functions *)
|
(* Auxiliary functions *)
|
||||||
@ -77,6 +79,7 @@ let help extension () =
|
|||||||
print " --bytes Bytes for source locations";
|
print " --bytes Bytes for source locations";
|
||||||
print " --mono Use Menhir monolithic API";
|
print " --mono Use Menhir monolithic API";
|
||||||
print " --expr Parse an expression";
|
print " --expr Parse an expression";
|
||||||
|
print " --pretty Pretty-print the input";
|
||||||
print " --verbose=<stages> cli, preproc, ast-tokens, ast (colon-separated)";
|
print " --verbose=<stages> cli, preproc, ast-tokens, ast (colon-separated)";
|
||||||
print " --version Commit hash on stdout";
|
print " --version Commit hash on stdout";
|
||||||
print " -h, --help This help";
|
print " -h, --help This help";
|
||||||
@ -100,6 +103,7 @@ and libs = ref []
|
|||||||
and verb_str = ref ""
|
and verb_str = ref ""
|
||||||
and mono = ref false
|
and mono = ref false
|
||||||
and expr = ref false
|
and expr = ref false
|
||||||
|
and pretty = ref false
|
||||||
|
|
||||||
let split_at_colon = Str.(split (regexp ":"))
|
let split_at_colon = Str.(split (regexp ":"))
|
||||||
|
|
||||||
@ -121,6 +125,7 @@ let specs extension =
|
|||||||
noshort, "bytes", set bytes true, None;
|
noshort, "bytes", set bytes true, None;
|
||||||
noshort, "mono", set mono true, None;
|
noshort, "mono", set mono true, None;
|
||||||
noshort, "expr", set expr true, None;
|
noshort, "expr", set expr true, None;
|
||||||
|
noshort, "pretty", set pretty true, None;
|
||||||
noshort, "verbose", None, Some add_verbose;
|
noshort, "verbose", None, Some add_verbose;
|
||||||
'h', "help", Some (help extension), None;
|
'h', "help", Some (help extension), None;
|
||||||
noshort, "version", Some version, None
|
noshort, "version", Some version, None
|
||||||
@ -156,6 +161,7 @@ let print_opt () =
|
|||||||
printf "bytes = %b\n" !bytes;
|
printf "bytes = %b\n" !bytes;
|
||||||
printf "mono = %b\n" !mono;
|
printf "mono = %b\n" !mono;
|
||||||
printf "expr = %b\n" !expr;
|
printf "expr = %b\n" !expr;
|
||||||
|
printf "pretty = %b\n" !pretty;
|
||||||
printf "verbose = %s\n" !verb_str;
|
printf "verbose = %s\n" !verb_str;
|
||||||
printf "input = %s\n" (string_of quote !input);
|
printf "input = %s\n" (string_of quote !input);
|
||||||
printf "libs = %s\n" (string_of_path !libs)
|
printf "libs = %s\n" (string_of_path !libs)
|
||||||
@ -185,6 +191,7 @@ let check ?block ?line ~ext =
|
|||||||
and mono = !mono
|
and mono = !mono
|
||||||
and expr = !expr
|
and expr = !expr
|
||||||
and verbose = !verbose
|
and verbose = !verbose
|
||||||
|
and pretty = !pretty
|
||||||
and libs = !libs in
|
and libs = !libs in
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
@ -199,6 +206,7 @@ let check ?block ?line ~ext =
|
|||||||
printf "mode = %s\n" (if mode = `Byte then "`Byte" else "`Point");
|
printf "mode = %s\n" (if mode = `Byte then "`Byte" else "`Point");
|
||||||
printf "mono = %b\n" mono;
|
printf "mono = %b\n" mono;
|
||||||
printf "expr = %b\n" expr;
|
printf "expr = %b\n" expr;
|
||||||
|
printf "pretty = %b\n" pretty;
|
||||||
printf "verbose = %s\n" !verb_str;
|
printf "verbose = %s\n" !verb_str;
|
||||||
printf "input = %s\n" (string_of quote input);
|
printf "input = %s\n" (string_of quote input);
|
||||||
printf "libs = %s\n" (string_of_path libs)
|
printf "libs = %s\n" (string_of_path libs)
|
||||||
@ -214,7 +222,7 @@ let check ?block ?line ~ext =
|
|||||||
| _ -> abort "Choose one of -q, -c, -u, -t."
|
| _ -> abort "Choose one of -q, -c, -u, -t."
|
||||||
|
|
||||||
in make ~input ~libs ~verbose ~offsets ~mode
|
in make ~input ~libs ~verbose ~offsets ~mode
|
||||||
~cmd ~mono ~expr ?block ?line ~ext
|
~cmd ~mono ~expr ?block ?line ~ext ~pretty
|
||||||
|
|
||||||
(* Parsing the command-line options *)
|
(* Parsing the command-line options *)
|
||||||
|
|
||||||
|
|||||||
@ -47,7 +47,10 @@ type command = Quiet | Copy | Units | Tokens
|
|||||||
{li If the field [expr] is [true], then the parser for
|
{li If the field [expr] is [true], then the parser for
|
||||||
expressions is used, otherwise a full-fledged contract is
|
expressions is used, otherwise a full-fledged contract is
|
||||||
expected.}
|
expected.}
|
||||||
} *)
|
|
||||||
|
{li If the field [pretty] is [true], then the source is
|
||||||
|
pretty-printed on the standard out.}
|
||||||
|
} *)
|
||||||
|
|
||||||
module SSet : Set.S with type elt = string and type t = Set.Make(String).t
|
module SSet : Set.S with type elt = string and type t = Set.Make(String).t
|
||||||
|
|
||||||
@ -67,7 +70,8 @@ type options = <
|
|||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : command;
|
cmd : command;
|
||||||
mono : bool;
|
mono : bool;
|
||||||
expr : bool
|
expr : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
val make :
|
val make :
|
||||||
@ -82,6 +86,7 @@ val make :
|
|||||||
cmd:command ->
|
cmd:command ->
|
||||||
mono:bool ->
|
mono:bool ->
|
||||||
expr:bool ->
|
expr:bool ->
|
||||||
|
pretty:bool ->
|
||||||
options
|
options
|
||||||
|
|
||||||
(** Parsing the command-line options on stdin. *)
|
(** Parsing the command-line options on stdin. *)
|
||||||
|
|||||||
@ -15,7 +15,8 @@ module type SubIO =
|
|||||||
ext : string;
|
ext : string;
|
||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : EvalOpt.command;
|
cmd : EvalOpt.command;
|
||||||
mono : bool
|
mono : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
val options : options
|
val options : options
|
||||||
@ -31,7 +32,7 @@ module type Printer =
|
|||||||
val mk_state :
|
val mk_state :
|
||||||
offsets:bool -> mode:[`Point|`Byte] -> buffer:Buffer.t -> state
|
offsets:bool -> mode:[`Point|`Byte] -> buffer:Buffer.t -> state
|
||||||
|
|
||||||
val pp_ast : state -> ast -> unit
|
val pp_cst : state -> ast -> unit
|
||||||
val pp_expr : state -> expr -> unit
|
val pp_expr : state -> expr -> unit
|
||||||
val print_tokens : state -> ast -> unit
|
val print_tokens : state -> ast -> unit
|
||||||
val print_expr : state -> expr -> unit
|
val print_expr : state -> expr -> unit
|
||||||
@ -145,7 +146,7 @@ module Make (Lexer: Lexer.S)
|
|||||||
if SSet.mem "ast" SubIO.options#verbose then
|
if SSet.mem "ast" SubIO.options#verbose then
|
||||||
begin
|
begin
|
||||||
Buffer.clear output;
|
Buffer.clear output;
|
||||||
ParserLog.pp_ast state ast;
|
ParserLog.pp_cst state ast;
|
||||||
Buffer.output_buffer stdout output
|
Buffer.output_buffer stdout output
|
||||||
end
|
end
|
||||||
in flush_all (); close (); Ok ast
|
in flush_all (); close (); Ok ast
|
||||||
|
|||||||
@ -17,7 +17,8 @@ module type SubIO =
|
|||||||
ext : string;
|
ext : string;
|
||||||
mode : [`Byte | `Point];
|
mode : [`Byte | `Point];
|
||||||
cmd : EvalOpt.command;
|
cmd : EvalOpt.command;
|
||||||
mono : bool
|
mono : bool;
|
||||||
|
pretty : bool
|
||||||
>
|
>
|
||||||
|
|
||||||
val options : options
|
val options : options
|
||||||
@ -35,7 +36,7 @@ module type Printer =
|
|||||||
val mk_state :
|
val mk_state :
|
||||||
offsets:bool -> mode:[`Point|`Byte] -> buffer:Buffer.t -> state
|
offsets:bool -> mode:[`Point|`Byte] -> buffer:Buffer.t -> state
|
||||||
|
|
||||||
val pp_ast : state -> ast -> unit
|
val pp_cst : state -> ast -> unit
|
||||||
val pp_expr : state -> expr -> unit
|
val pp_expr : state -> expr -> unit
|
||||||
val print_tokens : state -> ast -> unit
|
val print_tokens : state -> ast -> unit
|
||||||
val print_expr : state -> expr -> unit
|
val print_expr : state -> expr -> unit
|
||||||
|
|||||||
@ -31,9 +31,9 @@ val sepseq_cons : 'a -> 'sep -> ('a,'sep) sepseq -> ('a,'sep) nsepseq
|
|||||||
|
|
||||||
(* Reversing *)
|
(* Reversing *)
|
||||||
|
|
||||||
val nseq_rev: 'a nseq -> 'a nseq
|
val nseq_rev : 'a nseq -> 'a nseq
|
||||||
val nsepseq_rev: ('a,'sep) nsepseq -> ('a,'sep) nsepseq
|
val nsepseq_rev : ('a,'sep) nsepseq -> ('a,'sep) nsepseq
|
||||||
val sepseq_rev: ('a,'sep) sepseq -> ('a,'sep) sepseq
|
val sepseq_rev : ('a,'sep) sepseq -> ('a,'sep) sepseq
|
||||||
|
|
||||||
(* Rightwards iterators *)
|
(* Rightwards iterators *)
|
||||||
|
|
||||||
|
|||||||
@ -343,59 +343,41 @@ let rec compile_expression :
|
|||||||
let path' =
|
let path' =
|
||||||
let aux (s:Raw.selection) =
|
let aux (s:Raw.selection) =
|
||||||
match s with
|
match s with
|
||||||
FieldName property -> property.value
|
FieldName property -> Access_record property.value
|
||||||
| Component index -> Z.to_string (snd index.value)
|
| Component index -> Access_tuple (snd index.value)
|
||||||
in
|
in
|
||||||
List.map aux @@ npseq_to_list path in
|
List.map aux @@ npseq_to_list path in
|
||||||
return @@ List.fold_left (e_record_accessor ~loc ) var path'
|
return @@ e_accessor ~loc var path'
|
||||||
in
|
in
|
||||||
let compile_path : Raw.path -> string * label list = fun p ->
|
let compile_selection : Raw.selection -> access = fun s ->
|
||||||
match p with
|
|
||||||
| Raw.Name v -> (v.value , [])
|
|
||||||
| Raw.Path p -> (
|
|
||||||
let p' = p.value in
|
|
||||||
let var = p'.struct_name.value in
|
|
||||||
let path = p'.field_path in
|
|
||||||
let path' =
|
|
||||||
let aux (s:Raw.selection) =
|
|
||||||
match s with
|
match s with
|
||||||
| FieldName property -> Label property.value
|
| FieldName property -> Access_record property.value
|
||||||
| Component index -> Label (Z.to_string (snd index.value))
|
| Component index -> (Access_tuple (snd index.value)) in
|
||||||
in
|
|
||||||
List.map aux @@ npseq_to_list path in
|
let compile_path : Raw.path -> string * access list = function
|
||||||
(var , path')
|
Raw.Name v -> v.value, []
|
||||||
)
|
| Raw.Path {value; _} ->
|
||||||
in
|
let Raw.{struct_name; field_path; _} = value in
|
||||||
let compile_update = fun (u:Raw.update Region.reg) ->
|
let var = struct_name.value in
|
||||||
let (u, loc) = r_split u in
|
let path = List.map compile_selection @@ npseq_to_list field_path
|
||||||
let (name, path) = compile_path u.record in
|
in var, path in
|
||||||
let record = match path with
|
|
||||||
| [] -> e_variable (Var.of_name name)
|
let compile_update (u: Raw.update Region.reg) =
|
||||||
| _ ->
|
let u, loc = r_split u in
|
||||||
let aux expr (Label l) = e_record_accessor expr l in
|
let name, path = compile_path u.record in
|
||||||
List.fold_left aux (e_variable (Var.of_name name)) path in
|
let var = e_variable (Var.of_name name) in
|
||||||
|
let record = if path = [] then var else e_accessor var path in
|
||||||
let updates = u.updates.value.ne_elements in
|
let updates = u.updates.value.ne_elements in
|
||||||
let%bind updates' =
|
let%bind updates' =
|
||||||
let aux (f:Raw.field_path_assign Raw.reg) =
|
let aux (f: Raw.field_path_assignment Raw.reg) =
|
||||||
let (f,_) = r_split f in
|
let f, _ = r_split f in
|
||||||
let%bind expr = compile_expression f.field_expr in
|
let%bind expr = compile_expression f.field_expr
|
||||||
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr)
|
in ok (compile_path f.field_path, expr)
|
||||||
in
|
in bind_map_list aux @@ npseq_to_list updates in
|
||||||
bind_map_list aux @@ npseq_to_list updates
|
let aux ur ((var, path), expr) =
|
||||||
in
|
ok @@ e_update ~loc ur (Access_record var :: path) expr
|
||||||
let aux ur (path, expr) =
|
in bind_fold_list aux record updates'
|
||||||
let rec aux record = function
|
in trace (abstracting_expr t) @@
|
||||||
| [] -> failwith "error in parsing"
|
|
||||||
| hd :: [] -> ok @@ e_record_update ~loc record hd expr
|
|
||||||
| hd :: tl ->
|
|
||||||
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'
|
|
||||||
in
|
|
||||||
|
|
||||||
trace (abstracting_expr t) @@
|
|
||||||
match t with
|
match t with
|
||||||
Raw.ELetIn e ->
|
Raw.ELetIn e ->
|
||||||
let Raw.{kwd_rec; binding; body; attributes; _} = e.value in
|
let Raw.{kwd_rec; binding; body; attributes; _} = e.value in
|
||||||
@ -439,11 +421,11 @@ let rec compile_expression :
|
|||||||
| hd :: [] ->
|
| hd :: [] ->
|
||||||
if (List.length prep_vars = 1)
|
if (List.length prep_vars = 1)
|
||||||
then e_let_in ~loc hd inline rhs_b_expr body
|
then e_let_in ~loc hd inline rhs_b_expr body
|
||||||
else e_let_in ~loc hd inline (e_record_accessor ~loc rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body
|
else e_let_in ~loc hd inline (e_accessor ~loc rhs_b_expr [Access_tuple (Z.of_int ((List.length prep_vars) - 1))]) body
|
||||||
| hd :: tl ->
|
| hd :: tl ->
|
||||||
e_let_in ~loc hd
|
e_let_in ~loc hd
|
||||||
inline
|
inline
|
||||||
(e_record_accessor ~loc rhs_b_expr (string_of_int ((List.length prep_vars) - (List.length tl) - 1)))
|
(e_accessor ~loc rhs_b_expr [Access_tuple (Z.of_int ((List.length prep_vars) - (List.length tl) - 1))])
|
||||||
(chain_let_in tl body)
|
(chain_let_in tl body)
|
||||||
| [] -> body (* Precluded by corner case assertion above *)
|
| [] -> body (* Precluded by corner case assertion above *)
|
||||||
in
|
in
|
||||||
@ -960,7 +942,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu
|
|||||||
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
|
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))]
|
||||||
)
|
)
|
||||||
|
|
||||||
and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result =
|
and compile_cases : (Raw.pattern * expression) list -> matching_expr result =
|
||||||
fun t ->
|
fun t ->
|
||||||
let open Raw in
|
let open Raw in
|
||||||
let rec get_var (t:Raw.pattern) =
|
let rec get_var (t:Raw.pattern) =
|
||||||
@ -1031,7 +1013,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten
|
|||||||
match patterns with
|
match patterns with
|
||||||
| [(PFalse _, f) ; (PTrue _, t)]
|
| [(PFalse _, f) ; (PTrue _, t)]
|
||||||
| [(PTrue _, t) ; (PFalse _, f)] ->
|
| [(PTrue _, t) ; (PFalse _, f)] ->
|
||||||
ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)], ())
|
ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)])
|
||||||
| [(PList (PCons c), cons); (PList (PListComp sugar_nil), nil)]
|
| [(PList (PCons c), cons); (PList (PListComp sugar_nil), nil)]
|
||||||
| [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] ->
|
| [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] ->
|
||||||
let%bind () =
|
let%bind () =
|
||||||
@ -1044,7 +1026,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten
|
|||||||
let%bind a = get_var a in
|
let%bind a = get_var a in
|
||||||
let%bind b = get_var b in
|
let%bind b = get_var b in
|
||||||
ok (a, b) in
|
ok (a, b) in
|
||||||
ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons, ()); match_nil=nil}
|
ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons); match_nil=nil}
|
||||||
| lst ->
|
| lst ->
|
||||||
let error x =
|
let error x =
|
||||||
let title () = "Pattern" in
|
let title () = "Pattern" in
|
||||||
@ -1075,7 +1057,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten
|
|||||||
| [ (("None", None), none_expr);
|
| [ (("None", None), none_expr);
|
||||||
(("Some", Some some_var), some_expr) ] ->
|
(("Some", Some some_var), some_expr) ] ->
|
||||||
ok @@ Match_option {
|
ok @@ Match_option {
|
||||||
match_some = (Var.of_name some_var, some_expr, ());
|
match_some = (Var.of_name some_var, some_expr);
|
||||||
match_none = none_expr }
|
match_none = none_expr }
|
||||||
| _ -> simple_fail "bad option pattern"
|
| _ -> simple_fail "bad option pattern"
|
||||||
in bind_or (as_option () , as_variant ())
|
in bind_or (as_option () , as_variant ())
|
||||||
|
|||||||
@ -152,7 +152,7 @@ let return_statement expr = ok @@ fun expr'_opt ->
|
|||||||
| Some expr' -> ok @@ e_sequence expr expr'
|
| Some expr' -> ok @@ e_sequence expr expr'
|
||||||
|
|
||||||
let get_t_string_singleton_opt = function
|
let get_t_string_singleton_opt = function
|
||||||
| Raw.TStringLiteral s -> Some s.value
|
| Raw.TString s -> Some s.value
|
||||||
| _ -> None
|
| _ -> None
|
||||||
|
|
||||||
|
|
||||||
@ -252,7 +252,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
|
|||||||
@@ npseq_to_list s in
|
@@ npseq_to_list s in
|
||||||
let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in
|
let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in
|
||||||
ok @@ make_t ~loc @@ T_sum m
|
ok @@ make_t ~loc @@ T_sum m
|
||||||
| TStringLiteral _s -> simple_fail "we don't support singleton string type"
|
| TString _s -> simple_fail "we don't support singleton string type"
|
||||||
|
|
||||||
and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
|
and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
|
||||||
match lst with
|
match lst with
|
||||||
@ -271,31 +271,32 @@ let compile_projection : Raw.projection Region.reg -> _ = fun p ->
|
|||||||
let path' =
|
let path' =
|
||||||
let aux (s:Raw.selection) =
|
let aux (s:Raw.selection) =
|
||||||
match s with
|
match s with
|
||||||
| FieldName property -> property.value
|
| FieldName property -> Access_record property.value
|
||||||
| Component index -> (Z.to_string (snd index.value))
|
| Component index -> (Access_tuple (snd index.value))
|
||||||
in
|
in
|
||||||
List.map aux @@ npseq_to_list path in
|
List.map aux @@ npseq_to_list path in
|
||||||
ok @@ List.fold_left (e_record_accessor ~loc) var path'
|
ok @@ e_accessor ~loc var path'
|
||||||
|
|
||||||
|
|
||||||
let rec compile_expression (t:Raw.expr) : expr result =
|
let rec compile_expression (t:Raw.expr) : expr result =
|
||||||
let return x = ok x in
|
let return x = ok x in
|
||||||
match t with
|
match t with
|
||||||
| EAnnot a -> (
|
| EAnnot a -> (
|
||||||
let ((expr , type_expr) , loc) = r_split a in
|
let par, loc = r_split a in
|
||||||
|
let expr, _, type_expr = par.inside in
|
||||||
let%bind expr' = compile_expression expr in
|
let%bind expr' = compile_expression expr in
|
||||||
let%bind type_expr' = compile_type_expression type_expr in
|
let%bind type_expr' = compile_type_expression type_expr in
|
||||||
return @@ e_annotation ~loc expr' type_expr'
|
return @@ e_annotation ~loc expr' type_expr'
|
||||||
)
|
)
|
||||||
| EVar c -> (
|
| EVar c -> (
|
||||||
let (c' , loc) = r_split c in
|
let (c', loc) = r_split c in
|
||||||
match constants c' with
|
match constants c' with
|
||||||
| None -> return @@ e_variable ~loc (Var.of_name c.value)
|
| None -> return @@ e_variable ~loc (Var.of_name c.value)
|
||||||
| Some s -> return @@ e_constant ~loc s []
|
| Some s -> return @@ e_constant ~loc s []
|
||||||
)
|
)
|
||||||
| ECall x -> (
|
| ECall x -> (
|
||||||
let ((f, args) , loc) = r_split x in
|
let ((f, args), loc) = r_split x in
|
||||||
let (args , args_loc) = r_split args in
|
let (args, args_loc) = r_split args in
|
||||||
let args' = npseq_to_list args.inside in
|
let args' = npseq_to_list args.inside in
|
||||||
match f with
|
match f with
|
||||||
| EVar name -> (
|
| EVar name -> (
|
||||||
@ -327,7 +328,8 @@ let rec compile_expression (t:Raw.expr) : expr result =
|
|||||||
| ERecord r ->
|
| ERecord r ->
|
||||||
let%bind fields = bind_list
|
let%bind fields = bind_list
|
||||||
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = compile_expression v in ok (k.value, v))
|
@@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = compile_expression v in ok (k.value, v))
|
||||||
@@ List.map (fun (x:Raw.field_assign Raw.reg) -> (x.value.field_name, x.value.field_expr))
|
@@ List.map (fun (x:Raw.field_assignment Raw.reg) ->
|
||||||
|
(x.value.field_name, x.value.field_expr))
|
||||||
@@ npseq_to_list r.value.ne_elements in
|
@@ npseq_to_list r.value.ne_elements in
|
||||||
let aux prev (k, v) = SMap.add k v prev in
|
let aux prev (k, v) = SMap.add k v prev in
|
||||||
return @@ e_record (List.fold_left aux SMap.empty fields)
|
return @@ e_record (List.fold_left aux SMap.empty fields)
|
||||||
@ -451,51 +453,34 @@ let rec compile_expression (t:Raw.expr) : expr result =
|
|||||||
| Path p -> compile_projection p
|
| Path p -> compile_projection p
|
||||||
in
|
in
|
||||||
let%bind index = compile_expression lu.index.value.inside in
|
let%bind index = compile_expression lu.index.value.inside in
|
||||||
return @@ e_look_up ~loc path index
|
return @@ e_accessor ~loc path [Access_map index]
|
||||||
)
|
)
|
||||||
| EFun f ->
|
| EFun f ->
|
||||||
let (f , loc) = r_split f in
|
let (f , loc) = r_split f in
|
||||||
let%bind (_ty_opt, f') = compile_fun_expression ~loc f
|
let%bind (_ty_opt, f') = compile_fun_expression ~loc f
|
||||||
in return @@ f'
|
in return @@ f'
|
||||||
|
and compile_update (u: Raw.update Region.reg) =
|
||||||
|
let u, loc = r_split u in
|
||||||
and compile_update = fun (u:Raw.update Region.reg) ->
|
let name, path = compile_path u.record in
|
||||||
let (u, loc) = r_split u in
|
let var = e_variable (Var.of_name name) in
|
||||||
let (name, path) = compile_path u.record in
|
let record = if path = [] then var else e_accessor var path in
|
||||||
let record = match path with
|
|
||||||
| [] -> e_variable (Var.of_name name)
|
|
||||||
| _ -> e_accessor_list (e_variable (Var.of_name name)) path in
|
|
||||||
let updates = u.updates.value.ne_elements in
|
let updates = u.updates.value.ne_elements in
|
||||||
let%bind updates' =
|
let%bind updates' =
|
||||||
let aux (f:Raw.field_path_assign Raw.reg) =
|
let aux (f: Raw.field_path_assignment Raw.reg) =
|
||||||
let (f,_) = r_split f in
|
let f, _ = r_split f in
|
||||||
let%bind expr = compile_expression f.field_expr in
|
let%bind expr = compile_expression f.field_expr
|
||||||
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr)
|
in ok (compile_path f.field_path, expr)
|
||||||
in
|
in bind_map_list aux @@ npseq_to_list updates in
|
||||||
bind_map_list aux @@ npseq_to_list updates
|
let aux ur ((var, path), expr) =
|
||||||
in
|
ok @@ e_update ~loc ur (Access_record var :: path) expr
|
||||||
let aux ur (path, expr) =
|
in bind_fold_list aux record updates'
|
||||||
let rec aux record = function
|
|
||||||
| [] -> failwith "error in parsing"
|
|
||||||
| hd :: [] -> ok @@ e_record_update ~loc record hd expr
|
|
||||||
| hd :: tl ->
|
|
||||||
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'
|
|
||||||
|
|
||||||
and compile_logic_expression (t:Raw.logic_expr) : expression result =
|
and compile_logic_expression (t:Raw.logic_expr) : expression result =
|
||||||
let return x = ok x in
|
|
||||||
match t with
|
match t with
|
||||||
| BoolExpr (False reg) -> (
|
| BoolExpr (False reg) ->
|
||||||
let loc = Location.lift reg in
|
ok @@ e_bool ~loc:(Location.lift reg) false
|
||||||
return @@ e_bool ~loc false
|
| BoolExpr (True reg) ->
|
||||||
)
|
ok @@ e_bool ~loc:(Location.lift reg) true
|
||||||
| BoolExpr (True reg) -> (
|
|
||||||
let loc = Location.lift reg in
|
|
||||||
return @@ e_bool ~loc true
|
|
||||||
)
|
|
||||||
| BoolExpr (Or b) ->
|
| BoolExpr (Or b) ->
|
||||||
compile_binop "OR" b
|
compile_binop "OR" b
|
||||||
| BoolExpr (And b) ->
|
| BoolExpr (And b) ->
|
||||||
@ -668,7 +653,7 @@ and compile_fun_decl :
|
|||||||
let%bind tpl_declarations =
|
let%bind tpl_declarations =
|
||||||
let aux = fun i (param, type_expr) ->
|
let aux = fun i (param, type_expr) ->
|
||||||
let expr =
|
let expr =
|
||||||
e_record_accessor (e_variable arguments_name) (string_of_int i) in
|
e_accessor (e_variable arguments_name) [Access_record (string_of_int i)] in
|
||||||
let type_variable = Some type_expr in
|
let type_variable = Some type_expr in
|
||||||
let ass = return_let_in (Var.of_name param , type_variable) inline expr in
|
let ass = return_let_in (Var.of_name param , type_variable) inline expr in
|
||||||
ass
|
ass
|
||||||
@ -698,7 +683,7 @@ and compile_fun_expression :
|
|||||||
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
|
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
|
||||||
fun ~loc x ->
|
fun ~loc x ->
|
||||||
let open! Raw in
|
let open! Raw in
|
||||||
let {kwd_recursive;param;ret_type;return} : fun_expr = x in
|
let {param; ret_type; return; _} : fun_expr = x in
|
||||||
let statements = [] in
|
let statements = [] in
|
||||||
(match param.value.inside with
|
(match param.value.inside with
|
||||||
a, [] -> (
|
a, [] -> (
|
||||||
@ -714,10 +699,8 @@ and compile_fun_expression :
|
|||||||
bind_fold_right_list aux result body in
|
bind_fold_right_list aux result body in
|
||||||
let binder = Var.of_name binder in
|
let binder = Var.of_name binder in
|
||||||
let fun_type = t_function input_type output_type in
|
let fun_type = t_function input_type output_type in
|
||||||
let expression = match kwd_recursive with
|
let expression =
|
||||||
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
|
e_lambda ~loc binder (Some input_type)(Some output_type) result
|
||||||
| Some _ -> e_recursive ~loc binder fun_type
|
|
||||||
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
|
|
||||||
in
|
in
|
||||||
ok (Some fun_type , expression)
|
ok (Some fun_type , expression)
|
||||||
)
|
)
|
||||||
@ -731,7 +714,7 @@ and compile_fun_expression :
|
|||||||
(arguments_name , type_expression) in
|
(arguments_name , type_expression) in
|
||||||
let%bind tpl_declarations =
|
let%bind tpl_declarations =
|
||||||
let aux = fun i (param, param_type) ->
|
let aux = fun i (param, param_type) ->
|
||||||
let expr = e_record_accessor (e_variable arguments_name) (string_of_int i) in
|
let expr = e_accessor (e_variable arguments_name) [Access_tuple (Z.of_int i)] in
|
||||||
let type_variable = Some param_type in
|
let type_variable = Some param_type in
|
||||||
let ass = return_let_in (Var.of_name param , type_variable) false expr in
|
let ass = return_let_in (Var.of_name param , type_variable) false expr in
|
||||||
ass
|
ass
|
||||||
@ -745,10 +728,8 @@ and compile_fun_expression :
|
|||||||
let aux prec cur = cur (Some prec) in
|
let aux prec cur = cur (Some prec) in
|
||||||
bind_fold_right_list aux result body in
|
bind_fold_right_list aux result body in
|
||||||
let fun_type = t_function input_type output_type in
|
let fun_type = t_function input_type output_type in
|
||||||
let expression = match kwd_recursive with
|
let expression =
|
||||||
| None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
|
e_lambda ~loc binder (Some input_type)(Some output_type) result
|
||||||
| Some _ -> e_recursive ~loc binder fun_type
|
|
||||||
@@ {binder;input_type=Some input_type; output_type= Some output_type; result}
|
|
||||||
in
|
in
|
||||||
ok (Some fun_type , expression)
|
ok (Some fun_type , expression)
|
||||||
)
|
)
|
||||||
@ -822,7 +803,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
let%bind bound = compile_expression fi.bound in
|
let%bind bound = compile_expression fi.bound in
|
||||||
let%bind step = match fi.step with
|
let%bind step = match fi.step with
|
||||||
| None -> ok @@ e_int_z Z.one
|
| None -> ok @@ e_int_z Z.one
|
||||||
| Some step -> compile_expression step in
|
| Some (_, step) -> compile_expression step in
|
||||||
let%bind body = compile_block fi.block.value in
|
let%bind body = compile_block fi.block.value in
|
||||||
let%bind body = body @@ None in
|
let%bind body = body @@ None in
|
||||||
return_statement @@ e_for ~loc binder start bound step body
|
return_statement @@ e_for ~loc binder start bound step body
|
||||||
@ -869,23 +850,25 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
let (a , loc) = r_split a in
|
let (a , loc) = r_split a in
|
||||||
let%bind value_expr = compile_expression a.rhs in
|
let%bind value_expr = compile_expression a.rhs in
|
||||||
match a.lhs with
|
match a.lhs with
|
||||||
| Path path -> (
|
| Path path ->
|
||||||
let (name , path') = compile_path path in
|
let name , path' = compile_path path in
|
||||||
return_statement @@ e_ez_assign ~loc name path' value_expr
|
let name = Var.of_name name in
|
||||||
)
|
return_statement @@ e_assign ~loc name path' value_expr
|
||||||
| MapPath v -> (
|
| MapPath v ->
|
||||||
let v' = v.value in
|
let v' = v.value in
|
||||||
let%bind (varname,map,path) = match v'.path with
|
let%bind (varname,map,path) = match v'.path with
|
||||||
| Name name -> ok (name.value , e_variable (Var.of_name name.value), [])
|
| Name name ->
|
||||||
|
ok (name.value ,
|
||||||
|
e_variable (Var.of_name name.value), [])
|
||||||
| Path p ->
|
| Path p ->
|
||||||
let (name,p') = compile_path v'.path in
|
let name, p' = compile_path v'.path in
|
||||||
let%bind accessor = compile_projection p in
|
let%bind accessor = compile_projection p in
|
||||||
ok @@ (name , accessor , p')
|
ok @@ (name, accessor, p') in
|
||||||
in
|
let%bind key_expr =
|
||||||
let%bind key_expr = compile_expression v'.index.value.inside in
|
compile_expression v'.index.value.inside in
|
||||||
let expr' = e_map_add key_expr value_expr map in
|
let expr' = e_map_add key_expr value_expr map in
|
||||||
return_statement @@ e_ez_assign ~loc varname path expr'
|
let varname = Var.of_name varname in
|
||||||
)
|
return_statement @@ e_assign ~loc varname path expr'
|
||||||
)
|
)
|
||||||
| CaseInstr c -> (
|
| CaseInstr c -> (
|
||||||
let (c , loc) = r_split c in
|
let (c , loc) = r_split c in
|
||||||
@ -910,26 +893,28 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
let%bind m = compile_cases cases in
|
let%bind m = compile_cases cases in
|
||||||
return_statement @@ e_matching ~loc expr m
|
return_statement @@ e_matching ~loc expr m
|
||||||
)
|
)
|
||||||
| RecordPatch r -> (
|
| RecordPatch r ->
|
||||||
let reg = r.region in
|
let reg = r.region in
|
||||||
let (r,loc) = r_split r in
|
let r, loc = r_split r in
|
||||||
let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg=
|
let aux (fa: Raw.field_assignment Raw.reg) : Raw.field_path_assignment Raw.reg =
|
||||||
{value = {field_path = (fa.value.field_name, []); equal=fa.value.equal; field_expr = fa.value.field_expr};
|
{value = {field_path = Name fa.value.field_name;
|
||||||
region = fa.region}
|
assignment = fa.value.assignment;
|
||||||
in
|
field_expr = fa.value.field_expr};
|
||||||
let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = {
|
region = fa.region} in
|
||||||
|
let update : Raw.field_path_assignment Raw.reg Raw.ne_injection Raw.reg = {
|
||||||
value = Raw.map_ne_injection aux r.record_inj.value;
|
value = Raw.map_ne_injection aux r.record_inj.value;
|
||||||
region=r.record_inj.region
|
region = r.record_inj.region} in
|
||||||
} in
|
let u : Raw.update = {
|
||||||
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
|
record = r.path;
|
||||||
|
kwd_with = r.kwd_with;
|
||||||
|
updates = update} in
|
||||||
let%bind expr = compile_update {value=u;region=reg} in
|
let%bind expr = compile_update {value=u;region=reg} in
|
||||||
let (name , access_path) = compile_path r.path in
|
let name, access_path = compile_path r.path in
|
||||||
return_statement @@ e_ez_assign ~loc name access_path expr
|
let name = Var.of_name name in
|
||||||
|
return_statement @@ e_assign ~loc name access_path expr
|
||||||
)
|
| MapPatch patch ->
|
||||||
| MapPatch patch -> (
|
let map_p, loc = r_split patch in
|
||||||
let (map_p, loc) = r_split patch in
|
let name, access_path = compile_path map_p.path in
|
||||||
let (name, access_path) = compile_path map_p.path in
|
|
||||||
let%bind inj = bind_list
|
let%bind inj = bind_list
|
||||||
@@ List.map (fun (x:Raw.binding Region.reg) ->
|
@@ List.map (fun (x:Raw.binding Region.reg) ->
|
||||||
let x = x.value in
|
let x = x.value in
|
||||||
@ -939,19 +924,18 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
in ok @@ (key', value')
|
in ok @@ (key', value')
|
||||||
)
|
)
|
||||||
@@ npseq_to_list map_p.map_inj.value.ne_elements in
|
@@ npseq_to_list map_p.map_inj.value.ne_elements in
|
||||||
match inj with
|
(match inj with
|
||||||
| [] -> return_statement @@ e_skip ~loc ()
|
| [] -> return_statement @@ e_skip ~loc ()
|
||||||
| _ :: _ ->
|
| _ :: _ ->
|
||||||
let assigns = List.fold_right
|
let assigns = List.fold_right
|
||||||
(fun (key, value) map -> (e_map_add key value map))
|
(fun (key, value) map -> (e_map_add key value map))
|
||||||
inj
|
inj
|
||||||
(e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
|
(e_accessor ~loc (e_variable (Var.of_name name)) access_path)
|
||||||
in
|
and name = Var.of_name name in
|
||||||
return_statement @@ e_ez_assign ~loc name access_path assigns
|
return_statement @@ e_assign ~loc name access_path assigns)
|
||||||
)
|
|
||||||
| SetPatch patch -> (
|
| SetPatch patch -> (
|
||||||
let (setp, loc) = r_split patch in
|
let setp, loc = r_split patch in
|
||||||
let (name , access_path) = compile_path setp.path in
|
let name, access_path = compile_path setp.path in
|
||||||
let%bind inj =
|
let%bind inj =
|
||||||
bind_list @@
|
bind_list @@
|
||||||
List.map compile_expression @@
|
List.map compile_expression @@
|
||||||
@ -961,53 +945,50 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
| _ :: _ ->
|
| _ :: _ ->
|
||||||
let assigns = List.fold_right
|
let assigns = List.fold_right
|
||||||
(fun hd s -> e_constant C_SET_ADD [hd ; s])
|
(fun hd s -> e_constant C_SET_ADD [hd ; s])
|
||||||
inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in
|
inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
|
||||||
return_statement @@ e_ez_assign ~loc name access_path assigns
|
let name = Var.of_name name in
|
||||||
|
return_statement @@ e_assign ~loc name access_path assigns
|
||||||
)
|
)
|
||||||
| MapRemove r -> (
|
| MapRemove r ->
|
||||||
let (v , loc) = r_split r in
|
let (v , loc) = r_split r in
|
||||||
let key = v.key in
|
let key = v.key in
|
||||||
let%bind (varname,map,path) = match v.map with
|
let%bind (name,map,path) = match v.map with
|
||||||
| Name v -> ok (v.value , e_variable (Var.of_name v.value) , [])
|
| Name v -> ok (v.value , e_variable (Var.of_name v.value) , [])
|
||||||
| Path p ->
|
| Path p ->
|
||||||
let (name,p') = compile_path v.map in
|
let name, p' = compile_path v.map in
|
||||||
let%bind accessor = compile_projection p in
|
let%bind accessor = compile_projection p in
|
||||||
ok @@ (name , accessor , p')
|
ok @@ (name , accessor , p')
|
||||||
in
|
in
|
||||||
let%bind key' = compile_expression key in
|
let%bind key' = compile_expression key in
|
||||||
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
|
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
|
||||||
return_statement @@ e_ez_assign ~loc varname path expr
|
let name = Var.of_name name in
|
||||||
)
|
return_statement @@ e_assign ~loc name path expr
|
||||||
| SetRemove r -> (
|
| SetRemove r ->
|
||||||
let (set_rm, loc) = r_split r in
|
let set_rm, loc = r_split r in
|
||||||
let%bind (varname, set, path) = match set_rm.set with
|
let%bind (name, set, path) =
|
||||||
| Name v -> ok (v.value, e_variable (Var.of_name v.value), [])
|
match set_rm.set with
|
||||||
|
| Name v ->
|
||||||
|
ok (v.value, e_variable (Var.of_name v.value), [])
|
||||||
| Path path ->
|
| Path path ->
|
||||||
let(name, p') = compile_path set_rm.set in
|
let name, p' = compile_path set_rm.set in
|
||||||
let%bind accessor = compile_projection path in
|
let%bind accessor = compile_projection path in
|
||||||
ok @@ (name, accessor, p')
|
ok @@ (name, accessor, p') in
|
||||||
in
|
|
||||||
let%bind removed' = compile_expression set_rm.element in
|
let%bind removed' = compile_expression set_rm.element in
|
||||||
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
|
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
|
||||||
return_statement @@ e_ez_assign ~loc varname path expr
|
let name = Var.of_name name in
|
||||||
)
|
return_statement @@ e_assign ~loc name path expr
|
||||||
|
|
||||||
and compile_path : Raw.path -> string * string list = fun p ->
|
and compile_path : Raw.path -> string * access list = function
|
||||||
match p with
|
Raw.Name v -> v.value, []
|
||||||
| Raw.Name v -> (v.value , [])
|
| Raw.Path {value; _} ->
|
||||||
| Raw.Path p -> (
|
let Raw.{struct_name; field_path; _} = value in
|
||||||
let p' = p.value in
|
let var = struct_name.value in
|
||||||
let var = p'.struct_name.value in
|
let path = List.map compile_selection @@ npseq_to_list field_path
|
||||||
let path = p'.field_path in
|
in var, path
|
||||||
let path' =
|
|
||||||
let aux (s:Raw.selection) =
|
and compile_selection : Raw.selection -> access = function
|
||||||
match s with
|
FieldName property -> Access_record property.value
|
||||||
| FieldName property -> property.value
|
| Component index -> Access_tuple (snd index.value)
|
||||||
| Component index -> (Z.to_string (snd index.value))
|
|
||||||
in
|
|
||||||
List.map aux @@ npseq_to_list path in
|
|
||||||
(var , path')
|
|
||||||
)
|
|
||||||
|
|
||||||
and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
|
and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
|
||||||
let open Raw in
|
let open Raw in
|
||||||
@ -1059,14 +1040,14 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
|
|||||||
match patterns with
|
match patterns with
|
||||||
| [(PConstr PFalse _ , f) ; (PConstr PTrue _ , t)]
|
| [(PConstr PFalse _ , f) ; (PConstr PTrue _ , t)]
|
||||||
| [(PConstr PTrue _ , t) ; (PConstr PFalse _ , f)] ->
|
| [(PConstr PTrue _ , t) ; (PConstr PFalse _ , f)] ->
|
||||||
ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)], ())
|
ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)])
|
||||||
| [(PConstr PSomeApp v , some) ; (PConstr PNone _ , none)]
|
| [(PConstr PSomeApp v , some) ; (PConstr PNone _ , none)]
|
||||||
| [(PConstr PNone _ , none) ; (PConstr PSomeApp v , some)] -> (
|
| [(PConstr PNone _ , none) ; (PConstr PSomeApp v , some)] -> (
|
||||||
let (_, v) = v.value in
|
let (_, v) = v.value in
|
||||||
let%bind v = match v.value.inside with
|
let%bind v = match v.value.inside with
|
||||||
| PVar v -> ok v.value
|
| PVar v -> ok v.value
|
||||||
| p -> fail @@ unsupported_deep_Some_patterns p in
|
| p -> fail @@ unsupported_deep_Some_patterns p in
|
||||||
ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some, ()) }
|
ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some) }
|
||||||
)
|
)
|
||||||
| [(PList PCons c, cons) ; (PList (PNil _), nil)]
|
| [(PList PCons c, cons) ; (PList (PNil _), nil)]
|
||||||
| [(PList (PNil _), nil) ; (PList PCons c, cons)] ->
|
| [(PList (PNil _), nil) ; (PList PCons c, cons)] ->
|
||||||
@ -1079,7 +1060,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
|
|||||||
| _ -> fail @@ unsupported_deep_list_patterns c
|
| _ -> fail @@ unsupported_deep_list_patterns c
|
||||||
|
|
||||||
in
|
in
|
||||||
ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons,()) ; match_nil = nil}
|
ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons) ; match_nil = nil}
|
||||||
| lst ->
|
| lst ->
|
||||||
trace (simple_info "currently, only booleans, options, lists and \
|
trace (simple_info "currently, only booleans, options, lists and \
|
||||||
user-defined constructors are supported in patterns") @@
|
user-defined constructors are supported in patterns") @@
|
||||||
|
|||||||
@ -30,9 +30,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
|
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_look_up ab ->
|
|
||||||
let%bind res = bind_fold_pair self init' ab in
|
|
||||||
ok res
|
|
||||||
| E_application {lamb;args} -> (
|
| E_application {lamb;args} -> (
|
||||||
let ab = (lamb,args) in
|
let ab = (lamb,args) in
|
||||||
let%bind res = bind_fold_pair self init' ab in
|
let%bind res = bind_fold_pair self init' ab in
|
||||||
@ -56,13 +53,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = bind_fold_lmap aux (ok init') m in
|
let%bind res = bind_fold_lmap aux (ok init') m in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_record_update {record;update} -> (
|
| E_update {record;path;update} -> (
|
||||||
let%bind res = self init' record in
|
let%bind res = self init' record in
|
||||||
|
let aux res a = match a with
|
||||||
|
| Access_map e -> self res e
|
||||||
|
| _ -> ok res
|
||||||
|
in
|
||||||
|
let%bind res = bind_fold_list aux res path in
|
||||||
let%bind res = fold_expression self res update in
|
let%bind res = fold_expression self res update in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_record_accessor {record} -> (
|
| E_accessor {record;path} -> (
|
||||||
let%bind res = self init' record in
|
let%bind res = self init' record in
|
||||||
|
let aux res a = match a with
|
||||||
|
| Access_map e -> self res e
|
||||||
|
| _ -> ok res
|
||||||
|
in
|
||||||
|
let%bind res = bind_fold_list aux res path in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_tuple t -> (
|
| E_tuple t -> (
|
||||||
@ -73,15 +80,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = bind_fold_list aux (init') t in
|
let%bind res = bind_fold_list aux (init') t in
|
||||||
ok res
|
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 } -> (
|
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
||||||
let%bind res = self init' rhs in
|
let%bind res = self init' rhs in
|
||||||
let%bind res = self res let_result in
|
let%bind res = self res let_result in
|
||||||
@ -114,31 +112,37 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = self res body in
|
let%bind res = self res body in
|
||||||
ok res
|
ok res
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
|
| Match_variant lst -> (
|
||||||
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 aux init' ((_ , _) , e) =
|
||||||
let%bind res' = fold_expression f init' e in
|
let%bind res' = fold_expression f init' e in
|
||||||
ok res' in
|
ok res' in
|
||||||
let%bind res = bind_fold_list aux init lst in
|
let%bind res = bind_fold_list aux init lst in
|
||||||
ok res
|
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_record (_, _, e) -> (
|
||||||
|
let%bind res = fold_expression f init e in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
| Match_tuple (_, _, e) -> (
|
||||||
|
let%bind res = fold_expression f init e in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
| Match_variable (_, _, e) -> (
|
||||||
|
let%bind res = fold_expression f init e in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
|
||||||
type exp_mapper = expression -> expression result
|
type exp_mapper = expression -> expression result
|
||||||
type ty_exp_mapper = type_expression -> type_expression result
|
type ty_exp_mapper = type_expression -> type_expression result
|
||||||
@ -166,10 +170,6 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
let%bind lst' = bind_map_list (bind_map_pair self) lst in
|
let%bind lst' = bind_map_list (bind_map_pair self) lst in
|
||||||
return @@ E_big_map lst'
|
return @@ E_big_map lst'
|
||||||
)
|
)
|
||||||
| E_look_up ab -> (
|
|
||||||
let%bind ab' = bind_map_pair self ab in
|
|
||||||
return @@ E_look_up ab'
|
|
||||||
)
|
|
||||||
| E_ascription ascr -> (
|
| E_ascription ascr -> (
|
||||||
let%bind e' = self ascr.anno_expr in
|
let%bind e' = self ascr.anno_expr in
|
||||||
return @@ E_ascription {ascr with anno_expr=e'}
|
return @@ E_ascription {ascr with anno_expr=e'}
|
||||||
@ -179,32 +179,37 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
let%bind cases' = map_cases f cases in
|
let%bind cases' = map_cases f cases in
|
||||||
return @@ E_matching {matchee=e';cases=cases'}
|
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 -> (
|
| E_record m -> (
|
||||||
let%bind m' = bind_map_lmap self m in
|
let%bind m' = bind_map_lmap self m in
|
||||||
return @@ E_record m'
|
return @@ E_record m'
|
||||||
)
|
)
|
||||||
| E_record_update {record; path; update} -> (
|
| E_accessor {record; path} -> (
|
||||||
let%bind record = self record in
|
let%bind record = self record in
|
||||||
|
let aux a = match a with
|
||||||
|
| Access_map e ->
|
||||||
|
let%bind e = self e in
|
||||||
|
ok @@ Access_map e
|
||||||
|
| e -> ok @@ e
|
||||||
|
in
|
||||||
|
let%bind path = bind_map_list aux path in
|
||||||
|
return @@ E_accessor {record; path}
|
||||||
|
)
|
||||||
|
| E_update {record; path; update} -> (
|
||||||
|
let%bind record = self record in
|
||||||
|
let aux a = match a with
|
||||||
|
| Access_map e ->
|
||||||
|
let%bind e = self e in
|
||||||
|
ok @@ Access_map e
|
||||||
|
| e -> ok @@ e
|
||||||
|
in
|
||||||
|
let%bind path = bind_map_list aux path in
|
||||||
let%bind update = self update in
|
let%bind update = self update in
|
||||||
return @@ E_record_update {record;path;update}
|
return @@ E_update {record;path;update}
|
||||||
)
|
)
|
||||||
| E_tuple t -> (
|
| E_tuple t -> (
|
||||||
let%bind t' = bind_map_list self t in
|
let%bind t' = bind_map_list self t in
|
||||||
return @@ E_tuple t'
|
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 -> (
|
| E_constructor c -> (
|
||||||
let%bind e' = self c.element in
|
let%bind e' = self c.element in
|
||||||
return @@ E_constructor {c with element = e'}
|
return @@ E_constructor {c with element = e'}
|
||||||
@ -284,27 +289,35 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
|
|||||||
|
|
||||||
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
|
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
| Match_variant lst -> (
|
||||||
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 aux ((a , b) , e) =
|
||||||
let%bind e' = map_expression f e in
|
let%bind e' = map_expression f e in
|
||||||
ok ((a , b) , e')
|
ok ((a , b) , e')
|
||||||
in
|
in
|
||||||
let%bind lst' = bind_map_list aux lst in
|
let%bind lst' = bind_map_list aux lst in
|
||||||
ok @@ Match_variant (lst', ())
|
ok @@ Match_variant lst'
|
||||||
|
)
|
||||||
|
| 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_record (names, ty_opt, e) -> (
|
||||||
|
let%bind e' = map_expression f e in
|
||||||
|
ok @@ Match_record (names, ty_opt, e')
|
||||||
|
)
|
||||||
|
| Match_tuple (names, ty_opt, e) -> (
|
||||||
|
let%bind e' = map_expression f e in
|
||||||
|
ok @@ Match_tuple (names, ty_opt, e')
|
||||||
|
)
|
||||||
|
| Match_variable (name, ty_opt, e) -> (
|
||||||
|
let%bind e' = map_expression f e in
|
||||||
|
ok @@ Match_variable (name, ty_opt, e')
|
||||||
)
|
)
|
||||||
|
|
||||||
and map_program : abs_mapper -> program -> program result = fun m p ->
|
and map_program : abs_mapper -> program -> program result = fun m p ->
|
||||||
@ -347,10 +360,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
|
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
|
||||||
ok (res, return @@ E_big_map lst')
|
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 -> (
|
| E_ascription ascr -> (
|
||||||
let%bind (res,e') = self init' ascr.anno_expr in
|
let%bind (res,e') = self init' ascr.anno_expr in
|
||||||
ok (res, return @@ E_ascription {ascr with anno_expr=e'})
|
ok (res, return @@ E_ascription {ascr with anno_expr=e'})
|
||||||
@ -360,33 +369,38 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
let%bind (res,cases') = fold_map_cases f res cases in
|
let%bind (res,cases') = fold_map_cases f res cases in
|
||||||
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
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 -> (
|
| 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%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
|
let m' = LMap.of_list lst' in
|
||||||
ok (res, return @@ E_record m')
|
ok (res, return @@ E_record m')
|
||||||
)
|
)
|
||||||
| E_record_update {record; path; update} -> (
|
| E_accessor {record;path} -> (
|
||||||
let%bind (res, record) = self init' record in
|
let%bind (res, record) = self init' record in
|
||||||
|
let aux res a = match a with
|
||||||
|
| Access_map e ->
|
||||||
|
let%bind (res,e) = self res e in
|
||||||
|
ok @@ (res,Access_map e)
|
||||||
|
| e -> ok @@ (res,e)
|
||||||
|
in
|
||||||
|
let%bind (res, path) = bind_fold_map_list aux res path in
|
||||||
|
ok (res, return @@ E_accessor {record; path})
|
||||||
|
)
|
||||||
|
| E_update {record; path; update} -> (
|
||||||
|
let%bind (res, record) = self init' record in
|
||||||
|
let aux res a = match a with
|
||||||
|
| Access_map e ->
|
||||||
|
let%bind (res,e) = self res e in
|
||||||
|
ok @@ (res,Access_map e)
|
||||||
|
| e -> ok @@ (res,e)
|
||||||
|
in
|
||||||
|
let%bind (res, path) = bind_fold_map_list aux res path in
|
||||||
let%bind (res, update) = self res update in
|
let%bind (res, update) = self res update in
|
||||||
ok (res, return @@ E_record_update {record;path;update})
|
ok (res, return @@ E_update {record;path;update})
|
||||||
)
|
)
|
||||||
| E_tuple t -> (
|
| E_tuple t -> (
|
||||||
let%bind (res, t') = bind_fold_map_list self init' t in
|
let%bind (res, t') = bind_fold_map_list self init' t in
|
||||||
ok (res, return @@ E_tuple t')
|
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 -> (
|
| E_constructor c -> (
|
||||||
let%bind (res,e') = self init' c.element in
|
let%bind (res,e') = self init' c.element in
|
||||||
ok (res, return @@ E_constructor {c with element = e'})
|
ok (res, return @@ E_constructor {c with element = e'})
|
||||||
@ -440,25 +454,33 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
|
|
||||||
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
|
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
| Match_variant lst -> (
|
||||||
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 aux init ((a , b) , e) =
|
||||||
let%bind (init,e') = fold_map_expression f init e in
|
let%bind (init,e') = fold_map_expression f init e in
|
||||||
ok (init, ((a , b) , e'))
|
ok (init, ((a , b) , e'))
|
||||||
in
|
in
|
||||||
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
||||||
ok @@ (init, Match_variant (lst', ()))
|
ok @@ (init, Match_variant lst')
|
||||||
|
)
|
||||||
|
| 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_record (names, ty_opt, e) -> (
|
||||||
|
let%bind (init, e') = fold_map_expression f init e in
|
||||||
|
ok @@ (init, Match_record (names, ty_opt, e'))
|
||||||
|
)
|
||||||
|
| Match_tuple (names, ty_opt, e) -> (
|
||||||
|
let%bind (init, e') = fold_map_expression f init e in
|
||||||
|
ok @@ (init, Match_tuple (names, ty_opt, e'))
|
||||||
|
)
|
||||||
|
| Match_variable (name, ty_opt, e) -> (
|
||||||
|
let%bind (init, e') = fold_map_expression f init e in
|
||||||
|
ok @@ (init, Match_variable (name, ty_opt, e'))
|
||||||
)
|
)
|
||||||
|
|||||||
@ -46,7 +46,7 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam
|
|||||||
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs let_result)
|
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs let_result)
|
||||||
else(
|
else(
|
||||||
let free_var = if (List.mem name free_var) then free_var else name::free_var in
|
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
|
let expr = O.e_let_in (env,None) false false (O.e_update (O.e_variable env) [O.Access_record (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)
|
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_MAP_FOLD;arguments= _}
|
||||||
@ -58,9 +58,9 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam
|
|||||||
| E_skip
|
| E_skip
|
||||||
| E_literal _ | E_variable _
|
| E_literal _ | E_variable _
|
||||||
| E_application _ | E_lambda _| E_recursive _
|
| E_application _ | E_lambda _| E_recursive _
|
||||||
| E_constructor _ | E_record _| E_record_accessor _|E_record_update _
|
| E_constructor _ | E_record _| E_accessor _|E_update _
|
||||||
| E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _
|
| E_ascription _ | E_sequence _ | E_tuple _
|
||||||
| E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _
|
| E_map _ | E_big_map _ |E_list _ | E_set _
|
||||||
-> ok (true, (decl_var, free_var),ass_exp)
|
-> ok (true, (decl_var, free_var),ass_exp)
|
||||||
)
|
)
|
||||||
(element_names,[])
|
(element_names,[])
|
||||||
@ -87,8 +87,7 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
|
|||||||
else(
|
else(
|
||||||
let free_var = if (List.mem name free_var) then free_var else name::free_var in
|
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 (
|
let expr = O.e_let_in (env,None) false false (
|
||||||
O.e_record_update (O.e_variable env) (Label "0")
|
O.e_update (O.e_variable env) [O.Access_tuple Z.zero; O.Access_record (Var.to_name name)] (O.e_variable name)
|
||||||
(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
|
let_result in
|
||||||
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
|
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
|
||||||
@ -102,9 +101,9 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
|
|||||||
| E_skip
|
| E_skip
|
||||||
| E_literal _ | E_variable _
|
| E_literal _ | E_variable _
|
||||||
| E_application _ | E_lambda _| E_recursive _
|
| E_application _ | E_lambda _| E_recursive _
|
||||||
| E_constructor _ | E_record _| E_record_accessor _|E_record_update _
|
| E_constructor _ | E_record _| E_accessor _| E_update _
|
||||||
| E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _
|
| E_ascription _ | E_sequence _ | E_tuple _
|
||||||
| E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _
|
| E_map _ | E_big_map _ |E_list _ | E_set _
|
||||||
-> ok (true, (decl_var, free_var),ass_exp)
|
-> ok (true, (decl_var, free_var),ass_exp)
|
||||||
)
|
)
|
||||||
(element_names,[])
|
(element_names,[])
|
||||||
@ -120,7 +119,7 @@ and store_mutable_variable (free_vars : I.expression_variable list) =
|
|||||||
|
|
||||||
and restore_mutable_variable (expr : O.expression->O.expression) (free_vars : O.expression_variable list) (env : O.expression_variable) =
|
and restore_mutable_variable (expr : O.expression->O.expression) (free_vars : O.expression_variable list) (env : O.expression_variable) =
|
||||||
let aux (f: O.expression -> O.expression) (ev: 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)
|
fun expr -> f (O.e_let_in (ev,None) true false (O.e_accessor (O.e_variable env) [O.Access_record (Var.to_name ev)]) expr)
|
||||||
in
|
in
|
||||||
let ef = List.fold_left aux (fun e -> e) free_vars in
|
let ef = List.fold_left aux (fun e -> e) free_vars in
|
||||||
fun e -> match e with
|
fun e -> match e with
|
||||||
@ -234,13 +233,15 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ O.e_record ~loc (O.LMap.of_list record)
|
return @@ O.e_record ~loc (O.LMap.of_list record)
|
||||||
| I.E_record_accessor {record;path} ->
|
| I.E_accessor {record;path} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
return @@ O.e_record_accessor ~loc record path
|
let%bind path = compile_path path in
|
||||||
| I.E_record_update {record;path;update} ->
|
return @@ O.e_accessor ~loc record path
|
||||||
|
| I.E_update {record;path;update} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
|
let%bind path = compile_path path in
|
||||||
let%bind update = compile_expression update in
|
let%bind update = compile_expression update in
|
||||||
return @@ O.e_record_update ~loc record path update
|
return @@ O.e_update ~loc record path update
|
||||||
| I.E_map map ->
|
| I.E_map map ->
|
||||||
let%bind map = bind_map_list (
|
let%bind map = bind_map_list (
|
||||||
bind_map_pair compile_expression
|
bind_map_pair compile_expression
|
||||||
@ -259,9 +260,6 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
|
|||||||
| I.E_set set ->
|
| I.E_set set ->
|
||||||
let%bind set = bind_map_list compile_expression set in
|
let%bind set = bind_map_list compile_expression set in
|
||||||
return @@ O.e_set ~loc set
|
return @@ O.e_set ~loc set
|
||||||
| I.E_look_up look_up ->
|
|
||||||
let%bind (a,b) = bind_map_pair compile_expression look_up in
|
|
||||||
return @@ O.e_look_up ~loc a b
|
|
||||||
| I.E_ascription {anno_expr; type_annotation} ->
|
| I.E_ascription {anno_expr; type_annotation} ->
|
||||||
let%bind anno_expr = compile_expression anno_expr in
|
let%bind anno_expr = compile_expression anno_expr in
|
||||||
let%bind type_annotation = compile_type_expression type_annotation in
|
let%bind type_annotation = compile_type_expression type_annotation in
|
||||||
@ -298,41 +296,10 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
|
|||||||
| I.E_tuple tuple ->
|
| I.E_tuple tuple ->
|
||||||
let%bind tuple = bind_map_list compile_expression tuple in
|
let%bind tuple = bind_map_list compile_expression tuple in
|
||||||
return @@ O.e_tuple ~loc tuple
|
return @@ O.e_tuple ~loc tuple
|
||||||
| I.E_tuple_accessor {tuple;path} ->
|
|
||||||
let%bind tuple = compile_expression tuple in
|
|
||||||
return @@ O.e_tuple_accessor ~loc 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 ~loc tuple path update
|
|
||||||
| I.E_assign {variable; access_path; expression} ->
|
| I.E_assign {variable; access_path; expression} ->
|
||||||
let accessor ?loc s a =
|
let%bind access_path = compile_path access_path in
|
||||||
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 expression = compile_expression expression in
|
||||||
let%bind rhs = rhs @@ expression in
|
let rhs = O.e_update ~loc (O.e_variable ~loc variable) access_path expression in
|
||||||
ok @@ fun expr -> (match expr with
|
ok @@ fun expr -> (match expr with
|
||||||
| None -> O.e_let_in ~loc (variable,None) true false rhs (O.e_skip ())
|
| None -> O.e_let_in ~loc (variable,None) true false rhs (O.e_skip ())
|
||||||
| Some e -> O.e_let_in ~loc (variable, None) true false rhs e
|
| Some e -> O.e_let_in ~loc (variable, None) true false rhs e
|
||||||
@ -347,6 +314,16 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
|
|||||||
let%bind w = compile_while w in
|
let%bind w = compile_while w in
|
||||||
ok @@ w
|
ok @@ w
|
||||||
|
|
||||||
|
and compile_path : I.access list -> O.access list result =
|
||||||
|
fun path ->
|
||||||
|
let aux a = match a with
|
||||||
|
| I.Access_record s -> ok @@ O.Access_record s
|
||||||
|
| I.Access_tuple i -> ok @@ O.Access_tuple i
|
||||||
|
| I.Access_map e ->
|
||||||
|
let%bind e = compile_expression e in
|
||||||
|
ok @@ O.Access_map e
|
||||||
|
in
|
||||||
|
bind_map_list aux path
|
||||||
|
|
||||||
and compile_lambda : I.lambda -> O.lambda result =
|
and compile_lambda : I.lambda -> O.lambda result =
|
||||||
fun {binder;input_type;output_type;result}->
|
fun {binder;input_type;output_type;result}->
|
||||||
@ -365,7 +342,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
|
|||||||
match cases with
|
match cases with
|
||||||
| I.Match_option {match_none;match_some} ->
|
| 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 (n,expr) = match_some in
|
||||||
let%bind expr' = compile_expression expr in
|
let%bind expr' = compile_expression expr in
|
||||||
let env = Var.fresh () 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_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in
|
||||||
@ -374,7 +351,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
|
|||||||
let expr = add_to_end expr (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
|
let free_vars = List.sort_uniq Var.compare @@ free_vars_none @ free_vars_some in
|
||||||
if (List.length free_vars != 0) then
|
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 match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr)}) in
|
||||||
let return_expr = fun expr ->
|
let return_expr = fun expr ->
|
||||||
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
|
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
|
||||||
O.e_let_in (env,None) false false match_expr @@
|
O.e_let_in (env,None) false false match_expr @@
|
||||||
@ -382,10 +359,10 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
|
|||||||
in
|
in
|
||||||
ok @@ restore_mutable_variable return_expr free_vars env
|
ok @@ restore_mutable_variable return_expr free_vars env
|
||||||
else
|
else
|
||||||
return @@ O.e_matching ~loc matchee @@ O.Match_option {match_none=match_none'; match_some=(n,expr',tv)}
|
return @@ O.e_matching ~loc matchee @@ O.Match_option {match_none=match_none'; match_some=(n,expr')}
|
||||||
| I.Match_list {match_nil;match_cons} ->
|
| I.Match_list {match_nil;match_cons} ->
|
||||||
let%bind match_nil' = compile_expression match_nil in
|
let%bind match_nil' = compile_expression match_nil in
|
||||||
let (hd,tl,expr,tv) = match_cons in
|
let (hd,tl,expr) = match_cons in
|
||||||
let%bind expr' = compile_expression expr in
|
let%bind expr' = compile_expression expr in
|
||||||
let env = Var.fresh () 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_nil), match_nil) = repair_mutable_variable_in_matching match_nil' [] env in
|
||||||
@ -394,7 +371,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
|
|||||||
let expr = add_to_end expr (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
|
let free_vars = List.sort_uniq Var.compare @@ free_vars_nil @ free_vars_cons in
|
||||||
if (List.length free_vars != 0) then
|
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 match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr)}) in
|
||||||
let return_expr = fun expr ->
|
let return_expr = fun expr ->
|
||||||
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
|
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
|
||||||
O.e_let_in (env,None) false false match_expr @@
|
O.e_let_in (env,None) false false match_expr @@
|
||||||
@ -402,11 +379,8 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
|
|||||||
in
|
in
|
||||||
ok @@ restore_mutable_variable return_expr free_vars env
|
ok @@ restore_mutable_variable return_expr free_vars env
|
||||||
else
|
else
|
||||||
return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)}
|
return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')}
|
||||||
| I.Match_tuple ((lst,expr), tv) ->
|
| I.Match_variant lst ->
|
||||||
let%bind expr = compile_expression expr in
|
|
||||||
return @@ O.e_matching ~loc matchee @@ O.Match_tuple ((lst,expr), tv)
|
|
||||||
| I.Match_variant (lst,tv) ->
|
|
||||||
let env = Var.fresh () in
|
let env = Var.fresh () in
|
||||||
let aux fv ((c,n),expr) =
|
let aux fv ((c,n),expr) =
|
||||||
let%bind expr = compile_expression expr in
|
let%bind expr = compile_expression expr in
|
||||||
@ -418,10 +392,10 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
|
|||||||
let free_vars = List.sort_uniq Var.compare @@ List.concat fv in
|
let free_vars = List.sort_uniq Var.compare @@ List.concat fv in
|
||||||
if (List.length free_vars == 0) then (
|
if (List.length free_vars == 0) then (
|
||||||
let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
|
let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in
|
||||||
return @@ O.e_matching ~loc matchee @@ O.Match_variant (cases,tv)
|
return @@ O.e_matching ~loc matchee @@ O.Match_variant cases
|
||||||
) else (
|
) else (
|
||||||
let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in
|
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 match_expr = O.e_matching matchee @@ O.Match_variant cases in
|
||||||
let return_expr = fun expr ->
|
let return_expr = fun expr ->
|
||||||
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
|
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
|
||||||
O.e_let_in (env,None) false false match_expr @@
|
O.e_let_in (env,None) false false match_expr @@
|
||||||
@ -429,6 +403,18 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
|
|||||||
in
|
in
|
||||||
ok @@ restore_mutable_variable return_expr free_vars env
|
ok @@ restore_mutable_variable return_expr free_vars env
|
||||||
)
|
)
|
||||||
|
| I.Match_record (lst,ty_opt,expr) ->
|
||||||
|
let%bind expr = compile_expression expr in
|
||||||
|
let%bind ty_opt = bind_map_option (bind_map_list compile_type_expression) ty_opt in
|
||||||
|
return @@ O.e_matching ~loc matchee @@ O.Match_record (lst,ty_opt,expr)
|
||||||
|
| I.Match_tuple (lst,ty_opt,expr) ->
|
||||||
|
let%bind expr = compile_expression expr in
|
||||||
|
let%bind ty_opt = bind_map_option (bind_map_list compile_type_expression) ty_opt in
|
||||||
|
return @@ O.e_matching ~loc matchee @@ O.Match_tuple (lst,ty_opt,expr)
|
||||||
|
| I.Match_variable (lst,ty_opt,expr) ->
|
||||||
|
let%bind expr = compile_expression expr in
|
||||||
|
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
|
||||||
|
return @@ O.e_matching ~loc matchee @@ O.Match_variable (lst,ty_opt,expr)
|
||||||
|
|
||||||
and compile_while I.{condition;body} =
|
and compile_while I.{condition;body} =
|
||||||
let env_rec = Var.fresh () in
|
let env_rec = Var.fresh () in
|
||||||
@ -444,7 +430,7 @@ and compile_while I.{condition;body} =
|
|||||||
let for_body = add_to_end for_body ctrl in
|
let for_body = add_to_end for_body ctrl in
|
||||||
|
|
||||||
let aux name expr=
|
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
|
O.e_let_in (name,None) false false (O.e_accessor (O.e_variable binder) [Access_tuple Z.zero; Access_record (Var.to_name name)]) expr
|
||||||
in
|
in
|
||||||
let init_rec = O.e_tuple [store_mutable_variable @@ captured_name_list] 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 restore = fun expr -> List.fold_right aux captured_name_list expr in
|
||||||
@ -459,7 +445,7 @@ and compile_while I.{condition;body} =
|
|||||||
let return_expr = fun expr ->
|
let return_expr = fun expr ->
|
||||||
O.e_let_in let_binder false false init_rec @@
|
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 loop @@
|
||||||
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label"0")) @@
|
O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.zero]) @@
|
||||||
expr
|
expr
|
||||||
in
|
in
|
||||||
ok @@ restore_mutable_variable return_expr captured_name_list env_rec
|
ok @@ restore_mutable_variable return_expr captured_name_list env_rec
|
||||||
@ -474,7 +460,7 @@ and compile_for I.{binder;start;final;increment;body} =
|
|||||||
let continue_expr = O.e_constant C_FOLD_CONTINUE [(O.e_variable env_rec)] in
|
let continue_expr = O.e_constant C_FOLD_CONTINUE [(O.e_variable env_rec)] in
|
||||||
let ctrl =
|
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 (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)@@
|
O.e_let_in (env_rec, None) false false (O.e_update (O.e_variable env_rec) [Access_tuple Z.one] @@ O.e_variable binder)@@
|
||||||
continue_expr
|
continue_expr
|
||||||
in
|
in
|
||||||
(* Modify the body loop*)
|
(* Modify the body loop*)
|
||||||
@ -483,7 +469,7 @@ and compile_for I.{binder;start;final;increment;body} =
|
|||||||
let for_body = add_to_end for_body ctrl in
|
let for_body = add_to_end for_body ctrl in
|
||||||
|
|
||||||
let aux name expr=
|
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
|
O.e_let_in (name,None) false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.zero; Access_record (Var.to_name name)]) expr
|
||||||
in
|
in
|
||||||
|
|
||||||
(* restores the initial value of the free_var*)
|
(* restores the initial value of the free_var*)
|
||||||
@ -492,7 +478,7 @@ and compile_for I.{binder;start;final;increment;body} =
|
|||||||
(*Prep the lambda for the fold*)
|
(*Prep the lambda for the fold*)
|
||||||
let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable env_rec] in
|
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 @@
|
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_let_in (binder,Some (O.t_int ())) false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.one]) @@
|
||||||
O.e_cond cond (restore for_body) (stop_expr) in
|
O.e_cond cond (restore for_body) (stop_expr) in
|
||||||
|
|
||||||
(* Make the fold_while en precharge the vakye *)
|
(* Make the fold_while en precharge the vakye *)
|
||||||
@ -505,7 +491,7 @@ and compile_for I.{binder;start;final;increment;body} =
|
|||||||
O.e_let_in (binder, Some (O.t_int ())) false false start @@
|
O.e_let_in (binder, Some (O.t_int ())) false false start @@
|
||||||
O.e_let_in let_binder false false init_rec @@
|
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 loop @@
|
||||||
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label "0")) @@
|
O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.zero]) @@
|
||||||
expr
|
expr
|
||||||
in
|
in
|
||||||
ok @@ restore_mutable_variable return_expr captured_name_list env_rec
|
ok @@ restore_mutable_variable return_expr captured_name_list env_rec
|
||||||
@ -521,21 +507,21 @@ and compile_for_each I.{binder;collection;collection_type; body} =
|
|||||||
|
|
||||||
let%bind body = compile_expression body in
|
let%bind body = compile_expression body in
|
||||||
let%bind ((_,free_vars), body) = repair_mutable_variable_in_loops body element_names args 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 for_body = add_to_end body @@ (O.e_accessor (O.e_variable args) [Access_tuple Z.zero]) in
|
||||||
|
|
||||||
let init_record = store_mutable_variable free_vars in
|
let init_record = store_mutable_variable free_vars in
|
||||||
let%bind collect = compile_expression collection in
|
let%bind collect = compile_expression collection in
|
||||||
let aux name expr=
|
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
|
O.e_let_in (name,None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.zero; Access_record (Var.to_name name)]) expr
|
||||||
in
|
in
|
||||||
let restore = fun expr -> List.fold_right aux free_vars expr in
|
let restore = fun expr -> List.fold_right aux free_vars expr in
|
||||||
let restore = match collection_type with
|
let restore = match collection_type with
|
||||||
| Map -> (match snd binder 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"))
|
| Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.one; Access_tuple Z.zero])
|
||||||
(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))
|
(O.e_let_in (v, None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.one; Access_tuple Z.one]) 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)
|
| None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.one; Access_tuple Z.zero]) expr)
|
||||||
)
|
)
|
||||||
| _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_variable args) (Label "1")) expr)
|
| _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.one]) expr)
|
||||||
in
|
in
|
||||||
let lambda = O.e_lambda args None None (restore for_body) in
|
let lambda = O.e_lambda args None None (restore for_body) in
|
||||||
let%bind op_name = match collection_type with
|
let%bind op_name = match collection_type with
|
||||||
@ -601,18 +587,18 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
|
|||||||
let%bind lst = bind_map_list uncompile_type_expression lst in
|
let%bind lst = bind_map_list uncompile_type_expression lst in
|
||||||
return @@ T_operator (type_operator, lst)
|
return @@ T_operator (type_operator, lst)
|
||||||
|
|
||||||
let rec uncompile_expression' : O.expression -> I.expression result =
|
let rec uncompile_expression : O.expression -> I.expression result =
|
||||||
fun e ->
|
fun e ->
|
||||||
let return expr = ok @@ I.make_e ~loc:e.location expr in
|
let return expr = ok @@ I.make_e ~loc:e.location expr in
|
||||||
match e.expression_content with
|
match e.expression_content with
|
||||||
O.E_literal lit -> return @@ I.E_literal lit
|
O.E_literal lit -> return @@ I.E_literal lit
|
||||||
| O.E_constant {cons_name;arguments} ->
|
| O.E_constant {cons_name;arguments} ->
|
||||||
let%bind arguments = bind_map_list uncompile_expression' arguments in
|
let%bind arguments = bind_map_list uncompile_expression arguments in
|
||||||
return @@ I.E_constant {cons_name;arguments}
|
return @@ I.E_constant {cons_name;arguments}
|
||||||
| O.E_variable name -> return @@ I.E_variable name
|
| O.E_variable name -> return @@ I.E_variable name
|
||||||
| O.E_application {lamb; args} ->
|
| O.E_application {lamb; args} ->
|
||||||
let%bind lamb = uncompile_expression' lamb in
|
let%bind lamb = uncompile_expression lamb in
|
||||||
let%bind args = uncompile_expression' args in
|
let%bind args = uncompile_expression args in
|
||||||
return @@ I.E_application {lamb; args}
|
return @@ I.E_application {lamb; args}
|
||||||
| O.E_lambda lambda ->
|
| O.E_lambda lambda ->
|
||||||
let%bind lambda = uncompile_lambda lambda in
|
let%bind lambda = uncompile_lambda lambda in
|
||||||
@ -624,105 +610,116 @@ let rec uncompile_expression' : O.expression -> I.expression result =
|
|||||||
| O.E_let_in {let_binder;inline;rhs;let_result} ->
|
| O.E_let_in {let_binder;inline;rhs;let_result} ->
|
||||||
let (binder,ty_opt) = let_binder in
|
let (binder,ty_opt) = let_binder in
|
||||||
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
|
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
|
||||||
let%bind rhs = uncompile_expression' rhs in
|
let%bind rhs = uncompile_expression rhs in
|
||||||
let%bind let_result = uncompile_expression' let_result 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);inline;rhs;let_result}
|
||||||
| O.E_constructor {constructor;element} ->
|
| O.E_constructor {constructor;element} ->
|
||||||
let%bind element = uncompile_expression' element in
|
let%bind element = uncompile_expression element in
|
||||||
return @@ I.E_constructor {constructor;element}
|
return @@ I.E_constructor {constructor;element}
|
||||||
| O.E_matching {matchee; cases} ->
|
| O.E_matching {matchee; cases} ->
|
||||||
let%bind matchee = uncompile_expression' matchee in
|
let%bind matchee = uncompile_expression matchee in
|
||||||
let%bind cases = uncompile_matching cases in
|
let%bind cases = uncompile_matching cases in
|
||||||
return @@ I.E_matching {matchee;cases}
|
return @@ I.E_matching {matchee;cases}
|
||||||
| O.E_record record ->
|
| O.E_record record ->
|
||||||
let record = I.LMap.to_kv_list record in
|
let record = I.LMap.to_kv_list record in
|
||||||
let%bind record =
|
let%bind record =
|
||||||
bind_map_list (fun (k,v) ->
|
bind_map_list (fun (k,v) ->
|
||||||
let%bind v = uncompile_expression' v in
|
let%bind v = uncompile_expression v in
|
||||||
ok @@ (k,v)
|
ok @@ (k,v)
|
||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ I.E_record (O.LMap.of_list record)
|
return @@ I.E_record (O.LMap.of_list record)
|
||||||
| O.E_record_accessor {record;path} ->
|
| O.E_accessor {record;path} ->
|
||||||
let%bind record = uncompile_expression' record in
|
let%bind record = uncompile_expression record in
|
||||||
return @@ I.E_record_accessor {record;path}
|
let%bind path = uncompile_path path in
|
||||||
| O.E_record_update {record;path;update} ->
|
return @@ I.E_accessor {record;path}
|
||||||
let%bind record = uncompile_expression' record in
|
| O.E_update {record;path;update} ->
|
||||||
let%bind update = uncompile_expression' update in
|
let%bind record = uncompile_expression record in
|
||||||
return @@ I.E_record_update {record;path;update}
|
let%bind path = uncompile_path path in
|
||||||
|
let%bind update = uncompile_expression update in
|
||||||
|
return @@ I.E_update {record;path;update}
|
||||||
| O.E_tuple tuple ->
|
| O.E_tuple tuple ->
|
||||||
let%bind tuple = bind_map_list uncompile_expression' tuple in
|
let%bind tuple = bind_map_list uncompile_expression tuple in
|
||||||
return @@ I.E_tuple tuple
|
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 ->
|
| O.E_map map ->
|
||||||
let%bind map = bind_map_list (
|
let%bind map = bind_map_list (
|
||||||
bind_map_pair uncompile_expression'
|
bind_map_pair uncompile_expression
|
||||||
) map
|
) map
|
||||||
in
|
in
|
||||||
return @@ I.E_map map
|
return @@ I.E_map map
|
||||||
| O.E_big_map big_map ->
|
| O.E_big_map big_map ->
|
||||||
let%bind big_map = bind_map_list (
|
let%bind big_map = bind_map_list (
|
||||||
bind_map_pair uncompile_expression'
|
bind_map_pair uncompile_expression
|
||||||
) big_map
|
) big_map
|
||||||
in
|
in
|
||||||
return @@ I.E_big_map big_map
|
return @@ I.E_big_map big_map
|
||||||
| O.E_list lst ->
|
| O.E_list lst ->
|
||||||
let%bind lst = bind_map_list uncompile_expression' lst in
|
let%bind lst = bind_map_list uncompile_expression lst in
|
||||||
return @@ I.E_list lst
|
return @@ I.E_list lst
|
||||||
| O.E_set set ->
|
| O.E_set set ->
|
||||||
let%bind set = bind_map_list uncompile_expression' set in
|
let%bind set = bind_map_list uncompile_expression set in
|
||||||
return @@ I.E_set set
|
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} ->
|
| O.E_ascription {anno_expr; type_annotation} ->
|
||||||
let%bind anno_expr = uncompile_expression' anno_expr in
|
let%bind anno_expr = uncompile_expression anno_expr in
|
||||||
let%bind type_annotation = uncompile_type_expression type_annotation in
|
let%bind type_annotation = uncompile_type_expression type_annotation in
|
||||||
return @@ I.E_ascription {anno_expr; type_annotation}
|
return @@ I.E_ascription {anno_expr; type_annotation}
|
||||||
| O.E_cond {condition;then_clause;else_clause} ->
|
| O.E_cond {condition;then_clause;else_clause} ->
|
||||||
let%bind condition = uncompile_expression' condition in
|
let%bind condition = uncompile_expression condition in
|
||||||
let%bind then_clause = uncompile_expression' then_clause in
|
let%bind then_clause = uncompile_expression then_clause in
|
||||||
let%bind else_clause = uncompile_expression' else_clause in
|
let%bind else_clause = uncompile_expression else_clause in
|
||||||
return @@ I.E_cond {condition; then_clause; else_clause}
|
return @@ I.E_cond {condition; then_clause; else_clause}
|
||||||
| O.E_sequence {expr1; expr2} ->
|
| O.E_sequence {expr1; expr2} ->
|
||||||
let%bind expr1 = uncompile_expression' expr1 in
|
let%bind expr1 = uncompile_expression expr1 in
|
||||||
let%bind expr2 = uncompile_expression' expr2 in
|
let%bind expr2 = uncompile_expression expr2 in
|
||||||
return @@ I.E_sequence {expr1; expr2}
|
return @@ I.E_sequence {expr1; expr2}
|
||||||
| O.E_skip -> return @@ I.E_skip
|
| O.E_skip -> return @@ I.E_skip
|
||||||
|
|
||||||
|
and uncompile_path : O.access list -> I.access list result =
|
||||||
|
fun path -> let aux a = match a with
|
||||||
|
| O.Access_record s -> ok @@ I.Access_record s
|
||||||
|
| O.Access_tuple i -> ok @@ I.Access_tuple i
|
||||||
|
| O.Access_map e ->
|
||||||
|
let%bind e = uncompile_expression e in
|
||||||
|
ok @@ I.Access_map e
|
||||||
|
in
|
||||||
|
bind_map_list aux path
|
||||||
|
|
||||||
and uncompile_lambda : O.lambda -> I.lambda result =
|
and uncompile_lambda : O.lambda -> I.lambda result =
|
||||||
fun {binder;input_type;output_type;result}->
|
fun {binder;input_type;output_type;result}->
|
||||||
let%bind input_type = bind_map_option uncompile_type_expression input_type in
|
let%bind input_type = bind_map_option uncompile_type_expression input_type in
|
||||||
let%bind output_type = bind_map_option uncompile_type_expression output_type in
|
let%bind output_type = bind_map_option uncompile_type_expression output_type in
|
||||||
let%bind result = uncompile_expression' result in
|
let%bind result = uncompile_expression result in
|
||||||
ok @@ I.{binder;input_type;output_type;result}
|
ok @@ I.{binder;input_type;output_type;result}
|
||||||
and uncompile_matching : O.matching_expr -> I.matching_expr result =
|
and uncompile_matching : O.matching_expr -> I.matching_expr result =
|
||||||
fun m ->
|
fun m ->
|
||||||
match m with
|
match m with
|
||||||
| O.Match_list {match_nil;match_cons} ->
|
| O.Match_list {match_nil;match_cons} ->
|
||||||
let%bind match_nil = uncompile_expression' match_nil in
|
let%bind match_nil = uncompile_expression match_nil in
|
||||||
let (hd,tl,expr,tv) = match_cons in
|
let (hd,tl,expr) = match_cons in
|
||||||
let%bind expr = uncompile_expression' expr in
|
let%bind expr = uncompile_expression expr in
|
||||||
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
|
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr)}
|
||||||
| O.Match_option {match_none;match_some} ->
|
| O.Match_option {match_none;match_some} ->
|
||||||
let%bind match_none = uncompile_expression' match_none in
|
let%bind match_none = uncompile_expression match_none in
|
||||||
let (n,expr,tv) = match_some in
|
let (n,expr) = match_some in
|
||||||
let%bind expr = uncompile_expression' expr in
|
let%bind expr = uncompile_expression expr in
|
||||||
ok @@ I.Match_option {match_none; match_some=(n,expr,tv)}
|
ok @@ I.Match_option {match_none; match_some=(n,expr)}
|
||||||
| O.Match_tuple ((lst,expr), tv) ->
|
| O.Match_variant lst ->
|
||||||
let%bind expr = uncompile_expression' expr in
|
|
||||||
ok @@ O.Match_tuple ((lst,expr), tv)
|
|
||||||
| O.Match_variant (lst,tv) ->
|
|
||||||
let%bind lst = bind_map_list (
|
let%bind lst = bind_map_list (
|
||||||
fun ((c,n),expr) ->
|
fun ((c,n),expr) ->
|
||||||
let%bind expr = uncompile_expression' expr in
|
let%bind expr = uncompile_expression expr in
|
||||||
ok @@ ((c,n),expr)
|
ok @@ ((c,n),expr)
|
||||||
) lst
|
) lst
|
||||||
in
|
in
|
||||||
ok @@ I.Match_variant (lst,tv)
|
ok @@ I.Match_variant lst
|
||||||
|
| O.Match_record (lst,ty_opt,expr) ->
|
||||||
|
let%bind expr = uncompile_expression expr in
|
||||||
|
let%bind ty_opt = bind_map_option (bind_map_list uncompile_type_expression) ty_opt in
|
||||||
|
ok @@ I.Match_record (lst,ty_opt,expr)
|
||||||
|
| O.Match_tuple (lst,ty_opt,expr) ->
|
||||||
|
let%bind expr = uncompile_expression expr in
|
||||||
|
let%bind ty_opt = bind_map_option (bind_map_list uncompile_type_expression) ty_opt in
|
||||||
|
ok @@ I.Match_tuple (lst,ty_opt,expr)
|
||||||
|
| O.Match_variable (lst,ty_opt,expr) ->
|
||||||
|
let%bind expr = uncompile_expression expr in
|
||||||
|
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
|
||||||
|
ok @@ I.Match_variable (lst,ty_opt,expr)
|
||||||
|
|||||||
@ -30,9 +30,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
|
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_look_up ab ->
|
|
||||||
let%bind res = bind_fold_pair self init' ab in
|
|
||||||
ok res
|
|
||||||
| E_application {lamb;args} -> (
|
| E_application {lamb;args} -> (
|
||||||
let ab = (lamb,args) in
|
let ab = (lamb,args) in
|
||||||
let%bind res = bind_fold_pair self init' ab in
|
let%bind res = bind_fold_pair self init' ab in
|
||||||
@ -56,13 +53,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = bind_fold_lmap aux (ok init') m in
|
let%bind res = bind_fold_lmap aux (ok init') m in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_record_update {record;update} -> (
|
| E_update {record;path;update} -> (
|
||||||
let%bind res = self init' record in
|
let%bind res = self init' record in
|
||||||
|
let aux res a = match a with
|
||||||
|
| Access_map e -> self res e
|
||||||
|
| _ -> ok res
|
||||||
|
in
|
||||||
|
let%bind res = bind_fold_list aux res path in
|
||||||
let%bind res = fold_expression self res update in
|
let%bind res = fold_expression self res update in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_record_accessor {record} -> (
|
| E_accessor {record;path} -> (
|
||||||
let%bind res = self init' record in
|
let%bind res = self init' record in
|
||||||
|
let aux res a = match a with
|
||||||
|
| Access_map e -> self res e
|
||||||
|
| _ -> ok res
|
||||||
|
in
|
||||||
|
let%bind res = bind_fold_list aux res path in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
||||||
@ -90,40 +97,38 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = bind_fold_list aux (init') t in
|
let%bind res = bind_fold_list aux (init') t in
|
||||||
ok res
|
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 ->
|
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
|
| Match_variant lst -> (
|
||||||
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 aux init' ((_ , _) , e) =
|
||||||
let%bind res' = fold_expression f init' e in
|
let%bind res' = fold_expression f init' e in
|
||||||
ok res' in
|
ok res' in
|
||||||
let%bind res = bind_fold_list aux init lst in
|
let%bind res = bind_fold_list aux init lst in
|
||||||
ok res
|
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_record (_, _, e) -> (
|
||||||
|
let%bind res = fold_expression f init e in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
| Match_tuple (_, _, e) -> (
|
||||||
|
let%bind res = fold_expression f init e in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
| Match_variable (_, _, e) -> (
|
||||||
|
let%bind res = fold_expression f init e in
|
||||||
|
ok res
|
||||||
|
)
|
||||||
|
|
||||||
type exp_mapper = expression -> expression result
|
type exp_mapper = expression -> expression result
|
||||||
type ty_exp_mapper = type_expression -> type_expression result
|
type ty_exp_mapper = type_expression -> type_expression result
|
||||||
@ -151,10 +156,6 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
let%bind lst' = bind_map_list (bind_map_pair self) lst in
|
let%bind lst' = bind_map_list (bind_map_pair self) lst in
|
||||||
return @@ E_big_map lst'
|
return @@ E_big_map lst'
|
||||||
)
|
)
|
||||||
| E_look_up ab -> (
|
|
||||||
let%bind ab' = bind_map_pair self ab in
|
|
||||||
return @@ E_look_up ab'
|
|
||||||
)
|
|
||||||
| E_ascription ascr -> (
|
| E_ascription ascr -> (
|
||||||
let%bind e' = self ascr.anno_expr in
|
let%bind e' = self ascr.anno_expr in
|
||||||
return @@ E_ascription {ascr with anno_expr=e'}
|
return @@ E_ascription {ascr with anno_expr=e'}
|
||||||
@ -164,18 +165,32 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
let%bind cases' = map_cases f cases in
|
let%bind cases' = map_cases f cases in
|
||||||
return @@ E_matching {matchee=e';cases=cases'}
|
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 -> (
|
| E_record m -> (
|
||||||
let%bind m' = bind_map_lmap self m in
|
let%bind m' = bind_map_lmap self m in
|
||||||
return @@ E_record m'
|
return @@ E_record m'
|
||||||
)
|
)
|
||||||
| E_record_update {record; path; update} -> (
|
| E_accessor {record; path} -> (
|
||||||
let%bind record = self record in
|
let%bind record = self record in
|
||||||
|
let aux a = match a with
|
||||||
|
| Access_map e ->
|
||||||
|
let%bind e = self e in
|
||||||
|
ok @@ Access_map e
|
||||||
|
| e -> ok @@ e
|
||||||
|
in
|
||||||
|
let%bind path = bind_map_list aux path in
|
||||||
|
return @@ E_accessor {record; path}
|
||||||
|
)
|
||||||
|
| E_update {record; path; update} -> (
|
||||||
|
let%bind record = self record in
|
||||||
|
let aux a = match a with
|
||||||
|
| Access_map e ->
|
||||||
|
let%bind e = self e in
|
||||||
|
ok @@ Access_map e
|
||||||
|
| e -> ok @@ e
|
||||||
|
in
|
||||||
|
let%bind path = bind_map_list aux path in
|
||||||
let%bind update = self update in
|
let%bind update = self update in
|
||||||
return @@ E_record_update {record;path;update}
|
return @@ E_update {record;path;update}
|
||||||
)
|
)
|
||||||
| E_constructor c -> (
|
| E_constructor c -> (
|
||||||
let%bind e' = self c.element in
|
let%bind e' = self c.element in
|
||||||
@ -216,15 +231,6 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
let%bind t' = bind_map_list self t in
|
let%bind t' = bind_map_list self t in
|
||||||
return @@ E_tuple t'
|
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'
|
| 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 ->
|
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
|
||||||
@ -250,27 +256,35 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
|
|||||||
|
|
||||||
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
|
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
| Match_variant lst -> (
|
||||||
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 aux ((a , b) , e) =
|
||||||
let%bind e' = map_expression f e in
|
let%bind e' = map_expression f e in
|
||||||
ok ((a , b) , e')
|
ok ((a , b) , e')
|
||||||
in
|
in
|
||||||
let%bind lst' = bind_map_list aux lst in
|
let%bind lst' = bind_map_list aux lst in
|
||||||
ok @@ Match_variant (lst', ())
|
ok @@ Match_variant lst'
|
||||||
|
)
|
||||||
|
| 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_record (names, ty_opt, e) -> (
|
||||||
|
let%bind e' = map_expression f e in
|
||||||
|
ok @@ Match_record (names, ty_opt, e')
|
||||||
|
)
|
||||||
|
| Match_tuple (names, ty_opt, e) -> (
|
||||||
|
let%bind e' = map_expression f e in
|
||||||
|
ok @@ Match_tuple (names, ty_opt, e')
|
||||||
|
)
|
||||||
|
| Match_variable (name, ty_opt, e) -> (
|
||||||
|
let%bind e' = map_expression f e in
|
||||||
|
ok @@ Match_variable (name, ty_opt, e')
|
||||||
)
|
)
|
||||||
|
|
||||||
and map_program : abs_mapper -> program -> program result = fun m p ->
|
and map_program : abs_mapper -> program -> program result = fun m p ->
|
||||||
@ -313,10 +327,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
|
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
|
||||||
ok (res, return @@ E_big_map lst')
|
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 -> (
|
| E_ascription ascr -> (
|
||||||
let%bind (res,e') = self init' ascr.anno_expr in
|
let%bind (res,e') = self init' ascr.anno_expr in
|
||||||
ok (res, return @@ E_ascription {ascr with anno_expr=e'})
|
ok (res, return @@ E_ascription {ascr with anno_expr=e'})
|
||||||
@ -326,33 +336,38 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
let%bind (res,cases') = fold_map_cases f res cases in
|
let%bind (res,cases') = fold_map_cases f res cases in
|
||||||
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
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 -> (
|
| 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%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
|
let m' = LMap.of_list lst' in
|
||||||
ok (res, return @@ E_record m')
|
ok (res, return @@ E_record m')
|
||||||
)
|
)
|
||||||
| E_record_update {record; path; update} -> (
|
| E_accessor {record;path} -> (
|
||||||
let%bind (res, record) = self init' record in
|
let%bind (res, record) = self init' record in
|
||||||
|
let aux res a = match a with
|
||||||
|
| Access_map e ->
|
||||||
|
let%bind (res,e) = self res e in
|
||||||
|
ok @@ (res,Access_map e)
|
||||||
|
| e -> ok @@ (res,e)
|
||||||
|
in
|
||||||
|
let%bind (res, path) = bind_fold_map_list aux res path in
|
||||||
|
ok (res, return @@ E_accessor {record; path})
|
||||||
|
)
|
||||||
|
| E_update {record; path; update} -> (
|
||||||
|
let%bind (res, record) = self init' record in
|
||||||
|
let aux res a = match a with
|
||||||
|
| Access_map e ->
|
||||||
|
let%bind (res,e) = self res e in
|
||||||
|
ok @@ (res,Access_map e)
|
||||||
|
| e -> ok @@ (res,e)
|
||||||
|
in
|
||||||
|
let%bind (res, path) = bind_fold_map_list aux res path in
|
||||||
let%bind (res, update) = self res update in
|
let%bind (res, update) = self res update in
|
||||||
ok (res, return @@ E_record_update {record;path;update})
|
ok (res, return @@ E_update {record;path;update})
|
||||||
)
|
)
|
||||||
| E_tuple t -> (
|
| E_tuple t -> (
|
||||||
let%bind (res, t') = bind_fold_map_list self init' t in
|
let%bind (res, t') = bind_fold_map_list self init' t in
|
||||||
ok (res, return @@ E_tuple t')
|
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 -> (
|
| E_constructor c -> (
|
||||||
let%bind (res,e') = self init' c.element in
|
let%bind (res,e') = self init' c.element in
|
||||||
ok (res, return @@ E_constructor {c with element = e'})
|
ok (res, return @@ E_constructor {c with element = e'})
|
||||||
@ -389,28 +404,35 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
ok (res, return @@ E_sequence {expr1;expr2})
|
ok (res, return @@ E_sequence {expr1;expr2})
|
||||||
)
|
)
|
||||||
| E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e')
|
| 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 ->
|
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
| Match_variant lst -> (
|
||||||
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 aux init ((a , b) , e) =
|
||||||
let%bind (init,e') = fold_map_expression f init e in
|
let%bind (init,e') = fold_map_expression f init e in
|
||||||
ok (init, ((a , b) , e'))
|
ok (init, ((a , b) , e'))
|
||||||
in
|
in
|
||||||
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
||||||
ok @@ (init, Match_variant (lst', ()))
|
ok @@ (init, Match_variant lst')
|
||||||
|
)
|
||||||
|
| 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_record (names, ty_opt, e) -> (
|
||||||
|
let%bind (init, e') = fold_map_expression f init e in
|
||||||
|
ok @@ (init, Match_record (names, ty_opt, e'))
|
||||||
|
)
|
||||||
|
| Match_tuple (names, ty_opt, e) -> (
|
||||||
|
let%bind (init, e') = fold_map_expression f init e in
|
||||||
|
ok @@ (init, Match_tuple (names, ty_opt, e'))
|
||||||
|
)
|
||||||
|
| Match_variable (name, ty_opt, e) -> (
|
||||||
|
let%bind (init, e') = fold_map_expression f init e in
|
||||||
|
ok @@ (init, Match_variable (name, ty_opt, e'))
|
||||||
)
|
)
|
||||||
|
|||||||
@ -2,7 +2,7 @@ module I = Ast_sugar
|
|||||||
module O = Ast_core
|
module O = Ast_core
|
||||||
open Trace
|
open Trace
|
||||||
|
|
||||||
let rec idle_type_expression : I.type_expression -> O.type_expression result =
|
let rec compile_type_expression : I.type_expression -> O.type_expression result =
|
||||||
fun te ->
|
fun te ->
|
||||||
let return tc = ok @@ O.make_t ~loc:te.location tc in
|
let return tc = ok @@ O.make_t ~loc:te.location tc in
|
||||||
match te.type_content with
|
match te.type_content with
|
||||||
@ -11,7 +11,7 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
|
|||||||
let%bind sum =
|
let%bind sum =
|
||||||
bind_map_list (fun (k,v) ->
|
bind_map_list (fun (k,v) ->
|
||||||
let {ctor_type ; michelson_annotation ; ctor_decl_pos} : I.ctor_content = v in
|
let {ctor_type ; michelson_annotation ; ctor_decl_pos} : I.ctor_content = v in
|
||||||
let%bind ctor_type = idle_type_expression ctor_type in
|
let%bind ctor_type = compile_type_expression ctor_type in
|
||||||
let v' : O.ctor_content = {ctor_type ; michelson_annotation ; ctor_decl_pos} in
|
let v' : O.ctor_content = {ctor_type ; michelson_annotation ; ctor_decl_pos} in
|
||||||
ok @@ (k,v')
|
ok @@ (k,v')
|
||||||
) sum
|
) sum
|
||||||
@ -22,7 +22,7 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
|
|||||||
let%bind record =
|
let%bind record =
|
||||||
bind_map_list (fun (k,v) ->
|
bind_map_list (fun (k,v) ->
|
||||||
let {field_type ; michelson_annotation ; field_decl_pos} : I.field_content = v in
|
let {field_type ; michelson_annotation ; field_decl_pos} : I.field_content = v in
|
||||||
let%bind field_type = idle_type_expression field_type in
|
let%bind field_type = compile_type_expression field_type in
|
||||||
let v' : O.field_content = {field_type ; field_annotation=michelson_annotation ; field_decl_pos} in
|
let v' : O.field_content = {field_type ; field_annotation=michelson_annotation ; field_decl_pos} in
|
||||||
ok @@ (k,v')
|
ok @@ (k,v')
|
||||||
) record
|
) record
|
||||||
@ -30,19 +30,19 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
|
|||||||
return @@ O.T_record (O.LMap.of_list record)
|
return @@ O.T_record (O.LMap.of_list record)
|
||||||
| I.T_tuple tuple ->
|
| I.T_tuple tuple ->
|
||||||
let aux (i,acc) el =
|
let aux (i,acc) el =
|
||||||
let%bind el = idle_type_expression el in
|
let%bind el = compile_type_expression el in
|
||||||
ok @@ (i+1,(O.Label (string_of_int i), ({field_type=el;field_annotation=None;field_decl_pos=0}:O.field_content))::acc) in
|
ok @@ (i+1,(O.Label (string_of_int i), ({field_type=el;field_annotation=None;field_decl_pos=0}:O.field_content))::acc) in
|
||||||
let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in
|
let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in
|
||||||
let record = O.LMap.of_list lst in
|
let record = O.LMap.of_list lst in
|
||||||
return @@ O.T_record record
|
return @@ O.T_record record
|
||||||
| I.T_arrow {type1;type2} ->
|
| I.T_arrow {type1;type2} ->
|
||||||
let%bind type1 = idle_type_expression type1 in
|
let%bind type1 = compile_type_expression type1 in
|
||||||
let%bind type2 = idle_type_expression type2 in
|
let%bind type2 = compile_type_expression type2 in
|
||||||
return @@ T_arrow {type1;type2}
|
return @@ T_arrow {type1;type2}
|
||||||
| I.T_variable type_variable -> return @@ T_variable type_variable
|
| I.T_variable type_variable -> return @@ T_variable type_variable
|
||||||
| I.T_constant type_constant -> return @@ T_constant type_constant
|
| I.T_constant type_constant -> return @@ T_constant type_constant
|
||||||
| I.T_operator (type_operator, lst) ->
|
| I.T_operator (type_operator, lst) ->
|
||||||
let%bind lst = bind_map_list idle_type_expression lst in
|
let%bind lst = bind_map_list compile_type_expression lst in
|
||||||
return @@ T_operator (type_operator, lst)
|
return @@ T_operator (type_operator, lst)
|
||||||
|
|
||||||
let rec compile_expression : I.expression -> O.expression result =
|
let rec compile_expression : I.expression -> O.expression result =
|
||||||
@ -62,12 +62,12 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
let%bind lambda = compile_lambda lambda in
|
let%bind lambda = compile_lambda lambda in
|
||||||
return @@ O.E_lambda lambda
|
return @@ O.E_lambda lambda
|
||||||
| I.E_recursive {fun_name;fun_type;lambda} ->
|
| I.E_recursive {fun_name;fun_type;lambda} ->
|
||||||
let%bind fun_type = idle_type_expression fun_type in
|
let%bind fun_type = compile_type_expression fun_type in
|
||||||
let%bind lambda = compile_lambda lambda in
|
let%bind lambda = compile_lambda lambda in
|
||||||
return @@ O.E_recursive {fun_name;fun_type;lambda}
|
return @@ O.E_recursive {fun_name;fun_type;lambda}
|
||||||
| I.E_let_in {let_binder;inline;rhs;let_result} ->
|
| I.E_let_in {let_binder;inline;rhs;let_result} ->
|
||||||
let (binder,ty_opt) = let_binder in
|
let (binder,ty_opt) = let_binder in
|
||||||
let%bind ty_opt = bind_map_option idle_type_expression ty_opt in
|
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
|
||||||
let%bind rhs = compile_expression rhs in
|
let%bind rhs = compile_expression rhs in
|
||||||
let%bind let_result = compile_expression let_result 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);inline;rhs;let_result}
|
||||||
@ -76,8 +76,7 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
return @@ O.E_constructor {constructor;element}
|
return @@ O.E_constructor {constructor;element}
|
||||||
| I.E_matching {matchee; cases} ->
|
| I.E_matching {matchee; cases} ->
|
||||||
let%bind matchee = compile_expression matchee in
|
let%bind matchee = compile_expression matchee in
|
||||||
let%bind cases = compile_matching cases in
|
compile_matching e.location matchee cases
|
||||||
return @@ O.E_matching {matchee;cases}
|
|
||||||
| I.E_record record ->
|
| I.E_record record ->
|
||||||
let record = I.LMap.to_kv_list record in
|
let record = I.LMap.to_kv_list record in
|
||||||
let%bind record =
|
let%bind record =
|
||||||
@ -87,13 +86,46 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ O.E_record (O.LMap.of_list record)
|
return @@ O.E_record (O.LMap.of_list record)
|
||||||
| I.E_record_accessor {record;path} ->
|
| I.E_accessor {record;path} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
return @@ O.E_record_accessor {record;path}
|
let accessor ?loc e a =
|
||||||
| I.E_record_update {record;path;update} ->
|
match a with
|
||||||
|
I.Access_tuple i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i))
|
||||||
|
| I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a)
|
||||||
|
| I.Access_map k ->
|
||||||
|
let%bind k = compile_expression k in
|
||||||
|
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e]
|
||||||
|
in
|
||||||
|
bind_fold_list accessor record path
|
||||||
|
| I.E_update {record;path;update} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
let%bind update = compile_expression update in
|
let%bind update = compile_expression update in
|
||||||
return @@ O.E_record_update {record;path;update}
|
let accessor ?loc e a =
|
||||||
|
match a with
|
||||||
|
I.Access_tuple i -> ok @@ O.e_record_accessor ?loc e (Label (Z.to_string i))
|
||||||
|
| I.Access_record a -> ok @@ O.e_record_accessor ?loc e (Label a)
|
||||||
|
| I.Access_map k ->
|
||||||
|
let%bind k = compile_expression k in
|
||||||
|
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;e]
|
||||||
|
in
|
||||||
|
let updator ?loc (s:O.expression) a e =
|
||||||
|
match a with
|
||||||
|
I.Access_tuple i -> ok @@ O.e_record_update ?loc s (Label (Z.to_string i)) e
|
||||||
|
| 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 = updator ~loc:s.location s lst (expr)
|
||||||
|
in e u
|
||||||
|
in
|
||||||
|
ok @@ (s',e')
|
||||||
|
in
|
||||||
|
let%bind (_,rhs) = bind_fold_list aux (record, fun e -> ok @@ e) path in
|
||||||
|
rhs @@ update
|
||||||
| I.E_map map -> (
|
| I.E_map map -> (
|
||||||
let map = List.sort_uniq compare map in
|
let map = List.sort_uniq compare map in
|
||||||
let aux = fun prev (k, v) ->
|
let aux = fun prev (k, v) ->
|
||||||
@ -126,18 +158,15 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in
|
let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in
|
||||||
bind_fold_list aux init lst'
|
bind_fold_list aux init lst'
|
||||||
)
|
)
|
||||||
| I.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} ->
|
| I.E_ascription {anno_expr; type_annotation} ->
|
||||||
let%bind anno_expr = compile_expression anno_expr in
|
let%bind anno_expr = compile_expression anno_expr in
|
||||||
let%bind type_annotation = idle_type_expression type_annotation in
|
let%bind type_annotation = compile_type_expression type_annotation in
|
||||||
return @@ O.E_ascription {anno_expr; type_annotation}
|
return @@ O.E_ascription {anno_expr; type_annotation}
|
||||||
| I.E_cond {condition; then_clause; else_clause} ->
|
| I.E_cond {condition; then_clause; else_clause} ->
|
||||||
let%bind matchee = compile_expression condition in
|
let%bind matchee = compile_expression condition in
|
||||||
let%bind match_true = compile_expression then_clause in
|
let%bind match_true = compile_expression then_clause in
|
||||||
let%bind match_false = compile_expression else_clause in
|
let%bind match_false = compile_expression else_clause in
|
||||||
return @@ O.E_matching {matchee; cases=Match_variant ([((Constructor "true", Var.of_name "_"),match_true);((Constructor "false", Var.of_name "_"), match_false)],())}
|
return @@ O.E_matching {matchee; cases=Match_variant ([((Constructor "true", Var.of_name "_"),match_true);((Constructor "false", Var.of_name "_"), match_false)])}
|
||||||
| I.E_sequence {expr1; expr2} ->
|
| I.E_sequence {expr1; expr2} ->
|
||||||
let%bind expr1 = compile_expression expr1 in
|
let%bind expr1 = compile_expression expr1 in
|
||||||
let%bind expr2 = compile_expression expr2 in
|
let%bind expr2 = compile_expression expr2 in
|
||||||
@ -150,46 +179,71 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
let%bind (_, lst ) = bind_fold_list aux (0,[]) t in
|
let%bind (_, lst ) = bind_fold_list aux (0,[]) t in
|
||||||
let m = O.LMap.of_list lst in
|
let m = O.LMap.of_list lst in
|
||||||
return @@ O.E_record m
|
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 =
|
and compile_lambda : I.lambda -> O.lambda result =
|
||||||
fun {binder;input_type;output_type;result}->
|
fun {binder;input_type;output_type;result}->
|
||||||
let%bind input_type = bind_map_option idle_type_expression input_type in
|
let%bind input_type = bind_map_option compile_type_expression input_type in
|
||||||
let%bind output_type = bind_map_option idle_type_expression output_type in
|
let%bind output_type = bind_map_option compile_type_expression output_type in
|
||||||
let%bind result = compile_expression result in
|
let%bind result = compile_expression result in
|
||||||
ok @@ O.{binder;input_type;output_type;result}
|
ok @@ O.{binder;input_type;output_type;result}
|
||||||
and compile_matching : I.matching_expr -> O.matching_expr result =
|
and compile_matching : Location.t -> O.expression -> I.matching_expr -> O.expression result =
|
||||||
fun m ->
|
fun loc e m ->
|
||||||
match m with
|
match m with
|
||||||
| I.Match_list {match_nil;match_cons} ->
|
| I.Match_list {match_nil;match_cons} ->
|
||||||
let%bind match_nil = compile_expression match_nil in
|
let%bind match_nil = compile_expression match_nil in
|
||||||
let (hd,tl,expr,tv) = match_cons in
|
let (hd,tl,expr) = match_cons in
|
||||||
let%bind expr = compile_expression expr in
|
let%bind expr = compile_expression expr in
|
||||||
ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
|
ok @@ O.e_matching ~loc e @@ O.Match_list {match_nil; match_cons=(hd,tl,expr)}
|
||||||
| I.Match_option {match_none;match_some} ->
|
| 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 (n,expr) = match_some in
|
||||||
let%bind expr = compile_expression expr in
|
let%bind expr = compile_expression expr in
|
||||||
ok @@ O.Match_option {match_none; match_some=(n,expr,tv)}
|
ok @@ O.e_matching ~loc e @@ O.Match_option {match_none; match_some=(n,expr)}
|
||||||
| I.Match_tuple ((lst,expr), tv) ->
|
| I.Match_variant lst ->
|
||||||
let%bind expr = compile_expression expr in
|
|
||||||
ok @@ O.Match_tuple ((lst,expr), tv)
|
|
||||||
| I.Match_variant (lst,tv) ->
|
|
||||||
let%bind lst = bind_map_list (
|
let%bind lst = bind_map_list (
|
||||||
fun ((c,n),expr) ->
|
fun ((c,n),expr) ->
|
||||||
let%bind expr = compile_expression expr in
|
let%bind expr = compile_expression expr in
|
||||||
ok @@ ((c,n),expr)
|
ok @@ ((c,n),expr)
|
||||||
) lst
|
) lst
|
||||||
in
|
in
|
||||||
ok @@ O.Match_variant (lst,tv)
|
ok @@ O.e_matching ~loc e @@ O.Match_variant lst
|
||||||
|
| I.Match_record (fields,field_types, expr) ->
|
||||||
|
let combine fields field_types =
|
||||||
|
match field_types with
|
||||||
|
Some ft -> List.combine fields @@ List.map (fun x -> Some x) ft
|
||||||
|
| None -> List.map (fun x -> (x, None)) fields
|
||||||
|
in
|
||||||
|
let%bind next = compile_expression expr in
|
||||||
|
let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in
|
||||||
|
let aux ((index,expr) : int * _ ) ((field,name): (O.label * (O.expression_variable * O.type_expression option))) =
|
||||||
|
let f = fun expr' -> O.e_let_in name false (O.e_record_accessor e field) expr' in
|
||||||
|
(index+1, fun expr' -> expr (f expr'))
|
||||||
|
in
|
||||||
|
let (_,header) = List.fold_left aux (0, fun e -> e) @@
|
||||||
|
List.map (fun ((a,b),c) -> (a,(b,c))) @@
|
||||||
|
combine fields field_types
|
||||||
|
in
|
||||||
|
ok @@ header next
|
||||||
|
| I.Match_tuple (fields,field_types, expr) ->
|
||||||
|
let combine fields field_types =
|
||||||
|
match field_types with
|
||||||
|
Some ft -> List.combine fields @@ List.map (fun x -> Some x) ft
|
||||||
|
| None -> List.map (fun x -> (x, None)) fields
|
||||||
|
in
|
||||||
|
let%bind next = compile_expression expr in
|
||||||
|
let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in
|
||||||
|
let aux ((index,expr) : int * _ ) (field: O.expression_variable * O.type_expression option) =
|
||||||
|
let f = fun expr' -> O.e_let_in field false (O.e_record_accessor e (Label (string_of_int index))) expr' in
|
||||||
|
(index+1, fun expr' -> expr (f expr'))
|
||||||
|
in
|
||||||
|
let (_,header) = List.fold_left aux (0, fun e -> e) @@
|
||||||
|
combine fields field_types
|
||||||
|
in
|
||||||
|
ok @@ header next
|
||||||
|
| I.Match_variable (a, ty_opt, expr) ->
|
||||||
|
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
|
||||||
|
let%bind expr = compile_expression expr in
|
||||||
|
ok @@ O.e_let_in (a,ty_opt) false e expr
|
||||||
|
|
||||||
let compile_declaration : I.declaration Location.wrap -> _ =
|
let compile_declaration : I.declaration Location.wrap -> _ =
|
||||||
fun {wrap_content=declaration;location} ->
|
fun {wrap_content=declaration;location} ->
|
||||||
@ -197,10 +251,10 @@ let compile_declaration : I.declaration Location.wrap -> _ =
|
|||||||
match declaration with
|
match declaration with
|
||||||
| I.Declaration_constant (n, te_opt, inline, expr) ->
|
| I.Declaration_constant (n, te_opt, inline, expr) ->
|
||||||
let%bind expr = compile_expression expr in
|
let%bind expr = compile_expression expr in
|
||||||
let%bind te_opt = bind_map_option idle_type_expression te_opt in
|
let%bind te_opt = bind_map_option compile_type_expression te_opt in
|
||||||
return @@ O.Declaration_constant (n, te_opt, inline, expr)
|
return @@ O.Declaration_constant (n, te_opt, inline, expr)
|
||||||
| I.Declaration_type (n, te) ->
|
| I.Declaration_type (n, te) ->
|
||||||
let%bind te = idle_type_expression te in
|
let%bind te = compile_type_expression te in
|
||||||
return @@ O.Declaration_type (n,te)
|
return @@ O.Declaration_type (n,te)
|
||||||
|
|
||||||
let compile_program : I.program -> O.program result =
|
let compile_program : I.program -> O.program result =
|
||||||
@ -292,11 +346,13 @@ let rec uncompile_expression : O.expression -> I.expression result =
|
|||||||
return @@ I.E_record (O.LMap.of_list record)
|
return @@ I.E_record (O.LMap.of_list record)
|
||||||
| O.E_record_accessor {record;path} ->
|
| O.E_record_accessor {record;path} ->
|
||||||
let%bind record = uncompile_expression record in
|
let%bind record = uncompile_expression record in
|
||||||
return @@ I.E_record_accessor {record;path}
|
let Label path = path in
|
||||||
|
return @@ I.E_accessor {record;path=[I.Access_record path]}
|
||||||
| O.E_record_update {record;path;update} ->
|
| O.E_record_update {record;path;update} ->
|
||||||
let%bind record = uncompile_expression record in
|
let%bind record = uncompile_expression record in
|
||||||
let%bind update = uncompile_expression update in
|
let%bind update = uncompile_expression update in
|
||||||
return @@ I.E_record_update {record;path;update}
|
let Label path = path in
|
||||||
|
return @@ I.E_update {record;path=[I.Access_record path];update}
|
||||||
| O.E_ascription {anno_expr; type_annotation} ->
|
| O.E_ascription {anno_expr; type_annotation} ->
|
||||||
let%bind anno_expr = uncompile_expression anno_expr in
|
let%bind anno_expr = uncompile_expression anno_expr in
|
||||||
let%bind type_annotation = uncompile_type_expression type_annotation in
|
let%bind type_annotation = uncompile_type_expression type_annotation in
|
||||||
@ -313,22 +369,19 @@ and uncompile_matching : O.matching_expr -> I.matching_expr result =
|
|||||||
match m with
|
match m with
|
||||||
| O.Match_list {match_nil;match_cons} ->
|
| O.Match_list {match_nil;match_cons} ->
|
||||||
let%bind match_nil = uncompile_expression match_nil in
|
let%bind match_nil = uncompile_expression match_nil in
|
||||||
let (hd,tl,expr,tv) = match_cons in
|
let (hd,tl,expr) = match_cons in
|
||||||
let%bind expr = uncompile_expression expr in
|
let%bind expr = uncompile_expression expr in
|
||||||
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
|
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr)}
|
||||||
| O.Match_option {match_none;match_some} ->
|
| O.Match_option {match_none;match_some} ->
|
||||||
let%bind match_none = uncompile_expression match_none in
|
let%bind match_none = uncompile_expression match_none in
|
||||||
let (n,expr,tv) = match_some in
|
let (n,expr) = match_some in
|
||||||
let%bind expr = uncompile_expression expr in
|
let%bind expr = uncompile_expression expr in
|
||||||
ok @@ I.Match_option {match_none; match_some=(n,expr,tv)}
|
ok @@ I.Match_option {match_none; match_some=(n,expr)}
|
||||||
| O.Match_tuple ((lst,expr), tv) ->
|
| O.Match_variant lst ->
|
||||||
let%bind expr = uncompile_expression expr in
|
|
||||||
ok @@ O.Match_tuple ((lst,expr), tv)
|
|
||||||
| O.Match_variant (lst,tv) ->
|
|
||||||
let%bind lst = bind_map_list (
|
let%bind lst = bind_map_list (
|
||||||
fun ((c,n),expr) ->
|
fun ((c,n),expr) ->
|
||||||
let%bind expr = uncompile_expression expr in
|
let%bind expr = uncompile_expression expr in
|
||||||
ok @@ ((c,n),expr)
|
ok @@ ((c,n),expr)
|
||||||
) lst
|
) lst
|
||||||
in
|
in
|
||||||
ok @@ I.Match_variant (lst,tv)
|
ok @@ I.Match_variant lst
|
||||||
|
|||||||
@ -72,21 +72,17 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
|
|
||||||
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
|
| Match_list { match_nil ; match_cons = (_ , _ , cons) } -> (
|
||||||
let%bind res = fold_expression f init match_nil in
|
let%bind res = fold_expression f init match_nil in
|
||||||
let%bind res = fold_expression f res cons in
|
let%bind res = fold_expression f res cons in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| Match_option { match_none ; match_some = (_ , some, _) } -> (
|
| Match_option { match_none ; match_some = (_ , some) } -> (
|
||||||
let%bind res = fold_expression f init match_none in
|
let%bind res = fold_expression f init match_none in
|
||||||
let%bind res = fold_expression f res some in
|
let%bind res = fold_expression f res some in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| Match_tuple ((_ , e), _) -> (
|
| Match_variant lst -> (
|
||||||
let%bind res = fold_expression f init e in
|
|
||||||
ok res
|
|
||||||
)
|
|
||||||
| Match_variant (lst, _) -> (
|
|
||||||
let aux init' ((_ , _) , e) =
|
let aux init' ((_ , _) , e) =
|
||||||
let%bind res' = fold_expression f init' e in
|
let%bind res' = fold_expression f init' e in
|
||||||
ok res' in
|
ok res' in
|
||||||
@ -174,27 +170,23 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
|
|||||||
|
|
||||||
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
|
and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
| Match_list { match_nil ; match_cons = (hd , tl , cons) } -> (
|
||||||
let%bind match_nil = map_expression f match_nil in
|
let%bind match_nil = map_expression f match_nil in
|
||||||
let%bind cons = map_expression f cons in
|
let%bind cons = map_expression f cons in
|
||||||
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }
|
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons) }
|
||||||
)
|
)
|
||||||
| Match_option { match_none ; match_some = (name , some, _) } -> (
|
| Match_option { match_none ; match_some = (name , some) } -> (
|
||||||
let%bind match_none = map_expression f match_none in
|
let%bind match_none = map_expression f match_none in
|
||||||
let%bind some = map_expression f some in
|
let%bind some = map_expression f some in
|
||||||
ok @@ Match_option { match_none ; match_some = (name , some, ()) }
|
ok @@ Match_option { match_none ; match_some = (name , some) }
|
||||||
)
|
)
|
||||||
| Match_tuple ((names , e), _) -> (
|
| Match_variant lst -> (
|
||||||
let%bind e' = map_expression f e in
|
|
||||||
ok @@ Match_tuple ((names , e'), [])
|
|
||||||
)
|
|
||||||
| Match_variant (lst, _) -> (
|
|
||||||
let aux ((a , b) , e) =
|
let aux ((a , b) , e) =
|
||||||
let%bind e' = map_expression f e in
|
let%bind e' = map_expression f e in
|
||||||
ok ((a , b) , e')
|
ok ((a , b) , e')
|
||||||
in
|
in
|
||||||
let%bind lst' = bind_map_list aux lst in
|
let%bind lst' = bind_map_list aux lst in
|
||||||
ok @@ Match_variant (lst', ())
|
ok @@ Match_variant lst'
|
||||||
)
|
)
|
||||||
|
|
||||||
and map_program : abs_mapper -> program -> program result = fun m p ->
|
and map_program : abs_mapper -> program -> program result = fun m p ->
|
||||||
@ -274,25 +266,21 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
|
|
||||||
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
|
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
| 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, match_nil) = fold_map_expression f init match_nil in
|
||||||
let%bind (init, cons) = fold_map_expression f init cons in
|
let%bind (init, cons) = fold_map_expression f init cons in
|
||||||
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) })
|
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons) })
|
||||||
)
|
)
|
||||||
| Match_option { match_none ; match_some = (name , some, _) } -> (
|
| Match_option { match_none ; match_some = (name , some) } -> (
|
||||||
let%bind (init, match_none) = fold_map_expression f init match_none in
|
let%bind (init, match_none) = fold_map_expression f init match_none in
|
||||||
let%bind (init, some) = fold_map_expression f init some in
|
let%bind (init, some) = fold_map_expression f init some in
|
||||||
ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) })
|
ok @@ (init, Match_option { match_none ; match_some = (name , some) })
|
||||||
)
|
)
|
||||||
| Match_tuple ((names , e), _) -> (
|
| Match_variant lst -> (
|
||||||
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 aux init ((a , b) , e) =
|
||||||
let%bind (init,e') = fold_map_expression f init e in
|
let%bind (init,e') = fold_map_expression f init e in
|
||||||
ok (init, ((a , b) , e'))
|
ok (init, ((a , b) , e'))
|
||||||
in
|
in
|
||||||
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
||||||
ok @@ (init, Match_variant (lst', ()))
|
ok @@ (init, Match_variant lst')
|
||||||
)
|
)
|
||||||
|
|||||||
@ -3,6 +3,7 @@ module O = Ast_typed
|
|||||||
|
|
||||||
let convert_constructor' (I.Constructor c) = O.Constructor c
|
let convert_constructor' (I.Constructor c) = O.Constructor c
|
||||||
let convert_label (I.Label c) = O.Label c
|
let convert_label (I.Label c) = O.Label c
|
||||||
|
|
||||||
let convert_type_constant : I.type_constant -> O.type_constant = function
|
let convert_type_constant : I.type_constant -> O.type_constant = function
|
||||||
| TC_unit -> TC_unit
|
| TC_unit -> TC_unit
|
||||||
| TC_string -> TC_string
|
| TC_string -> TC_string
|
||||||
|
|||||||
@ -40,7 +40,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
|
|||||||
trace_strong (match_error ~expected:i ~actual:t loc)
|
trace_strong (match_error ~expected:i ~actual:t loc)
|
||||||
@@ get_t_option t in
|
@@ get_t_option t in
|
||||||
let%bind (match_none , state') = type_expression e state match_none in
|
let%bind (match_none , state') = type_expression e state match_none in
|
||||||
let (opt, b, _) = match_some in
|
let (opt, b) = match_some in
|
||||||
let e' = Environment.add_ez_binder opt tv e in
|
let e' = Environment.add_ez_binder opt tv e in
|
||||||
let%bind (body , state'') = type_expression e' state' b in
|
let%bind (body , state'') = type_expression e' state' b in
|
||||||
ok (O.Match_option {match_none ; match_some = { opt; body; tv}} , state'')
|
ok (O.Match_option {match_none ; match_some = { opt; body; tv}} , state'')
|
||||||
@ -49,23 +49,12 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin
|
|||||||
trace_strong (match_error ~expected:i ~actual:t loc)
|
trace_strong (match_error ~expected:i ~actual:t loc)
|
||||||
@@ get_t_list t in
|
@@ get_t_list t in
|
||||||
let%bind (match_nil , state') = type_expression e state match_nil in
|
let%bind (match_nil , state') = type_expression e state match_nil in
|
||||||
let (hd, tl, b, _) = match_cons in
|
let (hd, tl, b) = match_cons in
|
||||||
let e' = Environment.add_ez_binder hd t_elt e in
|
let e' = Environment.add_ez_binder hd t_elt e in
|
||||||
let e' = Environment.add_ez_binder tl t e' in
|
let e' = Environment.add_ez_binder tl t e' in
|
||||||
let%bind (body , state'') = type_expression e' state' b in
|
let%bind (body , state'') = type_expression e' state' b in
|
||||||
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body;tv=t}} , state'')
|
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body;tv=t}} , state'')
|
||||||
| Match_tuple ((vars, b),_) ->
|
| Match_variant lst ->
|
||||||
let%bind tvs =
|
|
||||||
trace_strong (match_error ~expected:i ~actual:t loc)
|
|
||||||
@@ get_t_tuple t in
|
|
||||||
let%bind lst' =
|
|
||||||
generic_try (match_tuple_wrong_arity tvs vars loc)
|
|
||||||
@@ (fun () -> List.combine vars tvs) in
|
|
||||||
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
|
|
||||||
let e' = List.fold_left aux e lst' in
|
|
||||||
let%bind (body , state') = type_expression e' state b in
|
|
||||||
ok (O.Match_tuple {vars ; body ; tvs} , state')
|
|
||||||
| Match_variant (lst,_) ->
|
|
||||||
let%bind variant_opt =
|
let%bind variant_opt =
|
||||||
let aux acc ((constructor_name , _) , _) =
|
let aux acc ((constructor_name , _) , _) =
|
||||||
let%bind (_ , variant) =
|
let%bind (_ , variant) =
|
||||||
@ -362,7 +351,6 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
|
|||||||
match cur with
|
match cur with
|
||||||
| Match_list { match_nil ; match_cons = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
|
| Match_list { match_nil ; match_cons = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
|
||||||
| Match_option { match_none ; match_some = {opt=_; body; tv=_} } -> [ match_none ; body ]
|
| Match_option { match_none ; match_some = {opt=_; body; tv=_} } -> [ match_none ; body ]
|
||||||
| Match_tuple { vars=_ ; body ; tvs=_ } -> [ body ]
|
|
||||||
| Match_variant { cases ; tv=_ } -> List.map (fun ({constructor=_; pattern=_; body} : O.matching_content_case) -> body) cases in
|
| Match_variant { cases ; tv=_ } -> List.map (fun ({constructor=_; pattern=_; body} : O.matching_content_case) -> body) cases in
|
||||||
List.map get_type_expression @@ aux m' in
|
List.map get_type_expression @@ aux m' in
|
||||||
let%bind () = match tvs with
|
let%bind () = match tvs with
|
||||||
|
|||||||
@ -264,8 +264,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
|||||||
return (e_record @@ LMap.of_list r')
|
return (e_record @@ LMap.of_list r')
|
||||||
| E_record_accessor {record; path} ->
|
| E_record_accessor {record; path} ->
|
||||||
let%bind r' = untype_expression record in
|
let%bind r' = untype_expression record in
|
||||||
let Label s = path in
|
let Label path = path in
|
||||||
return (e_record_accessor r' s)
|
return (e_record_accessor r' (Label path))
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
let%bind r' = untype_expression record in
|
let%bind r' = untype_expression record in
|
||||||
let%bind e = untype_expression update in
|
let%bind e = untype_expression update in
|
||||||
@ -299,22 +299,19 @@ and untype_lambda ty {binder; result} : I.lambda result =
|
|||||||
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
|
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
|
||||||
let open I in
|
let open I in
|
||||||
match m with
|
match m with
|
||||||
| Match_tuple { vars ; body ; tvs=_ } ->
|
|
||||||
let%bind b = f body in
|
|
||||||
ok @@ I.Match_tuple ((vars, b),[])
|
|
||||||
| Match_option {match_none ; match_some = {opt; body;tv=_}} ->
|
| Match_option {match_none ; match_some = {opt; body;tv=_}} ->
|
||||||
let%bind match_none = f match_none in
|
let%bind match_none = f match_none in
|
||||||
let%bind some = f body in
|
let%bind some = f body in
|
||||||
let match_some = opt, some, () in
|
let match_some = opt, some in
|
||||||
ok @@ Match_option {match_none ; match_some}
|
ok @@ Match_option {match_none ; match_some}
|
||||||
| Match_list {match_nil ; match_cons = {hd;tl;body;tv=_}} ->
|
| Match_list {match_nil ; match_cons = {hd;tl;body;tv=_}} ->
|
||||||
let%bind match_nil = f match_nil in
|
let%bind match_nil = f match_nil in
|
||||||
let%bind cons = f body in
|
let%bind cons = f body in
|
||||||
let match_cons = hd , tl , cons, () in
|
let match_cons = hd , tl , cons in
|
||||||
ok @@ Match_list {match_nil ; match_cons}
|
ok @@ Match_list {match_nil ; match_cons}
|
||||||
| Match_variant { cases ; tv=_ } ->
|
| Match_variant { cases ; tv=_ } ->
|
||||||
let aux ({constructor;pattern;body} : O.matching_content_case) =
|
let aux ({constructor;pattern;body} : O.matching_content_case) =
|
||||||
let%bind body = f body in
|
let%bind body = f body in
|
||||||
ok ((unconvert_constructor' constructor,pattern),body) in
|
ok ((unconvert_constructor' constructor,pattern),body) in
|
||||||
let%bind lst' = bind_map_list aux cases in
|
let%bind lst' = bind_map_list aux cases in
|
||||||
ok @@ Match_variant (lst',())
|
ok @@ Match_variant lst'
|
||||||
|
|||||||
@ -125,17 +125,6 @@ module Errors = struct
|
|||||||
] in
|
] in
|
||||||
error ~data title message ()
|
error ~data title message ()
|
||||||
|
|
||||||
|
|
||||||
let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () =
|
|
||||||
let title () = "matching tuple of different size" in
|
|
||||||
let message () = "" in
|
|
||||||
let data = [
|
|
||||||
("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ;
|
|
||||||
("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ;
|
|
||||||
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
|
|
||||||
] in
|
|
||||||
error ~data title message ()
|
|
||||||
|
|
||||||
(* TODO: this should be a trace_info? *)
|
(* TODO: this should be a trace_info? *)
|
||||||
let program_error (p:I.program) () =
|
let program_error (p:I.program) () =
|
||||||
let message () = "" in
|
let message () = "" in
|
||||||
@ -528,7 +517,7 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
|
|||||||
trace_strong (match_error ~expected:i ~actual:t loc)
|
trace_strong (match_error ~expected:i ~actual:t loc)
|
||||||
@@ get_t_option t in
|
@@ get_t_option t in
|
||||||
let%bind match_none = f e match_none in
|
let%bind match_none = f e match_none in
|
||||||
let (opt, b,_) = match_some in
|
let (opt, b) = match_some in
|
||||||
let e' = Environment.add_ez_binder opt tv e in
|
let e' = Environment.add_ez_binder opt tv e in
|
||||||
let%bind body = f e' b in
|
let%bind body = f e' b in
|
||||||
ok (O.Match_option {match_none ; match_some = {opt; body; tv}})
|
ok (O.Match_option {match_none ; match_some = {opt; body; tv}})
|
||||||
@ -537,23 +526,12 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
|
|||||||
trace_strong (match_error ~expected:i ~actual:t loc)
|
trace_strong (match_error ~expected:i ~actual:t loc)
|
||||||
@@ get_t_list t in
|
@@ get_t_list t in
|
||||||
let%bind match_nil = f e match_nil in
|
let%bind match_nil = f e match_nil in
|
||||||
let (hd, tl, b,_) = match_cons in
|
let (hd, tl, b) = match_cons in
|
||||||
let e' = Environment.add_ez_binder hd t_elt e in
|
let e' = Environment.add_ez_binder hd t_elt e in
|
||||||
let e' = Environment.add_ez_binder tl t e' in
|
let e' = Environment.add_ez_binder tl t e' in
|
||||||
let%bind body = f e' b in
|
let%bind body = f e' b in
|
||||||
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
|
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
|
||||||
| Match_tuple ((vars, b),_) ->
|
| Match_variant lst ->
|
||||||
let%bind tvs =
|
|
||||||
trace_strong (match_error ~expected:i ~actual:t loc)
|
|
||||||
@@ get_t_tuple t in
|
|
||||||
let%bind vars' =
|
|
||||||
generic_try (match_tuple_wrong_arity tvs vars loc)
|
|
||||||
@@ (fun () -> List.combine vars tvs) in
|
|
||||||
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
|
|
||||||
let e' = List.fold_left aux e vars' in
|
|
||||||
let%bind body = f e' b in
|
|
||||||
ok (O.Match_tuple { vars ; body ; tvs})
|
|
||||||
| Match_variant (lst,_) ->
|
|
||||||
let%bind variant_cases' =
|
let%bind variant_cases' =
|
||||||
trace (match_error ~expected:i ~actual:t loc)
|
trace (match_error ~expected:i ~actual:t loc)
|
||||||
@@ Ast_typed.Combinators.get_t_sum t in
|
@@ Ast_typed.Combinators.get_t_sum t in
|
||||||
@ -937,7 +915,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
|||||||
match cur with
|
match cur with
|
||||||
| Match_list { match_nil ; match_cons = {hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
|
| Match_list { match_nil ; match_cons = {hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
|
||||||
| Match_option { match_none ; match_some = {opt=_ ; body ; tv=_ } } -> [ match_none ; body ]
|
| Match_option { match_none ; match_some = {opt=_ ; body ; tv=_ } } -> [ match_none ; body ]
|
||||||
| Match_tuple {vars=_;body;tvs=_} -> [ body ]
|
|
||||||
| Match_variant {cases; tv=_} -> List.map (fun (c : O.matching_content_case) -> c.body) cases in
|
| Match_variant {cases; tv=_} -> List.map (fun (c : O.matching_content_case) -> c.body) cases in
|
||||||
List.map get_type_expression @@ aux m' in
|
List.map get_type_expression @@ aux m' in
|
||||||
let aux prec cur =
|
let aux prec cur =
|
||||||
@ -1081,7 +1058,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
|||||||
| E_record_accessor {record; path} ->
|
| E_record_accessor {record; path} ->
|
||||||
let%bind r' = untype_expression record in
|
let%bind r' = untype_expression record in
|
||||||
let Label s = path in
|
let Label s = path in
|
||||||
return (e_record_accessor r' s)
|
return (e_record_accessor r' (Label s))
|
||||||
| E_record_update {record=r; path=O.Label l; update=e} ->
|
| E_record_update {record=r; path=O.Label l; update=e} ->
|
||||||
let%bind r' = untype_expression r in
|
let%bind r' = untype_expression r in
|
||||||
let%bind e = untype_expression e in
|
let%bind e = untype_expression e in
|
||||||
@ -1104,22 +1081,19 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
|||||||
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
|
and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m ->
|
||||||
let open I in
|
let open I in
|
||||||
match m with
|
match m with
|
||||||
| Match_tuple {vars; body;tvs=_} ->
|
|
||||||
let%bind b = f body in
|
|
||||||
ok @@ I.Match_tuple ((vars, b),[])
|
|
||||||
| Match_option {match_none ; match_some = {opt; body ; tv=_}} ->
|
| Match_option {match_none ; match_some = {opt; body ; tv=_}} ->
|
||||||
let%bind match_none = f match_none in
|
let%bind match_none = f match_none in
|
||||||
let%bind some = f body in
|
let%bind some = f body in
|
||||||
let match_some = opt, some, () in
|
let match_some = opt, some in
|
||||||
ok @@ Match_option {match_none ; match_some}
|
ok @@ Match_option {match_none ; match_some}
|
||||||
| Match_list {match_nil ; match_cons = {hd ; tl ; body ; tv=_}} ->
|
| Match_list {match_nil ; match_cons = {hd ; tl ; body ; tv=_}} ->
|
||||||
let%bind match_nil = f match_nil in
|
let%bind match_nil = f match_nil in
|
||||||
let%bind cons = f body in
|
let%bind cons = f body in
|
||||||
let match_cons = hd , tl , cons, () in
|
let match_cons = hd , tl , cons in
|
||||||
ok @@ Match_list {match_nil ; match_cons}
|
ok @@ Match_list {match_nil ; match_cons}
|
||||||
| Match_variant {cases;tv=_} ->
|
| Match_variant {cases;tv=_} ->
|
||||||
let aux ({constructor;pattern;body} : O.matching_content_case) =
|
let aux ({constructor;pattern;body} : O.matching_content_case) =
|
||||||
let%bind c' = f body in
|
let%bind c' = f body in
|
||||||
ok ((unconvert_constructor' constructor,pattern),c') in
|
ok ((unconvert_constructor' constructor,pattern),c') in
|
||||||
let%bind lst' = bind_map_list aux cases in
|
let%bind lst' = bind_map_list aux cases in
|
||||||
ok @@ Match_variant (lst',())
|
ok @@ Match_variant lst'
|
||||||
|
|||||||
@ -63,10 +63,6 @@ and fold_cases : 'a . 'a folder -> 'a -> matching_expr -> 'a result = fun f init
|
|||||||
let%bind res = fold_expression f res body in
|
let%bind res = fold_expression f res body in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| Match_tuple {vars=_ ; body; tvs=_} -> (
|
|
||||||
let%bind res = fold_expression f init body in
|
|
||||||
ok res
|
|
||||||
)
|
|
||||||
| Match_variant {cases;tv=_} -> (
|
| Match_variant {cases;tv=_} -> (
|
||||||
let aux init' {constructor=_; pattern=_ ; body} =
|
let aux init' {constructor=_; pattern=_ ; body} =
|
||||||
let%bind res' = fold_expression f init' body in
|
let%bind res' = fold_expression f init' body in
|
||||||
@ -140,10 +136,6 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
|
|||||||
let%bind body = map_expression f body in
|
let%bind body = map_expression f body in
|
||||||
ok @@ Match_option { match_none ; match_some = { opt ; body ; tv } }
|
ok @@ Match_option { match_none ; match_some = { opt ; body ; tv } }
|
||||||
)
|
)
|
||||||
| Match_tuple { vars ; body ; tvs } -> (
|
|
||||||
let%bind body = map_expression f body in
|
|
||||||
ok @@ Match_tuple { vars ; body ; tvs }
|
|
||||||
)
|
|
||||||
| Match_variant {cases;tv} -> (
|
| Match_variant {cases;tv} -> (
|
||||||
let aux { constructor ; pattern ; body } =
|
let aux { constructor ; pattern ; body } =
|
||||||
let%bind body = map_expression f body in
|
let%bind body = map_expression f body in
|
||||||
@ -231,10 +223,6 @@ and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matchin
|
|||||||
let%bind (init, body) = fold_map_expression f init body in
|
let%bind (init, body) = fold_map_expression f init body in
|
||||||
ok @@ (init, Match_option { match_none ; match_some = { opt ; body ; tv } })
|
ok @@ (init, Match_option { match_none ; match_some = { opt ; body ; tv } })
|
||||||
)
|
)
|
||||||
| Match_tuple { vars ; body ; tvs } -> (
|
|
||||||
let%bind (init, body) = fold_map_expression f init body in
|
|
||||||
ok @@ (init, Match_tuple {vars ; body ; tvs })
|
|
||||||
)
|
|
||||||
| Match_variant {cases ; tv} -> (
|
| Match_variant {cases ; tv} -> (
|
||||||
let aux init {constructor ; pattern ; body} =
|
let aux init {constructor ; pattern ; body} =
|
||||||
let%bind (init, body) = fold_map_expression f init body in
|
let%bind (init, body) = fold_map_expression f init body in
|
||||||
|
|||||||
@ -67,9 +67,6 @@ and check_recursive_call_in_matching = fun n final_path c ->
|
|||||||
let%bind _ = check_recursive_call n final_path match_none in
|
let%bind _ = check_recursive_call n final_path match_none in
|
||||||
let%bind _ = check_recursive_call n final_path body in
|
let%bind _ = check_recursive_call n final_path body in
|
||||||
ok ()
|
ok ()
|
||||||
| Match_tuple {vars=_;body;tvs=_} ->
|
|
||||||
let%bind _ = check_recursive_call n final_path body in
|
|
||||||
ok ()
|
|
||||||
| Match_variant {cases;tv=_} ->
|
| Match_variant {cases;tv=_} ->
|
||||||
let aux {constructor=_; pattern=_; body} =
|
let aux {constructor=_; pattern=_; body} =
|
||||||
let%bind _ = check_recursive_call n final_path body in
|
let%bind _ = check_recursive_call n final_path body in
|
||||||
|
|||||||
@ -32,16 +32,6 @@ them. please report this to the developers." in
|
|||||||
let content () = Format.asprintf "%a" Var.pp name in
|
let content () = Format.asprintf "%a" Var.pp name in
|
||||||
error title content
|
error title content
|
||||||
|
|
||||||
let row_loc l = ("location" , fun () -> Format.asprintf "%a" Location.pp l)
|
|
||||||
|
|
||||||
let unsupported_pattern_matching kind location =
|
|
||||||
let title () = "unsupported pattern-matching" in
|
|
||||||
let content () = Format.asprintf "%s patterns aren't supported yet" kind in
|
|
||||||
let data = [
|
|
||||||
row_loc location ;
|
|
||||||
] in
|
|
||||||
error ~data title content
|
|
||||||
|
|
||||||
let not_functional_main location =
|
let not_functional_main location =
|
||||||
let title () = "not functional main" in
|
let title () = "not functional main" in
|
||||||
let content () = "main should be a function" in
|
let content () = "main should be a function" in
|
||||||
@ -615,7 +605,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
|
|||||||
trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
|
trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
|
||||||
aux expr' tree''
|
aux expr' tree''
|
||||||
)
|
)
|
||||||
| AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location
|
|
||||||
)
|
)
|
||||||
|
|
||||||
and transpile_lambda l (input_type , output_type) =
|
and transpile_lambda l (input_type , output_type) =
|
||||||
@ -739,7 +728,6 @@ and transpile_recursive {fun_name; fun_type; lambda} =
|
|||||||
trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
|
trace_strong (corner_case ~loc:__LOC__ "building constructor") @@
|
||||||
aux expr tree''
|
aux expr tree''
|
||||||
)
|
)
|
||||||
| AST.Match_tuple _ -> failwith "match_tuple not supported"
|
|
||||||
in
|
in
|
||||||
let%bind fun_type = transpile_type fun_type in
|
let%bind fun_type = transpile_type fun_type in
|
||||||
let%bind (input_type,output_type) = get_t_function fun_type in
|
let%bind (input_type,output_type) = get_t_function fun_type in
|
||||||
|
|||||||
@ -83,10 +83,10 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
c.arguments
|
c.arguments
|
||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "{%a}" (record_sep expression (const ";")) m
|
fprintf ppf "{%a}" (record_sep expression (const ";")) m
|
||||||
| E_record_accessor ra ->
|
| E_accessor {record;path} ->
|
||||||
fprintf ppf "%a.%a" expression ra.record label ra.path
|
fprintf ppf "%a.%a" expression record (list_sep accessor (const ".")) path
|
||||||
| E_record_update {record; path; update} ->
|
| E_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with %a = %a }" expression record label path expression update
|
fprintf ppf "{ %a with %a = %a }" expression record (list_sep accessor (const ".")) path expression update
|
||||||
| E_map m ->
|
| E_map m ->
|
||||||
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
|
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
|
||||||
| E_big_map m ->
|
| E_big_map m ->
|
||||||
@ -95,8 +95,6 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
fprintf ppf "list[%a]" (list_sep_d expression) lst
|
fprintf ppf "list[%a]" (list_sep_d expression) lst
|
||||||
| E_set lst ->
|
| E_set lst ->
|
||||||
fprintf ppf "set[%a]" (list_sep_d expression) lst
|
fprintf ppf "set[%a]" (list_sep_d expression) lst
|
||||||
| E_look_up (ds, ind) ->
|
|
||||||
fprintf ppf "(%a)[%a]" expression ds expression ind
|
|
||||||
| E_lambda {binder; input_type; output_type; result} ->
|
| 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
|
expression_variable binder
|
||||||
@ -129,14 +127,10 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
fprintf ppf "skip"
|
fprintf ppf "skip"
|
||||||
| E_tuple t ->
|
| E_tuple t ->
|
||||||
fprintf ppf "(%a)" (list_sep_d expression) 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} ->
|
| E_assign {variable; access_path; expression=e} ->
|
||||||
fprintf ppf "%a%a := %a"
|
fprintf ppf "%a%a := %a"
|
||||||
expression_variable variable
|
expression_variable variable
|
||||||
(list_sep (fun ppf a -> fprintf ppf ".%a" accessor a) (fun ppf () -> fprintf ppf "")) access_path
|
(list_sep accessor (const ".")) access_path
|
||||||
expression e
|
expression e
|
||||||
| E_for {binder; start; final; increment; body} ->
|
| E_for {binder; start; final; increment; body} ->
|
||||||
fprintf ppf "for %a from %a to %a by %a do %a"
|
fprintf ppf "for %a from %a to %a by %a do %a"
|
||||||
@ -157,7 +151,7 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
|
|
||||||
and accessor ppf a =
|
and accessor ppf a =
|
||||||
match a with
|
match a with
|
||||||
| Access_tuple i -> fprintf ppf "%d" i
|
| Access_tuple i -> fprintf ppf "%a" Z.pp_print i
|
||||||
| Access_record s -> fprintf ppf "%s" s
|
| Access_record s -> fprintf ppf "%s" s
|
||||||
| Access_map e -> fprintf ppf "%a" expression e
|
| Access_map e -> fprintf ppf "%a" expression e
|
||||||
|
|
||||||
@ -184,27 +178,35 @@ and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * ex
|
|||||||
fun f ppf ((c,n),a) ->
|
fun f ppf ((c,n),a) ->
|
||||||
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
|
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
|
||||||
|
|
||||||
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
|
and matching : (formatter -> expression -> unit) -> formatter -> matching_expr -> unit =
|
||||||
fun f ppf m -> match m with
|
fun f ppf m -> match m with
|
||||||
| Match_tuple ((lst, b), _) ->
|
| Match_variant lst ->
|
||||||
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
|
|
||||||
| Match_variant (lst, _) ->
|
|
||||||
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
|
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
|
||||||
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
|
| Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
|
||||||
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
|
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
|
||||||
| Match_option {match_none ; match_some = (some, match_some, _)} ->
|
| Match_option {match_none ; match_some = (some, match_some)} ->
|
||||||
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
|
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
|
||||||
|
| Match_tuple (lst, _,b) ->
|
||||||
|
fprintf ppf "(%a) -> %a" (list_sep_d expression_variable) lst f b
|
||||||
|
| Match_record (lst, _,b) ->
|
||||||
|
fprintf ppf "{%a} -> %a" (list_sep_d (fun ppf (a,b) -> fprintf ppf "%a = %a" label a expression_variable b)) lst f b
|
||||||
|
| Match_variable (a, _,b) ->
|
||||||
|
fprintf ppf "%a -> %a" expression_variable a f b
|
||||||
|
|
||||||
(* Shows the type expected for the matched value *)
|
(* Shows the type expected for the matched value *)
|
||||||
and matching_type ppf m = match m with
|
and matching_type ppf m = match m with
|
||||||
| Match_tuple _ ->
|
| Match_variant lst ->
|
||||||
fprintf ppf "tuple"
|
|
||||||
| Match_variant (lst, _) ->
|
|
||||||
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
|
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
|
||||||
| Match_list _ ->
|
| Match_list _ ->
|
||||||
fprintf ppf "list"
|
fprintf ppf "list"
|
||||||
| Match_option _ ->
|
| Match_option _ ->
|
||||||
fprintf ppf "option"
|
fprintf ppf "option"
|
||||||
|
| Match_tuple _ ->
|
||||||
|
fprintf ppf "tuple"
|
||||||
|
| Match_record _ ->
|
||||||
|
fprintf ppf "record"
|
||||||
|
| Match_variable _ ->
|
||||||
|
fprintf ppf "variable"
|
||||||
|
|
||||||
and matching_variant_case_type ppf ((c,n),_a) =
|
and matching_variant_case_type ppf ((c,n),_a) =
|
||||||
fprintf ppf "| %a %a" constructor c expression_variable n
|
fprintf ppf "| %a %a" constructor c expression_variable n
|
||||||
|
|||||||
@ -119,15 +119,12 @@ let e_let_in ?loc (binder, ascr) inline rhs let_result = make_e ?loc @@ E_let_in
|
|||||||
let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
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_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 ?loc record path = make_e ?loc @@ E_accessor {record; path}
|
||||||
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b
|
let e_update ?loc record path update = make_e ?loc @@ E_update {record; path; update}
|
||||||
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_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 ?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_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_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause}
|
||||||
@ -138,7 +135,6 @@ 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_set ?loc lst : expression = make_e ?loc @@ E_set lst
|
||||||
let e_map ?loc lst : expression = make_e ?loc @@ E_map 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_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_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 ?loc binder start final increment body = make_e ?loc @@ E_for {binder;start;final;increment;body}
|
||||||
@ -148,9 +144,14 @@ let e_bool ?loc b : expression = e_constructor ?loc (string_of_bool b) (e_unit
|
|||||||
|
|
||||||
let ez_match_variant (lst : ((string * string) * 'a) list) =
|
let ez_match_variant (lst : ((string * string) * 'a) list) =
|
||||||
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
|
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
|
||||||
Match_variant (lst,())
|
Match_variant lst
|
||||||
let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
|
let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) =
|
||||||
e_matching ?loc a (ez_match_variant lst)
|
e_matching ?loc a (ez_match_variant lst)
|
||||||
|
|
||||||
|
let e_matching_record ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_record (lst,ty_opt, expr)
|
||||||
|
let e_matching_tuple ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_tuple (lst,ty_opt, expr)
|
||||||
|
let e_matching_variable ?loc m var ty_opt expr = e_matching ?loc m @@ Match_variable (var,ty_opt, expr)
|
||||||
|
|
||||||
let e_record_ez ?loc (lst : (string * expr) list) : expression =
|
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
|
let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
|
||||||
make_e ?loc @@ E_record map
|
make_e ?loc @@ E_record map
|
||||||
@ -184,14 +185,10 @@ let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
|
|||||||
|
|
||||||
let e_assign ?loc variable access_path expression =
|
let e_assign ?loc variable access_path expression =
|
||||||
make_e ?loc @@ E_assign {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 ->
|
let get_e_accessor = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record_accessor {record; path} -> ok (record , path)
|
| E_accessor {record; path} -> ok (record , path)
|
||||||
| _ -> simple_fail "not an accessor"
|
| _ -> simple_fail "not an accessor"
|
||||||
|
|
||||||
let assert_e_accessor = fun t ->
|
let assert_e_accessor = fun t ->
|
||||||
|
|||||||
@ -98,20 +98,20 @@ val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option
|
|||||||
|
|
||||||
val e_constructor : ?loc:Location.t -> string -> expression -> expression
|
val e_constructor : ?loc:Location.t -> string -> expression -> expression
|
||||||
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
||||||
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
|
val ez_match_variant : ((string * string ) * expression) list -> matching_expr
|
||||||
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
|
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
|
||||||
|
val e_matching_record : ?loc:Location.t -> expression -> (label * expression_variable) list -> type_expression list option -> expression -> expression
|
||||||
|
val e_matching_tuple : ?loc:Location.t -> expression -> expression_variable list -> type_expression list option -> expression -> expression
|
||||||
|
val e_matching_variable: ?loc:Location.t -> expression -> expression_variable -> type_expression option -> expression -> expression
|
||||||
|
|
||||||
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
||||||
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> 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 : ?loc:Location.t -> expression -> access list -> expression
|
||||||
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
|
val e_update : ?loc:Location.t -> expression -> access list -> expression -> expression
|
||||||
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
|
||||||
|
|
||||||
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
||||||
|
|
||||||
val e_tuple : ?loc:Location.t -> expression list -> 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_pair : ?loc:Location.t -> expression -> expression -> expression
|
||||||
|
|
||||||
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
@ -122,10 +122,8 @@ val e_list : ?loc:Location.t -> expression list -> expression
|
|||||||
val e_set : ?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_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
||||||
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
||||||
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
|
|
||||||
|
|
||||||
val e_assign : ?loc:Location.t -> expression_variable -> access list -> 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_while : ?loc:Location.t -> expression -> expression -> expression
|
||||||
val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression
|
val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression
|
||||||
|
|||||||
@ -53,8 +53,8 @@ and expression_content =
|
|||||||
| E_matching of matching
|
| E_matching of matching
|
||||||
(* Record *)
|
(* Record *)
|
||||||
| E_record of expression label_map
|
| E_record of expression label_map
|
||||||
| E_record_accessor of record_accessor
|
| E_accessor of accessor
|
||||||
| E_record_update of record_update
|
| E_update of update
|
||||||
(* Advanced *)
|
(* Advanced *)
|
||||||
| E_ascription of ascription
|
| E_ascription of ascription
|
||||||
(* Sugar *)
|
(* Sugar *)
|
||||||
@ -62,14 +62,11 @@ and expression_content =
|
|||||||
| E_sequence of sequence
|
| E_sequence of sequence
|
||||||
| E_skip
|
| E_skip
|
||||||
| E_tuple of expression list
|
| E_tuple of expression list
|
||||||
| E_tuple_accessor of tuple_accessor
|
|
||||||
| E_tuple_update of tuple_update
|
|
||||||
(* Data Structures *)
|
(* Data Structures *)
|
||||||
| E_map of (expression * expression) list
|
| E_map of (expression * expression) list
|
||||||
| E_big_map of (expression * expression) list
|
| E_big_map of (expression * expression) list
|
||||||
| E_list of expression list
|
| E_list of expression list
|
||||||
| E_set of expression list
|
| E_set of expression list
|
||||||
| E_look_up of (expression * expression)
|
|
||||||
(* Imperative *)
|
(* Imperative *)
|
||||||
| E_assign of assign
|
| E_assign of assign
|
||||||
| E_for of for_
|
| E_for of for_
|
||||||
@ -105,12 +102,25 @@ and let_in =
|
|||||||
|
|
||||||
and constructor = {constructor: constructor'; element: expression}
|
and constructor = {constructor: constructor'; element: expression}
|
||||||
|
|
||||||
and record_accessor = {record: expression; path: label}
|
and accessor = {record: expression; path: access list}
|
||||||
and record_update = {record: expression; path: label ; update: expression}
|
and update = {record: expression; path: access list; update: expression}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
and matching_expr = (expr,unit) matching_content
|
and matching_expr =
|
||||||
|
| Match_variant of ((constructor' * expression_variable) * expression) list
|
||||||
|
| Match_list of {
|
||||||
|
match_nil : expression ;
|
||||||
|
match_cons : expression_variable * expression_variable * expression ;
|
||||||
|
}
|
||||||
|
| Match_option of {
|
||||||
|
match_none : expression ;
|
||||||
|
match_some : expression_variable * expression ;
|
||||||
|
}
|
||||||
|
| Match_tuple of expression_variable list * type_expression list option * expression
|
||||||
|
| Match_record of (label * expression_variable) list * type_expression list option * expression
|
||||||
|
| Match_variable of expression_variable * type_expression option * expression
|
||||||
|
|
||||||
and matching =
|
and matching =
|
||||||
{ matchee: expression
|
{ matchee: expression
|
||||||
; cases: matching_expr
|
; cases: matching_expr
|
||||||
@ -129,9 +139,6 @@ and sequence = {
|
|||||||
expr2: expression ;
|
expr2: expression ;
|
||||||
}
|
}
|
||||||
|
|
||||||
and tuple_accessor = {tuple: expression; path: int}
|
|
||||||
and tuple_update = {tuple: expression; path: int ; update: expression}
|
|
||||||
|
|
||||||
and assign = {
|
and assign = {
|
||||||
variable : expression_variable;
|
variable : expression_variable;
|
||||||
access_path : access list;
|
access_path : access list;
|
||||||
@ -139,7 +146,7 @@ and assign = {
|
|||||||
}
|
}
|
||||||
|
|
||||||
and access =
|
and access =
|
||||||
| Access_tuple of int
|
| Access_tuple of Z.t
|
||||||
| Access_record of string
|
| Access_record of string
|
||||||
| Access_map of expr
|
| Access_map of expr
|
||||||
|
|
||||||
|
|||||||
@ -78,10 +78,10 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
c.arguments
|
c.arguments
|
||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "{%a}" (record_sep_expr expression (const ";")) m
|
fprintf ppf "{%a}" (record_sep_expr expression (const ";")) m
|
||||||
| E_record_accessor ra ->
|
| E_accessor {record;path} ->
|
||||||
fprintf ppf "%a.%a" expression ra.record label ra.path
|
fprintf ppf "%a.%a" expression record (list_sep accessor (const ".")) path
|
||||||
| E_record_update {record; path; update} ->
|
| E_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with %a = %a }" expression record label path expression update
|
fprintf ppf "{ %a with %a = %a }" expression record (list_sep accessor (const ".")) path expression update
|
||||||
| E_map m ->
|
| E_map m ->
|
||||||
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
|
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
|
||||||
| E_big_map m ->
|
| E_big_map m ->
|
||||||
@ -90,8 +90,6 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
fprintf ppf "list[%a]" (list_sep_d expression) lst
|
fprintf ppf "list[%a]" (list_sep_d expression) lst
|
||||||
| E_set lst ->
|
| E_set lst ->
|
||||||
fprintf ppf "set[%a]" (list_sep_d expression) lst
|
fprintf ppf "set[%a]" (list_sep_d expression) lst
|
||||||
| E_look_up (ds, ind) ->
|
|
||||||
fprintf ppf "(%a)[%a]" expression ds expression ind
|
|
||||||
| E_lambda {binder; input_type; output_type; result} ->
|
| 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
|
expression_variable binder
|
||||||
@ -127,10 +125,12 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
fprintf ppf "skip"
|
fprintf ppf "skip"
|
||||||
| E_tuple t ->
|
| E_tuple t ->
|
||||||
fprintf ppf "(%a)" (list_sep_d expression) t
|
fprintf ppf "(%a)" (list_sep_d expression) t
|
||||||
| E_tuple_accessor ta ->
|
|
||||||
fprintf ppf "%a.%d" expression ta.tuple ta.path
|
and accessor ppf a =
|
||||||
| E_tuple_update {tuple; path; update} ->
|
match a with
|
||||||
fprintf ppf "{ %a with %d = %a }" expression tuple path expression update
|
| Access_tuple i -> fprintf ppf "%a" Z.pp_print i
|
||||||
|
| Access_record s -> fprintf ppf "%s" s
|
||||||
|
| Access_map e -> fprintf ppf "%a" expression e
|
||||||
|
|
||||||
and option_type_name ppf
|
and option_type_name ppf
|
||||||
((n, ty_opt) : expression_variable * type_expression option) =
|
((n, ty_opt) : expression_variable * type_expression option) =
|
||||||
@ -150,27 +150,35 @@ and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * ex
|
|||||||
fun f ppf ((c,n),a) ->
|
fun f ppf ((c,n),a) ->
|
||||||
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
|
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
|
||||||
|
|
||||||
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
|
and matching : (formatter -> expression -> unit) -> formatter -> matching_expr -> unit =
|
||||||
fun f ppf m -> match m with
|
fun f ppf m -> match m with
|
||||||
| Match_tuple ((lst, b), _) ->
|
| Match_variant lst ->
|
||||||
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
|
|
||||||
| Match_variant (lst, _) ->
|
|
||||||
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
|
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
|
||||||
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
|
| Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
|
||||||
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
|
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons
|
||||||
| Match_option {match_none ; match_some = (some, match_some, _)} ->
|
| Match_option {match_none ; match_some = (some, match_some)} ->
|
||||||
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
|
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
|
||||||
|
| Match_tuple (lst, _,b) ->
|
||||||
|
fprintf ppf "(%a) -> %a" (list_sep_d expression_variable) lst f b
|
||||||
|
| Match_record (lst, _,b) ->
|
||||||
|
fprintf ppf "{%a} -> %a" (list_sep_d (fun ppf (a,b) -> fprintf ppf "%a = %a" label a expression_variable b)) lst f b
|
||||||
|
| Match_variable (a, _,b) ->
|
||||||
|
fprintf ppf "%a -> %a" expression_variable a f b
|
||||||
|
|
||||||
(* Shows the type expected for the matched value *)
|
(* Shows the type expected for the matched value *)
|
||||||
and matching_type ppf m = match m with
|
and matching_type ppf m = match m with
|
||||||
| Match_tuple _ ->
|
| Match_variant lst ->
|
||||||
fprintf ppf "tuple"
|
|
||||||
| Match_variant (lst, _) ->
|
|
||||||
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
|
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
|
||||||
| Match_list _ ->
|
| Match_list _ ->
|
||||||
fprintf ppf "list"
|
fprintf ppf "list"
|
||||||
| Match_option _ ->
|
| Match_option _ ->
|
||||||
fprintf ppf "option"
|
fprintf ppf "option"
|
||||||
|
| Match_tuple _ ->
|
||||||
|
fprintf ppf "tuple"
|
||||||
|
| Match_record _ ->
|
||||||
|
fprintf ppf "record"
|
||||||
|
| Match_variable _ ->
|
||||||
|
fprintf ppf "variable"
|
||||||
|
|
||||||
and matching_variant_case_type ppf ((c,n),_a) =
|
and matching_variant_case_type ppf ((c,n),_a) =
|
||||||
fprintf ppf "| %a %a" constructor c expression_variable n
|
fprintf ppf "| %a %a" constructor c expression_variable n
|
||||||
|
|||||||
@ -108,14 +108,12 @@ let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constru
|
|||||||
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
|
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 ?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_accessor ?loc record path = make_e ?loc @@ E_accessor {record; path}
|
||||||
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update}
|
let e_update ?loc record path update = make_e ?loc @@ E_update {record; path; update}
|
||||||
|
|
||||||
let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}
|
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 ?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_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_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause}
|
||||||
@ -126,7 +124,6 @@ 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_set ?loc lst : expression = make_e ?loc @@ E_set lst
|
||||||
let e_map ?loc lst : expression = make_e ?loc @@ E_map 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_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 e_bool ?loc b : expression = e_constructor ?loc (Constructor (string_of_bool b)) (e_unit ())
|
let e_bool ?loc b : expression = e_constructor ?loc (Constructor (string_of_bool b)) (e_unit ())
|
||||||
|
|
||||||
@ -150,13 +147,13 @@ let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
let get_e_record_accessor = fun t ->
|
let get_e_accessor = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record_accessor {record; path} -> ok (record, path)
|
| E_accessor {record; path} -> ok (record, path)
|
||||||
| _ -> simple_fail "not a record accessor"
|
| _ -> simple_fail "not a record accessor"
|
||||||
|
|
||||||
let assert_e_accessor = fun t ->
|
let assert_e_accessor = fun t ->
|
||||||
let%bind _ = get_e_record_accessor t in
|
let%bind _ = get_e_accessor t in
|
||||||
ok ()
|
ok ()
|
||||||
|
|
||||||
let get_e_pair = fun t ->
|
let get_e_pair = fun t ->
|
||||||
|
|||||||
@ -79,14 +79,12 @@ val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> l
|
|||||||
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> 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 : ?loc:Location.t -> expr label_map -> expression
|
||||||
val e_record_accessor : ?loc:Location.t -> expression -> label -> expression
|
val e_accessor : ?loc:Location.t -> expression -> access list -> expression
|
||||||
val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression
|
val e_update : ?loc:Location.t -> expression -> access list -> expression -> expression
|
||||||
|
|
||||||
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
||||||
|
|
||||||
val e_tuple : ?loc:Location.t -> expression list -> 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_pair : ?loc:Location.t -> expression -> expression -> expression
|
||||||
|
|
||||||
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
@ -97,7 +95,6 @@ val e_list : ?loc:Location.t -> expression list -> expression
|
|||||||
val e_set : ?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_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
||||||
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
||||||
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
|
|
||||||
|
|
||||||
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
||||||
|
|
||||||
|
|||||||
@ -54,8 +54,8 @@ and expression_content =
|
|||||||
| E_matching of matching
|
| E_matching of matching
|
||||||
(* Record *)
|
(* Record *)
|
||||||
| E_record of expression label_map
|
| E_record of expression label_map
|
||||||
| E_record_accessor of record_accessor
|
| E_accessor of accessor
|
||||||
| E_record_update of record_update
|
| E_update of update
|
||||||
(* Advanced *)
|
(* Advanced *)
|
||||||
| E_ascription of ascription
|
| E_ascription of ascription
|
||||||
(* Sugar *)
|
(* Sugar *)
|
||||||
@ -63,14 +63,11 @@ and expression_content =
|
|||||||
| E_sequence of sequence
|
| E_sequence of sequence
|
||||||
| E_skip
|
| E_skip
|
||||||
| E_tuple of expression list
|
| E_tuple of expression list
|
||||||
| E_tuple_accessor of tuple_accessor
|
|
||||||
| E_tuple_update of tuple_update
|
|
||||||
(* Data Structures *)
|
(* Data Structures *)
|
||||||
| E_map of (expression * expression) list
|
| E_map of (expression * expression) list
|
||||||
| E_big_map of (expression * expression) list
|
| E_big_map of (expression * expression) list
|
||||||
| E_list of expression list
|
| E_list of expression list
|
||||||
| E_set of expression list
|
| E_set of expression list
|
||||||
| E_look_up of (expression * expression)
|
|
||||||
|
|
||||||
and constant =
|
and constant =
|
||||||
{ cons_name: constant' (* this is at the end because it is huge *)
|
{ cons_name: constant' (* this is at the end because it is huge *)
|
||||||
@ -103,10 +100,28 @@ and let_in = {
|
|||||||
|
|
||||||
and constructor = {constructor: constructor'; element: expression}
|
and constructor = {constructor: constructor'; element: expression}
|
||||||
|
|
||||||
and record_accessor = {record: expression; path: label}
|
and accessor = {record: expression; path: access list}
|
||||||
and record_update = {record: expression; path: label ; update: expression}
|
and update = {record: expression; path: access list ; update: expression}
|
||||||
|
|
||||||
|
and access =
|
||||||
|
| Access_tuple of Z.t
|
||||||
|
| Access_record of string
|
||||||
|
| Access_map of expr
|
||||||
|
|
||||||
|
and matching_expr =
|
||||||
|
| Match_variant of ((constructor' * expression_variable) * expression) list
|
||||||
|
| Match_list of {
|
||||||
|
match_nil : expression ;
|
||||||
|
match_cons : expression_variable * expression_variable * expression ;
|
||||||
|
}
|
||||||
|
| Match_option of {
|
||||||
|
match_none : expression ;
|
||||||
|
match_some : expression_variable * expression ;
|
||||||
|
}
|
||||||
|
| Match_tuple of expression_variable list * type_expression list option * expression
|
||||||
|
| Match_record of (label * expression_variable) list * type_expression list option * expression
|
||||||
|
| Match_variable of expression_variable * type_expression option * expression
|
||||||
|
|
||||||
and matching_expr = (expr,unit) matching_content
|
|
||||||
and matching =
|
and matching =
|
||||||
{ matchee: expression
|
{ matchee: expression
|
||||||
; cases: matching_expr
|
; cases: matching_expr
|
||||||
@ -124,9 +139,6 @@ and sequence = {
|
|||||||
expr2: expression ;
|
expr2: expression ;
|
||||||
}
|
}
|
||||||
|
|
||||||
and tuple_accessor = {tuple: expression; path: int}
|
|
||||||
and tuple_update = {tuple: expression; path: int ; update: expression}
|
|
||||||
|
|
||||||
and environment_element_definition =
|
and environment_element_definition =
|
||||||
| ED_binder
|
| ED_binder
|
||||||
| ED_declaration of (expression * free_variables)
|
| ED_declaration of (expression * free_variables)
|
||||||
|
|||||||
@ -66,26 +66,22 @@ and assoc_expression ppf : expr * expr -> unit =
|
|||||||
and single_record_patch ppf ((p, expr) : label * expr) =
|
and single_record_patch ppf ((p, expr) : label * expr) =
|
||||||
fprintf ppf "%a <- %a" label p expression expr
|
fprintf ppf "%a <- %a" label p expression expr
|
||||||
|
|
||||||
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
|
and matching_variant_case : (_ -> expression -> unit) -> _ -> (constructor' * expression_variable) * expression -> unit =
|
||||||
fun f ppf ((c,n),a) ->
|
fun f ppf ((c,n),a) ->
|
||||||
fprintf ppf "| %a %a ->@;<1 2>%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 =
|
and matching : (formatter -> expression -> unit) -> formatter -> matching_expr -> unit =
|
||||||
fun f ppf m -> match m with
|
fun f ppf m -> match m with
|
||||||
| Match_tuple ((lst, b), _) ->
|
| Match_variant lst ->
|
||||||
fprintf ppf "@[<hv>| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b
|
|
||||||
| Match_variant (lst, _) ->
|
|
||||||
fprintf ppf "@[<hv>%a@]" (list_sep (matching_variant_case f) (tag "@ ")) lst
|
fprintf ppf "@[<hv>%a@]" (list_sep (matching_variant_case f) (tag "@ ")) lst
|
||||||
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
|
| Match_list {match_nil ; match_cons = (hd, tl, 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
|
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, _)} ->
|
| Match_option {match_none ; match_some = (some, match_some)} ->
|
||||||
fprintf ppf "@[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%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 *)
|
(* Shows the type expected for the matched value *)
|
||||||
and matching_type ppf m = match m with
|
and matching_type ppf m = match m with
|
||||||
| Match_tuple _ ->
|
| Match_variant lst ->
|
||||||
fprintf ppf "tuple"
|
|
||||||
| Match_variant (lst, _) ->
|
|
||||||
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
|
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
|
||||||
| Match_list _ ->
|
| Match_list _ ->
|
||||||
fprintf ppf "list"
|
fprintf ppf "list"
|
||||||
|
|||||||
@ -107,7 +107,7 @@ let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constru
|
|||||||
let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
|
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 ?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_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = b}
|
||||||
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update}
|
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_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty}
|
||||||
|
|||||||
@ -74,7 +74,7 @@ val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
|
|||||||
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
val e_constructor : ?loc:Location.t -> string -> expression -> expression
|
val e_constructor : ?loc:Location.t -> string -> expression -> expression
|
||||||
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
||||||
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
|
val e_record_accessor : ?loc:Location.t -> expression -> label -> expression
|
||||||
val e_variable : ?loc:Location.t -> expression_variable -> expression
|
val e_variable : ?loc:Location.t -> expression_variable -> expression
|
||||||
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> 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_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
||||||
|
|||||||
@ -76,7 +76,17 @@ and constructor = {constructor: constructor'; element: expression}
|
|||||||
and record_accessor = {record: expression; path: label}
|
and record_accessor = {record: expression; path: label}
|
||||||
and record_update = {record: expression; path: label ; update: expression}
|
and record_update = {record: expression; path: label ; update: expression}
|
||||||
|
|
||||||
and matching_expr = (expr,unit) matching_content
|
and matching_expr =
|
||||||
|
| Match_list of {
|
||||||
|
match_nil : expression ;
|
||||||
|
match_cons : expression_variable * expression_variable * expression ;
|
||||||
|
}
|
||||||
|
| Match_option of {
|
||||||
|
match_none : expression ;
|
||||||
|
match_some : expression_variable * expression ;
|
||||||
|
}
|
||||||
|
| Match_variant of ((constructor' * expression_variable) * expression) list
|
||||||
|
|
||||||
and matching =
|
and matching =
|
||||||
{ matchee: expression
|
{ matchee: expression
|
||||||
; cases: matching_expr
|
; cases: matching_expr
|
||||||
|
|||||||
@ -315,8 +315,6 @@ and matching_variant_case : (_ -> expression -> unit) -> _ -> matching_content_c
|
|||||||
fprintf ppf "| %a %a -> %a" constructor c expression_variable pattern f body
|
fprintf ppf "| %a %a -> %a" constructor c expression_variable pattern f body
|
||||||
|
|
||||||
and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit = fun f ppf m -> match m with
|
and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit = fun f ppf m -> match m with
|
||||||
| Match_tuple {vars; body; tvs=_} ->
|
|
||||||
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) vars f body
|
|
||||||
| Match_variant {cases ; tv=_} ->
|
| Match_variant {cases ; tv=_} ->
|
||||||
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) cases
|
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) cases
|
||||||
| Match_list {match_nil ; match_cons = {hd; tl; body; tv=_}} ->
|
| Match_list {match_nil ; match_cons = {hd; tl; body; tv=_}} ->
|
||||||
|
|||||||
@ -124,12 +124,6 @@ and matching_content_option = {
|
|||||||
and expression_variable_list = expression_variable list
|
and expression_variable_list = expression_variable list
|
||||||
and type_expression_list = type_expression list
|
and type_expression_list = type_expression list
|
||||||
|
|
||||||
and matching_content_tuple = {
|
|
||||||
vars : expression_variable_list ;
|
|
||||||
body : expression ;
|
|
||||||
tvs : type_expression_list ;
|
|
||||||
}
|
|
||||||
|
|
||||||
and matching_content_case = {
|
and matching_content_case = {
|
||||||
constructor : constructor' ;
|
constructor : constructor' ;
|
||||||
pattern : expression_variable ;
|
pattern : expression_variable ;
|
||||||
@ -146,7 +140,6 @@ and matching_content_variant = {
|
|||||||
and matching_expr =
|
and matching_expr =
|
||||||
| Match_list of matching_content_list
|
| Match_list of matching_content_list
|
||||||
| Match_option of matching_content_option
|
| Match_option of matching_content_option
|
||||||
| Match_tuple of matching_content_tuple
|
|
||||||
| Match_variant of matching_content_variant
|
| Match_variant of matching_content_variant
|
||||||
|
|
||||||
and constant' =
|
and constant' =
|
||||||
|
|||||||
@ -92,21 +92,6 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs ->
|
|||||||
in
|
in
|
||||||
return @@ Match_option { match_none ; match_some }
|
return @@ Match_option { match_none ; match_some }
|
||||||
)
|
)
|
||||||
| Match_tuple c -> (
|
|
||||||
let var_tvs =
|
|
||||||
try (
|
|
||||||
List.combine c.vars c.tvs
|
|
||||||
) with _ -> raise (Failure ("Internal error: broken invariant at " ^ __LOC__))
|
|
||||||
in
|
|
||||||
let env' =
|
|
||||||
let aux prev (var , tv) =
|
|
||||||
Environment.add_ez_binder var tv prev
|
|
||||||
in
|
|
||||||
List.fold_left aux env var_tvs
|
|
||||||
in
|
|
||||||
let body = self ~env' c.body in
|
|
||||||
return @@ Match_tuple { c with body }
|
|
||||||
)
|
|
||||||
| Match_variant c -> (
|
| Match_variant c -> (
|
||||||
let variant_type = Combinators.get_t_sum_exn c.tv in
|
let variant_type = Combinators.get_t_sum_exn c.tv in
|
||||||
let cases =
|
let cases =
|
||||||
|
|||||||
@ -236,8 +236,6 @@ module Free_variables = struct
|
|||||||
match m with
|
match m with
|
||||||
| Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } -> union (f b n) (f (union (of_list [hd ; tl]) b) body)
|
| Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } -> union (f b n) (f (union (of_list [hd ; tl]) b) body)
|
||||||
| Match_option { match_none = n ; match_some = {opt; body; tv=_} } -> union (f b n) (f (union (singleton opt) b) body)
|
| Match_option { match_none = n ; match_some = {opt; body; tv=_} } -> union (f b n) (f (union (singleton opt) b) body)
|
||||||
| Match_tuple { vars ; body ; tvs=_ } ->
|
|
||||||
f (union (of_list vars) b) body
|
|
||||||
| Match_variant { cases ; tv=_ } -> unions @@ List.map (matching_variant_case f b) cases
|
| Match_variant { cases ; tv=_ } -> unions @@ List.map (matching_variant_case f b) cases
|
||||||
|
|
||||||
and matching_expression = fun x -> matching expression x
|
and matching_expression = fun x -> matching expression x
|
||||||
|
|||||||
@ -90,8 +90,6 @@ module Captured_variables = struct
|
|||||||
let%bind n' = f b n in
|
let%bind n' = f b n in
|
||||||
let%bind s' = f (union (singleton opt) b) body in
|
let%bind s' = f (union (singleton opt) b) body in
|
||||||
ok @@ union n' s'
|
ok @@ union n' s'
|
||||||
| Match_tuple { vars ; body ; tvs=_ } ->
|
|
||||||
f (union (of_list vars) b) body
|
|
||||||
| Match_variant { cases ; tv=_ } ->
|
| Match_variant { cases ; tv=_ } ->
|
||||||
let%bind lst' = bind_map_list (matching_variant_case f b) cases in
|
let%bind lst' = bind_map_list (matching_variant_case f b) cases in
|
||||||
ok @@ unions lst'
|
ok @@ unions lst'
|
||||||
|
|||||||
@ -1,3 +1,5 @@
|
|||||||
|
include Types
|
||||||
|
|
||||||
module Types = Types
|
module Types = Types
|
||||||
module PP = PP
|
module PP = PP
|
||||||
module Helpers = Helpers
|
module Helpers = Helpers
|
||||||
|
|||||||
@ -11,6 +11,7 @@ type label = Label of string
|
|||||||
module CMap = Map.Make( struct type t = constructor' let compare (Constructor a) (Constructor b) = compare a b end)
|
module CMap = Map.Make( struct type t = constructor' let compare (Constructor a) (Constructor b) = compare a b end)
|
||||||
module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = String.compare a b end)
|
module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = String.compare a b end)
|
||||||
|
|
||||||
|
|
||||||
type 'a label_map = 'a LMap.t
|
type 'a label_map = 'a LMap.t
|
||||||
type 'a constructor_map = 'a CMap.t
|
type 'a constructor_map = 'a CMap.t
|
||||||
|
|
||||||
@ -169,18 +170,6 @@ type literal =
|
|||||||
| Literal_void
|
| Literal_void
|
||||||
| Literal_operation of
|
| Literal_operation of
|
||||||
Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
|
Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
|
||||||
and ('a,'tv) matching_content =
|
|
||||||
| Match_list of {
|
|
||||||
match_nil : 'a ;
|
|
||||||
match_cons : expression_variable * expression_variable * 'a * 'tv;
|
|
||||||
}
|
|
||||||
| Match_option of {
|
|
||||||
match_none : 'a ;
|
|
||||||
match_some : expression_variable * 'a * 'tv;
|
|
||||||
}
|
|
||||||
| Match_tuple of (expression_variable list * 'a) * 'tv list
|
|
||||||
| Match_variant of ((constructor' * expression_variable) * 'a) list * 'tv
|
|
||||||
|
|
||||||
and constant' =
|
and constant' =
|
||||||
| C_INT
|
| C_INT
|
||||||
| C_UNIT
|
| C_UNIT
|
||||||
|
|||||||
1515
src/test/contracts/dune
Normal file
1515
src/test/contracts/dune
Normal file
File diff suppressed because it is too large
Load Diff
172
src/test/contracts/expected/FA1.2.ligo.expected
Normal file
172
src/test/contracts/expected/FA1.2.ligo.expected
Normal file
@ -0,0 +1,172 @@
|
|||||||
|
type tokens is big_map (address, nat)
|
||||||
|
|
||||||
|
type allowances is big_map (address * address, nat)
|
||||||
|
|
||||||
|
type storage is
|
||||||
|
record [
|
||||||
|
tokens : tokens;
|
||||||
|
allowances : allowances;
|
||||||
|
total_amount : nat
|
||||||
|
]
|
||||||
|
|
||||||
|
type transfer is
|
||||||
|
record [
|
||||||
|
address_from : address;
|
||||||
|
address_to : address;
|
||||||
|
value : nat
|
||||||
|
]
|
||||||
|
|
||||||
|
type approve is record [spender : address; value : nat]
|
||||||
|
|
||||||
|
type getAllowance is
|
||||||
|
record [
|
||||||
|
owner : address;
|
||||||
|
spender : address;
|
||||||
|
callback : contract (nat)
|
||||||
|
]
|
||||||
|
|
||||||
|
type getBalance is
|
||||||
|
record [owner : address; callback : contract (nat)]
|
||||||
|
|
||||||
|
type getTotalSupply is record [callback : contract (nat)]
|
||||||
|
|
||||||
|
type action is
|
||||||
|
Transfer of transfer
|
||||||
|
| Approve of approve
|
||||||
|
| GetAllowance of getAllowance
|
||||||
|
| GetBalance of getBalance
|
||||||
|
| GetTotalSupply of getTotalSupply
|
||||||
|
|
||||||
|
function transfer (const p : transfer; const s : storage)
|
||||||
|
: list (operation) * storage is
|
||||||
|
block {
|
||||||
|
var new_allowances : allowances := Big_map.empty;
|
||||||
|
if Tezos.sender = p.address_from
|
||||||
|
then {
|
||||||
|
new_allowances := s.allowances
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
var authorized_value : nat
|
||||||
|
:= case (Big_map.find_opt
|
||||||
|
((Tezos.sender, p.address_from), s.allowances))
|
||||||
|
of [
|
||||||
|
Some (value) -> value
|
||||||
|
| None -> 0n
|
||||||
|
];
|
||||||
|
if (authorized_value < p.value)
|
||||||
|
then {
|
||||||
|
failwith ("Not Enough Allowance")
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
new_allowances :=
|
||||||
|
Big_map.update
|
||||||
|
((Tezos.sender, p.address_from),
|
||||||
|
(Some (abs (authorized_value - p.value))),
|
||||||
|
s.allowances)
|
||||||
|
}
|
||||||
|
};
|
||||||
|
var sender_balance : nat
|
||||||
|
:= case (Big_map.find_opt (p.address_from, s.tokens)) of [
|
||||||
|
Some (value) -> value
|
||||||
|
| None -> 0n
|
||||||
|
];
|
||||||
|
var new_tokens : tokens := Big_map.empty;
|
||||||
|
if (sender_balance < p.value)
|
||||||
|
then {
|
||||||
|
failwith ("Not Enough Balance")
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
new_tokens :=
|
||||||
|
Big_map.update
|
||||||
|
(p.address_from,
|
||||||
|
(Some (abs (sender_balance - p.value))), s.tokens);
|
||||||
|
var receiver_balance : nat
|
||||||
|
:= case (Big_map.find_opt (p.address_to, s.tokens)) of [
|
||||||
|
Some (value) -> value
|
||||||
|
| None -> 0n
|
||||||
|
];
|
||||||
|
new_tokens :=
|
||||||
|
Big_map.update
|
||||||
|
(p.address_to, (Some (receiver_balance + p.value)),
|
||||||
|
new_tokens)
|
||||||
|
}
|
||||||
|
} with
|
||||||
|
((nil : list (operation)),
|
||||||
|
s with
|
||||||
|
record [
|
||||||
|
tokens = new_tokens;
|
||||||
|
allowances = new_allowances
|
||||||
|
])
|
||||||
|
|
||||||
|
function approve (const p : approve; const s : storage)
|
||||||
|
: list (operation) * storage is
|
||||||
|
block {
|
||||||
|
var previous_value : nat
|
||||||
|
:= case Big_map.find_opt
|
||||||
|
((p.spender, Tezos.sender), s.allowances)
|
||||||
|
of [
|
||||||
|
Some (value) -> value
|
||||||
|
| None -> 0n
|
||||||
|
];
|
||||||
|
var new_allowances : allowances := Big_map.empty;
|
||||||
|
if previous_value > 0n and p.value > 0n
|
||||||
|
then {
|
||||||
|
failwith ("Unsafe Allowance Change")
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
new_allowances :=
|
||||||
|
Big_map.update
|
||||||
|
((p.spender, Tezos.sender), (Some (p.value)),
|
||||||
|
s.allowances)
|
||||||
|
}
|
||||||
|
} with
|
||||||
|
((nil : list (operation)),
|
||||||
|
s with
|
||||||
|
record [allowances = new_allowances])
|
||||||
|
|
||||||
|
function getAllowance
|
||||||
|
(const p : getAllowance;
|
||||||
|
const s : storage) : list (operation) * storage is
|
||||||
|
block {
|
||||||
|
var value : nat
|
||||||
|
:= case Big_map.find_opt
|
||||||
|
((p.owner, p.spender), s.allowances)
|
||||||
|
of [
|
||||||
|
Some (value) -> value
|
||||||
|
| None -> 0n
|
||||||
|
];
|
||||||
|
var op : operation
|
||||||
|
:= Tezos.transaction (value, 0mutez, p.callback)
|
||||||
|
} with (list [op], s)
|
||||||
|
|
||||||
|
function getBalance
|
||||||
|
(const p : getBalance;
|
||||||
|
const s : storage) : list (operation) * storage is
|
||||||
|
block {
|
||||||
|
var value : nat
|
||||||
|
:= case Big_map.find_opt (p.owner, s.tokens) of [
|
||||||
|
Some (value) -> value
|
||||||
|
| None -> 0n
|
||||||
|
];
|
||||||
|
var op : operation
|
||||||
|
:= Tezos.transaction (value, 0mutez, p.callback)
|
||||||
|
} with (list [op], s)
|
||||||
|
|
||||||
|
function getTotalSupply
|
||||||
|
(const p : getTotalSupply;
|
||||||
|
const s : storage) : list (operation) * storage is
|
||||||
|
block {
|
||||||
|
var total : nat := s.total_amount;
|
||||||
|
var op : operation
|
||||||
|
:= Tezos.transaction (total, 0mutez, p.callback)
|
||||||
|
} with (list [op], s)
|
||||||
|
|
||||||
|
function main (const a : action; const s : storage)
|
||||||
|
: list (operation) * storage is
|
||||||
|
case a of [
|
||||||
|
Transfer (p) -> transfer (p, s)
|
||||||
|
| Approve (p) -> approve (p, s)
|
||||||
|
| GetAllowance (p) -> getAllowance (p, s)
|
||||||
|
| GetBalance (p) -> getBalance (p, s)
|
||||||
|
| GetTotalSupply (p) -> getTotalSupply (p, s)
|
||||||
|
]
|
||||||
136
src/test/contracts/expected/FA1.2.mligo.expected
Normal file
136
src/test/contracts/expected/FA1.2.mligo.expected
Normal file
@ -0,0 +1,136 @@
|
|||||||
|
type tokens = (address, nat) big_map
|
||||||
|
|
||||||
|
type allowances = (address * address, nat) big_map
|
||||||
|
|
||||||
|
type storage =
|
||||||
|
{tokens : tokens;
|
||||||
|
allowances : allowances;
|
||||||
|
total_amount : nat}
|
||||||
|
|
||||||
|
type transfer =
|
||||||
|
{address_from : address;
|
||||||
|
address_to : address;
|
||||||
|
value : nat}
|
||||||
|
|
||||||
|
type approve = {spender : address; value : nat}
|
||||||
|
|
||||||
|
type getAllowance =
|
||||||
|
{owner : address;
|
||||||
|
spender : address;
|
||||||
|
callback : nat contract}
|
||||||
|
|
||||||
|
type getBalance = {owner : address; callback : nat contract}
|
||||||
|
|
||||||
|
type getTotalSupply = {callback : nat contract}
|
||||||
|
|
||||||
|
type action =
|
||||||
|
Transfer of transfer
|
||||||
|
| Approve of approve
|
||||||
|
| GetAllowance of getAllowance
|
||||||
|
| GetBalance of getBalance
|
||||||
|
| GetTotalSupply of getTotalSupply
|
||||||
|
|
||||||
|
let transfer (p, s : transfer * storage)
|
||||||
|
: operation list * storage =
|
||||||
|
let new_allowances =
|
||||||
|
if Tezos.sender = p.address_from
|
||||||
|
then s.allowances
|
||||||
|
else
|
||||||
|
let authorized_value =
|
||||||
|
match Big_map.find_opt
|
||||||
|
(Tezos.sender, p.address_from)
|
||||||
|
s.allowances
|
||||||
|
with
|
||||||
|
Some value -> value
|
||||||
|
| None -> 0n
|
||||||
|
in if (authorized_value < p.value)
|
||||||
|
then (failwith "Not Enough Allowance" : allowances)
|
||||||
|
else
|
||||||
|
Big_map.update
|
||||||
|
(Tezos.sender, p.address_from)
|
||||||
|
(Some (abs (authorized_value - p.value)))
|
||||||
|
s.allowances
|
||||||
|
in let sender_balance =
|
||||||
|
match Big_map.find_opt p.address_from s.tokens with
|
||||||
|
Some value -> value
|
||||||
|
| None -> 0n
|
||||||
|
in if (sender_balance < p.value)
|
||||||
|
then
|
||||||
|
(failwith "Not Enough Balance"
|
||||||
|
: operation list * storage)
|
||||||
|
else
|
||||||
|
let new_tokens =
|
||||||
|
Big_map.update
|
||||||
|
p.address_from
|
||||||
|
(Some (abs (sender_balance - p.value)))
|
||||||
|
s.tokens
|
||||||
|
in let receiver_balance =
|
||||||
|
match Big_map.find_opt p.address_to s.tokens
|
||||||
|
with
|
||||||
|
Some value -> value
|
||||||
|
| None -> 0n
|
||||||
|
in let new_tokens =
|
||||||
|
Big_map.update
|
||||||
|
p.address_to
|
||||||
|
(Some (receiver_balance + p.value))
|
||||||
|
new_tokens
|
||||||
|
in ([] : operation list),
|
||||||
|
{s with
|
||||||
|
tokens = new_tokens;
|
||||||
|
allowances = new_allowances}
|
||||||
|
|
||||||
|
let approve (p, s : approve * storage)
|
||||||
|
: operation list * storage =
|
||||||
|
let previous_value =
|
||||||
|
match Big_map.find_opt
|
||||||
|
(p.spender, Tezos.sender)
|
||||||
|
s.allowances
|
||||||
|
with
|
||||||
|
Some value -> value
|
||||||
|
| None -> 0n
|
||||||
|
in if previous_value > 0n && p.value > 0n
|
||||||
|
then
|
||||||
|
(failwith "Unsafe Allowance Change"
|
||||||
|
: operation list * storage)
|
||||||
|
else
|
||||||
|
let new_allowances =
|
||||||
|
Big_map.update
|
||||||
|
(p.spender, Tezos.sender)
|
||||||
|
(Some (p.value))
|
||||||
|
s.allowances
|
||||||
|
in ([] : operation list),
|
||||||
|
{s with
|
||||||
|
allowances = new_allowances}
|
||||||
|
|
||||||
|
let getAllowance (p, s : getAllowance * storage)
|
||||||
|
: operation list * storage =
|
||||||
|
let value =
|
||||||
|
match Big_map.find_opt (p.owner, p.spender) s.allowances
|
||||||
|
with
|
||||||
|
Some value -> value
|
||||||
|
| None -> 0n
|
||||||
|
in let op = Tezos.transaction value 0mutez p.callback
|
||||||
|
in ([op], s)
|
||||||
|
|
||||||
|
let getBalance (p, s : getBalance * storage)
|
||||||
|
: operation list * storage =
|
||||||
|
let value =
|
||||||
|
match Big_map.find_opt p.owner s.tokens with
|
||||||
|
Some value -> value
|
||||||
|
| None -> 0n
|
||||||
|
in let op = Tezos.transaction value 0mutez p.callback
|
||||||
|
in ([op], s)
|
||||||
|
|
||||||
|
let getTotalSupply (p, s : getTotalSupply * storage)
|
||||||
|
: operation list * storage =
|
||||||
|
let total = s.total_amount
|
||||||
|
in let op = Tezos.transaction total 0mutez p.callback
|
||||||
|
in ([op], s)
|
||||||
|
|
||||||
|
let main (a, s : action * storage) =
|
||||||
|
match a with
|
||||||
|
Transfer p -> transfer (p, s)
|
||||||
|
| Approve p -> approve (p, s)
|
||||||
|
| GetAllowance p -> getAllowance (p, s)
|
||||||
|
| GetBalance p -> getBalance (p, s)
|
||||||
|
| GetTotalSupply p -> getTotalSupply (p, s)
|
||||||
4
src/test/contracts/expected/address.ligo.expected
Normal file
4
src/test/contracts/expected/address.ligo.expected
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
function main (const p : key_hash) : address is
|
||||||
|
block {
|
||||||
|
const c : contract (unit) = Tezos.implicit_account (p)
|
||||||
|
} with Tezos.address (c)
|
||||||
3
src/test/contracts/expected/address.mligo.expected
Normal file
3
src/test/contracts/expected/address.mligo.expected
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
let main (p : key_hash) =
|
||||||
|
let c : unit contract = Tezos.implicit_account p
|
||||||
|
in Tezos.address c
|
||||||
4
src/test/contracts/expected/address.religo.expected
Normal file
4
src/test/contracts/expected/address.religo.expected
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
let main = (p: key_hash): address => {
|
||||||
|
let c: contract(unit) = Tezos.implicit_account(p);
|
||||||
|
Tezos.address(c)
|
||||||
|
};
|
||||||
7
src/test/contracts/expected/amount.ligo.expected
Normal file
7
src/test/contracts/expected/amount.ligo.expected
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
function check (const p : unit) : int is
|
||||||
|
block {
|
||||||
|
var result : int := 0;
|
||||||
|
if amount = 100000000mutez
|
||||||
|
then result := 42
|
||||||
|
else result := 0
|
||||||
|
} with result
|
||||||
2
src/test/contracts/expected/amount.mligo.expected
Normal file
2
src/test/contracts/expected/amount.mligo.expected
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
let check_ (p : unit) : int =
|
||||||
|
if Tezos.amount = 100000000mutez then 42 else 0
|
||||||
6
src/test/contracts/expected/amount.religo.expected
Normal file
6
src/test/contracts/expected/amount.religo.expected
Normal file
@ -0,0 +1,6 @@
|
|||||||
|
let check_ = (p: unit): int =>
|
||||||
|
if (Tezos.amount == 100000000mutez) {
|
||||||
|
42
|
||||||
|
} else {
|
||||||
|
0
|
||||||
|
};
|
||||||
10
src/test/contracts/expected/amount_lambda.mligo.expected
Normal file
10
src/test/contracts/expected/amount_lambda.mligo.expected
Normal file
@ -0,0 +1,10 @@
|
|||||||
|
let f1 (x : unit) : unit -> tez =
|
||||||
|
let amt : tez = Current.amount
|
||||||
|
in fun (x : unit) -> amt
|
||||||
|
|
||||||
|
let f2 (x : unit) : unit -> tez =
|
||||||
|
fun (x : unit) -> Current.amount
|
||||||
|
|
||||||
|
let main (b, s : bool * (unit -> tez))
|
||||||
|
: operation list * (unit -> tez) =
|
||||||
|
(([] : operation list), (if b then f1 () else f2 ()))
|
||||||
4
src/test/contracts/expected/annotation.ligo.expected
Normal file
4
src/test/contracts/expected/annotation.ligo.expected
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
const lst : list (int) = list []
|
||||||
|
|
||||||
|
const my_address : address
|
||||||
|
= ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address)
|
||||||
13
src/test/contracts/expected/application.ligo.expected
Normal file
13
src/test/contracts/expected/application.ligo.expected
Normal file
@ -0,0 +1,13 @@
|
|||||||
|
type foo is record [bar : int -> int]
|
||||||
|
|
||||||
|
function f (const i : int) : int is i
|
||||||
|
|
||||||
|
function g (const i : unit) : int -> int is f
|
||||||
|
|
||||||
|
const r : foo = record [bar = f]
|
||||||
|
|
||||||
|
const x : int = f (42)
|
||||||
|
|
||||||
|
const y : int = r.bar (42)
|
||||||
|
|
||||||
|
const z : int = (g (unit)) (42)
|
||||||
16
src/test/contracts/expected/arithmetic.ligo.expected
Normal file
16
src/test/contracts/expected/arithmetic.ligo.expected
Normal file
@ -0,0 +1,16 @@
|
|||||||
|
function mod_op (const n : int) : nat is n mod 42
|
||||||
|
|
||||||
|
function plus_op (const n : int) : int is n + 42
|
||||||
|
|
||||||
|
function minus_op (const n : int) : int is n - 42
|
||||||
|
|
||||||
|
function times_op (const n : int) : int is n * 42
|
||||||
|
|
||||||
|
function div_op (const n : int) : int is n / 2
|
||||||
|
|
||||||
|
function int_op (const n : nat) : int is int (n)
|
||||||
|
|
||||||
|
function neg_op (const n : int) : int is -n
|
||||||
|
|
||||||
|
function ediv_op (const n : int) : option (int * nat) is
|
||||||
|
ediv (n, 2)
|
||||||
17
src/test/contracts/expected/arithmetic.mligo.expected
Normal file
17
src/test/contracts/expected/arithmetic.mligo.expected
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
let mod_op (n : int) : nat = n mod 42
|
||||||
|
|
||||||
|
let plus_op (n : int) : int = n + 42
|
||||||
|
|
||||||
|
let minus_op (n : int) : int = n - 42
|
||||||
|
|
||||||
|
let times_op (n : int) : int = n * 42
|
||||||
|
|
||||||
|
let div_op (n : int) : int = n / 2
|
||||||
|
|
||||||
|
let neg_op (n : int) : int = -n
|
||||||
|
|
||||||
|
let foo (n : int) : int = n + 10
|
||||||
|
|
||||||
|
let neg_op_2 (b : int) : int = -(foo b)
|
||||||
|
|
||||||
|
let ediv_op (n : int) : (int * nat) option = ediv n 2
|
||||||
17
src/test/contracts/expected/arithmetic.religo.expected
Normal file
17
src/test/contracts/expected/arithmetic.religo.expected
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
let mod_op = (n: int): nat => n mod 42;
|
||||||
|
|
||||||
|
let plus_op = (n: int): int => n + 42;
|
||||||
|
|
||||||
|
let minus_op = (n: int): int => n - 42;
|
||||||
|
|
||||||
|
let times_op = (n: int): int => n * 42;
|
||||||
|
|
||||||
|
let div_op = (n: int): int => n / 2;
|
||||||
|
|
||||||
|
let neg_op = (n: int): int => -n;
|
||||||
|
|
||||||
|
let foo = (n: int): int => n + 10;
|
||||||
|
|
||||||
|
let neg_op_2 = (b: int): int => -foo(b);
|
||||||
|
|
||||||
|
let ediv_op = (n: int): option((int, nat)) => ediv(n, 2);
|
||||||
3
src/test/contracts/expected/assert.mligo.expected
Normal file
3
src/test/contracts/expected/assert.mligo.expected
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
let main (p, s : bool * unit) =
|
||||||
|
let u : unit = assert p
|
||||||
|
in ([] : operation list), s
|
||||||
4
src/test/contracts/expected/assign.ligo.expected
Normal file
4
src/test/contracts/expected/assign.ligo.expected
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
function main (const i : int) : int is
|
||||||
|
block {
|
||||||
|
i := i + 1
|
||||||
|
} with i
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user