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

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

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-01-22 11:43:35 +01:00
commit 7437d6ae1a
46 changed files with 981 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,6 +12,17 @@ Each LIGO smart contract is essentially a single function, that has the followin
```
(const parameter: my_type, const store: my_store_type): (list(operation), my_store_type)
```
<!--CameLIGO-->
```
(parameter, store: my_type * my_store_type) : operation list * my_store_type
```
<!--ReasonLIGO-->
```
(parameter_store: (my_type, my_store_type)) : (list(operation), my_store_type)
```
<!--END_DOCUSAURUS_CODE_TABS-->
This means that every smart contract needs at least one entrypoint function, here's an example:
@ -26,6 +37,25 @@ type store is unit;
function main(const parameter: parameter; const store: store): (list(operation) * store) is
block { skip } with ((nil : list(operation)), store)
```
<!--CameLIGO-->
```cameligo group=a
type parameter = unit
type store = unit
let main (parameter, store: parameter * store) : operation list * store =
(([]: operation list), store)
```
<!--ReasonLIGO-->
```reasonligo group=a
type parameter = unit;
type store = unit;
let main = (parameter_store: (parameter, store)) : (list(operation), store) => {
let parameter, store = parameter_store;
(([]: list(operation)), store);
};
```
<!--END_DOCUSAURUS_CODE_TABS-->
Each entrypoint function receives two arguments:
@ -52,9 +82,30 @@ function main (const p : unit ; const s : unit) : (list(operation) * unit) is
if amount > 0mutez then failwith("This contract does not accept tez") else skip
} with ((nil : list(operation)), unit);
```
<!--CameLIGO-->
```cameligo group=b
let main (p, s: unit * unit) : operation list * unit =
if amount > 0mutez
then (failwith "This contract does not accept tez": operation list * unit)
else (([]: operation list), unit)
```
<!--ReasonLIGO-->
```reasonligo group=b
let main = (p_s: (unit, unit)) : (list(operation), unit) => {
if (amount > 0mutez) {
(failwith("This contract does not accept tez"): (list(operation), unit));
}
else {
(([]: list(operation)), ());
};
};
```
<!--END_DOCUSAURUS_CODE_TABS-->
### Access control locking
### Access Control
This example shows how `sender` or `source` can be used to deny access to an entrypoint.
@ -67,6 +118,28 @@ function main (const p : unit ; const s : unit) : (list(operation) * unit) is
if source =/= owner then failwith("This address can't call the contract") else skip
} with ((nil : list(operation)), unit);
```
<!--CameLIGO-->
```cameligo group=c
let owner: address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address)
let main (p,s: unit * unit) : operation list * unit =
if source <> owner
then (failwith "This address can't call the contract": operation list * unit)
else (([]: operation list), ())
```
<!--ReasonLIGO-->
```reasonligo group=c
let owner: address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address);
let main = (p_s: (unit, unit)) : (list(operation), unit) => {
if (source != owner) {
(failwith("This address can't call the contract"): (list(operation), unit));
}
else {
(([]: list(operation)), ());
};
};
```
<!--END_DOCUSAURUS_CODE_TABS-->
### Cross contract calls

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

@ -49,6 +49,39 @@ function main (const p : action ; const s : int) : (list(operation) * int) is
| Decrement (n) -> s - n
end)
```
<!--CameLIGO-->
```cameligo
type action =
| Increment of int
| Decrement of int
let main (p, s: action * int) : operation list * int =
let result =
match p with
| Increment n -> s + n
| Decrement n -> s - n
in
(([]: operation list), result)
```
<!--ReasonLIGO-->
```reasonligo
type action =
| Increment(int)
| Decrement(int);
let main = (p_s: (action, int)) : (list(operation), int) => {
let p, s = p_s;
let result =
switch (p) {
| Increment(n) => s + n
| Decrement(n) => s - n
};
(([]: list(operation)), result);
};
```
<!--END_DOCUSAURUS_CODE_TABS-->
To dry-run the counter contract, we will use the `main` entrypoint, provide a variant parameter of `Increment(5)` and an initial storage value of `5`.

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

@ -17,6 +17,17 @@ You can obtain the current time using the built-in syntax specific expression, p
```pascaligo group=a
const today: timestamp = now;
```
<!--CameLIGO-->
```cameligo group=a
let today: timestamp = Current.time
```
<!--ReasonLIGO-->
```reasonligo group=a
let today: timestamp = Current.time;
```
<!--END_DOCUSAURUS_CODE_TABS-->
> When running code with ligo CLI, the option `--predecessor-timestamp` allows you to control what `now` returns.
@ -35,6 +46,25 @@ const in_24_hrs: timestamp = today + one_day;
const some_date: timestamp = ("2000-01-01T10:10:10Z" : timestamp);
const one_day_later: timestamp = some_date + one_day;
```
<!--CameLIGO-->
```cameligo group=b
let today: timestamp = Current.time
let one_day: int = 86400
let in_24_hrs: timestamp = today + one_day
let some_date: timestamp = ("2000-01-01t10:10:10Z" : timestamp)
let one_day_later: timestamp = some_date + one_day
```
<!--ReasonLIGO-->
```reasonligo group=b
let today: timestamp = Current.time;
let one_day: int = 86400;
let in_24_hrs: timestamp = today + one_day;
let some_date: timestamp = ("2000-01-01t10:10:10Z" : timestamp);
let one_day_later: timestamp = some_date + one_day;
```
<!--END_DOCUSAURUS_CODE_TABS-->
#### 24 hours ago
@ -45,6 +75,21 @@ const today: timestamp = now;
const one_day: int = 86400;
const in_24_hrs: timestamp = today - one_day;
```
<!--CameLIGO-->
```cameligo group=c
let today: timestamp = Current.time
let one_day: int = 86400
let in_24_hrs: timestamp = today - one_day
```
<!--ReasonLIGO-->
```reasonligo group=c
let today: timestamp = Current.time;
let one_day: int = 86400;
let in_24_hrs: timestamp = today - one_day;
```
<!--END_DOCUSAURUS_CODE_TABS-->
### Comparing timestamps
@ -56,6 +101,17 @@ You can also compare timestamps using the same comparison operators as for numbe
```pascaligo group=c
const not_tommorow: bool = (now = in_24_hrs)
```
<!--CameLIGO-->
```cameligo group=c
let not_tomorrow: bool = (Current.time = in_24_hrs)
```
<!--ReasonLIGO-->
```reasonligo group=c
let not_tomorrow: bool = (Current.time == in_24_hrs);
```
<!--END_DOCUSAURUS_CODE_TABS-->
## Addresses
@ -69,6 +125,17 @@ Here's how you can define an address:
```pascaligo group=d
const my_account: address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address);
```
<!--CameLIGO-->
```cameligo group=d
let my_account: address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address)
```
<!--ReasonLIGO-->
```reasonligo group=d
let my_account: address = ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address);
```
<!--END_DOCUSAURUS_CODE_TABS-->
## Signatures

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

@ -82,6 +82,42 @@ function main (const p : action ; const s : int) : (list(operation) * int) is
| Reset(n) -> 0
end)
```
<!--CameLIGO-->
```cameligo
type action =
| Increment of int
| Decrement of int
| Reset of unit
let main (p, s: action * int) : operation list * int =
let result =
match p with
| Increment n -> s + n
| Decrement n -> s - n
| Reset n -> 0
in
(([]: operation list), result)
```
<!--ReasonLIGO-->
```reasonligo
type action =
| Increment(int)
| Decrement(int)
| Reset(unit);
let main = (p_s: (action, int)) : (list(operation), int) => {
let p, s = p_s;
let result =
switch (p) {
| Increment(n) => s + n
| Decrement(n) => s - n
| Reset n => 0
};
(([]: list(operation)), result);
};
```
<!--END_DOCUSAURUS_CODE_TABS-->

9
gitlab-pages/docs/language-basics/functions.md
View File

@ -107,15 +107,6 @@ value.
<!--END_DOCUSAURUS_CODE_TABS-->
<!--DOCUSAURUS_CODE_TABS-->
<!--Pascaligo-->
```pascaligo group=b
const increment : (int -> int) = (function (const i : int) : int is i + 1);
// a = 2
const a: int = increment(1);
```
<!--END_DOCUSAURUS_CODE_TABS-->
## Anonymous functions
Functions without a name, also known as anonymous functions are useful in cases when you want to pass the function as an argument or assign it to a key in a record/map.

2
gitlab-pages/docs/language-basics/sets-lists-touples.md → gitlab-pages/docs/language-basics/sets-lists-tuples.md
View File

@ -1,5 +1,5 @@
---
id: sets-lists-touples
id: sets-lists-tuples
title: Sets, Lists, Tuples
---

146
gitlab-pages/docs/language-basics/tezos-specific.md Normal file
View File

@ -0,0 +1,146 @@
---
id: tezos-specific
title: Tezos Domain-Specific Operations
---
LIGO is a language for writing Tezos smart contracts. It would be a little odd if
it didn't have any Tezos specific functions. This page will tell you about them.
## Pack and Unpack
Michelson provides the `PACK` and `UNPACK` instructions for data serialization.
`PACK` converts Michelson data structures to a binary format, and `UNPACK`
reverses it. This functionality can be accessed from within LIGO.
> ⚠️ `PACK` and `UNPACK` are features of Michelson that are intended to be used by people that really know what they're doing. There are several failure cases (such as `UNPACK`ing a lambda from an untrusted source), most of which are beyond the scope of this document. Don't use these functions without doing your homework first.
<!--DOCUSAURUS_CODE_TABS-->
<!--PascaLIGO-->
```pascaligo
function id_string (const p : string) : option(string) is block {
const packed : bytes = bytes_pack(p) ;
} with (bytes_unpack(packed): option(string))
```
<!--CameLIGO-->
```cameligo
let id_string (p: string) : string option =
let packed: bytes = Bytes.pack p in
((Bytes.unpack packed): string option)
```
<!--ReasonLIGO-->
```reasonligo
let id_string = (p: string) : option(string) => {
let packed : bytes = Bytes.pack(p);
((Bytes.unpack(packed)): option(string));
};
```
<!--END_DOCUSAURUS_CODE_TABS-->
## Hashing Keys
It's often desirable to hash a public key. In Michelson, certain data structures
such as maps will not allow the use of the `key` type. Even if this weren't the case
hashes are much smaller than keys, and storage on blockchains comes at a cost premium.
You can hash keys with the `key_hash` type and associated built in function.
<!--DOCUSAURUS_CODE_TABS-->
<!--PascaLIGO-->
```pascaligo
function check_hash_key (const kh1 : key_hash; const k2 : key) : bool * key_hash is block {
var ret : bool := False ;
var kh2 : key_hash := crypto_hash_key(k2) ;
if kh1 = kh2 then ret := True else skip;
} with (ret, kh2)
```
<!--CameLIGO-->
```cameligo
let check_hash_key (kh1, k2: key_hash * key) : bool * key_hash =
let kh2 : key_hash = Crypto.hash_key k2 in
if kh1 = kh2
then (true, kh2)
else (false, kh2)
```
<!--ReasonLIGO-->
```reasonligo
let check_hash_key = (kh1_k2: (key_hash, key)) : (bool, key_hash) => {
let kh1, k2 = kh1_k2;
let kh2 : key_hash = Crypto.hash_key(k2);
if (kh1 == kh2) {
(true, kh2);
}
else {
(false, kh2);
}
};
```
<!--END_DOCUSAURUS_CODE_TABS-->
## Checking Signatures
Sometimes a contract will want to check that a message has been signed by a
particular key. For example, a point-of-sale system might want a customer to
sign a transaction so it can be processed asynchronously. You can do this in LIGO
using the `key` and `signature` types.
> ⚠️ There is no way to *generate* a signed message in LIGO. This is because that would require storing a private key on chain, at which point it isn't very private anymore.
<!--DOCUSAURUS_CODE_TABS-->
<!--PascaLIGO-->
```pascaligo
function check_signature
(const pk: key;
const signed: signature;
const msg: bytes) : bool
is crypto_check(pk, signed, msg)
```
<!--CameLIGO-->
```cameligo
let check_signature (pk, signed, msg: key * signature * bytes) : bool =
Crypto.check pk signed msg
```
<!--ReasonLIGO-->
```reasonligo
let check_signature = (param: (key, signature, bytes)) : bool => {
let pk, signed, msg = param;
Crypto.check(pk, signed, msg);
};
```
<!--END_DOCUSAURUS_CODE_TABS-->
## Getting The Contract's Own Address
Often you want to get the address of the contract being executed. You can do it with
`self_address`.
> ⚠️ Due to limitations in Michelson, self_address in a contract is only allowed at the entry-point level. Using it in a utility function will cause an error.
<!--DOCUSAURUS_CODE_TABS-->
<!--PascaLIGO-->
```pascaligo
const current_addr : address = self_address;
```
<!--CameLIGO-->
```cameligo
let current_addr : address = Current.self_address
```
<!--ReasonLIGO-->
```reasonligo
let current_addr : address = Current.self_address;
```
<!--END_DOCUSAURUS_CODE_TABS-->

32
gitlab-pages/website/core/CodeExamples.js
View File

@ -24,51 +24,51 @@ ${pre}`;
const CAMELIGO_EXAMPLE = `${pre}ocaml
type storage = int
(* variant defining pseudo multi-entrypoint
actions *)
(* variant defining pseudo multi-entrypoint actions *)
type action =
| Increment of int
| Decrement of int
let add (a: int) (b: int) : int = a + b
let sub (a: int) (b: int) : int = a - b
let subtract (a: int) (b: int): int = a - b
(* real entrypoint that re-routes the flow based on the action provided *)
(* real entrypoint that re-routes the flow
based on the action provided *)
let%entry main(p : action) storage =
let main (p,s: action * storage) =
let storage =
match p with
| Increment n -> add storage n
| Decrement n -> subtract storage n
in (([] : operation list), storage)
| Increment n -> add s n
| Decrement n -> sub s n
in ([] : operation list), storage
${pre}`;
const REASONLIGO_EXAMPLE = `${pre}reasonligo
type storage = int;
/* variant defining pseudo multi-entrypoint
actions */
/* variant defining pseudo multi-entrypoint actions */
type action =
| Increment(int)
| Decrement(int);
let add = (a: int, b: int): int => a + b;
let sub = (a: int, b: int): int => a - b;
let subtract = (a: int, b: int): int => a - b;
/* real entrypoint that re-routes the flow based on the action provided */
/* real entrypoint that re-routes the flow
based on the action provided */
let main = (p: action, storage) => {
let main2 = (p: action, storage) => {
let storage =
switch (p) {
| Increment(n) => add(storage, n)
| Decrement(n) => subtract(storage, n)
| Decrement(n) => sub(storage, n)
};
([]: list(operation), storage);
};
let main = (x: (action, storage)) => main2(x[0],x[1]);
${pre}`;

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

@ -11,7 +11,8 @@
"language-basics/loops",
"language-basics/unit-option-pattern-matching",
"language-basics/maps-records",
"language-basics/sets-lists-touples"
"language-basics/sets-lists-tuples",
"language-basics/tezos-specific"
],
"Advanced": [
"advanced/timestamps-addresses",

55
src/bin/cli.ml
View File

@ -138,6 +138,57 @@ let compile_file =
let doc = "Subcommand: compile a contract." 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
ok @@ Format.asprintf "%s \n" (Buffer.contents pp)
)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-cst" in
let doc = "Subcommand: print the cst. Warning: intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_ast =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
ok @@ Format.asprintf "%a\n" Compile.Of_simplified.pretty_print simplified
)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-ast" in
let doc = "Subcommand: print the ast. Warning: intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_typed_ast =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
let%bind typed,_ = Compile.Of_simplified.compile simplified in
ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed
)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-typed-ast" in
let doc = "Subcommand: print the typed ast. Warning: intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let print_mini_c =
let f source_file syntax display_format = (
toplevel ~display_format @@
let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in
let%bind typed,_ = Compile.Of_simplified.compile simplified in
let%bind mini_c = Compile.Of_typed.compile typed in
ok @@ Format.asprintf "%a\n" Compile.Of_mini_c.pretty_print mini_c
)
in
let term = Term.(const f $ source_file 0 $ syntax $ display_format) in
let cmdname = "print-mini-c" in
let doc = "Subcommand: print mini c. Warning: intended for development of LIGO and can break at any time." in
(Term.ret term, Term.info ~doc cmdname)
let measure_contract =
let f source_file entry_point syntax display_format =
toplevel ~display_format @@
@ -371,4 +422,8 @@ let run ?argv () =
run_function ;
evaluate_value ;
dump_changelog ;
print_cst ;
print_ast ;
print_typed_ast ;
print_mini_c
]

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

@ -2,6 +2,8 @@ open Cli_expect
let contract basename =
"../../test/contracts/" ^ basename
let bad_contract basename =
"../../test/contracts/negative/" ^ basename
let%expect_test _ =
run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ;
@ -1024,3 +1026,15 @@ let%expect_test _ =
[%expect {|
failwith("This contract always fails") |}]
let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "self_in_lambda.mligo" ; "main" ] ;
[%expect {|
ligo: Wrong SELF_ADDRESS location: SELF_ADDRESS is only allowed at top-level
If you're not sure how to fix this error, you can
do one of the following:
* Visit our documentation: https://ligolang.org/docs/intro/what-and-why/
* Ask a question on our Discord: https://discord.gg/9rhYaEt
* Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new
* Check the changelog by running 'ligo changelog' |}]

32
src/bin/expect_tests/help_tests.ml
View File

@ -47,6 +47,22 @@ let%expect_test _ =
measure-contract
Subcommand: measure a contract's compiled size in bytes.
print-ast
Subcommand: print the ast. Warning: intended for development of
LIGO and can break at any time.
print-cst
Subcommand: print the cst. Warning: intended for development of
LIGO and can break at any time.
print-mini-c
Subcommand: print mini c. Warning: intended for development of
LIGO and can break at any time.
print-typed-ast
Subcommand: print the typed ast. Warning: intended for development
of LIGO and can break at any time.
run-function
Subcommand: run a function with the given parameter.
@ -104,6 +120,22 @@ let%expect_test _ =
measure-contract
Subcommand: measure a contract's compiled size in bytes.
print-ast
Subcommand: print the ast. Warning: intended for development of
LIGO and can break at any time.
print-cst
Subcommand: print the cst. Warning: intended for development of
LIGO and can break at any time.
print-mini-c
Subcommand: print mini c. Warning: intended for development of
LIGO and can break at any time.
print-typed-ast
Subcommand: print the typed ast. Warning: intended for development
of LIGO and can break at any time.
run-function
Subcommand: run a function with the given parameter.

38
src/main/compile/helpers.ml
View File

@ -133,3 +133,41 @@ let parsify_string = fun (syntax : v_syntax) source_filename ->
let%bind parsified = parsify source_filename in
let%bind applied = Self_ast_simplified.all_program parsified in
ok applied
let pretty_print_pascaligo = fun source ->
let%bind ast = Parser.Pascaligo.parse_file source in
let buffer = Buffer.create 59 in
let state = Parser.Pascaligo.ParserLog.mk_state
~offsets:true
~mode:`Byte
~buffer in
Parser.Pascaligo.ParserLog.pp_ast state ast;
ok buffer
let pretty_print_cameligo = fun source ->
let%bind ast = Parser.Cameligo.parse_file source in
let buffer = Buffer.create 59 in
let state = Parser.Cameligo.ParserLog.mk_state
~offsets:true
~mode:`Byte
~buffer in
Parser.Cameligo.ParserLog.pp_ast state ast;
ok buffer
let pretty_print_reasonligo = fun source ->
let%bind ast = Parser.Reasonligo.parse_file source in
let buffer = Buffer.create 59 in
let state = Parser.Reasonligo.ParserLog.mk_state
~offsets:true
~mode:`Byte
~buffer in
Parser.Reasonligo.ParserLog.pp_ast state ast;
ok buffer
let pretty_print = fun syntax source_filename ->
let%bind v_syntax = syntax_to_variant syntax (Some source_filename) in
(match v_syntax with
| Pascaligo -> pretty_print_pascaligo
| Cameligo -> pretty_print_cameligo
| ReasonLIGO -> pretty_print_reasonligo)
source_filename

7
src/main/compile/of_michelson.ml
View File

@ -5,10 +5,9 @@ open Trace
module Errors = struct
(*
TODO: those errors should have been caught in the earlier stages on the ligo pipeline
Here, in case of contract not typechecking, we should write a warning with a "please report"
on stderr and print the ill-typed michelson code;
build_contract is a kind of security net
*)
let title_type_check_msg () = "Invalid contract (This might be a compiler bug, please report) "
let title_type_check_msg () = "generated Michelson contract failed to typecheck"
let bad_parameter c () =
let message () =
let code = Format.asprintf "%a" Michelson.pp c in
@ -22,7 +21,7 @@ module Errors = struct
let bad_contract c () =
let message () =
let code = Format.asprintf "%a" Michelson.pp c in
"bad contract type (contract entry point is expected to be of the form \"parameter * storage -> list(operation) * storage\"):\n"^code in
"bad contract type\n"^code in
error title_type_check_msg message
let unknown () =
let message () =

4
src/main/compile/of_mini_c.ml
View File

@ -3,6 +3,7 @@ open Proto_alpha_utils
open Trace
let compile_contract : expression -> Compiler.compiled_expression result = fun e ->
let%bind e = Self_mini_c.contract_check e in
let%bind (input_ty , _) = get_t_function e.type_value in
let%bind body = get_function e in
let%bind body = Compiler.Program.translate_function_body body [] input_ty in
@ -32,3 +33,6 @@ let aggregate_and_compile_contract = fun (program : Types.program) name ->
let aggregate_and_compile_expression = fun program exp ->
aggregate_and_compile program (ExpressionForm exp)
let pretty_print program =
Mini_c.PP.program program

3
src/main/compile/of_simplified.ml
View File

@ -18,3 +18,6 @@ let apply (entry_point : string) (param : Ast_simplified.expression) : Ast_simpl
{ expression = Ast_simplified.E_application (entry_point_var, param) ;
location = Virtual "generated application" } in
ok applied
let pretty_print formatter (program : Ast_simplified.program) =
Ast_simplified.PP.program formatter program

3
src/main/compile/of_source.ml
View File

@ -18,3 +18,6 @@ let compile_contract_input : string -> string -> v_syntax -> Ast_simplified.expr
fun storage parameter syntax ->
let%bind (storage,parameter) = bind_map_pair (compile_expression syntax) (storage,parameter) in
ok @@ Ast_simplified.e_pair storage parameter
let pretty_print source_filename syntax =
Helpers.pretty_print syntax source_filename

3
src/main/compile/of_typed.ml
View File

@ -22,3 +22,6 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As
| _ -> dummy_fail
)
| _ -> dummy_fail )
let pretty_print ppf program =
Ast_typed.PP.program ppf program

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

@ -439,8 +439,22 @@ fun_expr:
{p.value with inside = arg_to_pattern p.value.inside}
in PPar {p with value}
| EUnit u -> PUnit u
| e -> let open! SyntaxError
in raise (Error (WrongFunctionArguments e))
| ETuple { value; region } ->
PTuple { value = Utils.nsepseq_map arg_to_pattern value; region}
| EAnnot {region; value = {inside = t, colon, typ; _}} ->
let value = { pattern = arg_to_pattern t; colon; type_expr = typ} in
PPar {
value = {
lpar = Region.ghost;
rpar = Region.ghost;
inside = PTyped {region; value}
};
region
}
| e -> (
let open! SyntaxError in
raise (Error (WrongFunctionArguments e))
)
in
let fun_args_to_pattern = function
EAnnot {

15
src/passes/2-simplify/cameligo.ml
View File

@ -36,7 +36,7 @@ module Errors = struct
] in
error ~data title message
let unsuppported_let_in_function (patterns : Raw.pattern list) =
let unsupported_let_in_function (patterns : Raw.pattern list) =
let title () = "unsupported 'let ... in' function" in
let message () = "defining functions via 'let ... in' is not supported yet" in
let patterns_loc =
@ -179,6 +179,10 @@ let rec tuple_pattern_to_typed_vars : Raw.pattern -> _ = fun pattern ->
| Raw.PVar _ -> bind_list [pattern_to_typed_var pattern]
| other -> (fail @@ wrong_pattern "parenthetical, tuple, or variable" other)
let rec unpar_pattern : Raw.pattern -> Raw.pattern = function
| PPar p -> unpar_pattern p.value.inside
| _ as p -> p
let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te ->
trace (simple_info "simplifying this type expression...") @@
match te with
@ -354,7 +358,7 @@ let rec simpl_expression :
(* let f p1 ps... = rhs in body *)
| (f, p1 :: ps) ->
fail @@ unsuppported_let_in_function (f :: p1 :: ps)
fail @@ unsupported_let_in_function (f :: p1 :: ps)
end
| Raw.EAnnot a ->
let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in
@ -541,7 +545,8 @@ and simpl_fun lamb' : expr result =
(match pt with
| Raw.PTyped pt ->
begin
match pt.value.pattern with
let pt_pattern = unpar_pattern pt.value.pattern in
match pt_pattern with
| Raw.PVar _ -> params
| Raw.PTuple _ ->
[Raw.PTyped
@ -581,10 +586,10 @@ and simpl_fun lamb' : expr result =
match destruct with (* Handle tuple parameter destructuring *)
(* In this section we create a let ... in that binds the original parameters *)
| Raw.PPar pp ->
(match pp.value.inside with
(match unpar_pattern pp.value.inside with
| Raw.PTyped pt ->
let vars = pt.value in
(match vars.pattern with
(match unpar_pattern vars.pattern with
| PTuple vars ->
let let_in_binding: Raw.let_binding =
{binders = (PTuple vars, []) ;

8
src/passes/3-self_ast_simplified/self_ast_simplified.ml
View File

@ -6,14 +6,6 @@ let all = [
Literals.peephole_expression ;
]
let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x ->
match fs with
| [] -> ok x
| hd :: tl -> (
let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in
bind aux (ok x)
)
let all_program =
let all_p = List.map Helpers.map_program all in
bind_chain all_p

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

@ -729,94 +729,98 @@ let compare_simple_c_constant = function
| C_arrow -> (function
(* N/A -> 1 *)
| C_arrow -> 0
| C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_option -> (function
| C_arrow -> 1
| C_option -> 0
| C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_tuple -> (function
| C_arrow | C_option -> 1
| C_tuple -> 0
| C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_record -> (function
| C_arrow | C_option | C_tuple -> 1
| C_record -> 0
| C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_variant -> (function
| C_arrow | C_option | C_tuple | C_record -> 1
| C_variant -> 0
| C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant -> 1
| C_map -> 0
| C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_big_map -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map -> 1
| C_big_map -> 0
| C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_list -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map -> 1
| C_list -> 0
| C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_set -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list -> 1
| C_set -> 0
| C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_unit -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
| C_unit -> 0
| C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_bool -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1
| C_bool -> 0
| C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_string -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool -> 1
| C_string -> 0
| C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_nat -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string -> 1
| C_nat -> 0
| C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_mutez -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat -> 1
| C_mutez -> 0
| C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_timestamp -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez -> 1
| C_timestamp -> 0
| C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_int -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp -> 1
| C_int -> 0
| C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_address -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1
| C_address -> 0
| C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_bytes -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1
| C_bytes -> 0
| C_key_hash | C_key | C_signature | C_operation | C_contract -> -1)
| C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key_hash -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1
| C_key_hash -> 0
| C_key | C_signature | C_operation | C_contract -> -1)
| C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_key -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1
| C_key -> 0
| C_signature | C_operation | C_contract -> -1)
| C_signature | C_operation | C_contract | C_chain_id -> -1)
| C_signature -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1
| C_signature -> 0
| C_operation | C_contract -> -1)
| C_operation | C_contract | C_chain_id -> -1)
| C_operation -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1
| C_operation -> 0
| C_contract -> -1)
| C_contract | C_chain_id -> -1)
| C_contract -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1
| C_contract -> 0
| C_chain_id -> -1)
| C_chain_id -> (function
| C_arrow | C_option | C_tuple | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_bool | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1
| C_chain_id -> 0
(* N/A -> -1 *)
)
let rec compare_typeclass a b = compare_list (compare_list compare_type_value) a b

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

@ -956,12 +956,41 @@ let type_program_returns_state (p:I.program) : (environment * Solver.state * O.p
(* module TSMap = TMap(Solver.TypeVariable) *)
(* let c_tag_to_string : Solver.Core.constant_tag -> string = function
* | Solver.Core.C_arrow -> "arrow"
* | Solver.Core.C_option -> "option"
* | Solver.Core.C_tuple -> "tuple"
* | Solver.Core.C_record -> failwith "record"
* | Solver.Core.C_variant -> failwith "variant"
* | Solver.Core.C_map -> "map"
* | Solver.Core.C_big_map -> "big"
* | Solver.Core.C_list -> "list"
* | Solver.Core.C_set -> "set"
* | Solver.Core.C_unit -> "unit"
* | Solver.Core.C_bool -> "bool"
* | Solver.Core.C_string -> "string"
* | Solver.Core.C_nat -> "nat"
* | Solver.Core.C_mutez -> "mutez"
* | Solver.Core.C_timestamp -> "timestamp"
* | Solver.Core.C_int -> "int"
* | Solver.Core.C_address -> "address"
* | Solver.Core.C_bytes -> "bytes"
* | Solver.Core.C_key_hash -> "key_hash"
* | Solver.Core.C_key -> "key"
* | Solver.Core.C_signature -> "signature"
* | Solver.Core.C_operation -> "operation"
* | Solver.Core.C_contract -> "contract"
* | Solver.Core.C_chain_id -> "chain_id" *)
let type_program (p : I.program) : (O.program * Solver.state) result =
let%bind (env, state, program) = type_program_returns_state p in
let subst_all =
let assignments = state.structured_dbs.assignments in
let aux (v : I.type_variable) (expr : Solver.c_constructor_simpl) (p:O.program result) =
let%bind p = p in
let Solver.{ tv ; c_tag ; tv_list } = expr in
let () = ignore tv (* I think there is an issue where the tv is stored twice (as a key and in the element itself) *) in
let%bind (expr : O.type_value') = Typesystem.Core.type_expression'_of_simple_c_constant (c_tag , (List.map (fun s -> O.{ type_value' = T_variable s ; simplified = None }) tv_list)) in
Typesystem.Misc.Substitution.Pattern.program ~p ~v ~expr in
(* let p = TSMap.bind_fold_Map aux program assignments in *) (* TODO: Module magic: this does not work *)
let p = Solver.TypeVariableMap.fold aux assignments (ok program) in

8
src/passes/7-self_mini_c/helpers.ml
View File

@ -163,3 +163,11 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind updates = bind_map_list (fun (p,e) -> let%bind e = self e in ok(p,e)) updates in
return @@ E_update(r,updates)
)
let map_sub_level_expression : mapper -> expression -> expression result = fun f e ->
match e.content with
| E_closure {binder ; body} ->
let%bind body = map_expression f body in
let content = E_closure {binder; body} in
ok @@ { e with content }
| _ -> ok e

26
src/passes/7-self_mini_c/michelson_restrictions.ml Normal file
View File

@ -0,0 +1,26 @@
open Mini_c
open Trace
module Errors = struct
let bad_self_address cst () =
let title = thunk @@
Format.asprintf "Wrong %alocation" Mini_c.PP.expression' cst in
let message = thunk @@
Format.asprintf "%ais only allowed at top-level" Mini_c.PP.expression' cst in
error title message ()
end
open Errors
let self_in_lambdas : expression -> expression result =
fun e ->
match e.content with
| E_closure {binder=_ ; body} ->
let%bind _self_in_lambdas = Helpers.map_expression
(fun e -> match e.content with
| E_constant (C_SELF_ADDRESS, _) as c -> fail (bad_self_address c)
| _ -> ok e)
body in
ok e
| _ -> ok e

5
src/passes/7-self_mini_c/self_mini_c.ml
View File

@ -250,6 +250,11 @@ let betas : bool ref -> expression -> expression =
fun changed ->
map_expression (beta changed)
let contract_check =
let all = [Michelson_restrictions.self_in_lambdas] in
let all_e = List.map Helpers.map_sub_level_expression all in
bind_chain all_e
let rec all_expression : expression -> expression =
fun e ->
let changed = ref false in

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

@ -1,5 +1,6 @@
open Trace
open Types
include Stage_common.Misc
module Errors = struct
let different_kinds a b () =

1
src/stages/common/ast_common.ml
View File

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

85
src/stages/common/misc.ml Normal file
View File

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

32
src/stages/typesystem/core.ml
View File

@ -31,6 +31,7 @@ type constant_tag =
| C_signature (* * *)
| C_operation (* * *)
| C_contract (* * -> * *)
| C_chain_id (* * *)
type accessor =
| L_int of int
@ -67,3 +68,34 @@ and type_constraint =
(* is the first list in case on of the type of the type class as a kind *->*->* ? *)
and typeclass = type_value list list
open Trace
let type_expression'_of_simple_c_constant = function
| C_contract , [x] -> ok @@ T_operator(TC_contract x)
| C_option , [x] -> ok @@ T_operator(TC_option x)
| C_list , [x] -> ok @@ T_operator(TC_list x)
| C_set , [x] -> ok @@ T_operator(TC_set x)
| C_map , [x ; y] -> ok @@ T_operator(TC_map (x , y))
| C_big_map , [x ; y] -> ok @@ T_operator(TC_big_map (x, y))
| (C_contract | C_option | C_list | C_set | C_map | C_big_map), _ ->
failwith "internal error: wrong number of arguments for type operator"
| C_unit , [] -> ok @@ T_constant(TC_unit)
| C_string , [] -> ok @@ T_constant(TC_string)
| C_bytes , [] -> ok @@ T_constant(TC_bytes)
| C_nat , [] -> ok @@ T_constant(TC_nat)
| C_int , [] -> ok @@ T_constant(TC_int)
| C_mutez , [] -> ok @@ T_constant(TC_mutez)
| C_bool , [] -> ok @@ T_constant(TC_bool)
| C_operation , [] -> ok @@ T_constant(TC_operation)
| C_address , [] -> ok @@ T_constant(TC_address)
| C_key , [] -> ok @@ T_constant(TC_key)
| C_key_hash , [] -> ok @@ T_constant(TC_key_hash)
| C_chain_id , [] -> ok @@ T_constant(TC_chain_id)
| C_signature , [] -> ok @@ T_constant(TC_signature)
| C_timestamp , [] -> ok @@ T_constant(TC_timestamp)
| _ , [] ->
failwith "internal error: wrong number of arguments for type constant"
| _ , _ ->
failwith "internal error: unknown type operator"

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

@ -78,23 +78,37 @@ module Substitution = struct
| T.T_constant (type_name) ->
let%bind type_name = s_type_name_constant ~v ~expr type_name in
ok @@ T.T_constant (type_name)
| T.T_variable _ -> failwith "TODO: T_variable"
| T.T_operator _ -> failwith "TODO: T_operator"
| T.T_variable variable ->
if Var.equal variable v
then ok @@ expr
else ok @@ T.T_variable variable
| T.T_operator (type_name_and_args) ->
let bind_map_type_operator = Stage_common.Misc.bind_map_type_operator in (* TODO: write T.Misc.bind_map_type_operator, but it doesn't work *)
let%bind type_name_and_args = bind_map_type_operator (s_type_value ~v ~expr) type_name_and_args in
ok @@ T.T_operator type_name_and_args
| T.T_arrow _ ->
let _TODO = (v, expr) in
failwith "TODO: T_function"
and s_type_expression ~v ~expr : Ast_simplified.type_expression w = fun {type_expression'} ->
and s_type_expression' ~v ~expr : _ Ast_simplified.type_expression' w = fun type_expression' ->
match type_expression' with
| Ast_simplified.T_tuple _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_sum _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_arrow (_, _) -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_operator _ -> failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_constant _ ->
let _TODO = (v, expr) in
failwith "TODO: subst: unimplemented case s_type_expression"
| Ast_simplified.T_tuple _ -> failwith "TODO: subst: unimplemented case s_type_expression tuple"
| Ast_simplified.T_sum _ -> failwith "TODO: subst: unimplemented case s_type_expression sum"
| Ast_simplified.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression record"
| Ast_simplified.T_arrow (_, _) -> failwith "TODO: subst: unimplemented case s_type_expression arrow"
| Ast_simplified.T_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression variable"
| Ast_simplified.T_operator op ->
let%bind op =
Stage_common.Misc.bind_map_type_operator (* TODO: write Ast_simplified.Misc.type_operator_name *)
(s_type_expression ~v ~expr)
op in
ok @@ Ast_simplified.T_operator op
| Ast_simplified.T_constant constant ->
ok @@ Ast_simplified.T_constant constant
and s_type_expression ~v ~expr : Ast_simplified.type_expression w = fun {type_expression'} ->
let%bind type_expression' = s_type_expression' ~v ~expr type_expression' in
ok @@ Ast_simplified.{type_expression'}
and s_type_value ~v ~expr : T.type_value w = fun { type_value'; simplified } ->
let%bind type_value' = s_type_value' ~v ~expr type_value' in

11
src/test/contracts/bytes_unpack.mligo Normal file
View File

@ -0,0 +1,11 @@
let id_string (p: string) : string option =
let packed: bytes = Bytes.pack p in
((Bytes.unpack packed): string option)
let id_int (p: int) : int option =
let packed: bytes = Bytes.pack p in
((Bytes.unpack packed): int option)
let id_address (p: address) : address option =
let packed: bytes = Bytes.pack p in
((Bytes.unpack packed): address option)

14
src/test/contracts/bytes_unpack.religo Normal file
View File

@ -0,0 +1,14 @@
let id_string = (p: string) : option(string) => {
let packed : bytes = Bytes.pack(p);
((Bytes.unpack(packed)): option(string));
};
let id_int = (p: int) : option(int) => {
let packed: bytes = Bytes.pack(p);
((Bytes.unpack(packed)): option(int));
};
let id_address = (p: address) : option(address) => {
let packed: bytes = Bytes.pack(p);
((Bytes.unpack(packed)): option(address));
};

2
src/test/contracts/check_signature.ligo Normal file
View File

@ -0,0 +1,2 @@
function check_signature (const pk: key; const signed: signature; const msg: bytes) : bool is
crypto_check(pk, signed, msg)

2
src/test/contracts/check_signature.mligo Normal file
View File

@ -0,0 +1,2 @@
let check_signature (pk, signed, msg: key * signature * bytes) : bool =
Crypto.check pk signed msg

4
src/test/contracts/check_signature.religo Normal file
View File

@ -0,0 +1,4 @@
let check_signature = (param: (key, signature, bytes)) : bool => {
let pk, signed, msg = param;
Crypto.check(pk, signed, msg);
};

5
src/test/contracts/key_hash.mligo Normal file
View File

@ -0,0 +1,5 @@
let check_hash_key (kh1, k2: key_hash * key) : bool * key_hash =
let kh2 : key_hash = Crypto.hash_key k2 in
if kh1 = kh2
then (true, kh2)
else (false, kh2)

10
src/test/contracts/key_hash.religo Normal file
View File

@ -0,0 +1,10 @@
let check_hash_key = (kh1_k2: (key_hash, key)) : (bool, key_hash) => {
let kh1, k2 = kh1_k2;
let kh2 : key_hash = Crypto.hash_key(k2);
if (kh1 == kh2) {
(true, kh2);
}
else {
(false, kh2);
}
};

5
src/test/contracts/negative/self_in_lambda.mligo Normal file
View File

@ -0,0 +1,5 @@
let foo (u: unit) : address =
Current.self_address
let main (ps: unit * address): (operation list * address) =
( ([] : operation list) , foo)

3
src/test/contracts/tuple_param_destruct.mligo
View File

@ -1 +1,2 @@
let sum (result, i : int * int) : int = result + i
let sum (result, i : int * int) : int = result - i
let parentheses ((((result, i))) : ((int * int))) : int = result - i

2
src/test/contracts/tuple_param_destruct.religo Normal file
View File

@ -0,0 +1,2 @@
let sum = ((result, i) : (int, int)) : int => result - i;
let parentheses = (((((result, i)))) : (((int, int)))) : int => result - i;

12
src/test/contracts/website2.mligo
View File

@ -1,3 +1,5 @@
(* IF YOU CHANGE THIS, CHANGE THE EXAMPLE ON THE FRONT PAGE OF THE WEBSITE *)
type storage = int
(* variant defining pseudo multi-entrypoint actions *)
@ -11,9 +13,11 @@ let sub (a: int) (b: int) : int = a - b
(* real entrypoint that re-routes the flow based on the action provided *)
let main (ps: action * storage) =
let main (p,s: action * storage) =
let storage =
match ps.0 with
| Increment n -> add ps.1 n
| Decrement n -> sub ps.1 n
match p with
| Increment n -> add s n
| Decrement n -> sub s n
in ([] : operation list), storage
(* IF YOU CHANGE THIS, CHANGE THE EXAMPLE ON THE FRONT PAGE OF THE WEBSITE *)

4
src/test/contracts/website2.religo
View File

@ -1,3 +1,5 @@
(* IF YOU CHANGE THIS, CHANGE THE EXAMPLE ON THE FRONT PAGE OF THE WEBSITE *)
type storage = int;
/* variant defining pseudo multi-entrypoint actions */
@ -21,3 +23,5 @@ let main2 = (p: action, storage) => {
};
let main = (x: (action, storage)) => main2(x[0],x[1]);
(* IF YOU CHANGE THIS, CHANGE THE EXAMPLE ON THE FRONT PAGE OF THE WEBSITE *)

100
src/test/integration_tests.ml
View File

@ -1901,6 +1901,67 @@ let key_hash () : unit result =
let%bind () = expect_eq program "check_hash_key" make_input make_expected in
ok ()
let key_hash_mligo () : unit result =
let open Tezos_crypto in
let (raw_pkh,raw_pk,_) = Signature.generate_key () in
let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in
let pk_str = Signature.Public_key.to_b58check raw_pk in
let%bind program = mtype_file "./contracts/key_hash.mligo" in
let make_input = e_pair (e_key_hash pkh_str) (e_key pk_str) in
let make_expected = e_pair (e_bool true) (e_key_hash pkh_str) in
let%bind () = expect_eq program "check_hash_key" make_input make_expected in
ok ()
let key_hash_religo () : unit result =
let open Tezos_crypto in
let (raw_pkh,raw_pk,_) = Signature.generate_key () in
let pkh_str = Signature.Public_key_hash.to_b58check raw_pkh in
let pk_str = Signature.Public_key.to_b58check raw_pk in
let%bind program = retype_file "./contracts/key_hash.religo" in
let make_input = e_pair (e_key_hash pkh_str) (e_key pk_str) in
let make_expected = e_pair (e_bool true) (e_key_hash pkh_str) in
let%bind () = expect_eq program "check_hash_key" make_input make_expected in
ok ()
let check_signature () : unit result =
let open Tezos_crypto in
let (_, raw_pk, sk) = Signature.generate_key () in
let pk_str = Signature.Public_key.to_b58check raw_pk in
let signed = Signature.sign sk (Bytes.of_string "hello world") in
let%bind program = type_file "./contracts/check_signature.ligo" in
let make_input = e_tuple [e_key pk_str ;
e_signature (Signature.to_b58check signed) ;
e_bytes_ofbytes (Bytes.of_string "hello world")] in
let make_expected = e_bool true in
let%bind () = expect_eq program "check_signature" make_input make_expected in
ok ()
let check_signature_mligo () : unit result =
let open Tezos_crypto in
let (_, raw_pk, sk) = Signature.generate_key () in
let pk_str = Signature.Public_key.to_b58check raw_pk in
let signed = Signature.sign sk (Bytes.of_string "hello world") in
let%bind program = mtype_file "./contracts/check_signature.mligo" in
let make_input = e_tuple [e_key pk_str ;
e_signature (Signature.to_b58check signed) ;
e_bytes_ofbytes (Bytes.of_string "hello world")] in
let make_expected = e_bool true in
let%bind () = expect_eq program "check_signature" make_input make_expected in
ok ()
let check_signature_religo () : unit result =
let open Tezos_crypto in
let (_, raw_pk, sk) = Signature.generate_key () in
let pk_str = Signature.Public_key.to_b58check raw_pk in
let signed = Signature.sign sk (Bytes.of_string "hello world") in
let%bind program = retype_file "./contracts/check_signature.religo" in
let make_input = e_tuple [e_key pk_str ;
e_signature (Signature.to_b58check signed) ;
e_bytes_ofbytes (Bytes.of_string "hello world")] in
let make_expected = e_bool true in
let%bind () = expect_eq program "check_signature" make_input make_expected in
ok ()
let curry () : unit result =
let%bind program = mtype_file "./contracts/curry.mligo" in
let%bind () =
@ -1943,8 +2004,15 @@ let type_tuple_destruct () : unit result =
let tuple_param_destruct () : unit result =
let%bind program = mtype_file "./contracts/tuple_param_destruct.mligo" in
let%bind () = expect_eq program "sum" (e_tuple [e_int 10; e_int 10]) (e_int 20)
in ok ()
let%bind () = expect_eq program "sum" (e_tuple [e_int 20; e_int 10]) (e_int 10) in
let%bind () = expect_eq program "parentheses" (e_tuple [e_int 20; e_int 10]) (e_int 10) in
ok ()
let tuple_param_destruct_religo () : unit result =
let%bind program = retype_file "./contracts/tuple_param_destruct.religo" in
let%bind () = expect_eq program "sum" (e_tuple [e_int 20; e_int 10]) (e_int 10) in
let%bind () = expect_eq program "parentheses" (e_tuple [e_int 20; e_int 10]) (e_int 10) in
ok ()
let let_in_multi_bind () : unit result =
let%bind program = mtype_file "./contracts/let_in_multi_bind.mligo" in
@ -1968,6 +2036,26 @@ let bytes_unpack () : unit result =
let%bind () = expect_eq program "id_address" (e_address addr) (e_some (e_address addr)) in
ok ()
let bytes_unpack_mligo () : unit result =
let%bind program = mtype_file "./contracts/bytes_unpack.mligo" in
let%bind () = expect_eq program "id_string" (e_string "teststring") (e_some (e_string "teststring")) in
let%bind () = expect_eq program "id_int" (e_int 42) (e_some (e_int 42)) in
let open Proto_alpha_utils.Memory_proto_alpha in
let addr = Protocol.Alpha_context.Contract.to_b58check @@
(List.nth dummy_environment.identities 0).implicit_contract in
let%bind () = expect_eq program "id_address" (e_address addr) (e_some (e_address addr)) in
ok ()
let bytes_unpack_religo () : unit result =
let%bind program = retype_file "./contracts/bytes_unpack.religo" in
let%bind () = expect_eq program "id_string" (e_string "teststring") (e_some (e_string "teststring")) in
let%bind () = expect_eq program "id_int" (e_int 42) (e_some (e_int 42)) in
let open Proto_alpha_utils.Memory_proto_alpha in
let addr = Protocol.Alpha_context.Contract.to_b58check @@
(List.nth dummy_environment.identities 0).implicit_contract in
let%bind () = expect_eq program "id_address" (e_address addr) (e_some (e_address addr)) in
ok ()
let empty_case () : unit result =
let%bind program = type_file "./contracts/empty_case.ligo" in
let%bind () =
@ -2012,7 +2100,14 @@ let empty_case_religo () : unit result =
let main = test_suite "Integration (End to End)" [
test "bytes unpack" bytes_unpack ;
test "bytes unpack (mligo)" bytes_unpack_mligo ;
test "bytes unpack (religo)" bytes_unpack_religo ;
test "key hash" key_hash ;
test "key hash (mligo)" key_hash_mligo ;
test "key hash (religo)" key_hash_religo ;
test "check signature" check_signature ;
test "check signature (mligo)" check_signature_mligo ;
test "check signature (religo)" check_signature_religo ;
test "chain id" chain_id ;
test "type alias" type_alias ;
test "function" function_ ;
@ -2159,6 +2254,7 @@ let main = test_suite "Integration (End to End)" [
test "attributes (religo)" attributes_religo;
test "let in multi-bind (mligo)" let_in_multi_bind ;
test "tuple param destruct (mligo)" tuple_param_destruct ;
test "tuple param destruct (religo)" tuple_param_destruct_religo ;
test "empty case" empty_case ;
test "empty case (mligo)" empty_case_mligo ;
test "empty case (religo)" empty_case_religo ;

3
src/test/md_file_tests.ml
View File

@ -100,10 +100,11 @@ let md_files = [
"/gitlab-pages/docs/language-basics/strings.md";
"/gitlab-pages/docs/language-basics/maps-records.md";
"/gitlab-pages/docs/language-basics/variables-and-constants.md";
"/gitlab-pages/docs/language-basics/sets-lists-touples.md";
"/gitlab-pages/docs/language-basics/sets-lists-tuples.md";
"/gitlab-pages/docs/language-basics/operators.md";
"/gitlab-pages/docs/language-basics/unit-option-pattern-matching.md";
"/gitlab-pages/docs/language-basics/loops.md";
"/gitlab-pages/docs/language-basics/tezos-specific.md";
"/gitlab-pages/docs/contributors/big-picture/back-end.md";
"/gitlab-pages/docs/contributors/big-picture/vendors.md";
"/gitlab-pages/docs/contributors/big-picture/front-end.md";

8
vendors/ligo-utils/simple-utils/trace.ml vendored
View File

@ -705,6 +705,14 @@ let bind_list_cons v lst =
lst >>? fun lst ->
ok (v::lst)
let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x ->
match fs with
| [] -> ok x
| hd :: tl -> (
let aux : 'a -> 'a result = fun x -> bind (bind_chain tl) (hd x) in
bind aux (ok x)
)
(**
Wraps a call that might trigger an exception in a result.
*)