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
|
||||
cache/*
|
||||
Version.ml
|
||||
/result
|
||||
/result-*
|
||||
/_opam/
|
||||
/*.pp.ligo
|
||||
/*.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';
|
||||
|
||||
<SyntaxTitle syntax="pascaligo">
|
||||
function and : nat -> nat -> nat
|
||||
function and : 'a -> nat -> nat
|
||||
</SyntaxTitle>
|
||||
<SyntaxTitle syntax="cameligo">
|
||||
val and : nat -> nat -> nat
|
||||
val and : 'a -> nat -> nat
|
||||
</SyntaxTitle>
|
||||
<SyntaxTitle syntax="reasonligo">
|
||||
let and: (nat, nat) => nat
|
||||
let and: ('a, nat) => nat
|
||||
</SyntaxTitle>
|
||||
|
||||
`'a` can either be an `int` or `nat`.
|
||||
|
||||
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">
|
||||
function or : nat -> nat -> nat
|
||||
</SyntaxTitle>
|
||||
@ -32,6 +57,28 @@ let or: (nat, nat) => nat
|
||||
|
||||
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">
|
||||
function xor : nat -> nat -> nat
|
||||
</SyntaxTitle>
|
||||
@ -44,6 +91,28 @@ let xor: (nat, nat) => nat
|
||||
|
||||
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">
|
||||
function shift_left : nat -> nat -> nat
|
||||
</SyntaxTitle>
|
||||
@ -56,6 +125,28 @@ let shift_left: (nat, nat) => nat
|
||||
|
||||
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">
|
||||
function shift_right : nat -> nat -> nat
|
||||
</SyntaxTitle>
|
||||
@ -67,3 +158,25 @@ let shift_right: (nat, nat) => nat
|
||||
</SyntaxTitle>
|
||||
|
||||
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": {
|
||||
"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": {
|
||||
"version": "1.6.5",
|
||||
"resolved": "https://registry.npmjs.org/@mdx-js/mdx/-/mdx-1.6.5.tgz",
|
||||
@ -1621,6 +1635,11 @@
|
||||
"integrity": "sha512-ljr9hGQYW3kZY1NmQbmSe4yXvgq3KDRt0FMBOB5OaDWqi4X2WzEsp6SZ02KmVrieNW1cjWlj13pgvcf0towZPw==",
|
||||
"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": {
|
||||
"version": "2.2.1",
|
||||
"resolved": "https://registry.npmjs.org/@mrmlnc/readdir-enhanced/-/readdir-enhanced-2.2.1.tgz",
|
||||
@ -1859,6 +1878,11 @@
|
||||
"integrity": "sha512-//oorEZjL6sbPcKUaCdIGlIUeH26mgzimjBB77G6XRgnDl/L5wOnpyBGRe/Mmf5CVW3PwEBE1NjiMZ/ssFh4wA==",
|
||||
"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": {
|
||||
"version": "1.5.4",
|
||||
"resolved": "https://registry.npmjs.org/@types/q/-/q-1.5.4.tgz",
|
||||
@ -2516,6 +2540,37 @@
|
||||
"integrity": "sha512-3YDiu347mtVtjpyV3u5kVqQLP242c06zwDOgpeRnybmXlYYsLbtTrUBUm8i8srONt+FWobl5aibnU1030PeeuA==",
|
||||
"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": {
|
||||
"version": "6.26.0",
|
||||
"resolved": "https://registry.npmjs.org/babel-code-frame/-/babel-code-frame-6.26.0.tgz",
|
||||
@ -3418,7 +3473,6 @@
|
||||
"version": "2.0.6",
|
||||
"resolved": "https://registry.npmjs.org/clipboard/-/clipboard-2.0.6.tgz",
|
||||
"integrity": "sha512-g5zbiixBRk/wyKakSwCKd7vQXDjFnAMGHoEyBogG/bw9kTD9GvdAvaoRR1ALcEzt3pVKxZR0pViekPMIS0QyGg==",
|
||||
"dev": true,
|
||||
"requires": {
|
||||
"good-listener": "^1.2.2",
|
||||
"select": "^1.1.2",
|
||||
@ -4419,8 +4473,7 @@
|
||||
"delegate": {
|
||||
"version": "3.2.0",
|
||||
"resolved": "https://registry.npmjs.org/delegate/-/delegate-3.2.0.tgz",
|
||||
"integrity": "sha512-IofjkYBZaZivn0V8nnsMJGBr4jVLxHDheKSW88PyxS5QC4Vo9ZbZVvhzlSxY87fVq3STR6r+4cGepyHkcWOQSw==",
|
||||
"dev": true
|
||||
"integrity": "sha512-IofjkYBZaZivn0V8nnsMJGBr4jVLxHDheKSW88PyxS5QC4Vo9ZbZVvhzlSxY87fVq3STR6r+4cGepyHkcWOQSw=="
|
||||
},
|
||||
"depd": {
|
||||
"version": "1.1.2",
|
||||
@ -5961,7 +6014,6 @@
|
||||
"version": "1.2.2",
|
||||
"resolved": "https://registry.npmjs.org/good-listener/-/good-listener-1.2.2.tgz",
|
||||
"integrity": "sha1-1TswzfkxPf+33JoNR3CWqm0UXFA=",
|
||||
"dev": true,
|
||||
"requires": {
|
||||
"delegate": "^3.1.2"
|
||||
}
|
||||
@ -7367,6 +7419,11 @@
|
||||
"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": {
|
||||
"version": "1.1.6",
|
||||
"resolved": "https://registry.npmjs.org/lines-and-columns/-/lines-and-columns-1.1.6.tgz",
|
||||
@ -10042,14 +10099,12 @@
|
||||
"prism-react-renderer": {
|
||||
"version": "1.1.1",
|
||||
"resolved": "https://registry.npmjs.org/prism-react-renderer/-/prism-react-renderer-1.1.1.tgz",
|
||||
"integrity": "sha512-MgMhSdHuHymNRqD6KM3eGS0PNqgK9q4QF5P0yoQQvpB6jNjeSAi3jcSAz0Sua/t9fa4xDOMar9HJbLa08gl9ug==",
|
||||
"dev": true
|
||||
"integrity": "sha512-MgMhSdHuHymNRqD6KM3eGS0PNqgK9q4QF5P0yoQQvpB6jNjeSAi3jcSAz0Sua/t9fa4xDOMar9HJbLa08gl9ug=="
|
||||
},
|
||||
"prismjs": {
|
||||
"version": "1.20.0",
|
||||
"resolved": "https://registry.npmjs.org/prismjs/-/prismjs-1.20.0.tgz",
|
||||
"integrity": "sha512-AEDjSrVNkynnw6A+B1DsFkd6AVdTnp+/WoUixFRULlCLZVRZlVQMVWio/16jv7G1FscUxQxOQhWwApgbnxr6kQ==",
|
||||
"dev": true,
|
||||
"requires": {
|
||||
"clipboard": "^2.0.0"
|
||||
}
|
||||
@ -10267,6 +10322,14 @@
|
||||
"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": {
|
||||
"version": "10.2.1",
|
||||
"resolved": "https://registry.npmjs.org/react-dev-utils/-/react-dev-utils-10.2.1.tgz",
|
||||
@ -11452,8 +11515,7 @@
|
||||
"select": {
|
||||
"version": "1.1.2",
|
||||
"resolved": "https://registry.npmjs.org/select/-/select-1.1.2.tgz",
|
||||
"integrity": "sha1-DnNQrN7ICxEIUoeG7B1EGNEbOW0=",
|
||||
"dev": true
|
||||
"integrity": "sha1-DnNQrN7ICxEIUoeG7B1EGNEbOW0="
|
||||
},
|
||||
"select-hose": {
|
||||
"version": "2.0.0",
|
||||
@ -12678,8 +12740,7 @@
|
||||
"tiny-emitter": {
|
||||
"version": "2.1.0",
|
||||
"resolved": "https://registry.npmjs.org/tiny-emitter/-/tiny-emitter-2.1.0.tgz",
|
||||
"integrity": "sha512-NB6Dk1A9xgQPMoGqC5CVXn123gWyte215ONT5Pp5a0yt4nlEoO1ZWeCwpncaekPHXO60i47ihFnZPiRPjRMq4Q==",
|
||||
"dev": true
|
||||
"integrity": "sha512-NB6Dk1A9xgQPMoGqC5CVXn123gWyte215ONT5Pp5a0yt4nlEoO1ZWeCwpncaekPHXO60i47ihFnZPiRPjRMq4Q=="
|
||||
},
|
||||
"tiny-invariant": {
|
||||
"version": "1.1.0",
|
||||
@ -14516,8 +14577,7 @@
|
||||
"yaml": {
|
||||
"version": "1.10.0",
|
||||
"resolved": "https://registry.npmjs.org/yaml/-/yaml-1.10.0.tgz",
|
||||
"integrity": "sha512-yr2icI4glYaNG+KWONODapy2/jDdMSDnrONSjblABjD9B4Z5LgiircSt8m8sRZFNi08kG9Sm0uSHtEmP3zaEGg==",
|
||||
"dev": true
|
||||
"integrity": "sha512-yr2icI4glYaNG+KWONODapy2/jDdMSDnrONSjblABjD9B4Z5LgiircSt8m8sRZFNi08kG9Sm0uSHtEmP3zaEGg=="
|
||||
},
|
||||
"yargs": {
|
||||
"version": "13.3.2",
|
||||
|
||||
@ -29,6 +29,10 @@
|
||||
},
|
||||
"dependencies": {
|
||||
"@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 Clipboard from 'clipboard';
|
||||
import rangeParser from 'parse-numeric-range';
|
||||
import useDocusaurusContext from '@docusaurus/useDocusaurusContext';
|
||||
import useThemeContext from '@theme/hooks/useThemeContext';
|
||||
import { LigoSnippet } from '@ligolang/ligo-snippets'
|
||||
|
||||
import styles from './styles.module.css';
|
||||
|
||||
@ -160,6 +162,7 @@ const highlightDirectiveRegex = (lang) => {
|
||||
const codeBlockTitleRegex = /title=".*"/;
|
||||
|
||||
export default ({ children, className: languageClassName, metastring }) => {
|
||||
|
||||
const {
|
||||
siteConfig: {
|
||||
themeConfig: {prism = {}},
|
||||
@ -277,6 +280,34 @@ export default ({children, className: languageClassName, metastring}) => {
|
||||
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 (
|
||||
<Highlight
|
||||
{...defaultProps}
|
||||
|
||||
@ -242,6 +242,10 @@ p {
|
||||
border-top: none;
|
||||
}
|
||||
|
||||
.tabs .tabs__item {
|
||||
outline: 0;
|
||||
}
|
||||
|
||||
.tabs .nav-tabs > div {
|
||||
font-size: 1em;
|
||||
font-weight: normal;
|
||||
|
||||
@ -9,11 +9,12 @@ let
|
||||
inherit (import sources."gitignore.nix" { inherit (self) lib; })
|
||||
gitignoreSource;
|
||||
# Remove list of directories or files from source (to stop unneeded rebuilds)
|
||||
# Also, apply the gitignore here.
|
||||
filterOut = xs:
|
||||
self.lib.cleanSourceWith {
|
||||
gitignoreSource (self.lib.cleanSourceWith {
|
||||
filter = p: type: !(builtins.elem (builtins.baseNameOf p) xs);
|
||||
src = gitignoreSource ../.;
|
||||
};
|
||||
});
|
||||
in {
|
||||
ocamlPackages = self.ocaml-ng.ocamlPackages_4_07.overrideScope'
|
||||
(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
|
||||
(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 f source_file syntax 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)
|
||||
)
|
||||
in
|
||||
@ -489,5 +501,6 @@ let run ?argv () =
|
||||
print_ast_typed ;
|
||||
print_mini_c ;
|
||||
list_declarations ;
|
||||
preprocess
|
||||
preprocess;
|
||||
pretty_print
|
||||
]
|
||||
|
||||
@ -57,6 +57,9 @@ let%expect_test _ =
|
||||
Subcommand: Preprocess the source file. Warning: Intended for
|
||||
development of LIGO and can break at any time.
|
||||
|
||||
pretty-print
|
||||
Subcommand: Pretty-print the source file.
|
||||
|
||||
print-ast
|
||||
Subcommand: Print the AST. Warning: Intended for development of
|
||||
LIGO and can break at any time.
|
||||
@ -148,6 +151,9 @@ let%expect_test _ =
|
||||
Subcommand: Preprocess the source file. Warning: Intended for
|
||||
development of LIGO and can break at any time.
|
||||
|
||||
pretty-print
|
||||
Subcommand: Pretty-print the source file.
|
||||
|
||||
print-ast
|
||||
Subcommand: Print the AST. Warning: Intended for development of
|
||||
LIGO and can break at any time.
|
||||
|
||||
@ -7,7 +7,7 @@ let%expect_test _ =
|
||||
let%expect_test _ =
|
||||
run_ligo_bad ["interpret" ; "(\"thisisnotasignature\":signature)" ; "--syntax=pascaligo"] ;
|
||||
[%expect {|
|
||||
ligo: in file "", line 0, characters 1-32. Badly formatted literal: Signature thisisnotasignature {"location":"in file \"\", line 0, characters 1-32"}
|
||||
ligo: in file "", line 0, characters 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
|
||||
@ -25,7 +25,7 @@ let%expect_test _ =
|
||||
let%expect_test _ =
|
||||
run_ligo_bad ["interpret" ; "(\"thisisnotapublickey\":key)" ; "--syntax=pascaligo"] ;
|
||||
[%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
|
||||
|
||||
@ -129,7 +129,7 @@ let parsify_string syntax source =
|
||||
let%bind applied = Self_ast_imperative.all_program parsified
|
||||
in ok applied
|
||||
|
||||
let pretty_print_pascaligo source =
|
||||
let pretty_print_pascaligo_cst source =
|
||||
let%bind ast = Parser.Pascaligo.parse_file source in
|
||||
let buffer = Buffer.create 59 in
|
||||
let state =
|
||||
@ -137,10 +137,10 @@ let pretty_print_pascaligo source =
|
||||
~offsets:true
|
||||
~mode:`Byte
|
||||
~buffer in
|
||||
Parser_pascaligo.ParserLog.pp_ast state ast;
|
||||
Parser_pascaligo.ParserLog.pp_cst state ast;
|
||||
ok buffer
|
||||
|
||||
let pretty_print_cameligo source =
|
||||
let pretty_print_cameligo_cst source =
|
||||
let%bind ast = Parser.Cameligo.parse_file source in
|
||||
let buffer = Buffer.create 59 in
|
||||
let state = (* TODO: Should flow from the CLI *)
|
||||
@ -148,10 +148,10 @@ let pretty_print_cameligo source =
|
||||
~offsets:true
|
||||
~mode:`Point
|
||||
~buffer in
|
||||
Parser_cameligo.ParserLog.pp_ast state ast;
|
||||
Parser_cameligo.ParserLog.pp_cst state ast;
|
||||
ok buffer
|
||||
|
||||
let pretty_print_reasonligo source =
|
||||
let pretty_print_reasonligo_cst source =
|
||||
let%bind ast = Parser.Reasonligo.parse_file source in
|
||||
let buffer = Buffer.create 59 in
|
||||
let state = (* TODO: Should flow from the CLI *)
|
||||
@ -159,16 +159,16 @@ let pretty_print_reasonligo source =
|
||||
~offsets:true
|
||||
~mode:`Point
|
||||
~buffer in
|
||||
Parser_cameligo.ParserLog.pp_ast state ast;
|
||||
Parser_cameligo.ParserLog.pp_cst state ast;
|
||||
ok buffer
|
||||
|
||||
let pretty_print syntax source =
|
||||
let pretty_print_cst 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
|
||||
PascaLIGO -> pretty_print_pascaligo_cst source
|
||||
| CameLIGO -> pretty_print_cameligo_cst source
|
||||
| ReasonLIGO -> pretty_print_reasonligo_cst source
|
||||
|
||||
let preprocess_pascaligo = Parser.Pascaligo.preprocess
|
||||
|
||||
@ -183,3 +183,44 @@ let preprocess syntax source =
|
||||
PascaLIGO -> preprocess_pascaligo source
|
||||
| CameLIGO -> preprocess_cameligo 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
|
||||
ok @@ Ast_imperative.e_pair storage parameter
|
||||
|
||||
let pretty_print source_filename syntax =
|
||||
Helpers.pretty_print syntax source_filename
|
||||
let pretty_print_cst source_filename syntax =
|
||||
Helpers.pretty_print_cst syntax source_filename
|
||||
|
||||
let preprocess source_filename syntax =
|
||||
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 ParErr = Parser_cameligo.ParErr
|
||||
module SSet = Set.Make (String)
|
||||
module Pretty = Parser_cameligo.Pretty
|
||||
|
||||
(* Mock IOs TODO: Fill them with CLI options *)
|
||||
|
||||
@ -19,7 +20,8 @@ module SubIO =
|
||||
ext : string; (* ".mligo" *)
|
||||
mode : [`Byte | `Point];
|
||||
cmd : EvalOpt.command;
|
||||
mono : bool
|
||||
mono : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
let options : options =
|
||||
@ -34,6 +36,7 @@ module SubIO =
|
||||
method mode = `Point
|
||||
method cmd = EvalOpt.Quiet
|
||||
method mono = false
|
||||
method pretty = false
|
||||
end
|
||||
|
||||
let make =
|
||||
@ -46,6 +49,7 @@ module SubIO =
|
||||
~mode:options#mode
|
||||
~cmd:options#cmd
|
||||
~mono:options#mono
|
||||
~pretty:options#mono
|
||||
end
|
||||
|
||||
module Parser =
|
||||
@ -146,3 +150,18 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
|
||||
(* Preprocessing a contract in a file *)
|
||||
|
||||
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. *)
|
||||
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/ParserUnit.mli
|
||||
../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 declaration =
|
||||
Let of (kwd_let * kwd_rec option * let_binding * attributes) reg
|
||||
Let of let_decl
|
||||
| TypeDecl of type_decl reg
|
||||
|
||||
(* Non-recursive values *)
|
||||
|
||||
and let_decl =
|
||||
(kwd_let * kwd_rec option * let_binding * attributes) reg
|
||||
|
||||
and let_binding = {
|
||||
binders : pattern nseq;
|
||||
lhs_type : (colon * type_expr) option;
|
||||
@ -225,7 +228,7 @@ and field_pattern = {
|
||||
and expr =
|
||||
ECase of expr case reg
|
||||
| ECond of cond_expr reg
|
||||
| EAnnot of (expr * colon * type_expr) par reg
|
||||
| EAnnot of annot_expr par reg
|
||||
| ELogic of logic_expr
|
||||
| EArith of arith_expr
|
||||
| EString of string_expr
|
||||
@ -244,6 +247,8 @@ and expr =
|
||||
| EFun of fun_expr reg
|
||||
| ESeq of expr injection reg
|
||||
|
||||
and annot_expr = expr * colon * type_expr
|
||||
|
||||
and 'a injection = {
|
||||
compound : compound;
|
||||
elements : ('a, semi) sepseq;
|
||||
@ -339,15 +344,16 @@ and update = {
|
||||
lbrace : lbrace;
|
||||
record : path;
|
||||
kwd_with : kwd_with;
|
||||
updates : field_path_assign reg ne_injection reg;
|
||||
rbrace : rbrace;
|
||||
updates : field_path_assignment reg ne_injection reg;
|
||||
rbrace : rbrace
|
||||
}
|
||||
|
||||
and field_path_assign = {
|
||||
field_path : (field_name, dot) nsepseq;
|
||||
and field_path_assignment = {
|
||||
field_path : path;
|
||||
assignment : equal;
|
||||
field_expr : expr
|
||||
}
|
||||
|
||||
and path =
|
||||
Name of variable
|
||||
| Path of projection reg
|
||||
|
||||
@ -431,7 +431,7 @@ type nat_err =
|
||||
| Non_canonical_zero_nat
|
||||
|
||||
let mk_nat lexeme region =
|
||||
match (String.index_opt lexeme 'n') with
|
||||
match String.index_opt lexeme 'n' with
|
||||
None -> Error Invalid_natural
|
||||
| Some _ -> let z =
|
||||
Str.(global_replace (regexp "_") "" lexeme) |>
|
||||
@ -442,8 +442,7 @@ let mk_nat lexeme region =
|
||||
else Ok (Nat Region.{region; value = lexeme,z})
|
||||
|
||||
let mk_mutez lexeme region =
|
||||
let z =
|
||||
Str.(global_replace (regexp "_") "" lexeme) |>
|
||||
let z = Str.(global_replace (regexp "_") "" lexeme) |>
|
||||
Str.(global_replace (regexp "mutez") "") |>
|
||||
Z.of_string in
|
||||
if Z.equal z Z.zero && lexeme <> "0mutez"
|
||||
|
||||
@ -236,10 +236,7 @@ type_annotation:
|
||||
irrefutable:
|
||||
sub_irrefutable { $1 }
|
||||
| tuple(sub_irrefutable) {
|
||||
let hd, tl = $1 in
|
||||
let start = pattern_to_region hd in
|
||||
let stop = last fst tl in
|
||||
let region = cover start stop
|
||||
let region = nsepseq_to_region pattern_to_region $1
|
||||
in PTuple {region; value=$1} }
|
||||
|
||||
sub_irrefutable:
|
||||
@ -276,9 +273,7 @@ pattern:
|
||||
PList (PCons {region; value=$1,$2,$3})
|
||||
}
|
||||
| tuple(sub_pattern) {
|
||||
let start = pattern_to_region (fst $1) in
|
||||
let stop = last fst (snd $1) in
|
||||
let region = cover start stop
|
||||
let region = nsepseq_to_region pattern_to_region $1
|
||||
in PTuple {region; value=$1} }
|
||||
|
||||
sub_pattern:
|
||||
@ -333,10 +328,7 @@ constr_pattern:
|
||||
|
||||
ptuple:
|
||||
tuple(tail) {
|
||||
let hd, tl = $1 in
|
||||
let start = pattern_to_region hd in
|
||||
let stop = last fst tl in
|
||||
let region = cover start stop
|
||||
let region = nsepseq_to_region pattern_to_region $1
|
||||
in PTuple {region; value=$1} }
|
||||
|
||||
unit:
|
||||
@ -372,9 +364,7 @@ base_expr(right_expr):
|
||||
|
||||
tuple_expr:
|
||||
tuple(disj_expr_level) {
|
||||
let start = expr_to_region (fst $1) in
|
||||
let stop = last fst (snd $1) in
|
||||
let region = cover start stop
|
||||
let region = nsepseq_to_region expr_to_region $1
|
||||
in ETuple {region; value=$1} }
|
||||
|
||||
conditional(right_expr):
|
||||
@ -534,8 +524,7 @@ mult_expr_level:
|
||||
| unary_expr_level { $1 }
|
||||
|
||||
unary_expr_level:
|
||||
call_expr_level { $1 }
|
||||
| "-" call_expr_level {
|
||||
"-" call_expr_level {
|
||||
let start = $1 in
|
||||
let stop = expr_to_region $2 in
|
||||
let region = cover start stop
|
||||
@ -547,7 +536,9 @@ unary_expr_level:
|
||||
let stop = expr_to_region $2 in
|
||||
let region = cover start stop
|
||||
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 | constr_expr | core_expr { $1 }
|
||||
@ -593,7 +584,10 @@ core_expr:
|
||||
| record_expr { ERecord $1 }
|
||||
| update_record { EUpdate $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_name "." module_fun {
|
||||
@ -642,7 +636,7 @@ update_record:
|
||||
lbrace = $1;
|
||||
record = $2;
|
||||
kwd_with = $3;
|
||||
updates = {value = {compound = Braces($1,$5);
|
||||
updates = {value = {compound = Braces (ghost, ghost);
|
||||
ne_elements;
|
||||
terminator};
|
||||
region = cover $3 $5};
|
||||
@ -650,20 +644,15 @@ update_record:
|
||||
in {region; value} }
|
||||
|
||||
field_path_assignment :
|
||||
nsepseq(field_name,".") "=" expr {
|
||||
let start = nsepseq_to_region (fun x -> x.region) $1 in
|
||||
let region = cover start (expr_to_region $3) in
|
||||
let value = {field_path = $1;
|
||||
assignment = $2;
|
||||
field_expr = $3}
|
||||
path "=" expr {
|
||||
let region = cover (path_to_region $1) (expr_to_region $3)
|
||||
and value = {field_path=$1; assignment=$2; field_expr=$3}
|
||||
in {region; value} }
|
||||
|
||||
field_assignment:
|
||||
field_name "=" expr {
|
||||
let start = $1.region in
|
||||
let stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
let value = {field_name = $1;
|
||||
let region = cover $1.region (expr_to_region $3)
|
||||
and value = {field_name = $1;
|
||||
assignment = $2;
|
||||
field_expr = $3}
|
||||
in {region; value} }
|
||||
|
||||
@ -136,11 +136,10 @@ let rec print_tokens state {decl;eof} =
|
||||
print_token state eof "EOF"
|
||||
|
||||
and print_attributes state attributes =
|
||||
List.iter (
|
||||
fun ({value = attribute; region}) ->
|
||||
let apply {value = attribute; region} =
|
||||
let attribute_formatted = sprintf "[@@%s]" attribute in
|
||||
print_token state region attribute_formatted
|
||||
) attributes
|
||||
in List.iter apply attributes
|
||||
|
||||
and print_statement state = function
|
||||
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; _} =
|
||||
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_expr state field_expr
|
||||
|
||||
@ -616,12 +615,20 @@ let pp_node state name =
|
||||
let node = sprintf "%s%s\n" state#pad_path name
|
||||
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 =
|
||||
pp_ident state {value=name; region}
|
||||
|
||||
let rec pp_ast state {decl; _} =
|
||||
let rec pp_cst state {decl; _} =
|
||||
let apply len rank =
|
||||
pp_declaration (state#pad len rank) 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
|
||||
| PVerbatim v ->
|
||||
pp_node state "PVerbatim";
|
||||
pp_string (state#pad 1 0) v
|
||||
pp_verbatim (state#pad 1 0) v
|
||||
| PUnit {region; _} ->
|
||||
pp_loc_node state "PUnit" region
|
||||
| PFalse region ->
|
||||
@ -938,7 +945,7 @@ and pp_projection state proj =
|
||||
List.iteri (apply len) selections
|
||||
|
||||
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
|
||||
|
||||
and pp_path state = function
|
||||
@ -963,10 +970,10 @@ and pp_field_assign state {value; _} =
|
||||
pp_expr (state#pad 2 1) value.field_expr
|
||||
|
||||
and pp_field_path_assign state {value; _} =
|
||||
pp_node state "<field path for update>";
|
||||
let path = Utils.nsepseq_to_list value.field_path in
|
||||
List.iter (pp_ident (state#pad 2 0)) path;
|
||||
pp_expr (state#pad 2 1) value.field_expr
|
||||
let {field_path; field_expr; _} = value in
|
||||
pp_node state "<update>";
|
||||
pp_path (state#pad 2 0) field_path;
|
||||
pp_expr (state#pad 2 1) field_expr
|
||||
|
||||
and pp_constr_expr state = function
|
||||
ENone region ->
|
||||
@ -987,11 +994,11 @@ and pp_constr_app_expr state (constr, expr_opt) =
|
||||
|
||||
and pp_list_expr state = function
|
||||
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 1) value.arg2
|
||||
| EListComp {value; region} ->
|
||||
pp_loc_node state "List" region;
|
||||
pp_loc_node state "EListComp" region;
|
||||
if value.elements = None
|
||||
then pp_node (state#pad 1 0) "<nil>"
|
||||
else pp_injection pp_expr state value
|
||||
|
||||
@ -27,5 +27,5 @@ val expr_to_string :
|
||||
|
||||
(** {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
|
||||
|
||||
@ -22,7 +22,8 @@ module SubIO =
|
||||
ext : string;
|
||||
mode : [`Byte | `Point];
|
||||
cmd : EvalOpt.command;
|
||||
mono : bool
|
||||
mono : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
let options : options =
|
||||
@ -36,6 +37,7 @@ module SubIO =
|
||||
method mode = IO.options#mode
|
||||
method cmd = IO.options#cmd
|
||||
method mono = IO.options#mono
|
||||
method pretty = IO.options#pretty
|
||||
end
|
||||
|
||||
let make =
|
||||
@ -48,6 +50,7 @@ module SubIO =
|
||||
~mode:options#mode
|
||||
~cmd:options#cmd
|
||||
~mono:options#mono
|
||||
~pretty:options#pretty
|
||||
end
|
||||
|
||||
module Parser =
|
||||
@ -67,14 +70,28 @@ module ParserLog =
|
||||
module Lexer = Lexer.Make (LexToken)
|
||||
|
||||
module Unit =
|
||||
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
|
||||
ParserUnit.Make (Lexer)(AST)(Parser)(Parser_msg)(ParserLog)(SubIO)
|
||||
|
||||
(* Main *)
|
||||
|
||||
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 ->
|
||||
(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 () =
|
||||
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}}
|
||||
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 patch_ (m : foobar) : foobar = Map.literal [(0, 5); (1, 6); (2, 7)]
|
||||
|
||||
let x = 4
|
||||
let y : t = (if true then -3 + f x x else 0) - 1
|
||||
let f (x: int) y = (x : int)
|
||||
let (greet_num : int), (greeting : string), one_more_component =
|
||||
different_types of_many_things + ffffff 124312
|
||||
|
||||
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 w =
|
||||
match f 3 with
|
||||
None -> []
|
||||
| Some (1::[2;3]) -> [4;5]::[]
|
||||
let f (xxxxxxxxxxx: tttttttttttttt) y = (xxxxxxxxxxxx : tttttttttttttttttt)
|
||||
let n : nat = 0n
|
||||
let a = A
|
||||
let b = B a
|
||||
let c = C (a, B (a))
|
||||
let d = None
|
||||
let e = Some (a, B b)
|
||||
let z = z.1.2
|
||||
let v = "hello" ^ "world" ^ "!"
|
||||
let w = Map.literal [(1,"1"); (2,"2")]
|
||||
|
||||
let r = { field = 0}
|
||||
let r = { r with field = 42}
|
||||
let z = let v = "hello" ^ "world" ^ "!" in v
|
||||
let r = { field = 0; another = 11111111111111111; and_another_one = "dddddd"}
|
||||
let r = { r with field = 42; another = 11111111111111111; and_another_one = "dddddddddddddddddddddd"}
|
||||
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 y : t = (if true then -30000000000000 + f x x y y y y else 10000000000000000000) - 1
|
||||
let w =
|
||||
match f 3 with
|
||||
None -> []
|
||||
| Some (1::[2;3;4;5;6]) -> [4;5]::[]
|
||||
|
||||
@ -15,8 +15,10 @@
|
||||
(name parser_cameligo)
|
||||
(public_name ligo.parser.cameligo)
|
||||
(modules
|
||||
Scoping AST cameligo Parser ParserLog LexToken ParErr)
|
||||
Scoping AST cameligo Parser ParserLog LexToken ParErr Pretty)
|
||||
(libraries
|
||||
pprint
|
||||
terminal_size
|
||||
menhirLib
|
||||
parser_shared
|
||||
str
|
||||
@ -26,8 +28,8 @@
|
||||
(pps bisect_ppx --conditional))
|
||||
(flags (:standard -open Parser_shared -open Simple_utils)))
|
||||
|
||||
;; Build of the unlexer (for covering the
|
||||
;; error states of the LR automaton)
|
||||
;; Build of the unlexer (for covering the error states of the LR
|
||||
;; automaton)
|
||||
|
||||
(executable
|
||||
(name Unlexer)
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -19,7 +19,8 @@ module SubIO =
|
||||
ext : string; (* ".ligo" *)
|
||||
mode : [`Byte | `Point];
|
||||
cmd : EvalOpt.command;
|
||||
mono : bool
|
||||
mono : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
let options : options =
|
||||
@ -34,6 +35,7 @@ module SubIO =
|
||||
method mode = `Point
|
||||
method cmd = EvalOpt.Quiet
|
||||
method mono = false
|
||||
method pretty = false
|
||||
end
|
||||
|
||||
let make =
|
||||
@ -46,6 +48,7 @@ module SubIO =
|
||||
~mode:options#mode
|
||||
~cmd:options#cmd
|
||||
~mono:options#mono
|
||||
~pretty:options#pretty
|
||||
end
|
||||
|
||||
module Parser =
|
||||
|
||||
@ -21,5 +21,3 @@ $HOME/git/OCaml-build/Makefile
|
||||
../shared/ParserUnit.mli
|
||||
../shared/ParserUnit.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 fun_name = string reg
|
||||
type type_name = string reg
|
||||
type type_constr = string reg
|
||||
type field_name = string reg
|
||||
type map_name = string reg
|
||||
type set_name = string reg
|
||||
@ -181,11 +182,11 @@ and type_expr =
|
||||
TProd of cartesian
|
||||
| TSum of (variant reg, vbar) nsepseq 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
|
||||
| TPar of type_expr par reg
|
||||
| TVar of variable
|
||||
| TStringLiteral of Lexer.lexeme reg
|
||||
| TString of Lexer.lexeme 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 *)
|
||||
|
||||
and fun_expr = {
|
||||
kwd_recursive: kwd_recursive option;
|
||||
kwd_function : kwd_function;
|
||||
param : parameters;
|
||||
colon : colon;
|
||||
@ -249,19 +249,14 @@ and param_var = {
|
||||
}
|
||||
|
||||
and block = {
|
||||
opening : block_opening;
|
||||
enclosing : block_enclosing;
|
||||
statements : statements;
|
||||
terminator : semi option;
|
||||
closing : block_closing
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and block_opening =
|
||||
Block of kwd_block * lbrace
|
||||
| Begin of kwd_begin
|
||||
|
||||
and block_closing =
|
||||
Block of rbrace
|
||||
| End of kwd_end
|
||||
and block_enclosing =
|
||||
Block of kwd_block * lbrace * rbrace
|
||||
| BeginEnd of kwd_begin * kwd_end
|
||||
|
||||
and statements = (statement, semi) nsepseq
|
||||
|
||||
@ -378,10 +373,10 @@ and set_membership = {
|
||||
and 'a case = {
|
||||
kwd_case : kwd_case;
|
||||
expr : expr;
|
||||
opening : opening;
|
||||
kwd_of : kwd_of;
|
||||
enclosing : enclosing;
|
||||
lead_vbar : vbar option;
|
||||
cases : ('a case_clause reg, vbar) nsepseq reg;
|
||||
closing : closing
|
||||
cases : ('a case_clause reg, vbar) nsepseq reg
|
||||
}
|
||||
|
||||
and 'a case_clause = {
|
||||
@ -421,8 +416,7 @@ and for_int = {
|
||||
assign : var_assign reg;
|
||||
kwd_to : kwd_to;
|
||||
bound : expr;
|
||||
kwd_step : kwd_step option;
|
||||
step : expr option;
|
||||
step : (kwd_step * expr) option;
|
||||
block : block reg
|
||||
}
|
||||
|
||||
@ -452,7 +446,7 @@ and collection =
|
||||
and expr =
|
||||
ECase of expr case reg
|
||||
| ECond of cond_expr reg
|
||||
| EAnnot of annot_expr reg
|
||||
| EAnnot of annot_expr par reg
|
||||
| ELogic of logic_expr
|
||||
| EArith of arith_expr
|
||||
| EString of string_expr
|
||||
@ -471,34 +465,12 @@ and expr =
|
||||
| EPar of expr par reg
|
||||
| EFun of fun_expr reg
|
||||
|
||||
and annot_expr = (expr * type_expr)
|
||||
and annot_expr = expr * colon * type_expr
|
||||
|
||||
and set_expr =
|
||||
SetInj of expr injection 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 =
|
||||
MapLookUp of map_lookup reg
|
||||
| MapInj of binding reg injection reg
|
||||
@ -569,13 +541,13 @@ and constr_expr =
|
||||
| NoneExpr of c_None
|
||||
| ConstrApp of (constr * arguments option) reg
|
||||
|
||||
and field_assign = {
|
||||
and field_assignment = {
|
||||
field_name : field_name;
|
||||
equal : equal;
|
||||
assignment : equal;
|
||||
field_expr : expr
|
||||
}
|
||||
|
||||
and record = field_assign reg ne_injection
|
||||
and record = field_assignment reg ne_injection
|
||||
|
||||
and projection = {
|
||||
struct_name : variable;
|
||||
@ -586,12 +558,12 @@ and projection = {
|
||||
and update = {
|
||||
record : path;
|
||||
kwd_with : kwd_with;
|
||||
updates : field_path_assign reg ne_injection reg
|
||||
updates : field_path_assignment reg ne_injection reg
|
||||
}
|
||||
|
||||
and field_path_assign = {
|
||||
field_path : (field_name, dot) nsepseq;
|
||||
equal : equal;
|
||||
and field_path_assignment = {
|
||||
field_path : path;
|
||||
assignment : equal;
|
||||
field_expr : expr
|
||||
}
|
||||
|
||||
@ -605,6 +577,38 @@ and fun_call = (expr * arguments) reg
|
||||
|
||||
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 *)
|
||||
|
||||
and pattern =
|
||||
@ -635,7 +639,7 @@ and list_pattern =
|
||||
| PCons of (pattern, cons) nsepseq reg
|
||||
|
||||
|
||||
(* Projecting regions *)
|
||||
(* PROJECTING REGIONS *)
|
||||
|
||||
let rec last to_region = function
|
||||
[] -> Region.ghost
|
||||
@ -660,7 +664,7 @@ let type_expr_to_region = function
|
||||
| TApp {region; _}
|
||||
| TFun {region; _}
|
||||
| TPar {region; _}
|
||||
| TStringLiteral {region; _}
|
||||
| TString {region; _}
|
||||
| TVar {region; _} -> region
|
||||
|
||||
let rec expr_to_region = function
|
||||
|
||||
@ -122,7 +122,8 @@ attr_decl:
|
||||
open_attr_decl ";"? { $1 }
|
||||
|
||||
open_attr_decl:
|
||||
ne_injection("attributes","<string>") { $1 }
|
||||
ne_injection("attributes","<string>") {
|
||||
$1 (fun region -> NEInjAttr region) }
|
||||
|
||||
(* Type declarations *)
|
||||
|
||||
@ -161,7 +162,7 @@ cartesian:
|
||||
|
||||
core_type:
|
||||
type_name { TVar $1 }
|
||||
| "<string>" { TStringLiteral $1 }
|
||||
| "<string>" { TString $1 }
|
||||
| par(type_expr) { TPar $1 }
|
||||
| type_name type_tuple {
|
||||
let region = cover $1.region $2.region
|
||||
@ -214,19 +215,19 @@ record_type:
|
||||
let () = Utils.nsepseq_to_list ne_elements
|
||||
|> Scoping.check_fields in
|
||||
let region = cover $1 $3
|
||||
and value = {opening = Kwd $1;
|
||||
and value = {kind = NEInjRecord $1;
|
||||
enclosing = End $3;
|
||||
ne_elements;
|
||||
terminator;
|
||||
closing = End $3}
|
||||
terminator}
|
||||
in TRecord {region; value}
|
||||
}
|
||||
| "record" "[" sep_or_term_list(field_decl,";") "]" {
|
||||
let ne_elements, terminator = $3 in
|
||||
let region = cover $1 $4
|
||||
and value = {opening = KwdBracket ($1,$2);
|
||||
and value = {kind = NEInjRecord $1;
|
||||
enclosing = Brackets ($2,$4);
|
||||
ne_elements;
|
||||
terminator;
|
||||
closing = RBracket $4}
|
||||
terminator}
|
||||
in TRecord {region; value} }
|
||||
|
||||
field_decl:
|
||||
@ -238,16 +239,15 @@ field_decl:
|
||||
|
||||
|
||||
fun_expr:
|
||||
| ioption ("recursive") "function" parameters ":" type_expr "is" expr {
|
||||
let stop = expr_to_region $7 in
|
||||
let region = cover $2 stop
|
||||
and value = {kwd_recursive= $1;
|
||||
kwd_function = $2;
|
||||
param = $3;
|
||||
colon = $4;
|
||||
ret_type = $5;
|
||||
kwd_is = $6;
|
||||
return = $7}
|
||||
"function" parameters ":" type_expr "is" expr {
|
||||
let stop = expr_to_region $6 in
|
||||
let region = cover $1 stop
|
||||
and value = {kwd_function = $1;
|
||||
param = $2;
|
||||
colon = $3;
|
||||
ret_type = $4;
|
||||
kwd_is = $5;
|
||||
return = $6}
|
||||
in {region; value} }
|
||||
|
||||
(* Function declarations *)
|
||||
@ -271,7 +271,8 @@ open_fun_decl:
|
||||
attributes = None}
|
||||
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;
|
||||
let stop = expr_to_region $8 in
|
||||
let region = cover $2 stop
|
||||
@ -326,19 +327,17 @@ block:
|
||||
"begin" sep_or_term_list(statement,";") "end" {
|
||||
let statements, terminator = $2 in
|
||||
let region = cover $1 $3
|
||||
and value = {opening = Begin $1;
|
||||
and value = {enclosing = BeginEnd ($1,$3);
|
||||
statements;
|
||||
terminator;
|
||||
closing = End $3}
|
||||
terminator}
|
||||
in {region; value}
|
||||
}
|
||||
| "block" "{" sep_or_term_list(statement,";") "}" {
|
||||
let statements, terminator = $3 in
|
||||
let region = cover $1 $4
|
||||
and value = {opening = Block ($1,$2);
|
||||
and value = {enclosing = Block ($1,$2,$4);
|
||||
statements;
|
||||
terminator;
|
||||
closing = Block $4}
|
||||
terminator}
|
||||
in {region; value} }
|
||||
|
||||
statement:
|
||||
@ -404,8 +403,7 @@ instruction:
|
||||
set_remove:
|
||||
"remove" expr "from" "set" path {
|
||||
let region = cover $1 (path_to_region $5) in
|
||||
let value = {
|
||||
kwd_remove = $1;
|
||||
let value = {kwd_remove = $1;
|
||||
element = $2;
|
||||
kwd_from = $3;
|
||||
kwd_set = $4;
|
||||
@ -415,8 +413,7 @@ set_remove:
|
||||
map_remove:
|
||||
"remove" expr "from" "map" path {
|
||||
let region = cover $1 (path_to_region $5) in
|
||||
let value = {
|
||||
kwd_remove = $1;
|
||||
let value = {kwd_remove = $1;
|
||||
key = $2;
|
||||
kwd_from = $3;
|
||||
kwd_map = $4;
|
||||
@ -425,82 +422,83 @@ map_remove:
|
||||
|
||||
set_patch:
|
||||
"patch" path "with" ne_injection("set",expr) {
|
||||
let region = cover $1 $4.region in
|
||||
let value = {
|
||||
kwd_patch = $1;
|
||||
let set_inj = $4 (fun region -> NEInjSet region) in
|
||||
let region = cover $1 set_inj.region in
|
||||
let value = {kwd_patch = $1;
|
||||
path = $2;
|
||||
kwd_with = $3;
|
||||
set_inj = $4}
|
||||
set_inj}
|
||||
in {region; value} }
|
||||
|
||||
map_patch:
|
||||
"patch" path "with" ne_injection("map",binding) {
|
||||
let region = cover $1 $4.region in
|
||||
let value = {
|
||||
kwd_patch = $1;
|
||||
let map_inj = $4 (fun region -> NEInjMap region) in
|
||||
let region = cover $1 map_inj.region in
|
||||
let value = {kwd_patch = $1;
|
||||
path = $2;
|
||||
kwd_with = $3;
|
||||
map_inj = $4}
|
||||
map_inj}
|
||||
in {region; value} }
|
||||
|
||||
injection(Kind,element):
|
||||
Kind sep_or_term_list(element,";") "end" {
|
||||
fun mk_kwd ->
|
||||
let elements, terminator = $2 in
|
||||
let region = cover $1 $3
|
||||
and value = {
|
||||
opening = Kwd $1;
|
||||
kind = mk_kwd $1;
|
||||
enclosing = End $3;
|
||||
elements = Some elements;
|
||||
terminator;
|
||||
closing = End $3}
|
||||
terminator}
|
||||
in {region; value}
|
||||
}
|
||||
| Kind "end" {
|
||||
fun mk_kwd ->
|
||||
let region = cover $1 $2
|
||||
and value = {
|
||||
opening = Kwd $1;
|
||||
and value = {kind = mk_kwd $1;
|
||||
enclosing = End $2;
|
||||
elements = None;
|
||||
terminator = None;
|
||||
closing = End $2}
|
||||
terminator = None}
|
||||
in {region; value}
|
||||
}
|
||||
| Kind "[" sep_or_term_list(element,";") "]" {
|
||||
fun mk_kwd ->
|
||||
let elements, terminator = $3 in
|
||||
let region = cover $1 $4
|
||||
and value = {
|
||||
opening = KwdBracket ($1,$2);
|
||||
and value = {kind = mk_kwd $1;
|
||||
enclosing = Brackets ($2,$4);
|
||||
elements = Some elements;
|
||||
terminator;
|
||||
closing = RBracket $4}
|
||||
terminator}
|
||||
in {region; value}
|
||||
}
|
||||
| Kind "[" "]" {
|
||||
fun mk_kwd ->
|
||||
let region = cover $1 $3
|
||||
and value = {
|
||||
opening = KwdBracket ($1,$2);
|
||||
and value = {kind = mk_kwd $1;
|
||||
enclosing = Brackets ($2,$3);
|
||||
elements = None;
|
||||
terminator = None;
|
||||
closing = RBracket $3}
|
||||
terminator = None}
|
||||
in {region; value} }
|
||||
|
||||
ne_injection(Kind,element):
|
||||
Kind sep_or_term_list(element,";") "end" {
|
||||
fun mk_kwd ->
|
||||
let ne_elements, terminator = $2 in
|
||||
let region = cover $1 $3
|
||||
and value = {
|
||||
opening = Kwd $1;
|
||||
and value = {kind = mk_kwd $1;
|
||||
enclosing = End $3;
|
||||
ne_elements;
|
||||
terminator;
|
||||
closing = End $3}
|
||||
terminator}
|
||||
in {region; value}
|
||||
}
|
||||
| Kind "[" sep_or_term_list(element,";") "]" {
|
||||
fun mk_kwd ->
|
||||
let ne_elements, terminator = $3 in
|
||||
let region = cover $1 $4
|
||||
and value = {
|
||||
opening = KwdBracket ($1,$2);
|
||||
and value = {kind = mk_kwd $1;
|
||||
enclosing = Brackets ($2,$4);
|
||||
ne_elements;
|
||||
terminator;
|
||||
closing = RBracket $4}
|
||||
terminator}
|
||||
in {region; value} }
|
||||
|
||||
binding:
|
||||
@ -508,20 +506,19 @@ binding:
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop
|
||||
and value = {
|
||||
source = $1;
|
||||
and value = {source = $1;
|
||||
arrow = $2;
|
||||
image = $3}
|
||||
in {region; value} }
|
||||
|
||||
record_patch:
|
||||
"patch" path "with" ne_injection("record",field_assignment) {
|
||||
let region = cover $1 $4.region in
|
||||
let value = {
|
||||
kwd_patch = $1;
|
||||
let record_inj = $4 (fun region -> NEInjRecord region) in
|
||||
let region = cover $1 record_inj.region in
|
||||
let value = {kwd_patch = $1;
|
||||
path = $2;
|
||||
kwd_with = $3;
|
||||
record_inj = $4}
|
||||
record_inj}
|
||||
in {region; value} }
|
||||
|
||||
proc_call:
|
||||
@ -547,12 +544,9 @@ if_clause:
|
||||
clause_block:
|
||||
block { LongBlock $1 }
|
||||
| "{" sep_or_term_list(statement,";") "}" {
|
||||
let statements, terminator = $2 in
|
||||
let region = cover $1 $3 in
|
||||
let value = {lbrace = $1;
|
||||
inside = statements, terminator;
|
||||
rbrace = $3} in
|
||||
ShortBlock {value; region} }
|
||||
let value = {lbrace=$1; inside=$2; rbrace=$3}
|
||||
in ShortBlock {value; region} }
|
||||
|
||||
case_instr:
|
||||
case(if_clause) { $1 if_clause_to_region }
|
||||
@ -563,10 +557,10 @@ case(rhs):
|
||||
let region = cover $1 $6 in
|
||||
let value = {kwd_case = $1;
|
||||
expr = $2;
|
||||
opening = Kwd $3;
|
||||
kwd_of = $3;
|
||||
enclosing = End $6;
|
||||
lead_vbar = $4;
|
||||
cases = $5 rhs_to_region;
|
||||
closing = End $6}
|
||||
cases = $5 rhs_to_region}
|
||||
in {region; value}
|
||||
}
|
||||
| "case" expr "of" "[" "|"? cases(rhs) "]" {
|
||||
@ -574,10 +568,10 @@ case(rhs):
|
||||
let region = cover $1 $7 in
|
||||
let value = {kwd_case = $1;
|
||||
expr = $2;
|
||||
opening = KwdBracket ($3,$4);
|
||||
kwd_of = $3;
|
||||
enclosing = Brackets ($4,$7);
|
||||
lead_vbar = $5;
|
||||
cases = $6 rhs_to_region;
|
||||
closing = RBracket $7}
|
||||
cases = $6 rhs_to_region}
|
||||
in {region; value} }
|
||||
|
||||
cases(rhs):
|
||||
@ -628,7 +622,6 @@ for_loop:
|
||||
assign = $2;
|
||||
kwd_to = $3;
|
||||
bound = $4;
|
||||
kwd_step = None;
|
||||
step = None;
|
||||
block = $5}
|
||||
in For (ForInt {region; value})
|
||||
@ -639,8 +632,7 @@ for_loop:
|
||||
assign = $2;
|
||||
kwd_to = $3;
|
||||
bound = $4;
|
||||
kwd_step = Some $5;
|
||||
step = Some $6;
|
||||
step = Some ($5, $6);
|
||||
block = $7}
|
||||
in For (ForInt {region; value})
|
||||
}
|
||||
@ -854,7 +846,7 @@ core_expr:
|
||||
| "False" { ELogic (BoolExpr (False $1)) }
|
||||
| "True" { ELogic (BoolExpr (True $1)) }
|
||||
| "Unit" { EUnit $1 }
|
||||
| annot_expr { EAnnot $1 }
|
||||
| par(annot_expr) { EAnnot $1 }
|
||||
| tuple_expr { ETuple $1 }
|
||||
| list_expr { EList $1 }
|
||||
| "None" { EConstr (NoneExpr $1) }
|
||||
@ -896,20 +888,20 @@ fun_call_or_par_or_projection:
|
||||
| fun_call { ECall $1 }
|
||||
|
||||
annot_expr:
|
||||
"(" disj_expr ":" type_expr ")" {
|
||||
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} }
|
||||
disj_expr ":" type_expr { $1,$2,$3 }
|
||||
|
||||
set_expr:
|
||||
injection("set",expr) { SetInj $1 }
|
||||
injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) }
|
||||
|
||||
map_expr:
|
||||
map_lookup { MapLookUp $1 }
|
||||
| injection("map",binding) { MapInj $1 }
|
||||
| injection("big_map",binding) { BigMapInj $1 }
|
||||
map_lookup {
|
||||
MapLookUp $1
|
||||
}
|
||||
| injection("map",binding) {
|
||||
MapInj ($1 (fun region -> InjMap region))
|
||||
}
|
||||
| injection("big_map",binding) {
|
||||
BigMapInj ($1 (fun region -> InjBigMap region)) }
|
||||
|
||||
map_lookup:
|
||||
path brackets(expr) {
|
||||
@ -957,41 +949,40 @@ record_expr:
|
||||
"record" sep_or_term_list(field_assignment,";") "end" {
|
||||
let ne_elements, terminator = $2 in
|
||||
let region = cover $1 $3
|
||||
and value : field_assign AST.reg ne_injection = {
|
||||
opening = Kwd $1;
|
||||
and value : field_assignment AST.reg ne_injection = {
|
||||
kind = NEInjRecord $1;
|
||||
enclosing = End $3;
|
||||
ne_elements;
|
||||
terminator;
|
||||
closing = End $3}
|
||||
terminator}
|
||||
in {region; value}
|
||||
}
|
||||
| "record" "[" sep_or_term_list(field_assignment,";") "]" {
|
||||
let ne_elements, terminator = $3 in
|
||||
let region = cover $1 $4
|
||||
and value : field_assign AST.reg ne_injection = {
|
||||
opening = KwdBracket ($1,$2);
|
||||
and value : field_assignment AST.reg ne_injection = {
|
||||
kind = NEInjRecord $1;
|
||||
enclosing = Brackets ($2,$4);
|
||||
ne_elements;
|
||||
terminator;
|
||||
closing = RBracket $4}
|
||||
terminator}
|
||||
in {region; value} }
|
||||
|
||||
update_record:
|
||||
path "with" ne_injection("record",field_path_assignment) {
|
||||
let region = cover (path_to_region $1) $3.region in
|
||||
let value = {record=$1; kwd_with=$2; updates=$3}
|
||||
let updates = $3 (fun region -> NEInjRecord region) in
|
||||
let region = cover (path_to_region $1) updates.region in
|
||||
let value = {record=$1; kwd_with=$2; updates}
|
||||
in {region; value} }
|
||||
|
||||
field_assignment:
|
||||
field_name "=" expr {
|
||||
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} }
|
||||
|
||||
field_path_assignment:
|
||||
nsepseq(field_name,".") "=" expr {
|
||||
let start = nsepseq_to_region (fun x -> x.region) $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop
|
||||
and value = {field_path=$1; equal=$2; field_expr=$3}
|
||||
path "=" expr {
|
||||
let region = cover (path_to_region $1) (expr_to_region $3)
|
||||
and value = {field_path=$1; assignment=$2; field_expr=$3}
|
||||
in {region; value} }
|
||||
|
||||
fun_call:
|
||||
@ -1010,7 +1001,7 @@ arguments:
|
||||
par(nsepseq(expr,",")) { $1 }
|
||||
|
||||
list_expr:
|
||||
injection("list",expr) { EListComp $1 }
|
||||
injection("list",expr) { EListComp ($1 (fun region -> InjList region)) }
|
||||
| "nil" { ENil $1 }
|
||||
|
||||
(* Patterns *)
|
||||
@ -1034,9 +1025,10 @@ core_pattern:
|
||||
| constr_pattern { PConstr $1 }
|
||||
|
||||
list_pattern:
|
||||
injection("list",core_pattern) { PListComp $1 }
|
||||
| "nil" { PNil $1 }
|
||||
"nil" { PNil $1 }
|
||||
| par(cons_pattern) { PParCons $1 }
|
||||
| injection("list",core_pattern) {
|
||||
PListComp ($1 (fun region -> InjList region)) }
|
||||
|
||||
cons_pattern:
|
||||
core_pattern "#" pattern { $1,$2,$3 }
|
||||
|
||||
@ -27,7 +27,7 @@ let mk_state ~offsets ~mode ~buffer =
|
||||
val 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
|
||||
(space before reaching a subtree, then a vertical bar for it)
|
||||
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) =
|
||||
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 :
|
||||
state -> string -> (state -> 'a -> unit) ->
|
||||
@ -117,7 +117,7 @@ let rec print_tokens state ast =
|
||||
print_token state eof "EOF"
|
||||
|
||||
and print_attr_decl state =
|
||||
print_ne_injection state "attributes" print_string
|
||||
print_ne_injection state print_string
|
||||
|
||||
and print_decl state = function
|
||||
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
|
||||
| TPar par_type -> print_par_type state par_type
|
||||
| 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; _} =
|
||||
print_nsepseq state "*" print_type_expr value
|
||||
@ -170,8 +170,8 @@ and print_variant state ({value; _}: variant reg) =
|
||||
and print_sum_type state {value; _} =
|
||||
print_nsepseq state "|" print_variant value
|
||||
|
||||
and print_record_type state record_type =
|
||||
print_ne_injection state "record" print_field_decl record_type
|
||||
and print_record_type state =
|
||||
print_ne_injection state print_field_decl
|
||||
|
||||
and print_type_app state {value; _} =
|
||||
let type_name, type_tuple = value in
|
||||
@ -221,9 +221,8 @@ and print_fun_decl state {value; _} =
|
||||
print_terminator state terminator;
|
||||
|
||||
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
|
||||
print_token_opt state kwd_recursive "recursive";
|
||||
print_token state kwd_function "function";
|
||||
print_parameters state param;
|
||||
print_token state colon ":";
|
||||
@ -256,22 +255,19 @@ and print_param_var state {value; _} =
|
||||
print_type_expr state param_type
|
||||
|
||||
and print_block state block =
|
||||
let {opening; statements; terminator; closing} = block.value in
|
||||
print_block_opening state opening;
|
||||
let {enclosing; statements; terminator} = block.value in
|
||||
match enclosing with
|
||||
Block (kwd_block, lbrace, rbrace) ->
|
||||
print_token state kwd_block "block";
|
||||
print_token state lbrace "{";
|
||||
print_statements state statements;
|
||||
print_terminator state terminator;
|
||||
print_block_closing state closing
|
||||
|
||||
and print_block_opening state = function
|
||||
Block (kwd_block, lbrace) ->
|
||||
print_token state kwd_block "block";
|
||||
print_token state lbrace "{"
|
||||
| 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"
|
||||
print_token state rbrace "}"
|
||||
| BeginEnd (kwd_begin, kwd_end) ->
|
||||
print_token state kwd_begin "begin";
|
||||
print_statements state statements;
|
||||
print_terminator state terminator;
|
||||
print_token state kwd_end "end"
|
||||
|
||||
and print_data_decl state = function
|
||||
LocalConst decl -> print_const_decl state decl
|
||||
@ -344,14 +340,20 @@ and print_clause_block state = function
|
||||
print_token state rbrace "}"
|
||||
|
||||
and print_case_instr state (node : if_clause case) =
|
||||
let {kwd_case; expr; opening;
|
||||
lead_vbar; cases; closing} = node in
|
||||
let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
|
||||
print_token state kwd_case "case";
|
||||
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_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
|
||||
None -> fun _ -> ()
|
||||
@ -393,19 +395,16 @@ and print_for_loop state = function
|
||||
| ForCollect for_collect -> print_for_collect state for_collect
|
||||
|
||||
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_var_assign state assign;
|
||||
print_token state kwd_to "to";
|
||||
print_expr state bound;
|
||||
match kwd_step with
|
||||
| None -> ();
|
||||
| Some kwd_step ->
|
||||
(match step with
|
||||
None -> ();
|
||||
| Some (kwd_step, expr) ->
|
||||
print_token state kwd_step "step";
|
||||
match step with
|
||||
| None -> ();
|
||||
| Some step ->
|
||||
print_expr state step;
|
||||
print_expr state expr);
|
||||
print_block state block
|
||||
|
||||
and print_var_assign state {value; _} =
|
||||
@ -461,19 +460,27 @@ and print_expr state = function
|
||||
| EPar e -> print_par_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_type_expr state type_expr
|
||||
|
||||
and print_case_expr state (node : expr case) =
|
||||
let {kwd_case; expr; opening;
|
||||
lead_vbar; cases; closing} = node in
|
||||
let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
|
||||
print_token state kwd_case "case";
|
||||
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_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; _} =
|
||||
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
|
||||
MapLookUp {value; _} -> print_map_lookup state value
|
||||
| MapInj inj -> print_injection state "map" print_binding inj
|
||||
| BigMapInj inj -> print_injection state "big_map" print_binding inj
|
||||
| MapInj inj -> print_injection state print_binding inj
|
||||
| BigMapInj inj -> print_injection state print_binding inj
|
||||
|
||||
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
|
||||
|
||||
and print_set_membership state {value; _} =
|
||||
@ -600,7 +607,7 @@ and print_list_expr state = function
|
||||
print_expr state arg1;
|
||||
print_token state op "#";
|
||||
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
|
||||
|
||||
and print_constr_expr state = function
|
||||
@ -608,27 +615,26 @@ and print_constr_expr state = function
|
||||
| NoneExpr e -> print_none_expr state e
|
||||
| ConstrApp e -> print_constr_app state e
|
||||
|
||||
and print_record_expr state e =
|
||||
print_ne_injection state "record" print_field_assign e
|
||||
and print_record_expr state =
|
||||
print_ne_injection state print_field_assignment
|
||||
|
||||
and print_field_assign state {value; _} =
|
||||
let {field_name; equal; field_expr} = value in
|
||||
and print_field_assignment state {value; _} =
|
||||
let {field_name; assignment; field_expr} = value in
|
||||
print_var state field_name;
|
||||
print_token state equal "=";
|
||||
print_token state assignment "=";
|
||||
print_expr state field_expr
|
||||
|
||||
and print_field_path_assign state {value; _} =
|
||||
let {field_path; equal; field_expr} = value in
|
||||
print_nsepseq state "field_path" print_var field_path;
|
||||
print_token state equal "=";
|
||||
and print_field_path_assignment state {value; _} =
|
||||
let {field_path; assignment; field_expr} = value in
|
||||
print_path state field_path;
|
||||
print_token state assignment "=";
|
||||
print_expr state field_expr
|
||||
|
||||
and print_update_expr state {value; _} =
|
||||
let {record; kwd_with; updates} = value in
|
||||
print_path state record;
|
||||
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; _} =
|
||||
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_path state path;
|
||||
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 =
|
||||
let {kwd_patch; path; kwd_with; set_inj} = node in
|
||||
print_token state kwd_patch "patch";
|
||||
print_path state path;
|
||||
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 =
|
||||
let {kwd_patch; path; kwd_with; map_inj} = node in
|
||||
print_token state kwd_patch "patch";
|
||||
print_path state path;
|
||||
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 =
|
||||
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
|
||||
|
||||
and print_injection :
|
||||
'a.state -> string -> (state -> 'a -> unit) ->
|
||||
'a injection reg -> unit =
|
||||
fun state kwd print {value; _} ->
|
||||
let {opening; elements; terminator; closing} = value in
|
||||
print_opening state kwd opening;
|
||||
'a.state -> (state -> 'a -> unit) -> 'a injection reg -> unit =
|
||||
fun state print {value; _} ->
|
||||
let {kind; enclosing; elements; terminator} = value in
|
||||
print_injection_kwd state kind;
|
||||
match enclosing with
|
||||
Brackets (lbracket, rbracket) ->
|
||||
print_token state lbracket "[";
|
||||
print_sepseq state ";" print elements;
|
||||
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 :
|
||||
'a.state -> string -> (state -> 'a -> unit) ->
|
||||
'a ne_injection reg -> unit =
|
||||
fun state kwd print {value; _} ->
|
||||
let {opening; ne_elements; terminator; closing} = value in
|
||||
print_opening state kwd opening;
|
||||
'a.state -> (state -> 'a -> unit) -> 'a ne_injection reg -> unit =
|
||||
fun state print {value; _} ->
|
||||
let {kind; enclosing; ne_elements; terminator} = value in
|
||||
print_ne_injection_kwd state kind;
|
||||
match enclosing with
|
||||
Brackets (lbracket, rbracket) ->
|
||||
print_token state lbracket "[";
|
||||
print_nsepseq state ";" print ne_elements;
|
||||
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
|
||||
Kwd kwd ->
|
||||
print_token state kwd lexeme
|
||||
| KwdBracket (kwd, lbracket) ->
|
||||
print_token state kwd lexeme;
|
||||
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_ne_injection_kwd state = function
|
||||
NEInjAttr kwd_attributes -> print_token state kwd_attributes "attributes"
|
||||
| NEInjSet kwd_set -> print_token state kwd_set "set"
|
||||
| NEInjMap kwd_map -> print_token state kwd_map "map"
|
||||
| NEInjRecord kwd_record -> print_token state kwd_record "record"
|
||||
|
||||
and print_binding state {value; _} =
|
||||
let {source; arrow; image} = value in
|
||||
@ -787,7 +806,7 @@ and print_patterns state {value; _} =
|
||||
|
||||
and print_list_pattern state = function
|
||||
PListComp comp ->
|
||||
print_injection state "list" print_pattern comp
|
||||
print_injection state print_pattern comp
|
||||
| PNil kwd_nil ->
|
||||
print_token state kwd_nil "nil"
|
||||
| PParCons cons ->
|
||||
@ -831,7 +850,7 @@ let pattern_to_string ~offsets ~mode =
|
||||
let instruction_to_string ~offsets ~mode =
|
||||
to_string ~offsets ~mode print_instruction
|
||||
|
||||
(** {1 Pretty-printing the AST} *)
|
||||
(* Pretty-printing the AST *)
|
||||
|
||||
let pp_ident state {value=name; region} =
|
||||
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
|
||||
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 =
|
||||
pp_ident state {value=name; region}
|
||||
|
||||
let rec pp_ast state {decl; _} =
|
||||
let rec pp_cst state {decl; _} =
|
||||
let apply len rank =
|
||||
pp_declaration (state#pad len rank) in
|
||||
let decls = Utils.nseq_to_list decl in
|
||||
@ -943,8 +970,8 @@ and pp_type_expr state = function
|
||||
field_decl.value in
|
||||
let fields = Utils.nsepseq_to_list value.ne_elements in
|
||||
List.iteri (List.length fields |> apply) fields
|
||||
| TStringLiteral s ->
|
||||
pp_node state "String";
|
||||
| TString s ->
|
||||
pp_node state "TString";
|
||||
pp_string (state#pad 1 0) s
|
||||
|
||||
and pp_cartesian state {value; _} =
|
||||
@ -1244,8 +1271,8 @@ and pp_projection state proj =
|
||||
List.iteri (apply len) selections
|
||||
|
||||
and pp_update state update =
|
||||
pp_path state update.record;
|
||||
pp_ne_injection pp_field_path_assign state update.updates.value
|
||||
pp_path (state#pad 2 0) update.record;
|
||||
pp_ne_injection pp_field_path_assignment state update.updates.value
|
||||
|
||||
and pp_selection state = function
|
||||
FieldName name ->
|
||||
@ -1285,17 +1312,27 @@ and pp_for_loop state = function
|
||||
pp_for_collect state value
|
||||
|
||||
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 state = state#pad 3 0 in
|
||||
let state = state#pad arity 0 in
|
||||
pp_node state "<init>";
|
||||
pp_var_assign state for_int.assign.value in
|
||||
pp_var_assign state assign.value in
|
||||
let () =
|
||||
let state = state#pad 3 1 in
|
||||
let state = state#pad arity 1 in
|
||||
pp_node state "<bound>";
|
||||
pp_expr (state#pad 1 0) for_int.bound in
|
||||
pp_expr (state#pad 1 0) bound in
|
||||
let () =
|
||||
let state = state#pad 3 2 in
|
||||
let statements = for_int.block.value.statements in
|
||||
match step with
|
||||
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_statements state statements
|
||||
in ()
|
||||
@ -1343,18 +1380,18 @@ and pp_fun_call state (expr, args) =
|
||||
|
||||
and pp_record_patch state patch =
|
||||
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_ident (state#pad 2 0) value.field_name;
|
||||
pp_expr (state#pad 2 1) value.field_expr
|
||||
|
||||
and pp_field_path_assign state {value; _} =
|
||||
pp_node state "<field path for update>";
|
||||
let path = Utils.nsepseq_to_list value.field_path in
|
||||
List.iter (pp_ident (state#pad 2 0)) path;
|
||||
pp_expr (state#pad 2 1) value.field_expr
|
||||
and pp_field_path_assignment state {value; _} =
|
||||
let {field_path; field_expr; _} = value in
|
||||
pp_node state "<update>";
|
||||
pp_path (state#pad 2 0) field_path;
|
||||
pp_expr (state#pad 2 1) field_expr
|
||||
|
||||
and pp_map_patch state patch =
|
||||
pp_path (state#pad 2 0) patch.path;
|
||||
@ -1403,7 +1440,7 @@ and pp_expr state = function
|
||||
pp_cond_expr state value
|
||||
| EAnnot {value; region} ->
|
||||
pp_loc_node state "EAnnot" region;
|
||||
pp_annotated state value
|
||||
pp_annotated state value.inside
|
||||
| ELogic e_logic ->
|
||||
pp_node state "ELogic";
|
||||
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
|
||||
| ERecord {value; 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} ->
|
||||
pp_loc_node state "EProj" region;
|
||||
pp_projection state value
|
||||
@ -1576,9 +1613,9 @@ and pp_string_expr state = function
|
||||
pp_string (state#pad 1 0) s
|
||||
| Verbatim v ->
|
||||
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_type_expr (state#pad 2 1) t_expr
|
||||
|
||||
|
||||
@ -33,5 +33,5 @@ val instruction_to_string :
|
||||
|
||||
(** {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
|
||||
|
||||
@ -22,7 +22,8 @@ module SubIO =
|
||||
ext : string;
|
||||
mode : [`Byte | `Point];
|
||||
cmd : EvalOpt.command;
|
||||
mono : bool
|
||||
mono : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
let options : options =
|
||||
@ -36,6 +37,7 @@ module SubIO =
|
||||
method mode = IO.options#mode
|
||||
method cmd = IO.options#cmd
|
||||
method mono = IO.options#mono
|
||||
method pretty = IO.options#pretty
|
||||
end
|
||||
|
||||
let make =
|
||||
@ -48,6 +50,7 @@ module SubIO =
|
||||
~mode:options#mode
|
||||
~cmd:options#cmd
|
||||
~mono:options#mono
|
||||
~pretty:options#pretty
|
||||
end
|
||||
|
||||
module Parser =
|
||||
@ -67,14 +70,28 @@ module ParserLog =
|
||||
module Lexer = Lexer.Make (LexToken)
|
||||
|
||||
module Unit =
|
||||
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
|
||||
ParserUnit.Make (Lexer)(AST)(Parser)(Parser_msg)(ParserLog)(SubIO)
|
||||
|
||||
(* Main *)
|
||||
|
||||
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 ->
|
||||
(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 () =
|
||||
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 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
|
||||
begin
|
||||
var operations : list (operation) := list [];
|
||||
const operations : list (operation) = list [];
|
||||
const a : nat = 0n;
|
||||
x0 := record foo = "1"; bar = 4n end;
|
||||
x1 := nil;
|
||||
@ -13,7 +17,7 @@ function back (var store : store) : list (operation) * store is
|
||||
case foo of
|
||||
10n -> skip
|
||||
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];
|
||||
a := A;
|
||||
b := B (a);
|
||||
@ -21,12 +25,12 @@ function back (var store : store) : list (operation) * store is
|
||||
d := None;
|
||||
e := Some (a, B (b));
|
||||
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];
|
||||
a := "hello " ^ "world" ^ "!";
|
||||
r := record a = 0 end;
|
||||
r := r with record a = 42 end;
|
||||
patch store.backers with set [(1); f(2*3)];
|
||||
r := record aaaaaaaaaaaa = 100000000; bbbbbbb = ffffff (2, aa, x, y) + 1 end;
|
||||
r := r with record aaaaaaaaaaa = 444442; bbbbbbbbb = 43 + f (z) / 234 end;
|
||||
patch store.backers.8.aa.33333.5 with set [(1); f(2*3); 123124234/2345];
|
||||
remove (1,2,3) from set foo.bar;
|
||||
remove 3 from map foo.bar;
|
||||
patch store.backers with map [sender -> amount];
|
||||
@ -39,7 +43,7 @@ function back (var store : store) : list (operation) * store is
|
||||
begin
|
||||
acc := 2 - (if toggle then f(x) else Unit);
|
||||
end;
|
||||
for i := 1n to 10n
|
||||
for i := 1n to 10n step 2n
|
||||
begin
|
||||
acc := acc + i;
|
||||
end;
|
||||
@ -52,27 +56,32 @@ function back (var store : store) : list (operation) * store is
|
||||
| B (x, C (y,z)) -> 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
|
||||
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
|
||||
failwith ("Too soon.")
|
||||
else
|
||||
case store.backers[sender] of
|
||||
None ->
|
||||
failwith ("Not a backer.")
|
||||
| Some (0) -> skip
|
||||
| Some (quantity) ->
|
||||
if balance >= store.goal or store.funded then
|
||||
failwith ("Goal reached: no refund.")
|
||||
else
|
||||
begin
|
||||
operations.0.foo := list [transaction (unit, sender, quantity)];
|
||||
remove sender from map store.backers
|
||||
operations.0.foo := list [transaction (unit, sender, quantity); transaction (foo, bar, bazzzzzzzzzzzzzzz)];
|
||||
remove sender.0099999.fffff [fiar (abaxxasfdf)] from map store.backers.foooooo.barrrrr.01.bazzzzzzz
|
||||
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
|
||||
begin
|
||||
|
||||
@ -15,8 +15,10 @@
|
||||
(name parser_pascaligo)
|
||||
(public_name ligo.parser.pascaligo)
|
||||
(modules
|
||||
Scoping AST pascaligo Parser ParserLog LexToken ParErr)
|
||||
Scoping AST pascaligo Parser ParserLog LexToken ParErr Pretty)
|
||||
(libraries
|
||||
pprint
|
||||
terminal_size
|
||||
menhirLib
|
||||
parser_shared
|
||||
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 SyntaxError = Parser_reasonligo.SyntaxError
|
||||
module SSet = Set.Make (String)
|
||||
module Pretty = Parser_reasonligo.Pretty
|
||||
|
||||
(* Mock IOs TODO: Fill them with CLI options *)
|
||||
|
||||
@ -22,7 +23,8 @@ module SubIO =
|
||||
ext : string; (* ".religo" *)
|
||||
mode : [`Byte | `Point];
|
||||
cmd : EvalOpt.command;
|
||||
mono : bool
|
||||
mono : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
let options : options =
|
||||
@ -37,6 +39,7 @@ module SubIO =
|
||||
method mode = `Point
|
||||
method cmd = EvalOpt.Quiet
|
||||
method mono = false
|
||||
method pretty = false
|
||||
end
|
||||
|
||||
let make =
|
||||
@ -49,6 +52,7 @@ module SubIO =
|
||||
~mode:options#mode
|
||||
~cmd:options#cmd
|
||||
~mono:options#mono
|
||||
~pretty:options#pretty
|
||||
end
|
||||
|
||||
module Parser =
|
||||
@ -178,3 +182,18 @@ let parse_expression source = apply (fun () -> Unit.expr_in_string source)
|
||||
(* Preprocessing a contract in a file *)
|
||||
|
||||
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. *)
|
||||
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/Scoping.mli
|
||||
../cameligo/Scoping.ml
|
||||
|
||||
$HOME/git/ligo/_build/default/src/passes/1-parser/reasonligo/ParErr.ml
|
||||
|
||||
@ -279,15 +279,12 @@ let_binding:
|
||||
| par(closed_irrefutable) type_annotation? "=" expr {
|
||||
wild_error $4;
|
||||
Scoping.check_pattern $1.value.inside;
|
||||
{binders = PPar $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
|
||||
{binders = $1.value.inside, []; lhs_type=$2; eq=$3; let_rhs=$4}
|
||||
}
|
||||
| tuple(sub_irrefutable) type_annotation? "=" expr {
|
||||
wild_error $4;
|
||||
Utils.nsepseq_iter Scoping.check_pattern $1;
|
||||
let hd, tl = $1 in
|
||||
let start = pattern_to_region hd in
|
||||
let stop = last fst tl in
|
||||
let region = cover start stop in
|
||||
let region = nsepseq_to_region pattern_to_region $1 in
|
||||
let binders = PTuple {value=$1; region}, [] in
|
||||
{binders; lhs_type=$2; eq=$3; let_rhs=$4} }
|
||||
|
||||
@ -433,7 +430,18 @@ type_expr_simple:
|
||||
TProd {region = cover $1 $3; value=$2}
|
||||
}
|
||||
| "(" 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_expr_simple { $1,$2 }
|
||||
@ -456,8 +464,15 @@ fun_expr(right_expr):
|
||||
)
|
||||
| EAnnot {region; value = {inside = EVar v, colon, typ; _}} ->
|
||||
Scoping.check_reserved_name v;
|
||||
let value = {pattern = PVar v; colon; type_expr = typ}
|
||||
in PTyped {region; value}
|
||||
let value = {pattern = PVar v; colon; type_expr = typ} in
|
||||
PPar {
|
||||
value = {
|
||||
lpar = Region.ghost;
|
||||
rpar = Region.ghost;
|
||||
inside = PTyped {region; value}
|
||||
};
|
||||
region
|
||||
}
|
||||
| EPar p ->
|
||||
let value =
|
||||
{p.value with inside = arg_to_pattern p.value.inside}
|
||||
@ -497,7 +512,13 @@ fun_expr(right_expr):
|
||||
(arg_to_pattern fun_arg, [])
|
||||
| EPar {value = {inside = EFun {
|
||||
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;
|
||||
body;
|
||||
_
|
||||
@ -656,7 +677,7 @@ disj_expr_level:
|
||||
disj_expr
|
||||
| conj_expr_level { $1 }
|
||||
| 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 region =
|
||||
match $2 with
|
||||
@ -891,7 +912,7 @@ update_record:
|
||||
lbrace = $1;
|
||||
record = $3;
|
||||
kwd_with = $4;
|
||||
updates = {value = {compound = Braces($1,$6);
|
||||
updates = {value = {compound = Braces (ghost, ghost);
|
||||
ne_elements;
|
||||
terminator};
|
||||
region = cover $4 $6};
|
||||
@ -921,10 +942,9 @@ exprs:
|
||||
in
|
||||
let sequence = ESeq {
|
||||
value = {
|
||||
compound = BeginEnd(Region.ghost, Region.ghost);
|
||||
compound = BeginEnd (ghost, ghost);
|
||||
elements = Some val_;
|
||||
terminator = (snd c)
|
||||
};
|
||||
terminator = snd c};
|
||||
region = sequence_region
|
||||
}
|
||||
in
|
||||
@ -959,9 +979,8 @@ sequence:
|
||||
let value = {compound;
|
||||
elements = Some elts;
|
||||
terminator = None} in
|
||||
let region = cover $1 $3 in
|
||||
{region; value}
|
||||
}
|
||||
let region = cover $1 $3
|
||||
in {region; value} }
|
||||
|
||||
record:
|
||||
"{" field_assignment more_field_assignments? "}" {
|
||||
@ -986,15 +1005,13 @@ record:
|
||||
let ne_elements = Utils.nsepseq_cons field_name comma elts in
|
||||
let compound = Braces ($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:
|
||||
(* This can only happen with multiple fields -
|
||||
one item punning does NOT work in ReasonML *)
|
||||
field_name {
|
||||
let value = {
|
||||
field_name = $1;
|
||||
let value = {field_name = $1;
|
||||
assignment = ghost;
|
||||
field_expr = EVar $1}
|
||||
in {$1 with value}
|
||||
@ -1003,29 +1020,14 @@ field_assignment_punning:
|
||||
|
||||
field_assignment:
|
||||
field_name ":" expr {
|
||||
let start = $1.region in
|
||||
let stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
let value = {
|
||||
field_name = $1;
|
||||
let region = cover $1.region (expr_to_region $3)
|
||||
and value = {field_name = $1;
|
||||
assignment = $2;
|
||||
field_expr = $3}
|
||||
in {region; value} }
|
||||
|
||||
field_path_assignment:
|
||||
field_name {
|
||||
let value = {
|
||||
field_path = ($1,[]);
|
||||
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}
|
||||
path ":" expr {
|
||||
let region = cover (path_to_region $1) (expr_to_region $3)
|
||||
and value = {field_path=$1; assignment=$2; field_expr=$3}
|
||||
in {region; value} }
|
||||
|
||||
@ -22,7 +22,8 @@ module SubIO =
|
||||
ext : string;
|
||||
mode : [`Byte | `Point];
|
||||
cmd : EvalOpt.command;
|
||||
mono : bool
|
||||
mono : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
let options : options =
|
||||
@ -36,6 +37,7 @@ module SubIO =
|
||||
method mode = IO.options#mode
|
||||
method cmd = IO.options#cmd
|
||||
method mono = IO.options#mono
|
||||
method pretty = IO.options#pretty
|
||||
end
|
||||
|
||||
let make =
|
||||
@ -48,6 +50,7 @@ module SubIO =
|
||||
~mode:options#mode
|
||||
~cmd:options#cmd
|
||||
~mono:options#mono
|
||||
~pretty:options#pretty
|
||||
end
|
||||
|
||||
module Parser =
|
||||
@ -67,12 +70,23 @@ module ParserLog =
|
||||
module Lexer = Lexer.Make (LexToken)
|
||||
|
||||
module Unit =
|
||||
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(SubIO)
|
||||
ParserUnit.Make (Lexer)(AST)(Parser)(Parser_msg)(ParserLog)(SubIO)
|
||||
|
||||
(* Main *)
|
||||
|
||||
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 ->
|
||||
(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)
|
||||
(public_name ligo.parser.reasonligo)
|
||||
(modules
|
||||
SyntaxError reasonligo LexToken ParErr Parser)
|
||||
SyntaxError reasonligo LexToken ParErr Parser Pretty)
|
||||
(libraries
|
||||
menhirLib
|
||||
parser_shared
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -29,11 +29,12 @@ type options = <
|
||||
mode : [`Byte | `Point];
|
||||
cmd : command;
|
||||
mono : bool;
|
||||
expr : bool
|
||||
expr : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
let make ~input ~libs ~verbose ~offsets ?block
|
||||
?line ~ext ~mode ~cmd ~mono ~expr : options =
|
||||
?line ~ext ~mode ~cmd ~mono ~expr ~pretty : options =
|
||||
object
|
||||
method input = input
|
||||
method libs = libs
|
||||
@ -46,6 +47,7 @@ let make ~input ~libs ~verbose ~offsets ?block
|
||||
method cmd = cmd
|
||||
method mono = mono
|
||||
method expr = expr
|
||||
method pretty = pretty
|
||||
end
|
||||
|
||||
(* Auxiliary functions *)
|
||||
@ -77,6 +79,7 @@ let help extension () =
|
||||
print " --bytes Bytes for source locations";
|
||||
print " --mono Use Menhir monolithic API";
|
||||
print " --expr Parse an expression";
|
||||
print " --pretty Pretty-print the input";
|
||||
print " --verbose=<stages> cli, preproc, ast-tokens, ast (colon-separated)";
|
||||
print " --version Commit hash on stdout";
|
||||
print " -h, --help This help";
|
||||
@ -100,6 +103,7 @@ and libs = ref []
|
||||
and verb_str = ref ""
|
||||
and mono = ref false
|
||||
and expr = ref false
|
||||
and pretty = ref false
|
||||
|
||||
let split_at_colon = Str.(split (regexp ":"))
|
||||
|
||||
@ -121,6 +125,7 @@ let specs extension =
|
||||
noshort, "bytes", set bytes true, None;
|
||||
noshort, "mono", set mono true, None;
|
||||
noshort, "expr", set expr true, None;
|
||||
noshort, "pretty", set pretty true, None;
|
||||
noshort, "verbose", None, Some add_verbose;
|
||||
'h', "help", Some (help extension), None;
|
||||
noshort, "version", Some version, None
|
||||
@ -156,6 +161,7 @@ let print_opt () =
|
||||
printf "bytes = %b\n" !bytes;
|
||||
printf "mono = %b\n" !mono;
|
||||
printf "expr = %b\n" !expr;
|
||||
printf "pretty = %b\n" !pretty;
|
||||
printf "verbose = %s\n" !verb_str;
|
||||
printf "input = %s\n" (string_of quote !input);
|
||||
printf "libs = %s\n" (string_of_path !libs)
|
||||
@ -185,6 +191,7 @@ let check ?block ?line ~ext =
|
||||
and mono = !mono
|
||||
and expr = !expr
|
||||
and verbose = !verbose
|
||||
and pretty = !pretty
|
||||
and libs = !libs in
|
||||
|
||||
let () =
|
||||
@ -199,6 +206,7 @@ let check ?block ?line ~ext =
|
||||
printf "mode = %s\n" (if mode = `Byte then "`Byte" else "`Point");
|
||||
printf "mono = %b\n" mono;
|
||||
printf "expr = %b\n" expr;
|
||||
printf "pretty = %b\n" pretty;
|
||||
printf "verbose = %s\n" !verb_str;
|
||||
printf "input = %s\n" (string_of quote input);
|
||||
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."
|
||||
|
||||
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 *)
|
||||
|
||||
|
||||
@ -47,6 +47,9 @@ type command = Quiet | Copy | Units | Tokens
|
||||
{li If the field [expr] is [true], then the parser for
|
||||
expressions is used, otherwise a full-fledged contract is
|
||||
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
|
||||
@ -67,7 +70,8 @@ type options = <
|
||||
mode : [`Byte | `Point];
|
||||
cmd : command;
|
||||
mono : bool;
|
||||
expr : bool
|
||||
expr : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
val make :
|
||||
@ -82,6 +86,7 @@ val make :
|
||||
cmd:command ->
|
||||
mono:bool ->
|
||||
expr:bool ->
|
||||
pretty:bool ->
|
||||
options
|
||||
|
||||
(** Parsing the command-line options on stdin. *)
|
||||
|
||||
@ -15,7 +15,8 @@ module type SubIO =
|
||||
ext : string;
|
||||
mode : [`Byte | `Point];
|
||||
cmd : EvalOpt.command;
|
||||
mono : bool
|
||||
mono : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
val options : options
|
||||
@ -31,7 +32,7 @@ module type Printer =
|
||||
val mk_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 print_tokens : state -> ast -> unit
|
||||
val print_expr : state -> expr -> unit
|
||||
@ -145,7 +146,7 @@ module Make (Lexer: Lexer.S)
|
||||
if SSet.mem "ast" SubIO.options#verbose then
|
||||
begin
|
||||
Buffer.clear output;
|
||||
ParserLog.pp_ast state ast;
|
||||
ParserLog.pp_cst state ast;
|
||||
Buffer.output_buffer stdout output
|
||||
end
|
||||
in flush_all (); close (); Ok ast
|
||||
|
||||
@ -17,7 +17,8 @@ module type SubIO =
|
||||
ext : string;
|
||||
mode : [`Byte | `Point];
|
||||
cmd : EvalOpt.command;
|
||||
mono : bool
|
||||
mono : bool;
|
||||
pretty : bool
|
||||
>
|
||||
|
||||
val options : options
|
||||
@ -35,7 +36,7 @@ module type Printer =
|
||||
val mk_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 print_tokens : state -> ast -> unit
|
||||
val print_expr : state -> expr -> unit
|
||||
|
||||
@ -343,59 +343,41 @@ let rec compile_expression :
|
||||
let path' =
|
||||
let aux (s:Raw.selection) =
|
||||
match s with
|
||||
FieldName property -> property.value
|
||||
| Component index -> Z.to_string (snd index.value)
|
||||
FieldName property -> Access_record property.value
|
||||
| Component index -> Access_tuple (snd index.value)
|
||||
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
|
||||
let compile_path : Raw.path -> string * label list = fun p ->
|
||||
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) =
|
||||
let compile_selection : Raw.selection -> access = fun s ->
|
||||
match s with
|
||||
| FieldName property -> Label property.value
|
||||
| Component index -> Label (Z.to_string (snd index.value))
|
||||
in
|
||||
List.map aux @@ npseq_to_list path in
|
||||
(var , path')
|
||||
)
|
||||
in
|
||||
let compile_update = fun (u:Raw.update Region.reg) ->
|
||||
let (u, loc) = r_split u in
|
||||
let (name, path) = compile_path u.record in
|
||||
let record = match path with
|
||||
| [] -> e_variable (Var.of_name name)
|
||||
| _ ->
|
||||
let aux expr (Label l) = e_record_accessor expr l in
|
||||
List.fold_left aux (e_variable (Var.of_name name)) path in
|
||||
| FieldName property -> Access_record property.value
|
||||
| Component index -> (Access_tuple (snd index.value)) in
|
||||
|
||||
let compile_path : Raw.path -> string * access list = function
|
||||
Raw.Name v -> v.value, []
|
||||
| Raw.Path {value; _} ->
|
||||
let Raw.{struct_name; field_path; _} = value in
|
||||
let var = struct_name.value in
|
||||
let path = List.map compile_selection @@ npseq_to_list field_path
|
||||
in var, path in
|
||||
|
||||
let compile_update (u: Raw.update Region.reg) =
|
||||
let u, loc = r_split u in
|
||||
let name, path = compile_path u.record 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%bind updates' =
|
||||
let aux (f:Raw.field_path_assign Raw.reg) =
|
||||
let (f,_) = r_split f in
|
||||
let%bind expr = compile_expression f.field_expr in
|
||||
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr)
|
||||
in
|
||||
bind_map_list aux @@ npseq_to_list updates
|
||||
in
|
||||
let aux ur (path, expr) =
|
||||
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'
|
||||
in
|
||||
|
||||
trace (abstracting_expr t) @@
|
||||
let aux (f: Raw.field_path_assignment Raw.reg) =
|
||||
let f, _ = r_split f in
|
||||
let%bind expr = compile_expression f.field_expr
|
||||
in ok (compile_path f.field_path, expr)
|
||||
in bind_map_list aux @@ npseq_to_list updates in
|
||||
let aux ur ((var, path), expr) =
|
||||
ok @@ e_update ~loc ur (Access_record var :: path) expr
|
||||
in bind_fold_list aux record updates'
|
||||
in trace (abstracting_expr t) @@
|
||||
match t with
|
||||
Raw.ELetIn e ->
|
||||
let Raw.{kwd_rec; binding; body; attributes; _} = e.value in
|
||||
@ -439,11 +421,11 @@ let rec compile_expression :
|
||||
| hd :: [] ->
|
||||
if (List.length prep_vars = 1)
|
||||
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 ->
|
||||
e_let_in ~loc hd
|
||||
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)
|
||||
| [] -> body (* Precluded by corner case assertion above *)
|
||||
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'))]
|
||||
)
|
||||
|
||||
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 ->
|
||||
let open Raw in
|
||||
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
|
||||
| [(PFalse _, f) ; (PTrue _, t)]
|
||||
| [(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 (PListComp sugar_nil), nil); (PList (PCons c), cons)] ->
|
||||
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 b = get_var 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 ->
|
||||
let error x =
|
||||
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);
|
||||
(("Some", Some some_var), some_expr) ] ->
|
||||
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 }
|
||||
| _ -> simple_fail "bad option pattern"
|
||||
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'
|
||||
|
||||
let get_t_string_singleton_opt = function
|
||||
| Raw.TStringLiteral s -> Some s.value
|
||||
| Raw.TString s -> Some s.value
|
||||
| _ -> None
|
||||
|
||||
|
||||
@ -252,7 +252,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
|
||||
@@ 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
|
||||
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 =
|
||||
match lst with
|
||||
@ -271,18 +271,19 @@ let compile_projection : Raw.projection Region.reg -> _ = fun p ->
|
||||
let path' =
|
||||
let aux (s:Raw.selection) =
|
||||
match s with
|
||||
| FieldName property -> property.value
|
||||
| Component index -> (Z.to_string (snd index.value))
|
||||
| FieldName property -> Access_record property.value
|
||||
| Component index -> (Access_tuple (snd index.value))
|
||||
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 return x = ok x in
|
||||
match t with
|
||||
| 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 type_expr' = compile_type_expression type_expr in
|
||||
return @@ e_annotation ~loc expr' type_expr'
|
||||
@ -327,7 +328,8 @@ let rec compile_expression (t:Raw.expr) : expr result =
|
||||
| ERecord r ->
|
||||
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 (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
|
||||
let aux prev (k, v) = SMap.add k v prev in
|
||||
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
|
||||
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 ->
|
||||
let (f , loc) = r_split f in
|
||||
let%bind (_ty_opt, f') = compile_fun_expression ~loc f
|
||||
in return @@ f'
|
||||
|
||||
|
||||
and compile_update = fun (u:Raw.update Region.reg) ->
|
||||
let (u, loc) = r_split u in
|
||||
let (name, path) = compile_path u.record in
|
||||
let record = match path with
|
||||
| [] -> e_variable (Var.of_name name)
|
||||
| _ -> e_accessor_list (e_variable (Var.of_name name)) path in
|
||||
and compile_update (u: Raw.update Region.reg) =
|
||||
let u, loc = r_split u in
|
||||
let name, path = compile_path u.record 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%bind updates' =
|
||||
let aux (f:Raw.field_path_assign Raw.reg) =
|
||||
let (f,_) = r_split f in
|
||||
let%bind expr = compile_expression f.field_expr in
|
||||
ok ( List.map (fun (x: _ Raw.reg) -> x.value) (npseq_to_list f.field_path), expr)
|
||||
in
|
||||
bind_map_list aux @@ npseq_to_list updates
|
||||
in
|
||||
let aux ur (path, expr) =
|
||||
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'
|
||||
let aux (f: Raw.field_path_assignment Raw.reg) =
|
||||
let f, _ = r_split f in
|
||||
let%bind expr = compile_expression f.field_expr
|
||||
in ok (compile_path f.field_path, expr)
|
||||
in bind_map_list aux @@ npseq_to_list updates in
|
||||
let aux ur ((var, path), expr) =
|
||||
ok @@ e_update ~loc ur (Access_record var :: path) expr
|
||||
in bind_fold_list aux record updates'
|
||||
|
||||
and compile_logic_expression (t:Raw.logic_expr) : expression result =
|
||||
let return x = ok x in
|
||||
match t with
|
||||
| BoolExpr (False reg) -> (
|
||||
let loc = Location.lift reg in
|
||||
return @@ e_bool ~loc false
|
||||
)
|
||||
| BoolExpr (True reg) -> (
|
||||
let loc = Location.lift reg in
|
||||
return @@ e_bool ~loc true
|
||||
)
|
||||
| BoolExpr (False reg) ->
|
||||
ok @@ e_bool ~loc:(Location.lift reg) false
|
||||
| BoolExpr (True reg) ->
|
||||
ok @@ e_bool ~loc:(Location.lift reg) true
|
||||
| BoolExpr (Or b) ->
|
||||
compile_binop "OR" b
|
||||
| BoolExpr (And b) ->
|
||||
@ -668,7 +653,7 @@ and compile_fun_decl :
|
||||
let%bind tpl_declarations =
|
||||
let aux = fun i (param, type_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 ass = return_let_in (Var.of_name param , type_variable) inline expr in
|
||||
ass
|
||||
@ -698,7 +683,7 @@ and compile_fun_expression :
|
||||
loc:_ -> Raw.fun_expr -> (type_expression option * expression) result =
|
||||
fun ~loc x ->
|
||||
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
|
||||
(match param.value.inside with
|
||||
a, [] -> (
|
||||
@ -714,10 +699,8 @@ and compile_fun_expression :
|
||||
bind_fold_right_list aux result body in
|
||||
let binder = Var.of_name binder in
|
||||
let fun_type = t_function input_type output_type in
|
||||
let expression = match kwd_recursive with
|
||||
| None -> 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}
|
||||
let expression =
|
||||
e_lambda ~loc binder (Some input_type)(Some output_type) result
|
||||
in
|
||||
ok (Some fun_type , expression)
|
||||
)
|
||||
@ -731,7 +714,7 @@ and compile_fun_expression :
|
||||
(arguments_name , type_expression) in
|
||||
let%bind tpl_declarations =
|
||||
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 ass = return_let_in (Var.of_name param , type_variable) false expr in
|
||||
ass
|
||||
@ -745,10 +728,8 @@ and compile_fun_expression :
|
||||
let aux prec cur = cur (Some prec) in
|
||||
bind_fold_right_list aux result body in
|
||||
let fun_type = t_function input_type output_type in
|
||||
let expression = match kwd_recursive with
|
||||
| None -> 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}
|
||||
let expression =
|
||||
e_lambda ~loc binder (Some input_type)(Some output_type) result
|
||||
in
|
||||
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 step = match fi.step with
|
||||
| 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 = body @@ None in
|
||||
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%bind value_expr = compile_expression a.rhs in
|
||||
match a.lhs with
|
||||
| Path path -> (
|
||||
let (name , path') = compile_path path in
|
||||
return_statement @@ e_ez_assign ~loc name path' value_expr
|
||||
)
|
||||
| MapPath v -> (
|
||||
| Path path ->
|
||||
let name , path' = compile_path path in
|
||||
let name = Var.of_name name in
|
||||
return_statement @@ e_assign ~loc name path' value_expr
|
||||
| MapPath v ->
|
||||
let v' = v.value in
|
||||
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 ->
|
||||
let (name,p') = compile_path v'.path in
|
||||
let name, p' = compile_path v'.path in
|
||||
let%bind accessor = compile_projection p in
|
||||
ok @@ (name , accessor , p')
|
||||
in
|
||||
let%bind key_expr = compile_expression v'.index.value.inside in
|
||||
ok @@ (name, accessor, p') in
|
||||
let%bind key_expr =
|
||||
compile_expression v'.index.value.inside 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 -> (
|
||||
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
|
||||
return_statement @@ e_matching ~loc expr m
|
||||
)
|
||||
| RecordPatch r -> (
|
||||
| RecordPatch r ->
|
||||
let reg = r.region in
|
||||
let (r,loc) = r_split r in
|
||||
let aux (fa :Raw.field_assign Raw.reg) : Raw.field_path_assign Raw.reg=
|
||||
{value = {field_path = (fa.value.field_name, []); equal=fa.value.equal; field_expr = fa.value.field_expr};
|
||||
region = fa.region}
|
||||
in
|
||||
let update : Raw.field_path_assign Raw.reg Raw.ne_injection Raw.reg = {
|
||||
let r, loc = r_split r in
|
||||
let aux (fa: Raw.field_assignment Raw.reg) : Raw.field_path_assignment Raw.reg =
|
||||
{value = {field_path = Name fa.value.field_name;
|
||||
assignment = fa.value.assignment;
|
||||
field_expr = fa.value.field_expr};
|
||||
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;
|
||||
region=r.record_inj.region
|
||||
} in
|
||||
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
|
||||
region = r.record_inj.region} in
|
||||
let u : Raw.update = {
|
||||
record = r.path;
|
||||
kwd_with = r.kwd_with;
|
||||
updates = update} in
|
||||
let%bind expr = compile_update {value=u;region=reg} in
|
||||
let (name , access_path) = compile_path r.path in
|
||||
return_statement @@ e_ez_assign ~loc name access_path expr
|
||||
|
||||
)
|
||||
| MapPatch patch -> (
|
||||
let (map_p, loc) = r_split patch in
|
||||
let (name, access_path) = compile_path map_p.path in
|
||||
let name, access_path = compile_path r.path in
|
||||
let name = Var.of_name name in
|
||||
return_statement @@ e_assign ~loc name access_path expr
|
||||
| MapPatch patch ->
|
||||
let map_p, loc = r_split patch in
|
||||
let name, access_path = compile_path map_p.path in
|
||||
let%bind inj = bind_list
|
||||
@@ List.map (fun (x:Raw.binding Region.reg) ->
|
||||
let x = x.value in
|
||||
@ -939,19 +924,18 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
||||
in ok @@ (key', value')
|
||||
)
|
||||
@@ npseq_to_list map_p.map_inj.value.ne_elements in
|
||||
match inj with
|
||||
(match inj with
|
||||
| [] -> return_statement @@ e_skip ~loc ()
|
||||
| _ :: _ ->
|
||||
let assigns = List.fold_right
|
||||
(fun (key, value) map -> (e_map_add key value map))
|
||||
inj
|
||||
(e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
|
||||
in
|
||||
return_statement @@ e_ez_assign ~loc name access_path assigns
|
||||
)
|
||||
(e_accessor ~loc (e_variable (Var.of_name name)) access_path)
|
||||
and name = Var.of_name name in
|
||||
return_statement @@ e_assign ~loc name access_path assigns)
|
||||
| SetPatch patch -> (
|
||||
let (setp, loc) = r_split patch in
|
||||
let (name , access_path) = compile_path setp.path in
|
||||
let setp, loc = r_split patch in
|
||||
let name, access_path = compile_path setp.path in
|
||||
let%bind inj =
|
||||
bind_list @@
|
||||
List.map compile_expression @@
|
||||
@ -961,53 +945,50 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
||||
| _ :: _ ->
|
||||
let assigns = List.fold_right
|
||||
(fun hd s -> e_constant C_SET_ADD [hd ; s])
|
||||
inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in
|
||||
return_statement @@ e_ez_assign ~loc name access_path assigns
|
||||
inj (e_accessor ~loc (e_variable (Var.of_name name)) access_path) in
|
||||
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 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) , [])
|
||||
| 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
|
||||
ok @@ (name , accessor , p')
|
||||
in
|
||||
let%bind key' = compile_expression key in
|
||||
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
|
||||
return_statement @@ e_ez_assign ~loc varname path expr
|
||||
)
|
||||
| SetRemove r -> (
|
||||
let (set_rm, loc) = r_split r in
|
||||
let%bind (varname, set, path) = match set_rm.set with
|
||||
| Name v -> ok (v.value, e_variable (Var.of_name v.value), [])
|
||||
let name = Var.of_name name in
|
||||
return_statement @@ e_assign ~loc name path expr
|
||||
| SetRemove r ->
|
||||
let set_rm, loc = r_split r in
|
||||
let%bind (name, set, path) =
|
||||
match set_rm.set with
|
||||
| Name v ->
|
||||
ok (v.value, e_variable (Var.of_name v.value), [])
|
||||
| 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
|
||||
ok @@ (name, accessor, p')
|
||||
in
|
||||
ok @@ (name, accessor, p') in
|
||||
let%bind removed' = compile_expression set_rm.element 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 ->
|
||||
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
|
||||
| FieldName property -> property.value
|
||||
| Component index -> (Z.to_string (snd index.value))
|
||||
in
|
||||
List.map aux @@ npseq_to_list path in
|
||||
(var , path')
|
||||
)
|
||||
and compile_path : Raw.path -> string * access list = function
|
||||
Raw.Name v -> v.value, []
|
||||
| Raw.Path {value; _} ->
|
||||
let Raw.{struct_name; field_path; _} = value in
|
||||
let var = struct_name.value in
|
||||
let path = List.map compile_selection @@ npseq_to_list field_path
|
||||
in var, path
|
||||
|
||||
and compile_selection : Raw.selection -> access = function
|
||||
FieldName property -> Access_record property.value
|
||||
| Component index -> Access_tuple (snd index.value)
|
||||
|
||||
and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t ->
|
||||
let open Raw in
|
||||
@ -1059,14 +1040,14 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu
|
||||
match patterns with
|
||||
| [(PConstr PFalse _ , f) ; (PConstr PTrue _ , t)]
|
||||
| [(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 PNone _ , none) ; (PConstr PSomeApp v , some)] -> (
|
||||
let (_, v) = v.value in
|
||||
let%bind v = match v.value.inside with
|
||||
| PVar v -> ok v.value
|
||||
| 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 (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
|
||||
|
||||
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 ->
|
||||
trace (simple_info "currently, only booleans, options, lists and \
|
||||
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
|
||||
ok res
|
||||
)
|
||||
| E_look_up ab ->
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
ok res
|
||||
| E_application {lamb;args} -> (
|
||||
let ab = (lamb,args) in
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
@ -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
|
||||
ok res
|
||||
)
|
||||
| E_record_update {record;update} -> (
|
||||
| E_update {record;path;update} -> (
|
||||
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
|
||||
ok res
|
||||
)
|
||||
| E_record_accessor {record} -> (
|
||||
| E_accessor {record;path} -> (
|
||||
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
|
||||
)
|
||||
| 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
|
||||
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 } -> (
|
||||
let%bind res = self init' rhs 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
|
||||
ok res
|
||||
|
||||
|
||||
|
||||
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
||||
match m with
|
||||
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
|
||||
let%bind res = fold_expression f init match_nil in
|
||||
let%bind res = fold_expression f res cons in
|
||||
ok res
|
||||
)
|
||||
| Match_option { match_none ; match_some = (_ , some, _) } -> (
|
||||
let%bind res = fold_expression f init match_none in
|
||||
let%bind res = fold_expression f res some in
|
||||
ok res
|
||||
)
|
||||
| Match_tuple ((_ , e), _) -> (
|
||||
let%bind res = fold_expression f init e in
|
||||
ok res
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
| Match_variant lst -> (
|
||||
let aux init' ((_ , _) , e) =
|
||||
let%bind res' = fold_expression f init' e in
|
||||
ok res' in
|
||||
let%bind res = bind_fold_list aux init lst in
|
||||
ok res
|
||||
)
|
||||
| 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 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
|
||||
return @@ E_big_map lst'
|
||||
)
|
||||
| E_look_up ab -> (
|
||||
let%bind ab' = bind_map_pair self ab in
|
||||
return @@ E_look_up ab'
|
||||
)
|
||||
| E_ascription ascr -> (
|
||||
let%bind e' = self ascr.anno_expr in
|
||||
return @@ E_ascription {ascr with anno_expr=e'}
|
||||
@ -179,32 +179,37 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
||||
let%bind cases' = map_cases f cases in
|
||||
return @@ E_matching {matchee=e';cases=cases'}
|
||||
)
|
||||
| E_record_accessor acc -> (
|
||||
let%bind e' = self acc.record in
|
||||
return @@ E_record_accessor {acc with record = e'}
|
||||
)
|
||||
| E_record m -> (
|
||||
let%bind m' = bind_map_lmap self m in
|
||||
return @@ E_record m'
|
||||
)
|
||||
| E_record_update {record; path; update} -> (
|
||||
| E_accessor {record; path} -> (
|
||||
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
|
||||
return @@ E_record_update {record;path;update}
|
||||
return @@ E_update {record;path;update}
|
||||
)
|
||||
| E_tuple t -> (
|
||||
let%bind t' = bind_map_list self t in
|
||||
return @@ E_tuple t'
|
||||
)
|
||||
| E_tuple_update {tuple; path; update} -> (
|
||||
let%bind tuple = self tuple in
|
||||
let%bind update = self update in
|
||||
return @@ E_tuple_update {tuple; path; update}
|
||||
)
|
||||
| E_tuple_accessor {tuple;path} -> (
|
||||
let%bind tuple = self tuple in
|
||||
return @@ E_tuple_accessor {tuple;path}
|
||||
)
|
||||
| E_constructor c -> (
|
||||
let%bind e' = self c.element in
|
||||
return @@ E_constructor {c with element = e'}
|
||||
@ -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 ->
|
||||
match m with
|
||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
||||
let%bind match_nil = map_expression f match_nil in
|
||||
let%bind cons = map_expression f cons in
|
||||
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }
|
||||
)
|
||||
| Match_option { match_none ; match_some = (name , some, _) } -> (
|
||||
let%bind match_none = map_expression f match_none in
|
||||
let%bind some = map_expression f some in
|
||||
ok @@ Match_option { match_none ; match_some = (name , some, ()) }
|
||||
)
|
||||
| Match_tuple ((names , e), _) -> (
|
||||
let%bind e' = map_expression f e in
|
||||
ok @@ Match_tuple ((names , e'), [])
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
| Match_variant lst -> (
|
||||
let aux ((a , b) , e) =
|
||||
let%bind e' = map_expression f e in
|
||||
ok ((a , b) , e')
|
||||
in
|
||||
let%bind lst' = bind_map_list aux lst in
|
||||
ok @@ Match_variant (lst', ())
|
||||
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 ->
|
||||
@ -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
|
||||
ok (res, return @@ E_big_map lst')
|
||||
)
|
||||
| E_look_up ab -> (
|
||||
let%bind (res, ab') = bind_fold_map_pair self init' ab in
|
||||
ok (res, return @@ E_look_up ab')
|
||||
)
|
||||
| E_ascription ascr -> (
|
||||
let%bind (res,e') = self init' ascr.anno_expr in
|
||||
ok (res, return @@ E_ascription {ascr with anno_expr=e'})
|
||||
@ -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
|
||||
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
||||
)
|
||||
| E_record_accessor acc -> (
|
||||
let%bind (res, e') = self init' acc.record in
|
||||
ok (res, return @@ E_record_accessor {acc with record = e'})
|
||||
)
|
||||
| E_record m -> (
|
||||
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
||||
let m' = LMap.of_list lst' in
|
||||
ok (res, return @@ E_record m')
|
||||
)
|
||||
| E_record_update {record; path; update} -> (
|
||||
| E_accessor {record;path} -> (
|
||||
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
|
||||
ok (res, return @@ E_record_update {record;path;update})
|
||||
ok (res, return @@ E_update {record;path;update})
|
||||
)
|
||||
| E_tuple t -> (
|
||||
let%bind (res, t') = bind_fold_map_list self init' t in
|
||||
ok (res, return @@ E_tuple t')
|
||||
)
|
||||
| E_tuple_update {tuple; path; update} -> (
|
||||
let%bind (res, tuple) = self init' tuple in
|
||||
let%bind (res, update) = self res update in
|
||||
ok (res, return @@ E_tuple_update {tuple;path;update})
|
||||
)
|
||||
| E_tuple_accessor {tuple; path} -> (
|
||||
let%bind (res, tuple) = self init' tuple in
|
||||
ok (res, return @@ E_tuple_accessor {tuple; path})
|
||||
)
|
||||
| E_constructor c -> (
|
||||
let%bind (res,e') = self init' c.element in
|
||||
ok (res, return @@ E_constructor {c with element = e'})
|
||||
@ -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 ->
|
||||
match m with
|
||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
||||
let%bind (init, match_nil) = fold_map_expression f init match_nil in
|
||||
let%bind (init, cons) = fold_map_expression f init cons in
|
||||
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) })
|
||||
)
|
||||
| Match_option { match_none ; match_some = (name , some, _) } -> (
|
||||
let%bind (init, match_none) = fold_map_expression f init match_none in
|
||||
let%bind (init, some) = fold_map_expression f init some in
|
||||
ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) })
|
||||
)
|
||||
| Match_tuple ((names , e), _) -> (
|
||||
let%bind (init, e') = fold_map_expression f init e in
|
||||
ok @@ (init, Match_tuple ((names , e'), []))
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
| Match_variant lst -> (
|
||||
let aux init ((a , b) , e) =
|
||||
let%bind (init,e') = fold_map_expression f init e in
|
||||
ok (init, ((a , b) , e'))
|
||||
in
|
||||
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
||||
ok @@ (init, Match_variant (lst', ()))
|
||||
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)
|
||||
else(
|
||||
let free_var = if (List.mem name free_var) then free_var else name::free_var in
|
||||
let expr = O.e_let_in (env,None) false false (O.e_record_update (O.e_variable env) (O.Label (Var.to_name name)) (O.e_variable name)) let_result in
|
||||
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)
|
||||
)
|
||||
| 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_literal _ | E_variable _
|
||||
| E_application _ | E_lambda _| E_recursive _
|
||||
| E_constructor _ | E_record _| E_record_accessor _|E_record_update _
|
||||
| E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _
|
||||
| E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _
|
||||
| E_constructor _ | E_record _| E_accessor _|E_update _
|
||||
| E_ascription _ | E_sequence _ | E_tuple _
|
||||
| E_map _ | E_big_map _ |E_list _ | E_set _
|
||||
-> ok (true, (decl_var, free_var),ass_exp)
|
||||
)
|
||||
(element_names,[])
|
||||
@ -87,8 +87,7 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
|
||||
else(
|
||||
let free_var = if (List.mem name free_var) then free_var else name::free_var in
|
||||
let expr = O.e_let_in (env,None) false false (
|
||||
O.e_record_update (O.e_variable env) (Label "0")
|
||||
(O.e_record_update (O.e_record_accessor (O.e_variable env) (Label "0")) (Label (Var.to_name name)) (O.e_variable name))
|
||||
O.e_update (O.e_variable env) [O.Access_tuple Z.zero; 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)
|
||||
@ -102,9 +101,9 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
|
||||
| E_skip
|
||||
| E_literal _ | E_variable _
|
||||
| E_application _ | E_lambda _| E_recursive _
|
||||
| E_constructor _ | E_record _| E_record_accessor _|E_record_update _
|
||||
| E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _
|
||||
| E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _
|
||||
| E_constructor _ | E_record _| E_accessor _| E_update _
|
||||
| E_ascription _ | E_sequence _ | E_tuple _
|
||||
| E_map _ | E_big_map _ |E_list _ | E_set _
|
||||
-> ok (true, (decl_var, free_var),ass_exp)
|
||||
)
|
||||
(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) =
|
||||
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
|
||||
let ef = List.fold_left aux (fun e -> e) free_vars in
|
||||
fun e -> match e with
|
||||
@ -234,13 +233,15 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
|
||||
) record
|
||||
in
|
||||
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
|
||||
return @@ O.e_record_accessor ~loc record path
|
||||
| I.E_record_update {record;path;update} ->
|
||||
let%bind path = compile_path path in
|
||||
return @@ O.e_accessor ~loc record path
|
||||
| I.E_update {record;path;update} ->
|
||||
let%bind record = compile_expression record in
|
||||
let%bind path = compile_path path 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 ->
|
||||
let%bind map = bind_map_list (
|
||||
bind_map_pair compile_expression
|
||||
@ -259,9 +260,6 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
|
||||
| I.E_set set ->
|
||||
let%bind set = bind_map_list compile_expression set in
|
||||
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} ->
|
||||
let%bind anno_expr = compile_expression anno_expr 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 ->
|
||||
let%bind tuple = bind_map_list compile_expression tuple in
|
||||
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} ->
|
||||
let accessor ?loc s a =
|
||||
match a with
|
||||
I.Access_tuple _i -> failwith "adding tuple soon"
|
||||
| I.Access_record a -> ok @@ O.e_record_accessor ?loc s (Label a)
|
||||
| I.Access_map k ->
|
||||
let%bind k = compile_expression k in
|
||||
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;s]
|
||||
in
|
||||
let update ?loc (s:O.expression) a e =
|
||||
match a with
|
||||
I.Access_tuple _i -> failwith "adding tuple soon"
|
||||
| I.Access_record a -> ok @@ O.e_record_update ?loc s (Label a) e
|
||||
| I.Access_map k ->
|
||||
let%bind k = compile_expression k in
|
||||
ok @@ O.e_constant ?loc C_UPDATE [k;O.e_some (e);s]
|
||||
in
|
||||
let aux (s, e : O.expression * _) lst =
|
||||
let%bind s' = accessor ~loc:s.location s lst in
|
||||
let e' = fun expr ->
|
||||
let%bind u = update ~loc:s.location s lst (expr)
|
||||
in e u
|
||||
in
|
||||
ok @@ (s',e')
|
||||
in
|
||||
let%bind (_,rhs) = bind_fold_list aux (O.e_variable variable, fun e -> ok @@ e) access_path in
|
||||
let%bind access_path = compile_path access_path 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
|
||||
| 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
|
||||
@ -347,6 +314,16 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression)
|
||||
let%bind w = compile_while w in
|
||||
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 =
|
||||
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
|
||||
| I.Match_option {match_none;match_some} ->
|
||||
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 env = Var.fresh () 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 free_vars = List.sort_uniq Var.compare @@ free_vars_none @ free_vars_some in
|
||||
if (List.length free_vars != 0) then
|
||||
let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr,tv)}) in
|
||||
let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr)}) in
|
||||
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 match_expr @@
|
||||
@ -382,10 +359,10 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
|
||||
in
|
||||
ok @@ restore_mutable_variable return_expr free_vars env
|
||||
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} ->
|
||||
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 env = Var.fresh () 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 free_vars = List.sort_uniq Var.compare @@ free_vars_nil @ free_vars_cons in
|
||||
if (List.length free_vars != 0) then
|
||||
let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}) in
|
||||
let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr)}) in
|
||||
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 match_expr @@
|
||||
@ -402,11 +379,8 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
|
||||
in
|
||||
ok @@ restore_mutable_variable return_expr free_vars env
|
||||
else
|
||||
return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)}
|
||||
| I.Match_tuple ((lst,expr), tv) ->
|
||||
let%bind expr = compile_expression expr in
|
||||
return @@ O.e_matching ~loc matchee @@ O.Match_tuple ((lst,expr), tv)
|
||||
| I.Match_variant (lst,tv) ->
|
||||
return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')}
|
||||
| I.Match_variant lst ->
|
||||
let env = Var.fresh () in
|
||||
let aux fv ((c,n),expr) =
|
||||
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
|
||||
if (List.length free_vars == 0) then (
|
||||
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 (
|
||||
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 ->
|
||||
O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@
|
||||
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
|
||||
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} =
|
||||
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 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
|
||||
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
|
||||
@ -459,7 +445,7 @@ and compile_while I.{condition;body} =
|
||||
let return_expr = fun expr ->
|
||||
O.e_let_in let_binder false false init_rec @@
|
||||
O.e_let_in let_binder false false loop @@
|
||||
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label"0")) @@
|
||||
O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.zero]) @@
|
||||
expr
|
||||
in
|
||||
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 ctrl =
|
||||
O.e_let_in (binder,Some (O.t_int ())) false false (O.e_constant C_ADD [ O.e_variable binder ; step ]) @@
|
||||
O.e_let_in (env_rec, None) false false (O.e_record_update (O.e_variable env_rec) (Label "1") @@ O.e_variable binder)@@
|
||||
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
|
||||
in
|
||||
(* 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 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
|
||||
|
||||
(* 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*)
|
||||
let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable env_rec] in
|
||||
let aux_func = O.e_lambda env_rec None None @@
|
||||
O.e_let_in (binder,Some (O.t_int ())) false false (O.e_record_accessor (O.e_variable env_rec) (Label "1")) @@
|
||||
O.e_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
|
||||
|
||||
(* 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 let_binder false false init_rec @@
|
||||
O.e_let_in let_binder false false loop @@
|
||||
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) (Label "0")) @@
|
||||
O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.zero]) @@
|
||||
expr
|
||||
in
|
||||
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 ((_,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%bind collect = compile_expression collection in
|
||||
let aux name expr=
|
||||
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "0")) (Label (Var.to_name name))) expr
|
||||
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
|
||||
let restore = fun expr -> List.fold_right aux free_vars expr in
|
||||
let restore = match collection_type with
|
||||
| Map -> (match snd binder with
|
||||
| Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "1")) (Label "0"))
|
||||
(O.e_let_in (v, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "1")) (Label "1")) expr))
|
||||
| None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) (Label "1")) (Label "0")) expr)
|
||||
| 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_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_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
|
||||
let lambda = O.e_lambda args None None (restore for_body) in
|
||||
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
|
||||
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 ->
|
||||
let return expr = ok @@ I.make_e ~loc:e.location expr in
|
||||
match e.expression_content with
|
||||
O.E_literal lit -> return @@ I.E_literal lit
|
||||
| O.E_constant {cons_name;arguments} ->
|
||||
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}
|
||||
| O.E_variable name -> return @@ I.E_variable name
|
||||
| O.E_application {lamb; args} ->
|
||||
let%bind lamb = uncompile_expression' lamb in
|
||||
let%bind args = uncompile_expression' args in
|
||||
let%bind lamb = uncompile_expression lamb in
|
||||
let%bind args = uncompile_expression args in
|
||||
return @@ I.E_application {lamb; args}
|
||||
| O.E_lambda lambda ->
|
||||
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} ->
|
||||
let (binder,ty_opt) = let_binder in
|
||||
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
|
||||
let%bind rhs = uncompile_expression' rhs in
|
||||
let%bind let_result = uncompile_expression' let_result in
|
||||
let%bind rhs = uncompile_expression rhs in
|
||||
let%bind let_result = uncompile_expression let_result in
|
||||
return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
|
||||
| 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}
|
||||
| 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
|
||||
return @@ I.E_matching {matchee;cases}
|
||||
| O.E_record record ->
|
||||
let record = I.LMap.to_kv_list record in
|
||||
let%bind record =
|
||||
bind_map_list (fun (k,v) ->
|
||||
let%bind v = uncompile_expression' v in
|
||||
let%bind v = uncompile_expression v in
|
||||
ok @@ (k,v)
|
||||
) record
|
||||
in
|
||||
return @@ I.E_record (O.LMap.of_list record)
|
||||
| O.E_record_accessor {record;path} ->
|
||||
let%bind record = uncompile_expression' record in
|
||||
return @@ I.E_record_accessor {record;path}
|
||||
| O.E_record_update {record;path;update} ->
|
||||
let%bind record = uncompile_expression' record in
|
||||
let%bind update = uncompile_expression' update in
|
||||
return @@ I.E_record_update {record;path;update}
|
||||
| O.E_accessor {record;path} ->
|
||||
let%bind record = uncompile_expression record in
|
||||
let%bind path = uncompile_path path in
|
||||
return @@ I.E_accessor {record;path}
|
||||
| O.E_update {record;path;update} ->
|
||||
let%bind record = uncompile_expression record in
|
||||
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 ->
|
||||
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
|
||||
| O.E_tuple_accessor {tuple;path} ->
|
||||
let%bind tuple = uncompile_expression' tuple in
|
||||
return @@ I.E_tuple_accessor {tuple;path}
|
||||
| O.E_tuple_update {tuple;path;update} ->
|
||||
let%bind tuple = uncompile_expression' tuple in
|
||||
let%bind update = uncompile_expression' update in
|
||||
return @@ I.E_tuple_update {tuple;path;update}
|
||||
| O.E_map map ->
|
||||
let%bind map = bind_map_list (
|
||||
bind_map_pair uncompile_expression'
|
||||
bind_map_pair uncompile_expression
|
||||
) map
|
||||
in
|
||||
return @@ I.E_map map
|
||||
| O.E_big_map big_map ->
|
||||
let%bind big_map = bind_map_list (
|
||||
bind_map_pair uncompile_expression'
|
||||
bind_map_pair uncompile_expression
|
||||
) big_map
|
||||
in
|
||||
return @@ I.E_big_map big_map
|
||||
| O.E_list lst ->
|
||||
let%bind lst = bind_map_list uncompile_expression' lst in
|
||||
let%bind lst = bind_map_list uncompile_expression lst in
|
||||
return @@ I.E_list lst
|
||||
| O.E_set set ->
|
||||
let%bind set = bind_map_list uncompile_expression' set in
|
||||
let%bind set = bind_map_list uncompile_expression set in
|
||||
return @@ I.E_set set
|
||||
| O.E_look_up look_up ->
|
||||
let%bind look_up = bind_map_pair uncompile_expression' look_up in
|
||||
return @@ I.E_look_up look_up
|
||||
| O.E_ascription {anno_expr; type_annotation} ->
|
||||
let%bind anno_expr = uncompile_expression' anno_expr in
|
||||
let%bind anno_expr = uncompile_expression anno_expr in
|
||||
let%bind type_annotation = uncompile_type_expression type_annotation in
|
||||
return @@ I.E_ascription {anno_expr; type_annotation}
|
||||
| O.E_cond {condition;then_clause;else_clause} ->
|
||||
let%bind condition = uncompile_expression' condition in
|
||||
let%bind then_clause = uncompile_expression' then_clause in
|
||||
let%bind else_clause = uncompile_expression' else_clause in
|
||||
let%bind condition = uncompile_expression condition in
|
||||
let%bind then_clause = uncompile_expression then_clause in
|
||||
let%bind else_clause = uncompile_expression else_clause in
|
||||
return @@ I.E_cond {condition; then_clause; else_clause}
|
||||
| O.E_sequence {expr1; expr2} ->
|
||||
let%bind expr1 = uncompile_expression' expr1 in
|
||||
let%bind expr2 = uncompile_expression' expr2 in
|
||||
let%bind expr1 = uncompile_expression expr1 in
|
||||
let%bind expr2 = uncompile_expression expr2 in
|
||||
return @@ I.E_sequence {expr1; expr2}
|
||||
| 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 =
|
||||
fun {binder;input_type;output_type;result}->
|
||||
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 result = uncompile_expression' result in
|
||||
let%bind result = uncompile_expression result in
|
||||
ok @@ I.{binder;input_type;output_type;result}
|
||||
and uncompile_matching : O.matching_expr -> I.matching_expr result =
|
||||
fun m ->
|
||||
match m with
|
||||
| O.Match_list {match_nil;match_cons} ->
|
||||
let%bind match_nil = uncompile_expression' match_nil in
|
||||
let (hd,tl,expr,tv) = match_cons in
|
||||
let%bind expr = uncompile_expression' expr in
|
||||
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}
|
||||
let%bind match_nil = uncompile_expression match_nil in
|
||||
let (hd,tl,expr) = match_cons in
|
||||
let%bind expr = uncompile_expression expr in
|
||||
ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr)}
|
||||
| O.Match_option {match_none;match_some} ->
|
||||
let%bind match_none = uncompile_expression' match_none in
|
||||
let (n,expr,tv) = match_some in
|
||||
let%bind expr = uncompile_expression' expr in
|
||||
ok @@ I.Match_option {match_none; match_some=(n,expr,tv)}
|
||||
| O.Match_tuple ((lst,expr), tv) ->
|
||||
let%bind expr = uncompile_expression' expr in
|
||||
ok @@ O.Match_tuple ((lst,expr), tv)
|
||||
| O.Match_variant (lst,tv) ->
|
||||
let%bind match_none = uncompile_expression match_none in
|
||||
let (n,expr) = match_some in
|
||||
let%bind expr = uncompile_expression expr in
|
||||
ok @@ I.Match_option {match_none; match_some=(n,expr)}
|
||||
| O.Match_variant lst ->
|
||||
let%bind lst = bind_map_list (
|
||||
fun ((c,n),expr) ->
|
||||
let%bind expr = uncompile_expression' expr in
|
||||
let%bind expr = uncompile_expression expr in
|
||||
ok @@ ((c,n),expr)
|
||||
) lst
|
||||
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
|
||||
ok res
|
||||
)
|
||||
| E_look_up ab ->
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
ok res
|
||||
| E_application {lamb;args} -> (
|
||||
let ab = (lamb,args) in
|
||||
let%bind res = bind_fold_pair self init' ab in
|
||||
@ -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
|
||||
ok res
|
||||
)
|
||||
| E_record_update {record;update} -> (
|
||||
| E_update {record;path;update} -> (
|
||||
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
|
||||
ok res
|
||||
)
|
||||
| E_record_accessor {record} -> (
|
||||
| E_accessor {record;path} -> (
|
||||
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
|
||||
)
|
||||
| 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
|
||||
ok res
|
||||
)
|
||||
| E_tuple_update {tuple;update} -> (
|
||||
let%bind res = self init' tuple in
|
||||
let%bind res = fold_expression self res update in
|
||||
ok res
|
||||
)
|
||||
| E_tuple_accessor {tuple} -> (
|
||||
let%bind res = self init' tuple in
|
||||
ok res
|
||||
)
|
||||
|
||||
|
||||
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
||||
match m with
|
||||
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
|
||||
let%bind res = fold_expression f init match_nil in
|
||||
let%bind res = fold_expression f res cons in
|
||||
ok res
|
||||
)
|
||||
| Match_option { match_none ; match_some = (_ , some, _) } -> (
|
||||
let%bind res = fold_expression f init match_none in
|
||||
let%bind res = fold_expression f res some in
|
||||
ok res
|
||||
)
|
||||
| Match_tuple ((_ , e), _) -> (
|
||||
let%bind res = fold_expression f init e in
|
||||
ok res
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
| Match_variant lst -> (
|
||||
let aux init' ((_ , _) , e) =
|
||||
let%bind res' = fold_expression f init' e in
|
||||
ok res' in
|
||||
let%bind res = bind_fold_list aux init lst in
|
||||
ok res
|
||||
)
|
||||
| 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 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
|
||||
return @@ E_big_map lst'
|
||||
)
|
||||
| E_look_up ab -> (
|
||||
let%bind ab' = bind_map_pair self ab in
|
||||
return @@ E_look_up ab'
|
||||
)
|
||||
| E_ascription ascr -> (
|
||||
let%bind e' = self ascr.anno_expr in
|
||||
return @@ E_ascription {ascr with anno_expr=e'}
|
||||
@ -164,18 +165,32 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
||||
let%bind cases' = map_cases f cases in
|
||||
return @@ E_matching {matchee=e';cases=cases'}
|
||||
)
|
||||
| E_record_accessor acc -> (
|
||||
let%bind e' = self acc.record in
|
||||
return @@ E_record_accessor {acc with record = e'}
|
||||
)
|
||||
| E_record m -> (
|
||||
let%bind m' = bind_map_lmap self m in
|
||||
return @@ E_record m'
|
||||
)
|
||||
| E_record_update {record; path; update} -> (
|
||||
| E_accessor {record; path} -> (
|
||||
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
|
||||
return @@ E_record_update {record;path;update}
|
||||
return @@ E_update {record;path;update}
|
||||
)
|
||||
| E_constructor c -> (
|
||||
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
|
||||
return @@ E_tuple t'
|
||||
)
|
||||
| E_tuple_update {tuple; path; update} -> (
|
||||
let%bind tuple = self tuple in
|
||||
let%bind update = self update in
|
||||
return @@ E_tuple_update {tuple; path; update}
|
||||
)
|
||||
| E_tuple_accessor {tuple;path} -> (
|
||||
let%bind tuple = self tuple in
|
||||
return @@ E_tuple_accessor {tuple;path}
|
||||
)
|
||||
| E_literal _ | E_variable _ | E_skip as e' -> return e'
|
||||
|
||||
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
|
||||
@ -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 ->
|
||||
match m with
|
||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
||||
let%bind match_nil = map_expression f match_nil in
|
||||
let%bind cons = map_expression f cons in
|
||||
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }
|
||||
)
|
||||
| Match_option { match_none ; match_some = (name , some, _) } -> (
|
||||
let%bind match_none = map_expression f match_none in
|
||||
let%bind some = map_expression f some in
|
||||
ok @@ Match_option { match_none ; match_some = (name , some, ()) }
|
||||
)
|
||||
| Match_tuple ((names , e), _) -> (
|
||||
let%bind e' = map_expression f e in
|
||||
ok @@ Match_tuple ((names , e'), [])
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
| Match_variant lst -> (
|
||||
let aux ((a , b) , e) =
|
||||
let%bind e' = map_expression f e in
|
||||
ok ((a , b) , e')
|
||||
in
|
||||
let%bind lst' = bind_map_list aux lst in
|
||||
ok @@ Match_variant (lst', ())
|
||||
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 ->
|
||||
@ -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
|
||||
ok (res, return @@ E_big_map lst')
|
||||
)
|
||||
| E_look_up ab -> (
|
||||
let%bind (res, ab') = bind_fold_map_pair self init' ab in
|
||||
ok (res, return @@ E_look_up ab')
|
||||
)
|
||||
| E_ascription ascr -> (
|
||||
let%bind (res,e') = self init' ascr.anno_expr in
|
||||
ok (res, return @@ E_ascription {ascr with anno_expr=e'})
|
||||
@ -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
|
||||
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
||||
)
|
||||
| E_record_accessor acc -> (
|
||||
let%bind (res, e') = self init' acc.record in
|
||||
ok (res, return @@ E_record_accessor {acc with record = e'})
|
||||
)
|
||||
| E_record m -> (
|
||||
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
||||
let m' = LMap.of_list lst' in
|
||||
ok (res, return @@ E_record m')
|
||||
)
|
||||
| E_record_update {record; path; update} -> (
|
||||
| E_accessor {record;path} -> (
|
||||
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
|
||||
ok (res, return @@ E_record_update {record;path;update})
|
||||
ok (res, return @@ E_update {record;path;update})
|
||||
)
|
||||
| E_tuple t -> (
|
||||
let%bind (res, t') = bind_fold_map_list self init' t in
|
||||
ok (res, return @@ E_tuple t')
|
||||
)
|
||||
| E_tuple_update {tuple; path; update} -> (
|
||||
let%bind (res, tuple) = self init' tuple in
|
||||
let%bind (res, update) = self res update in
|
||||
ok (res, return @@ E_tuple_update {tuple;path;update})
|
||||
)
|
||||
| E_tuple_accessor {tuple; path} -> (
|
||||
let%bind (res, tuple) = self init' tuple in
|
||||
ok (res, return @@ E_tuple_accessor {tuple; path})
|
||||
)
|
||||
| E_constructor c -> (
|
||||
let%bind (res,e') = self init' c.element in
|
||||
ok (res, return @@ E_constructor {c with element = e'})
|
||||
@ -389,28 +404,35 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
||||
ok (res, return @@ E_sequence {expr1;expr2})
|
||||
)
|
||||
| E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e')
|
||||
|
||||
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
|
||||
match m with
|
||||
| Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> (
|
||||
let%bind (init, match_nil) = fold_map_expression f init match_nil in
|
||||
let%bind (init, cons) = fold_map_expression f init cons in
|
||||
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) })
|
||||
)
|
||||
| Match_option { match_none ; match_some = (name , some, _) } -> (
|
||||
let%bind (init, match_none) = fold_map_expression f init match_none in
|
||||
let%bind (init, some) = fold_map_expression f init some in
|
||||
ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) })
|
||||
)
|
||||
| Match_tuple ((names , e), _) -> (
|
||||
let%bind (init, e') = fold_map_expression f init e in
|
||||
ok @@ (init, Match_tuple ((names , e'), []))
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
| Match_variant lst -> (
|
||||
let aux init ((a , b) , e) =
|
||||
let%bind (init,e') = fold_map_expression f init e in
|
||||
ok (init, ((a , b) , e'))
|
||||
in
|
||||
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
||||
ok @@ (init, Match_variant (lst', ()))
|
||||
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
|
||||
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 ->
|
||||
let return tc = ok @@ O.make_t ~loc:te.location tc in
|
||||
match te.type_content with
|
||||
@ -11,7 +11,7 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
|
||||
let%bind sum =
|
||||
bind_map_list (fun (k,v) ->
|
||||
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
|
||||
ok @@ (k,v')
|
||||
) sum
|
||||
@ -22,7 +22,7 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
|
||||
let%bind record =
|
||||
bind_map_list (fun (k,v) ->
|
||||
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
|
||||
ok @@ (k,v')
|
||||
) 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)
|
||||
| I.T_tuple tuple ->
|
||||
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
|
||||
let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in
|
||||
let record = O.LMap.of_list lst in
|
||||
return @@ O.T_record record
|
||||
| I.T_arrow {type1;type2} ->
|
||||
let%bind type1 = idle_type_expression type1 in
|
||||
let%bind type2 = idle_type_expression type2 in
|
||||
let%bind type1 = compile_type_expression type1 in
|
||||
let%bind type2 = compile_type_expression type2 in
|
||||
return @@ T_arrow {type1;type2}
|
||||
| I.T_variable type_variable -> return @@ T_variable type_variable
|
||||
| I.T_constant type_constant -> return @@ T_constant type_constant
|
||||
| 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)
|
||||
|
||||
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
|
||||
return @@ O.E_lambda 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
|
||||
return @@ O.E_recursive {fun_name;fun_type;lambda}
|
||||
| I.E_let_in {let_binder;inline;rhs;let_result} ->
|
||||
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 let_result = compile_expression let_result in
|
||||
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}
|
||||
| I.E_matching {matchee; cases} ->
|
||||
let%bind matchee = compile_expression matchee in
|
||||
let%bind cases = compile_matching cases in
|
||||
return @@ O.E_matching {matchee;cases}
|
||||
compile_matching e.location matchee cases
|
||||
| I.E_record record ->
|
||||
let record = I.LMap.to_kv_list record in
|
||||
let%bind record =
|
||||
@ -87,13 +86,46 @@ let rec compile_expression : I.expression -> O.expression result =
|
||||
) record
|
||||
in
|
||||
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
|
||||
return @@ O.E_record_accessor {record;path}
|
||||
| I.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
|
||||
bind_fold_list accessor record path
|
||||
| I.E_update {record;path;update} ->
|
||||
let%bind record = compile_expression record in
|
||||
let%bind update = compile_expression update in
|
||||
return @@ O.E_record_update {record;path;update}
|
||||
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 -> (
|
||||
let map = List.sort_uniq compare map in
|
||||
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
|
||||
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} ->
|
||||
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}
|
||||
| I.E_cond {condition; then_clause; else_clause} ->
|
||||
let%bind matchee = compile_expression condition in
|
||||
let%bind match_true = compile_expression then_clause in
|
||||
let%bind match_false = compile_expression else_clause in
|
||||
return @@ O.E_matching {matchee; cases=Match_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} ->
|
||||
let%bind expr1 = compile_expression expr1 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 m = O.LMap.of_list lst in
|
||||
return @@ O.E_record m
|
||||
| I.E_tuple_accessor {tuple;path} ->
|
||||
let%bind record = compile_expression tuple in
|
||||
let path = O.Label (string_of_int path) in
|
||||
return @@ O.E_record_accessor {record;path}
|
||||
| I.E_tuple_update {tuple;path;update} ->
|
||||
let%bind record = compile_expression tuple in
|
||||
let path = O.Label (string_of_int path) in
|
||||
let%bind update = compile_expression update in
|
||||
return @@ O.E_record_update {record;path;update}
|
||||
|
||||
and compile_lambda : I.lambda -> O.lambda result =
|
||||
fun {binder;input_type;output_type;result}->
|
||||
let%bind input_type = bind_map_option idle_type_expression input_type in
|
||||
let%bind output_type = bind_map_option idle_type_expression output_type in
|
||||
let%bind input_type = bind_map_option compile_type_expression input_type in
|
||||
let%bind output_type = bind_map_option compile_type_expression output_type in
|
||||
let%bind result = compile_expression result in
|
||||
ok @@ O.{binder;input_type;output_type;result}
|
||||
and compile_matching : I.matching_expr -> O.matching_expr result =
|
||||
fun m ->
|
||||
and compile_matching : Location.t -> O.expression -> I.matching_expr -> O.expression result =
|
||||
fun loc e m ->
|
||||
match m with
|
||||
| I.Match_list {match_nil;match_cons} ->
|
||||
let%bind match_nil = compile_expression match_nil in
|
||||
let (hd,tl,expr,tv) = match_cons in
|
||||
let (hd,tl,expr) = match_cons 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} ->
|
||||
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
|
||||
ok @@ O.Match_option {match_none; match_some=(n,expr,tv)}
|
||||
| I.Match_tuple ((lst,expr), tv) ->
|
||||
let%bind expr = compile_expression expr in
|
||||
ok @@ O.Match_tuple ((lst,expr), tv)
|
||||
| I.Match_variant (lst,tv) ->
|
||||
ok @@ O.e_matching ~loc e @@ O.Match_option {match_none; match_some=(n,expr)}
|
||||
| I.Match_variant lst ->
|
||||
let%bind lst = bind_map_list (
|
||||
fun ((c,n),expr) ->
|
||||
let%bind expr = compile_expression expr in
|
||||
ok @@ ((c,n),expr)
|
||||
) lst
|
||||
in
|
||||
ok @@ O.Match_variant (lst,tv)
|
||||
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 -> _ =
|
||||
fun {wrap_content=declaration;location} ->
|
||||
@ -197,10 +251,10 @@ let compile_declaration : I.declaration Location.wrap -> _ =
|
||||
match declaration with
|
||||
| I.Declaration_constant (n, te_opt, inline, expr) ->
|
||||
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)
|
||||
| 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)
|
||||
|
||||
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)
|
||||
| O.E_record_accessor {record;path} ->
|
||||
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} ->
|
||||
let%bind record = uncompile_expression record 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} ->
|
||||
let%bind anno_expr = uncompile_expression anno_expr 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
|
||||
| O.Match_list {match_nil;match_cons} ->
|
||||
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
|
||||
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} ->
|
||||
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
|
||||
ok @@ I.Match_option {match_none; match_some=(n,expr,tv)}
|
||||
| O.Match_tuple ((lst,expr), tv) ->
|
||||
let%bind expr = uncompile_expression expr in
|
||||
ok @@ O.Match_tuple ((lst,expr), tv)
|
||||
| O.Match_variant (lst,tv) ->
|
||||
ok @@ I.Match_option {match_none; match_some=(n,expr)}
|
||||
| O.Match_variant lst ->
|
||||
let%bind lst = bind_map_list (
|
||||
fun ((c,n),expr) ->
|
||||
let%bind expr = uncompile_expression expr in
|
||||
ok @@ ((c,n),expr)
|
||||
) lst
|
||||
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 ->
|
||||
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 res cons in
|
||||
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 res some in
|
||||
ok res
|
||||
)
|
||||
| Match_tuple ((_ , e), _) -> (
|
||||
let%bind res = fold_expression f init e in
|
||||
ok res
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
| Match_variant lst -> (
|
||||
let aux init' ((_ , _) , e) =
|
||||
let%bind res' = fold_expression f init' e 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 ->
|
||||
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 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 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), _) -> (
|
||||
let%bind e' = map_expression f e in
|
||||
ok @@ Match_tuple ((names , e'), [])
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
| Match_variant lst -> (
|
||||
let aux ((a , b) , e) =
|
||||
let%bind e' = map_expression f e in
|
||||
ok ((a , b) , e')
|
||||
in
|
||||
let%bind lst' = bind_map_list aux lst in
|
||||
ok @@ Match_variant (lst', ())
|
||||
ok @@ Match_variant lst'
|
||||
)
|
||||
|
||||
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 ->
|
||||
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, 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, 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), _) -> (
|
||||
let%bind (init, e') = fold_map_expression f init e in
|
||||
ok @@ (init, Match_tuple ((names , e'), []))
|
||||
)
|
||||
| Match_variant (lst, _) -> (
|
||||
| Match_variant lst -> (
|
||||
let aux init ((a , b) , e) =
|
||||
let%bind (init,e') = fold_map_expression f init e in
|
||||
ok (init, ((a , b) , e'))
|
||||
in
|
||||
let%bind (init,lst') = bind_fold_map_list aux init lst in
|
||||
ok @@ (init, Match_variant (lst', ()))
|
||||
ok @@ (init, Match_variant lst')
|
||||
)
|
||||
|
||||
@ -3,6 +3,7 @@ module O = Ast_typed
|
||||
|
||||
let convert_constructor' (I.Constructor c) = O.Constructor c
|
||||
let convert_label (I.Label c) = O.Label c
|
||||
|
||||
let convert_type_constant : I.type_constant -> O.type_constant = function
|
||||
| TC_unit -> TC_unit
|
||||
| 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)
|
||||
@@ get_t_option t 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%bind (body , state'') = type_expression e' state' b in
|
||||
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)
|
||||
@@ get_t_list t 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 tl t e' 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'')
|
||||
| Match_tuple ((vars, b),_) ->
|
||||
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,_) ->
|
||||
| Match_variant lst ->
|
||||
let%bind variant_opt =
|
||||
let aux acc ((constructor_name , _) , _) =
|
||||
let%bind (_ , variant) =
|
||||
@ -362,7 +351,6 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression
|
||||
match cur with
|
||||
| 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_tuple { vars=_ ; body ; tvs=_ } -> [ body ]
|
||||
| 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
|
||||
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')
|
||||
| E_record_accessor {record; path} ->
|
||||
let%bind r' = untype_expression record in
|
||||
let Label s = path in
|
||||
return (e_record_accessor r' s)
|
||||
let Label path = path in
|
||||
return (e_record_accessor r' (Label path))
|
||||
| E_record_update {record; path; update} ->
|
||||
let%bind r' = untype_expression record 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 ->
|
||||
let open I in
|
||||
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=_}} ->
|
||||
let%bind match_none = f match_none 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}
|
||||
| Match_list {match_nil ; match_cons = {hd;tl;body;tv=_}} ->
|
||||
let%bind match_nil = f match_nil 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}
|
||||
| Match_variant { cases ; tv=_ } ->
|
||||
let aux ({constructor;pattern;body} : O.matching_content_case) =
|
||||
let%bind body = f body in
|
||||
ok ((unconvert_constructor' constructor,pattern),body) 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
|
||||
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? *)
|
||||
let program_error (p:I.program) () =
|
||||
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)
|
||||
@@ get_t_option t 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%bind body = f e' b in
|
||||
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)
|
||||
@@ get_t_list t 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 tl t e' in
|
||||
let%bind body = f e' b in
|
||||
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
|
||||
| Match_tuple ((vars, b),_) ->
|
||||
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,_) ->
|
||||
| Match_variant lst ->
|
||||
let%bind variant_cases' =
|
||||
trace (match_error ~expected:i ~actual:t loc)
|
||||
@@ 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_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_tuple {vars=_;body;tvs=_} -> [ body ]
|
||||
| Match_variant {cases; tv=_} -> List.map (fun (c : O.matching_content_case) -> c.body) cases in
|
||||
List.map get_type_expression @@ aux m' in
|
||||
let aux prec cur =
|
||||
@ -1081,7 +1058,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
||||
| E_record_accessor {record; path} ->
|
||||
let%bind r' = untype_expression record 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} ->
|
||||
let%bind r' = untype_expression r 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 ->
|
||||
let open I in
|
||||
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=_}} ->
|
||||
let%bind match_none = f match_none 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}
|
||||
| Match_list {match_nil ; match_cons = {hd ; tl ; body ; tv=_}} ->
|
||||
let%bind match_nil = f match_nil 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}
|
||||
| Match_variant {cases;tv=_} ->
|
||||
let aux ({constructor;pattern;body} : O.matching_content_case) =
|
||||
let%bind c' = f body in
|
||||
ok ((unconvert_constructor' constructor,pattern),c') 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
|
||||
ok res
|
||||
)
|
||||
| Match_tuple {vars=_ ; body; tvs=_} -> (
|
||||
let%bind res = fold_expression f init body in
|
||||
ok res
|
||||
)
|
||||
| Match_variant {cases;tv=_} -> (
|
||||
let aux init' {constructor=_; pattern=_ ; body} =
|
||||
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
|
||||
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} -> (
|
||||
let aux { constructor ; pattern ; body } =
|
||||
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
|
||||
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} -> (
|
||||
let aux init {constructor ; pattern ; body} =
|
||||
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 body in
|
||||
ok ()
|
||||
| Match_tuple {vars=_;body;tvs=_} ->
|
||||
let%bind _ = check_recursive_call n final_path body in
|
||||
ok ()
|
||||
| Match_variant {cases;tv=_} ->
|
||||
let aux {constructor=_; pattern=_; body} =
|
||||
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
|
||||
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 title () = "not functional main" 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") @@
|
||||
aux expr' tree''
|
||||
)
|
||||
| AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location
|
||||
)
|
||||
|
||||
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") @@
|
||||
aux expr tree''
|
||||
)
|
||||
| AST.Match_tuple _ -> failwith "match_tuple not supported"
|
||||
in
|
||||
let%bind fun_type = transpile_type 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
|
||||
| E_record m ->
|
||||
fprintf ppf "{%a}" (record_sep expression (const ";")) m
|
||||
| E_record_accessor ra ->
|
||||
fprintf ppf "%a.%a" expression ra.record label ra.path
|
||||
| E_record_update {record; path; update} ->
|
||||
fprintf ppf "{ %a with %a = %a }" expression record label path expression update
|
||||
| E_accessor {record;path} ->
|
||||
fprintf ppf "%a.%a" expression record (list_sep accessor (const ".")) path
|
||||
| E_update {record; path; update} ->
|
||||
fprintf ppf "{ %a with %a = %a }" expression record (list_sep accessor (const ".")) path expression update
|
||||
| E_map m ->
|
||||
fprintf ppf "map[%a]" (list_sep_d assoc_expression) 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
|
||||
| E_set lst ->
|
||||
fprintf ppf "set[%a]" (list_sep_d expression) lst
|
||||
| E_look_up (ds, ind) ->
|
||||
fprintf ppf "(%a)[%a]" expression ds expression ind
|
||||
| E_lambda {binder; input_type; output_type; result} ->
|
||||
fprintf ppf "lambda (%a:%a) : %a return %a"
|
||||
expression_variable binder
|
||||
@ -129,14 +127,10 @@ and expression_content ppf (ec : expression_content) =
|
||||
fprintf ppf "skip"
|
||||
| E_tuple t ->
|
||||
fprintf ppf "(%a)" (list_sep_d expression) t
|
||||
| E_tuple_accessor ta ->
|
||||
fprintf ppf "%a.%d" expression ta.tuple ta.path
|
||||
| E_tuple_update {tuple; path; update} ->
|
||||
fprintf ppf "{ %a with %d = %a }" expression tuple path expression update
|
||||
| E_assign {variable; access_path; expression=e} ->
|
||||
fprintf ppf "%a%a := %a"
|
||||
expression_variable variable
|
||||
(list_sep (fun ppf a -> fprintf ppf ".%a" accessor a) (fun ppf () -> fprintf ppf "")) access_path
|
||||
(list_sep accessor (const ".")) access_path
|
||||
expression e
|
||||
| E_for {binder; start; final; increment; body} ->
|
||||
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 =
|
||||
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_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) ->
|
||||
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
|
||||
| Match_tuple ((lst, b), _) ->
|
||||
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
|
||||
| Match_variant (lst, _) ->
|
||||
| Match_variant lst ->
|
||||
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
|
||||
| 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
|
||||
| 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
|
||||
| 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 *)
|
||||
and matching_type ppf m = match m with
|
||||
| Match_tuple _ ->
|
||||
fprintf ppf "tuple"
|
||||
| Match_variant (lst, _) ->
|
||||
| Match_variant lst ->
|
||||
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
|
||||
| Match_list _ ->
|
||||
fprintf ppf "list"
|
||||
| Match_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) =
|
||||
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_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b}
|
||||
|
||||
let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = Label b}
|
||||
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b
|
||||
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path=Label path; update}
|
||||
let e_accessor ?loc record path = make_e ?loc @@ E_accessor {record; path}
|
||||
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_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst
|
||||
let e_tuple_accessor ?loc tuple path : expression = make_e ?loc @@ E_tuple_accessor {tuple; path}
|
||||
let e_tuple_update ?loc tuple path update : expression = make_e ?loc @@ E_tuple_update {tuple; path; update}
|
||||
|
||||
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
|
||||
let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause}
|
||||
@ -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_map ?loc lst : expression = make_e ?loc @@ E_map lst
|
||||
let e_big_map ?loc lst : expression = make_e ?loc @@ E_big_map lst
|
||||
let e_look_up ?loc x y = make_e ?loc @@ E_look_up (x , y)
|
||||
|
||||
let e_while ?loc condition body = make_e ?loc @@ E_while {condition; body}
|
||||
let e_for ?loc binder start final increment body = make_e ?loc @@ E_for {binder;start;final;increment;body}
|
||||
@ -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 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) =
|
||||
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 map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in
|
||||
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 =
|
||||
make_e ?loc @@ E_assign {variable;access_path;expression}
|
||||
let e_ez_assign ?loc variable access_path expression =
|
||||
let variable = Var.of_name variable in
|
||||
let access_path = List.map (fun s -> Access_record s) access_path in
|
||||
e_assign ?loc variable access_path expression
|
||||
|
||||
let get_e_accessor = fun t ->
|
||||
match t with
|
||||
| E_record_accessor {record; path} -> ok (record , path)
|
||||
| E_accessor {record; path} -> ok (record , path)
|
||||
| _ -> simple_fail "not an accessor"
|
||||
|
||||
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_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_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_ez : ?loc:Location.t -> ( string * expr ) list -> expression
|
||||
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
|
||||
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
|
||||
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
||||
val e_accessor : ?loc:Location.t -> expression -> access list -> expression
|
||||
val e_update : ?loc:Location.t -> expression -> access list -> expression -> expression
|
||||
|
||||
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
||||
|
||||
val e_tuple : ?loc:Location.t -> expression list -> expression
|
||||
val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression
|
||||
val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression
|
||||
val e_pair : ?loc:Location.t -> expression -> expression -> expression
|
||||
|
||||
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||
@ -122,10 +122,8 @@ val e_list : ?loc:Location.t -> expression list -> expression
|
||||
val e_set : ?loc:Location.t -> expression list -> expression
|
||||
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
||||
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
||||
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
|
||||
|
||||
val e_assign : ?loc:Location.t -> expression_variable -> access list -> expression -> expression
|
||||
val e_ez_assign : ?loc:Location.t -> string -> string list -> expression -> expression
|
||||
|
||||
val e_while : ?loc:Location.t -> expression -> expression -> expression
|
||||
val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression
|
||||
|
||||
@ -53,8 +53,8 @@ and expression_content =
|
||||
| E_matching of matching
|
||||
(* Record *)
|
||||
| E_record of expression label_map
|
||||
| E_record_accessor of record_accessor
|
||||
| E_record_update of record_update
|
||||
| E_accessor of accessor
|
||||
| E_update of update
|
||||
(* Advanced *)
|
||||
| E_ascription of ascription
|
||||
(* Sugar *)
|
||||
@ -62,14 +62,11 @@ and expression_content =
|
||||
| E_sequence of sequence
|
||||
| E_skip
|
||||
| E_tuple of expression list
|
||||
| E_tuple_accessor of tuple_accessor
|
||||
| E_tuple_update of tuple_update
|
||||
(* Data Structures *)
|
||||
| E_map of (expression * expression) list
|
||||
| E_big_map of (expression * expression) list
|
||||
| E_list of expression list
|
||||
| E_set of expression list
|
||||
| E_look_up of (expression * expression)
|
||||
(* Imperative *)
|
||||
| E_assign of assign
|
||||
| E_for of for_
|
||||
@ -105,12 +102,25 @@ and let_in =
|
||||
|
||||
and constructor = {constructor: constructor'; element: expression}
|
||||
|
||||
and record_accessor = {record: expression; path: label}
|
||||
and record_update = {record: expression; path: label ; update: expression}
|
||||
and accessor = {record: expression; path: access list}
|
||||
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 =
|
||||
{ matchee: expression
|
||||
; cases: matching_expr
|
||||
@ -129,9 +139,6 @@ and sequence = {
|
||||
expr2: expression ;
|
||||
}
|
||||
|
||||
and tuple_accessor = {tuple: expression; path: int}
|
||||
and tuple_update = {tuple: expression; path: int ; update: expression}
|
||||
|
||||
and assign = {
|
||||
variable : expression_variable;
|
||||
access_path : access list;
|
||||
@ -139,7 +146,7 @@ and assign = {
|
||||
}
|
||||
|
||||
and access =
|
||||
| Access_tuple of int
|
||||
| Access_tuple of Z.t
|
||||
| Access_record of string
|
||||
| Access_map of expr
|
||||
|
||||
|
||||
@ -78,10 +78,10 @@ and expression_content ppf (ec : expression_content) =
|
||||
c.arguments
|
||||
| E_record m ->
|
||||
fprintf ppf "{%a}" (record_sep_expr expression (const ";")) m
|
||||
| E_record_accessor ra ->
|
||||
fprintf ppf "%a.%a" expression ra.record label ra.path
|
||||
| E_record_update {record; path; update} ->
|
||||
fprintf ppf "{ %a with %a = %a }" expression record label path expression update
|
||||
| E_accessor {record;path} ->
|
||||
fprintf ppf "%a.%a" expression record (list_sep accessor (const ".")) path
|
||||
| E_update {record; path; update} ->
|
||||
fprintf ppf "{ %a with %a = %a }" expression record (list_sep accessor (const ".")) path expression update
|
||||
| E_map m ->
|
||||
fprintf ppf "map[%a]" (list_sep_d assoc_expression) 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
|
||||
| E_set lst ->
|
||||
fprintf ppf "set[%a]" (list_sep_d expression) lst
|
||||
| E_look_up (ds, ind) ->
|
||||
fprintf ppf "(%a)[%a]" expression ds expression ind
|
||||
| E_lambda {binder; input_type; output_type; result} ->
|
||||
fprintf ppf "lambda (%a:%a) : %a return %a"
|
||||
expression_variable binder
|
||||
@ -127,10 +125,12 @@ and expression_content ppf (ec : expression_content) =
|
||||
fprintf ppf "skip"
|
||||
| E_tuple t ->
|
||||
fprintf ppf "(%a)" (list_sep_d expression) t
|
||||
| E_tuple_accessor ta ->
|
||||
fprintf ppf "%a.%d" expression ta.tuple ta.path
|
||||
| E_tuple_update {tuple; path; update} ->
|
||||
fprintf ppf "{ %a with %d = %a }" expression tuple path expression update
|
||||
|
||||
and accessor ppf a =
|
||||
match a with
|
||||
| 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
|
||||
((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) ->
|
||||
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
|
||||
| Match_tuple ((lst, b), _) ->
|
||||
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
|
||||
| Match_variant (lst, _) ->
|
||||
| Match_variant lst ->
|
||||
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
|
||||
| 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
|
||||
| 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
|
||||
| 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 *)
|
||||
and matching_type ppf m = match m with
|
||||
| Match_tuple _ ->
|
||||
fprintf ppf "tuple"
|
||||
| Match_variant (lst, _) ->
|
||||
| Match_variant lst ->
|
||||
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
|
||||
| Match_list _ ->
|
||||
fprintf ppf "list"
|
||||
| Match_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) =
|
||||
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_record ?loc map : expression = make_e ?loc @@ E_record map
|
||||
let e_record_accessor ?loc record path = make_e ?loc @@ E_record_accessor {record; path}
|
||||
let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update}
|
||||
let e_accessor ?loc record path = make_e ?loc @@ E_accessor {record; path}
|
||||
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_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst
|
||||
let e_tuple_accessor ?loc tuple path = make_e ?loc @@ E_tuple_accessor {tuple; path}
|
||||
let e_tuple_update ?loc tuple path update = make_e ?loc @@ E_tuple_update {tuple; path; update}
|
||||
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
|
||||
|
||||
let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause}
|
||||
@ -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_map ?loc lst : expression = make_e ?loc @@ E_map lst
|
||||
let e_big_map ?loc lst : expression = make_e ?loc @@ E_big_map lst
|
||||
let e_look_up ?loc a b : expression = make_e ?loc @@ E_look_up (a,b)
|
||||
|
||||
let 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
|
||||
| E_record_accessor {record; path} -> ok (record, path)
|
||||
| E_accessor {record; path} -> ok (record, path)
|
||||
| _ -> simple_fail "not a record accessor"
|
||||
|
||||
let assert_e_accessor = fun t ->
|
||||
let%bind _ = get_e_record_accessor t in
|
||||
let%bind _ = get_e_accessor t in
|
||||
ok ()
|
||||
|
||||
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_record : ?loc:Location.t -> expr label_map -> expression
|
||||
val e_record_accessor : ?loc:Location.t -> expression -> label -> expression
|
||||
val e_record_update : ?loc:Location.t -> expression -> label -> expression -> expression
|
||||
val e_accessor : ?loc:Location.t -> expression -> access list -> expression
|
||||
val e_update : ?loc:Location.t -> expression -> access list -> expression -> expression
|
||||
|
||||
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
||||
|
||||
val e_tuple : ?loc:Location.t -> expression list -> expression
|
||||
val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression
|
||||
val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression
|
||||
val e_pair : ?loc:Location.t -> expression -> expression -> expression
|
||||
|
||||
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||
@ -97,7 +95,6 @@ val e_list : ?loc:Location.t -> expression list -> expression
|
||||
val e_set : ?loc:Location.t -> expression list -> expression
|
||||
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
||||
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
||||
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
|
||||
|
||||
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
||||
|
||||
|
||||
@ -54,8 +54,8 @@ and expression_content =
|
||||
| E_matching of matching
|
||||
(* Record *)
|
||||
| E_record of expression label_map
|
||||
| E_record_accessor of record_accessor
|
||||
| E_record_update of record_update
|
||||
| E_accessor of accessor
|
||||
| E_update of update
|
||||
(* Advanced *)
|
||||
| E_ascription of ascription
|
||||
(* Sugar *)
|
||||
@ -63,14 +63,11 @@ and expression_content =
|
||||
| E_sequence of sequence
|
||||
| E_skip
|
||||
| E_tuple of expression list
|
||||
| E_tuple_accessor of tuple_accessor
|
||||
| E_tuple_update of tuple_update
|
||||
(* Data Structures *)
|
||||
| E_map of (expression * expression) list
|
||||
| E_big_map of (expression * expression) list
|
||||
| E_list of expression list
|
||||
| E_set of expression list
|
||||
| E_look_up of (expression * expression)
|
||||
|
||||
and constant =
|
||||
{ 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 record_accessor = {record: expression; path: label}
|
||||
and record_update = {record: expression; path: label ; update: expression}
|
||||
and accessor = {record: expression; path: access list}
|
||||
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 =
|
||||
{ matchee: expression
|
||||
; cases: matching_expr
|
||||
@ -124,9 +139,6 @@ and sequence = {
|
||||
expr2: expression ;
|
||||
}
|
||||
|
||||
and tuple_accessor = {tuple: expression; path: int}
|
||||
and tuple_update = {tuple: expression; path: int ; update: expression}
|
||||
|
||||
and environment_element_definition =
|
||||
| ED_binder
|
||||
| ED_declaration of (expression * free_variables)
|
||||
|
||||
@ -66,26 +66,22 @@ and assoc_expression ppf : expr * expr -> unit =
|
||||
and single_record_patch ppf ((p, expr) : label * expr) =
|
||||
fprintf ppf "%a <- %a" label p expression expr
|
||||
|
||||
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
|
||||
and matching_variant_case : (_ -> expression -> unit) -> _ -> (constructor' * expression_variable) * expression -> unit =
|
||||
fun f ppf ((c,n),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
|
||||
| Match_tuple ((lst, b), _) ->
|
||||
fprintf ppf "@[<hv>| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b
|
||||
| Match_variant (lst, _) ->
|
||||
| Match_variant 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
|
||||
| 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
|
||||
|
||||
(* Shows the type expected for the matched value *)
|
||||
and matching_type ppf m = match m with
|
||||
| Match_tuple _ ->
|
||||
fprintf ppf "tuple"
|
||||
| Match_variant (lst, _) ->
|
||||
| Match_variant lst ->
|
||||
fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
|
||||
| Match_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_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_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_constructor : ?loc:Location.t -> string -> expression -> 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_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> 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_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 =
|
||||
{ matchee: expression
|
||||
; 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
|
||||
|
||||
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=_} ->
|
||||
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) cases
|
||||
| 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 type_expression_list = type_expression list
|
||||
|
||||
and matching_content_tuple = {
|
||||
vars : expression_variable_list ;
|
||||
body : expression ;
|
||||
tvs : type_expression_list ;
|
||||
}
|
||||
|
||||
and matching_content_case = {
|
||||
constructor : constructor' ;
|
||||
pattern : expression_variable ;
|
||||
@ -146,7 +140,6 @@ and matching_content_variant = {
|
||||
and matching_expr =
|
||||
| Match_list of matching_content_list
|
||||
| Match_option of matching_content_option
|
||||
| Match_tuple of matching_content_tuple
|
||||
| Match_variant of matching_content_variant
|
||||
|
||||
and constant' =
|
||||
|
||||
@ -92,21 +92,6 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs ->
|
||||
in
|
||||
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 -> (
|
||||
let variant_type = Combinators.get_t_sum_exn c.tv in
|
||||
let cases =
|
||||
|
||||
@ -236,8 +236,6 @@ module Free_variables = struct
|
||||
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_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
|
||||
|
||||
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 s' = f (union (singleton opt) b) body in
|
||||
ok @@ union n' s'
|
||||
| Match_tuple { vars ; body ; tvs=_ } ->
|
||||
f (union (of_list vars) b) body
|
||||
| Match_variant { cases ; tv=_ } ->
|
||||
let%bind lst' = bind_map_list (matching_variant_case f b) cases in
|
||||
ok @@ unions lst'
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
include Types
|
||||
|
||||
module Types = Types
|
||||
module PP = PP
|
||||
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 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 constructor_map = 'a CMap.t
|
||||
|
||||
@ -169,18 +170,6 @@ type literal =
|
||||
| Literal_void
|
||||
| Literal_operation of
|
||||
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' =
|
||||
| C_INT
|
||||
| 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
|
||||
24
src/test/contracts/expected/attributes.ligo.expected
Normal file
24
src/test/contracts/expected/attributes.ligo.expected
Normal file
@ -0,0 +1,24 @@
|
||||
const x : int = 1
|
||||
|
||||
attributes ["inline"]
|
||||
|
||||
function foo (const a : int) : int is
|
||||
block {
|
||||
const test : int = 2 + a;
|
||||
attributes ["inline"]
|
||||
} with test
|
||||
|
||||
attributes ["inline"]
|
||||
|
||||
const y : int = 1
|
||||
|
||||
attributes ["inline"; "other"]
|
||||
|
||||
function bar (const b : int) : int is
|
||||
block {
|
||||
function test (const z : int) : int is
|
||||
block {
|
||||
const r : int = 2 + b + z
|
||||
} with r;
|
||||
attributes ["inline"; "foo"; "bar"]
|
||||
} with test (b)
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user