diff --git a/CHANGELOG.md b/CHANGELOG.md index fe908e334..3fc44d2cb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,7 +2,11 @@ ## [Unreleased] -## [Add crypto reference page to docs](https://gitlab.com/ligolang/ligo/-/merge_requests/459) +## [Support for self] (https://gitlab.com/ligolang/ligo/-/merge_requests/453) +### Added +- support for `Tezos.self(%Entrypoint)` + +## [Support for create_contract](https://gitlab.com/ligolang/ligo/-/merge_requests/459) ### Added - support for `Tezos.create_contract` origination diff --git a/gitlab-pages/docs/reference/current.md b/gitlab-pages/docs/reference/current.md index 0b5cd7265..642bbb6fe 100644 --- a/gitlab-pages/docs/reference/current.md +++ b/gitlab-pages/docs/reference/current.md @@ -321,6 +321,37 @@ let main = (p : unit) : address => Tezos.self_address; +## Self + +Typecast the currently running contract with an entrypoint annotation. +If your are using entrypoints: use "%bar" for constructor Bar +If you are not using entrypoints: use "%default" + + + +```pascaligo +function main (const p : unit) : contract(unit) is block { + const c : contract(unit) = Tezos.self("%Default") ; +} with c +``` + + + + +```cameligo +let main (p : unit) : unit contract = + (Tezos.self("%Default") : unit contract) +``` + + + + +```reasonligo +let main = (p: unit) : contract(unit) => + (Tezos.self("%Default") : contract(unit)); +``` + + ## Implicit Account diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 1ad68d049..a35e5d91c 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -134,7 +134,7 @@ let compile_file = let f source_file entry_point syntax display_format michelson_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 typed,_ = Compile.Of_simplified.compile (Contract entry_point) simplified in let%bind mini_c = Compile.Of_typed.compile typed in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in let%bind contract = Compile.Of_michelson.build_contract michelson in @@ -174,7 +174,7 @@ 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 + let%bind typed,_ = Compile.Of_simplified.compile Env simplified in ok @@ Format.asprintf "%a\n" Compile.Of_typed.pretty_print typed ) in @@ -187,7 +187,7 @@ 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 typed,_ = Compile.Of_simplified.compile Env 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 ) @@ -201,7 +201,7 @@ let measure_contract = let f source_file entry_point 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 typed,_ = Compile.Of_simplified.compile (Contract entry_point) simplified in let%bind mini_c = Compile.Of_typed.compile typed in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in let%bind contract = Compile.Of_michelson.build_contract michelson in @@ -218,7 +218,7 @@ let compile_parameter = let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format = toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in - let%bind typed_prg,state = Compile.Of_simplified.compile simplified in + let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let env = Ast_typed.program_environment typed_prg in @@ -249,7 +249,7 @@ let interpret = let%bind (decl_list,state,env) = match init_file with | Some init_file -> let%bind simplified = Compile.Of_source.compile init_file (Syntax_name syntax) in - let%bind typed_prg,state = Compile.Of_simplified.compile simplified in + let%bind typed_prg,state = Compile.Of_simplified.compile Env simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let env = Ast_typed.program_environment typed_prg in ok (mini_c_prg,state,env) @@ -280,7 +280,7 @@ let temp_ligo_interpreter = let f source_file syntax display_format = toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in - let%bind typed,_ = Compile.Of_simplified.compile simplified in + let%bind typed,_ = Compile.Of_simplified.compile Env simplified in let%bind res = Compile.Of_typed.some_interpret typed in ok @@ Format.asprintf "%s\n" res in @@ -294,7 +294,7 @@ let compile_storage = let f source_file entry_point expression syntax amount balance sender source predecessor_timestamp display_format michelson_format = toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in - let%bind typed_prg,state = Compile.Of_simplified.compile simplified in + let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let env = Ast_typed.program_environment typed_prg in @@ -323,7 +323,7 @@ let dry_run = let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in - let%bind typed_prg,state = Compile.Of_simplified.compile simplified in + let%bind typed_prg,state = Compile.Of_simplified.compile (Contract entry_point) simplified in let env = Ast_typed.program_environment typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in @@ -359,7 +359,7 @@ let run_function = toplevel ~display_format @@ let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind simplified_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in - let%bind typed_prg,state = Compile.Of_simplified.compile simplified_prg in + let%bind typed_prg,state = Compile.Of_simplified.compile Env simplified_prg in let env = Ast_typed.program_environment typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in @@ -390,7 +390,7 @@ let evaluate_value = let f source_file entry_point amount balance sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in - let%bind typed_prg,_ = Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = Compile.Of_simplified.compile Env simplified in let%bind mini_c = Compile.Of_typed.compile typed_prg in let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index d570c96ef..49b1563d7 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -1218,3 +1218,117 @@ ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, char DIP { DIP { DUP } ; SWAP ; CDR } ; PAIR ; DIP { DROP 2 } } } |}] + +let%expect_test _ = + run_ligo_bad [ "compile-contract" ; bad_contract "self_type_annotation.ligo" ; "main" ] ; + [%expect {| + ligo: in file "self_type_annotation.ligo", line 8, characters 41-64. bad self type: expected (TO_Contract (int)) but got (TO_Contract (nat)) {"location":"in file \"self_type_annotation.ligo\", line 8, characters 41-64"} + + + 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' |}] ; + + run_ligo_good [ "compile-contract" ; contract "self_type_annotation.ligo" ; "main" ] ; + [%expect {| + { parameter nat ; + storage int ; + code { DUP ; + SELF %default ; + SWAP ; + CDR ; + NIL operation ; + PAIR ; + DIP { DROP 2 } } } |}] + +let%expect_test _ = + run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract.mligo" ; "main" ] ; + [%expect {| + ligo: in file "", line 0, characters 0-0. badly typed contract: unexpected entrypoint type {"location":"in file \"\", line 0, characters 0-0","entrypoint":"main","entrypoint_type":"( nat * int ) -> int"} + + + 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' |}] ; + + run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract2.mligo" ; "main" ] ; + [%expect {| + ligo: in file "", line 0, characters 0-0. bad return type: expected (TO_list(operation)), got string {"location":"in file \"\", line 0, characters 0-0","entrypoint":"main"} + + + 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' |}] ; + + run_ligo_bad [ "compile-contract" ; bad_contract "bad_contract3.mligo" ; "main" ] ; + [%expect {| + ligo: in file "", line 0, characters 0-0. badly typed contract: expected {int} and {string} to be the same in the entrypoint type {"location":"in file \"\", line 0, characters 0-0","entrypoint":"main","entrypoint_type":"( nat * int ) -> ( (TO_list(operation)) * string )"} + + + 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' |}] + +let%expect_test _ = + run_ligo_good [ "compile-contract" ; contract "self_with_entrypoint.ligo" ; "main" ] ; + [%expect {| + { parameter (or (unit %default) (int %toto)) ; + storage nat ; + code { SELF %toto ; + DUP ; + PUSH mutez 300000000 ; + PUSH int 2 ; + TRANSFER_TOKENS ; + DUP ; + NIL operation ; + SWAP ; + CONS ; + DIP { DIP 2 { DUP } ; DIG 2 ; CDR } ; + PAIR ; + DIP { DROP 3 } } } |}] ; + + run_ligo_good [ "compile-contract" ; contract "self_without_entrypoint.ligo" ; "main" ] ; + [%expect {| + { parameter int ; + storage nat ; + code { SELF %default ; + DUP ; + PUSH mutez 300000000 ; + PUSH int 2 ; + TRANSFER_TOKENS ; + DUP ; + NIL operation ; + SWAP ; + CONS ; + DIP { DIP 2 { DUP } ; DIG 2 ; CDR } ; + PAIR ; + DIP { DROP 3 } } } |}] ; + + run_ligo_bad [ "compile-contract" ; bad_contract "self_bad_entrypoint_format.ligo" ; "main" ] ; + [%expect {| + ligo: in file "self_bad_entrypoint_format.ligo", line 8, characters 52-58. bad entrypoint format: entrypoint "Toto" is badly formatted. We expect "%bar" for entrypoint Bar and "%default" when no entrypoint used {"location":"in file \"self_bad_entrypoint_format.ligo\", line 8, characters 52-58"} + + + 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' |}] \ No newline at end of file diff --git a/src/main/compile/dune b/src/main/compile/dune index e59679ba5..7629e3d2b 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -9,6 +9,7 @@ interpreter ast_simplified self_ast_simplified + self_ast_typed typer_new typer ast_typed diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index 488e809ac..6a948e6d5 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -1,14 +1,23 @@ open Trace -let compile (program : Ast_simplified.program) : (Ast_typed.program * Typer.Solver.state) result = +type form = + | Contract of string + | Env + +let compile (cform: form) (program : Ast_simplified.program) : (Ast_typed.program * Typer.Solver.state) result = let%bind (prog_typed , state) = Typer.type_program program in let () = Typer.Solver.discard_state state in - ok @@ (prog_typed, state) + let%bind prog_typed' = match cform with + | Contract entrypoint -> Self_ast_typed.all_contract entrypoint prog_typed + | Env -> ok prog_typed in + ok @@ (prog_typed', state) let compile_expression ?(env = Ast_typed.Environment.full_empty) ~(state : Typer.Solver.state) (ae : Ast_simplified.expression) : (Ast_typed.expression * Typer.Solver.state) result = + let%bind (ae_typed,state) = Typer.type_expression_subst env state ae in let () = Typer.Solver.discard_state state in - Typer.type_expression_subst env state ae + let%bind ae_typed' = Self_ast_typed.all_expression ae_typed in + ok @@ (ae_typed',state) let apply (entry_point : string) (param : Ast_simplified.expression) : Ast_simplified.expression result = let name = Var.of_name entry_point in diff --git a/src/main/compile/wrapper.ml b/src/main/compile/wrapper.ml deleted file mode 100644 index ae8f9043e..000000000 --- a/src/main/compile/wrapper.ml +++ /dev/null @@ -1,12 +0,0 @@ -open Trace - -let source_to_typed syntax source_file = - let%bind simplified = Of_source.compile source_file syntax in - let%bind typed,state = Of_simplified.compile simplified in - let env = Ast_typed.program_environment typed in - ok (typed,state,env) - -let source_to_typed_expression ~env ~state parameter syntax = - let%bind simplified = Of_source.compile_expression syntax parameter in - let%bind (typed,_) = Of_simplified.compile_expression ~env ~state simplified in - ok typed diff --git a/src/passes/5-self_ast_typed/contract_passes.ml b/src/passes/5-self_ast_typed/contract_passes.ml new file mode 100644 index 000000000..c16898146 --- /dev/null +++ b/src/passes/5-self_ast_typed/contract_passes.ml @@ -0,0 +1,72 @@ +open Ast_typed +open Trace + +type contract_pass_data = { + contract_type : Helpers.contract_type ; + main_name : string ; +} + +module Errors = struct + let bad_self_type expected got loc () = + let title = thunk "bad self type" in + let message () = Format.asprintf "expected %a but got %a" Ast_typed.PP.type_expression expected Ast_typed.PP.type_expression got in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) + ] in + error ~data title message () + + let bad_format_entrypoint_ann ep loc () = + let title = thunk "bad entrypoint format" in + let message () = Format.asprintf "entrypoint \"%s\" is badly formatted. We expect \"%%bar\" for entrypoint Bar and \"%%default\" when no entrypoint used" ep in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ; + ] in + error ~data title message () + + let entrypoint_annotation_not_literal loc () = + let title = thunk "entrypoint annotation must be a string literal" in + let message () = Format.asprintf "" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ; + ] in + error ~data title message () + + let unmatched_entrypoint loc () = + let title = thunk "No constructor matches the entrypoint annotation" in + let message () = Format.asprintf "" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ; + ] in + error ~data title message () + +end + +let check_entrypoint_annotation_format ep exp = + match String.split_on_char '%' ep with + | [ "" ; ep'] -> + let cap = String.capitalize_ascii ep' in + if String.equal cap ep' then fail @@ Errors.bad_format_entrypoint_ann ep exp.location + else ok cap + | _ -> fail @@ Errors.bad_format_entrypoint_ann ep exp.location + + +let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data * expression) result = fun dat e -> + let bad_self_err () = Errors.bad_self_type + e.type_expression + {e.type_expression with type_content = T_operator (TC_contract dat.contract_type.parameter)} + e.location + in + match e.expression_content , e.type_expression with + | E_constant {cons_name=C_SELF ; arguments=[entrypoint_exp]}, {type_content = T_operator (TC_contract t) ; type_meta=_} -> + let%bind entrypoint = match entrypoint_exp.expression_content with + | E_literal (Literal_string ep) -> check_entrypoint_annotation_format ep entrypoint_exp + | _ -> fail @@ Errors.entrypoint_annotation_not_literal entrypoint_exp.location in + let%bind entrypoint_t = match dat.contract_type.parameter.type_content with + | T_sum cmap -> trace_option (Errors.unmatched_entrypoint entrypoint_exp.location) + @@ Stage_common.Types.CMap.find_opt (Constructor entrypoint) cmap + | t -> ok {dat.contract_type.parameter with type_content = t} in + let%bind () = + trace_strong (bad_self_err ()) @@ + Ast_typed.assert_type_expression_eq (entrypoint_t , t) in + ok (true, dat, e) + | _ -> ok (true,dat,e) diff --git a/src/passes/5-self_ast_typed/dune b/src/passes/5-self_ast_typed/dune new file mode 100644 index 000000000..0fc22a1d3 --- /dev/null +++ b/src/passes/5-self_ast_typed/dune @@ -0,0 +1,12 @@ +(library + (name self_ast_typed) + (public_name ligo.self_ast_typed) + (libraries + simple-utils + ast_typed + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/5-self_ast_typed/helpers.ml b/src/passes/5-self_ast_typed/helpers.ml new file mode 100644 index 000000000..f7d38302a --- /dev/null +++ b/src/passes/5-self_ast_typed/helpers.ml @@ -0,0 +1,394 @@ +open Ast_typed +open Trace +open Stage_common.Helpers + +type 'a folder = 'a -> expression -> 'a result +let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e -> + let self = fold_expression f in + let%bind init' = f init e in + match e.expression_content with + | E_literal _ | E_variable _ -> ok init' + | E_list lst | E_set lst | E_constant {arguments=lst} -> ( + let%bind res = bind_fold_list self init' lst in + ok res + ) + | E_map lst | E_big_map lst -> ( + let%bind res = bind_fold_list (bind_fold_pair self) init' lst in + ok res + ) + | E_look_up ab -> + let%bind res = bind_fold_pair self init' ab in + ok res + | E_loop {condition;body} -> + let ab = (condition,body) in + let%bind res = bind_fold_pair self init' ab in + ok res + | E_application {expr1;expr2} -> ( + let ab = (expr1,expr2) in + let%bind res = bind_fold_pair self init' ab in + ok res + ) + | E_lambda { binder = _ ; result = e } + | E_constructor {element=e} -> ( + let%bind res = self init' e in + ok res + ) + | E_matching {matchee=e; cases} -> ( + let%bind res = self init' e in + let%bind res = fold_cases f res cases in + ok res + ) + | E_record m -> ( + let aux init'' _ expr = + let%bind res = fold_expression self init'' expr in + ok res + in + let%bind res = bind_fold_lmap aux (ok init') m in + ok res + ) + | E_record_update {record;update} -> ( + let%bind res = self init' record in + let%bind res = fold_expression self res update in + ok res + ) + | E_record_accessor {expr} -> ( + let%bind res = self init' expr in + ok res + ) + | E_let_in { let_binder = _ ; rhs ; let_result } -> ( + let%bind res = self init' rhs in + let%bind res = self res let_result in + ok res + ) + +and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind res = fold_expression f init match_true in + let%bind res = fold_expression f res match_false in + ok res + ) + | Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> ( + let%bind res = fold_expression f init match_nil in + let%bind res = fold_expression f res cons in + ok res + ) + | Match_option { match_none ; match_some = (_ , some, _) } -> ( + let%bind res = fold_expression f init match_none in + let%bind res = fold_expression f res some in + ok res + ) + | Match_tuple ((_ , e), _) -> ( + let%bind res = fold_expression f init e in + ok res + ) + | Match_variant (lst, _) -> ( + let aux init' ((_ , _) , e) = + let%bind res' = fold_expression f init' e in + ok res' in + let%bind res = bind_fold_list aux init lst in + ok res + ) + +type mapper = expression -> expression result +let rec map_expression : mapper -> expression -> expression result = fun f e -> + let self = map_expression f in + let%bind e' = f e in + let return expression_content = ok { e' with expression_content } in + match e'.expression_content with + | E_list lst -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_list lst' + ) + | E_set lst -> ( + let%bind lst' = bind_map_list self lst in + return @@ E_set lst' + ) + | E_map lst -> ( + let%bind lst' = bind_map_list (bind_map_pair self) lst in + return @@ E_map lst' + ) + | E_big_map lst -> ( + let%bind lst' = bind_map_list (bind_map_pair self) lst in + return @@ E_big_map lst' + ) + | E_look_up ab -> ( + let%bind ab' = bind_map_pair self ab in + return @@ E_look_up ab' + ) + | E_loop {condition;body} -> ( + let ab = (condition,body) in + let%bind (a,b) = bind_map_pair self ab in + return @@ E_loop {condition = a; body = b} + ) + | E_matching {matchee=e;cases} -> ( + let%bind e' = self e in + let%bind cases' = map_cases f cases in + return @@ E_matching {matchee=e';cases=cases'} + ) + | E_record_accessor acc -> ( + let%bind e' = self acc.expr in + return @@ E_record_accessor {acc with expr = e'} + ) + | E_record m -> ( + let%bind m' = bind_map_lmap self m in + return @@ E_record m' + ) + | E_record_update {record; path; update} -> ( + let%bind record = self record in + let%bind update = self update in + return @@ E_record_update {record;path;update} + ) + | E_constructor c -> ( + let%bind e' = self c.element in + return @@ E_constructor {c with element = e'} + ) + | E_application {expr1;expr2} -> ( + let ab = (expr1,expr2) in + let%bind (a,b) = bind_map_pair self ab in + return @@ E_application {expr1=a;expr2=b} + ) + | E_let_in { let_binder ; rhs ; let_result; inline } -> ( + let%bind rhs = self rhs in + let%bind let_result = self let_result in + return @@ E_let_in { let_binder ; rhs ; let_result; inline } + ) + | E_lambda { binder ; result } -> ( + let%bind result = self result in + return @@ E_lambda { binder ; result } + ) + | E_constant c -> ( + let%bind args = bind_map_list self c.arguments in + return @@ E_constant {c with arguments=args} + ) + | E_literal _ | E_variable _ as e' -> return e' + + +and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind match_true = map_expression f match_true in + let%bind match_false = map_expression f match_false in + ok @@ Match_bool { match_true ; match_false } + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons, te) } -> ( + 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, te) } + ) + | Match_option { match_none ; match_some = (name , some, te) } -> ( + 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, te) } + ) + | Match_tuple ((names , e), _) -> ( + let%bind e' = map_expression f e in + ok @@ Match_tuple ((names , e'), []) + ) + | Match_variant (lst, te) -> ( + 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', te) + ) + +and map_program : mapper -> program -> program result = fun m p -> + let aux = fun (x : declaration) -> + match x with + | Declaration_constant (v , e , i, env) -> ( + let%bind e' = map_expression m e in + ok (Declaration_constant (v , e' , i, env)) + ) + in + bind_map_list (bind_map_location aux) p + +type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result +let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e -> + let self = fold_map_expression f in + let%bind (continue, init',e') = f a e in + if (not continue) then ok(init',e') + else + let return expression_content = { e' with expression_content } in + match e'.expression_content with + | E_list lst -> ( + let%bind (res, lst') = bind_fold_map_list self init' lst in + ok (res, return @@ E_list lst') + ) + | E_set lst -> ( + let%bind (res, lst') = bind_fold_map_list self init' lst in + ok (res, return @@ E_set lst') + ) + | E_map lst -> ( + let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in + ok (res, return @@ E_map lst') + ) + | E_big_map lst -> ( + let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in + ok (res, return @@ E_big_map lst') + ) + | E_look_up ab -> ( + let%bind (res, ab') = bind_fold_map_pair self init' ab in + ok (res, return @@ E_look_up ab') + ) + | E_loop {condition;body} -> ( + let ab = (condition,body) in + let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in + ok (res, return @@ E_loop {condition = a; body = b}) + ) + | E_matching {matchee=e;cases} -> ( + let%bind (res, e') = self init' e in + let%bind (res,cases') = fold_map_cases f res cases in + ok (res, return @@ E_matching {matchee=e';cases=cases'}) + ) + | E_record_accessor acc -> ( + let%bind (res, e') = self init' acc.expr in + ok (res, return @@ E_record_accessor {acc with expr = e'}) + ) + | E_record m -> ( + let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in + let m' = LMap.of_list lst' in + ok (res, return @@ E_record m') + ) + | E_record_update {record; path; update} -> ( + let%bind (res, record) = self init' record in + let%bind (res, update) = self res update in + ok (res, return @@ E_record_update {record;path;update}) + ) + | E_constructor c -> ( + let%bind (res,e') = self init' c.element in + ok (res, return @@ E_constructor {c with element = e'}) + ) + | E_application {expr1;expr2} -> ( + let ab = (expr1,expr2) in + let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in + ok (res, return @@ E_application {expr1=a;expr2=b}) + ) + | E_let_in { let_binder ; rhs ; let_result; inline } -> ( + let%bind (res,rhs) = self init' rhs in + let%bind (res,let_result) = self res let_result in + ok (res, return @@ E_let_in { let_binder ; rhs ; let_result ; inline }) + ) + | E_lambda { binder ; result } -> ( + let%bind (res,result) = self init' result in + ok ( res, return @@ E_lambda { binder ; result }) + ) + | E_constant c -> ( + let%bind (res,args) = bind_fold_map_list self init' c.arguments in + ok (res, return @@ E_constant {c with arguments=args}) + ) + | E_literal _ | E_variable _ as e' -> ok (init', return e') + +and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> + match m with + | Match_bool { match_true ; match_false } -> ( + let%bind (init, match_true) = fold_map_expression f init match_true in + let%bind (init, match_false) = fold_map_expression f init match_false in + ok @@ (init, Match_bool { match_true ; match_false }) + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons, te) } -> ( + 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, te) }) + ) + | Match_option { match_none ; match_some = (name , some, te) } -> ( + 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, te) }) + ) + | Match_tuple ((names , e), _) -> ( + let%bind (init, e') = fold_map_expression f init e in + ok @@ (init, Match_tuple ((names , e'), [])) + ) + | Match_variant (lst, te) -> ( + 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', te)) + ) + +and fold_map_program : 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p -> + let aux = fun (acc,acc_prg) (x : declaration Location.wrap) -> + match Location.unwrap x with + | Declaration_constant (v , e , i, env) -> ( + let%bind (acc',e') = fold_map_expression m acc e in + let wrap_content = Declaration_constant (v , e' , i, env) in + ok (acc', List.append acc_prg [{x with wrap_content}]) + ) + in + bind_fold_list aux (init,[]) p + +module Errors = struct + let bad_contract_io entrypoint e () = + let title = thunk "badly typed contract" in + let message () = Format.asprintf "unexpected entrypoint type" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp e.location); + ("entrypoint" , fun () -> entrypoint); + ("entrypoint_type" , fun () -> Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression) + ] in + error ~data title message () + + let expected_list_operation entrypoint got e () = + let title = thunk "bad return type" in + let message () = Format.asprintf "expected %a, got %a" + Ast_typed.PP.type_expression {got with type_content= T_operator (TC_list {got with type_content=T_constant TC_operation})} + Ast_typed.PP.type_expression got + in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp e.location); + ("entrypoint" , fun () -> entrypoint) + ] in + error ~data title message () + + let expected_same entrypoint t1 t2 e () = + let title = thunk "badly typed contract" in + let message () = Format.asprintf "expected {%a} and {%a} to be the same in the entrypoint type" + Ast_typed.PP.type_expression t1 + Ast_typed.PP.type_expression t2 + in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp e.location); + ("entrypoint" , fun () -> entrypoint); + ("entrypoint_type" , fun () -> Format.asprintf "%a" Ast_typed.PP.type_expression e.type_expression) + ] in + error ~data title message () + +end + +type contract_type = { + parameter : Ast_typed.type_expression ; + storage : Ast_typed.type_expression ; +} + +let fetch_contract_type : string -> program -> contract_type result = fun main_fname program -> + let main_decl = List.rev @@ List.filter + (fun declt -> + let (Declaration_constant (v , _ , _ , _)) = Location.unwrap declt in + String.equal (Var.to_name v) main_fname + ) + program + in + match main_decl with + | (hd::_) -> ( + let (Declaration_constant (_,e,_,_)) = Location.unwrap hd in + match e.type_expression.type_content with + | T_arrow {type1 ; type2} -> ( + match type1.type_content , type2.type_content with + | T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) -> + let%bind (parameter,storage) = Stage_common.Helpers.get_pair tin in + let%bind (listop,storage') = Stage_common.Helpers.get_pair tout in + let%bind () = trace_strong (Errors.expected_list_operation main_fname listop e) @@ + Ast_typed.assert_t_list_operation listop in + let%bind () = trace_strong (Errors.expected_same main_fname storage storage' e) @@ + Ast_typed.assert_type_expression_eq (storage,storage') in + (* TODO: on storage/parameter : assert_storable, assert_passable ? *) + ok { parameter ; storage } + | _ -> fail @@ Errors.bad_contract_io main_fname e + ) + | _ -> fail @@ Errors.bad_contract_io main_fname e + ) + | [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist") \ No newline at end of file diff --git a/src/passes/5-self_ast_typed/self_ast_typed.ml b/src/passes/5-self_ast_typed/self_ast_typed.ml new file mode 100644 index 000000000..165a1825f --- /dev/null +++ b/src/passes/5-self_ast_typed/self_ast_typed.ml @@ -0,0 +1,24 @@ +open Trace + +let all_passes = [] + +let contract_passes = [ + Contract_passes.self_typing ; +] + +let all_program = + let all_p = List.map Helpers.map_program all_passes in + bind_chain all_p + +let all_expression = + let all_p = List.map Helpers.map_expression all_passes in + bind_chain all_p + +let all_contract main_name prg = + let%bind contract_type = Helpers.fetch_contract_type main_name prg in + let data : Contract_passes.contract_pass_data = { + contract_type = contract_type ; + main_name = main_name ; + } in + let all_p = List.map (fun pass -> Helpers.fold_map_program pass data) contract_passes in + bind_chain_ignore_acc all_p prg diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 73635024e..491b1b91a 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -32,6 +32,20 @@ let rec get_operator : constant' -> type_value -> expression list -> predicate r | Ok (x,_) -> ok x | Error _ -> ( match s with + | C_SELF -> ( + let%bind entrypoint_as_string = match lst with + | [{ content = E_literal (D_string s); type_value = _ }] -> ( + match String.split_on_char '%' s with + | ["" ; s] -> ok @@ String.concat "" ["%" ; (String.uncapitalize_ascii s)] + | _ -> fail @@ corner_case ~loc:__LOC__ "mini_c . SELF" + ) + | _ -> + fail @@ corner_case ~loc:__LOC__ "mini_c . SELF" in + ok @@ simple_unary @@ seq [ + i_drop ; + prim ~annot:[entrypoint_as_string] I_SELF + ] + ) | C_NONE -> ( let%bind ty' = Mini_c.get_t_option ty in let%bind m_ty = Compiler_type.type_ ty' in diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 9fd521087..e2adcc18f 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -66,7 +66,6 @@ module Simplify = struct module Pascaligo = struct let constants = function (* Tezos module (ex-Michelson) *) - | "Tezos.chain_id" -> ok C_CHAIN_ID | "chain_id" -> ok C_CHAIN_ID (* Deprecated *) | "get_chain_id" -> ok C_CHAIN_ID (* Deprecated *) @@ -79,7 +78,8 @@ module Simplify = struct | "Tezos.sender" -> ok C_SENDER | "sender" -> ok C_SENDER (* Deprecated *) | "Tezos.address" -> ok C_ADDRESS - | "address" -> ok C_ADDRESS (* Deprecated *) + | "address" -> ok C_ADDRESS (* Deprecated *) + | "Tezos.self" -> ok C_SELF | "Tezos.self_address" -> ok C_SELF_ADDRESS | "self_address" -> ok C_SELF_ADDRESS (* Deprecated *) | "Tezos.implicit_account" -> ok C_IMPLICIT_ACCOUNT @@ -267,6 +267,7 @@ module Simplify = struct | "sender" -> ok C_SENDER (* Deprecated *) | "Tezos.address" -> ok C_ADDRESS | "Current.address" -> ok C_ADDRESS (* Deprecated *) + | "Tezos.self" -> ok C_SELF | "Tezos.self_address" -> ok C_SELF_ADDRESS | "Current.self_address" -> ok C_SELF_ADDRESS (* Deprecated *) | "Tezos.implicit_account" -> ok C_IMPLICIT_ACCOUNT @@ -791,6 +792,12 @@ module Typer = struct let self_address = typer_0 "SELF_ADDRESS" @@ fun _ -> ok @@ t_address () + let self = typer_1_opt "SELF" @@ fun entrypoint_as_string tv_opt -> + let%bind () = assert_t_string entrypoint_as_string in + match tv_opt with + | None -> simple_fail "untyped SELF" + | Some t -> ok @@ t + let implicit_account = typer_1 "IMPLICIT_ACCOUNT" @@ fun key_hash -> let%bind () = assert_t_key_hash key_hash in ok @@ t_contract (t_unit () ) () @@ -1228,6 +1235,7 @@ module Typer = struct | C_SENDER -> ok @@ sender ; | C_SOURCE -> ok @@ source ; | C_ADDRESS -> ok @@ address ; + | C_SELF -> ok @@ self; | C_SELF_ADDRESS -> ok @@ self_address; | C_IMPLICIT_ACCOUNT -> ok @@ implicit_account; | C_SET_DELEGATE -> ok @@ set_delegate ; diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index d1c0c4b1a..0a54bc708 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -233,6 +233,10 @@ let assert_t_bytes = fun t -> let%bind _ = get_t_bytes t in ok () +let assert_t_string = fun t -> + let%bind _ = get_t_string t in + ok () + let assert_t_operation (t:type_expression) : unit result = match t.type_content with | T_constant (TC_operation) -> ok () diff --git a/src/stages/ast_typed/combinators.mli b/src/stages/ast_typed/combinators.mli index 273fa15be..1b3f31aea 100644 --- a/src/stages/ast_typed/combinators.mli +++ b/src/stages/ast_typed/combinators.mli @@ -91,6 +91,7 @@ val is_t_bytes : type_expression -> bool val is_t_int : type_expression -> bool val assert_t_bytes : type_expression -> unit result +val assert_t_string : type_expression -> unit result (* val assert_t_operation : type_expression -> unit result *) diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 14cde83d5..ee232f044 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -143,6 +143,7 @@ let constant ppf : constant' -> unit = function | C_SOURCE -> fprintf ppf "SOURCE" | C_SENDER -> fprintf ppf "SENDER" | C_ADDRESS -> fprintf ppf "ADDRESS" + | C_SELF -> fprintf ppf "SELF" | C_SELF_ADDRESS -> fprintf ppf "SELF_ADDRESS" | C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT" | C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE" diff --git a/src/stages/common/helpers.ml b/src/stages/common/helpers.ml index 9a930215a..d498a1712 100644 --- a/src/stages/common/helpers.ml +++ b/src/stages/common/helpers.ml @@ -38,3 +38,9 @@ let label_range i j = let is_tuple_lmap m = List.for_all (fun i -> LMap.mem i m) @@ (label_range 0 (LMap.cardinal m)) + +let get_pair m = + let open Trace in + match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with + | Some e1, Some e2 -> ok (e1,e2) + | _ -> simple_fail "not a pair" diff --git a/src/stages/common/helpers.mli b/src/stages/common/helpers.mli index f35f9a33c..69efa24eb 100644 --- a/src/stages/common/helpers.mli +++ b/src/stages/common/helpers.mli @@ -16,3 +16,6 @@ val bind_map_cmap : 'a Types.constructor_map -> ('b Types.constructor_map * 'c list, 'd) result val is_tuple_lmap : 'a Types.label_map -> bool +val get_pair : + 'a Types.label_map -> + (('a * 'a) * 'b list, unit -> Trace.error) result diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index d6b0839fd..1eacb7f7c 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -285,6 +285,7 @@ and constant' = | C_SOURCE | C_SENDER | C_ADDRESS + | C_SELF | C_SELF_ADDRESS | C_IMPLICIT_ACCOUNT | C_SET_DELEGATE diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index bb0ff6476..7626081cc 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -237,6 +237,7 @@ and constant ppf : constant' -> unit = function | C_SOURCE -> fprintf ppf "SOURCE" | C_SENDER -> fprintf ppf "SENDER" | C_ADDRESS -> fprintf ppf "ADDRESS" + | C_SELF -> fprintf ppf "SELF" | C_SELF_ADDRESS -> fprintf ppf "SELF_ADDRESS" | C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT" | C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE" diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index be36603c7..5df29091f 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -5,7 +5,7 @@ open Test_helpers let type_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in ok @@ (typed,state) let get_program = @@ -21,7 +21,7 @@ let get_program = let compile_main () = let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/coase.ligo" (Syntax_name "pascaligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = diff --git a/src/test/contracts/negative/bad_contract.mligo b/src/test/contracts/negative/bad_contract.mligo new file mode 100644 index 000000000..28e5506f3 --- /dev/null +++ b/src/test/contracts/negative/bad_contract.mligo @@ -0,0 +1,5 @@ +type storage = int +type parameter = nat + +let main (action, store : parameter * storage) : storage = + store + 1 \ No newline at end of file diff --git a/src/test/contracts/negative/bad_contract2.mligo b/src/test/contracts/negative/bad_contract2.mligo new file mode 100644 index 000000000..7e95f7175 --- /dev/null +++ b/src/test/contracts/negative/bad_contract2.mligo @@ -0,0 +1,6 @@ +type storage = int +type parameter = nat +type return = string * storage + +let main (action, store : parameter * storage) : return = + ("bad",store + 1) \ No newline at end of file diff --git a/src/test/contracts/negative/bad_contract3.mligo b/src/test/contracts/negative/bad_contract3.mligo new file mode 100644 index 000000000..5c5c71a66 --- /dev/null +++ b/src/test/contracts/negative/bad_contract3.mligo @@ -0,0 +1,6 @@ +type storage = int +type parameter = nat +type return = operation list * string + +let main (action, store : parameter * storage) : return = + (([]: operation list),"bad") \ No newline at end of file diff --git a/src/test/contracts/negative/self_bad_entrypoint_format.ligo b/src/test/contracts/negative/self_bad_entrypoint_format.ligo new file mode 100644 index 000000000..ee22c4979 --- /dev/null +++ b/src/test/contracts/negative/self_bad_entrypoint_format.ligo @@ -0,0 +1,11 @@ +type parameter is Default | Toto of int +type storage is nat +type return is list (operation) * storage + + +function main (const p : parameter; const s : storage) : return is + block { + const self_contract: contract(int) = Tezos.self("Toto") ; + const op : operation = Tezos.transaction (2, 300tz, self_contract) ; + } + with (list [op], s) \ No newline at end of file diff --git a/src/test/contracts/negative/self_in_lambda.mligo b/src/test/contracts/negative/self_in_lambda.mligo index 4c497e268..b059189da 100644 --- a/src/test/contracts/negative/self_in_lambda.mligo +++ b/src/test/contracts/negative/self_in_lambda.mligo @@ -1,5 +1,5 @@ let foo (u : unit) : address = Tezos.self_address -let main (ps : unit * address) : (operation list * address) = - let dummy = foo () in - ([] : operation list), foo () +let main (ps: unit * address): (operation list * address) = + let dummy = foo () in (* force not to inline foo *) + ( ([] : operation list) , foo ()) diff --git a/src/test/contracts/negative/self_type_annotation.ligo b/src/test/contracts/negative/self_type_annotation.ligo new file mode 100644 index 000000000..375fbf0af --- /dev/null +++ b/src/test/contracts/negative/self_type_annotation.ligo @@ -0,0 +1,10 @@ +type parameter is nat +type storage is int +type return is list (operation) * storage + + +function main (const p : parameter; const s : storage) : return is + block { + const self_contract: contract(int) = Tezos.self ("%default"); + } + with ((nil: list(operation)), s) \ No newline at end of file diff --git a/src/test/contracts/self_type_annotation.ligo b/src/test/contracts/self_type_annotation.ligo new file mode 100644 index 000000000..3bd607aa1 --- /dev/null +++ b/src/test/contracts/self_type_annotation.ligo @@ -0,0 +1,10 @@ +type parameter is nat +type storage is int +type return is list (operation) * storage + + +function main (const p : parameter; const s : storage) : return is + block { + const self_contract: contract(parameter) = Tezos.self("%default") ; + } + with ((nil: list(operation)), s) \ No newline at end of file diff --git a/src/test/contracts/self_with_entrypoint.ligo b/src/test/contracts/self_with_entrypoint.ligo new file mode 100644 index 000000000..aede1b5b5 --- /dev/null +++ b/src/test/contracts/self_with_entrypoint.ligo @@ -0,0 +1,12 @@ +type parameter is Default | Toto of int +type storage is nat +type return is list (operation) * storage + + +function main (const p : parameter; const s : storage) : return is + block { + // const v : string = "%toto" ; + const self_contract: contract(int) = Tezos.self("%toto") ; + const op : operation = Tezos.transaction (2, 300tz, self_contract) ; + } + with (list [op], s) \ No newline at end of file diff --git a/src/test/contracts/self_without_entrypoint.ligo b/src/test/contracts/self_without_entrypoint.ligo new file mode 100644 index 000000000..04701cf1d --- /dev/null +++ b/src/test/contracts/self_without_entrypoint.ligo @@ -0,0 +1,11 @@ +type parameter is int +type storage is nat +type return is list (operation) * storage + + +function main (const p : parameter; const s : storage) : return is + block { + const self_contract: contract(int) = Tezos.self("%default") ; + const op : operation = Tezos.transaction (2, 300tz, self_contract) ; + } + with (list [op], s) \ No newline at end of file diff --git a/src/test/contracts/subtle_nontail_fail.mligo b/src/test/contracts/subtle_nontail_fail.mligo index 6b3c52b9b..c285b14a1 100644 --- a/src/test/contracts/subtle_nontail_fail.mligo +++ b/src/test/contracts/subtle_nontail_fail.mligo @@ -1,4 +1,4 @@ -let main (_ : unit * unit) = +let main (ps : unit * unit) : operation list * unit = if true - then failwith "This contract always fails" - else failwith "This contract still always fails" + then (failwith "This contract always fails" : operation list * unit) + else (failwith "This contract still always fails" : operation list * unit) diff --git a/src/test/hash_lock_tests.ml b/src/test/hash_lock_tests.ml index 7da1882ab..7a6db1ea8 100644 --- a/src/test/hash_lock_tests.ml +++ b/src/test/hash_lock_tests.ml @@ -4,7 +4,7 @@ open Ast_simplified let type_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "cameligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in ok @@ (typed,state) let get_program = @@ -19,7 +19,7 @@ let get_program = let compile_main () = let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/hashlock.mligo" (Syntax_name "cameligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = diff --git a/src/test/id_tests.ml b/src/test/id_tests.ml index db8b78960..294cd08ff 100644 --- a/src/test/id_tests.ml +++ b/src/test/id_tests.ml @@ -5,7 +5,7 @@ open Ast_simplified let mtype_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "cameligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in ok (typed,state) let get_program = @@ -20,7 +20,7 @@ let get_program = let compile_main () = let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/id.mligo" (Syntax_name "cameligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index e6de67651..ffac8e299 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -5,18 +5,18 @@ open Ast_simplified.Combinators let retype_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "reasonligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile Env simplified in let () = Typer.Solver.discard_state state in let () = Typer.Solver.discard_state state in ok typed let mtype_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "cameligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile Env simplified in let () = Typer.Solver.discard_state state in ok typed let type_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile Env simplified in let () = Typer.Solver.discard_state state in ok typed diff --git a/src/test/md_file_tests.ml b/src/test/md_file_tests.ml index ca3eb65e3..14748f9c8 100644 --- a/src/test/md_file_tests.ml +++ b/src/test/md_file_tests.ml @@ -69,7 +69,7 @@ let compile_groups _filename grp_list = trace (failed_to_compile_md_file _filename (s,grp,contents)) @@ let%bind v_syntax = Compile.Helpers.syntax_to_variant (Syntax_name s) None in let%bind simplified = Compile.Of_source.compile_string contents v_syntax in - let%bind typed,_ = Compile.Of_simplified.compile simplified in + let%bind typed,_ = Compile.Of_simplified.compile Env simplified in let%bind mini_c = Compile.Of_typed.compile typed in bind_map_list (fun ((_, _, exp),_) -> Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp) diff --git a/src/test/multisig_tests.ml b/src/test/multisig_tests.ml index e71c5ce99..704171e01 100644 --- a/src/test/multisig_tests.ml +++ b/src/test/multisig_tests.ml @@ -7,7 +7,7 @@ let refile = "./contracts/multisig.religo" let type_file f s = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name s) in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in ok @@ (typed,state) let get_program f st = diff --git a/src/test/multisig_v2_tests.ml b/src/test/multisig_v2_tests.ml index 0ed619c1d..391be83d2 100644 --- a/src/test/multisig_v2_tests.ml +++ b/src/test/multisig_v2_tests.ml @@ -3,7 +3,7 @@ open Test_helpers let type_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in ok @@ (typed,state) let get_program = @@ -18,7 +18,7 @@ let get_program = let compile_main () = let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/multisig-v2.ligo" (Syntax_name "pascaligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = diff --git a/src/test/pledge_tests.ml b/src/test/pledge_tests.ml index 189e45a82..d6af4f369 100644 --- a/src/test/pledge_tests.ml +++ b/src/test/pledge_tests.ml @@ -5,7 +5,7 @@ open Ast_simplified let retype_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "reasonligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile Env simplified in ok (typed,state) let get_program = @@ -20,7 +20,7 @@ let get_program = let compile_main () = let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/pledge.religo" (Syntax_name "reasonligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile Env simplified in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = diff --git a/src/test/replaceable_id_tests.ml b/src/test/replaceable_id_tests.ml index 54d7d1a64..60bcb203e 100644 --- a/src/test/replaceable_id_tests.ml +++ b/src/test/replaceable_id_tests.ml @@ -3,7 +3,7 @@ open Test_helpers let type_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in ok @@ (typed,state) let get_program = @@ -18,7 +18,7 @@ let get_program = let compile_main () = let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/replaceable_id.ligo" (Syntax_name "pascaligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = diff --git a/src/test/time_lock_repeat_tests.ml b/src/test/time_lock_repeat_tests.ml index 4405948bf..b5a3f7427 100644 --- a/src/test/time_lock_repeat_tests.ml +++ b/src/test/time_lock_repeat_tests.ml @@ -4,7 +4,7 @@ open Ast_simplified let type_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "cameligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in ok @@ (typed,state) let get_program = @@ -19,7 +19,7 @@ let get_program = let compile_main () = let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/timelock_repeat.mligo" (Syntax_name "cameligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = diff --git a/src/test/time_lock_tests.ml b/src/test/time_lock_tests.ml index a3437461a..eb3001f49 100644 --- a/src/test/time_lock_tests.ml +++ b/src/test/time_lock_tests.ml @@ -3,7 +3,7 @@ open Test_helpers let type_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in ok @@ (typed,state) let get_program = @@ -18,7 +18,7 @@ let get_program = let compile_main () = let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/time-lock.ligo" (Syntax_name "pascaligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = diff --git a/src/test/vote_tests.ml b/src/test/vote_tests.ml index 3a0a95021..ddc3d620d 100644 --- a/src/test/vote_tests.ml +++ b/src/test/vote_tests.ml @@ -3,7 +3,7 @@ open Test_helpers let type_file f = let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "cameligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed,state = Ligo.Compile.Of_simplified.compile (Contract "main") simplified in ok @@ (typed,state) let get_program = diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 6b7cdde70..0c3bcbcdd 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -699,6 +699,16 @@ let rec bind_chain : ('a -> 'a result) list -> 'a -> 'a result = fun fs x -> bind aux (ok x) ) +let rec bind_chain_ignore_acc : ('a -> ('b * 'a) result) list -> 'a -> 'a result = fun fs x -> + match fs with + | [] -> ok x + | hd :: tl -> ( + let aux : 'a -> 'a result = fun x -> + hd x >>? fun (_,aa) -> + bind (bind_chain_ignore_acc tl) (ok aa) in + bind aux (ok x) + ) + (** Wraps a call that might trigger an exception in a result. *)