From 7454e8b01fa050ec40a02c06b6e6f8bca226786d Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Tue, 24 Dec 2019 13:48:14 -0800 Subject: [PATCH 1/4] Add let-in multi bind test --- src/test/contracts/let_in_multi_bind.mligo | 2 ++ src/test/integration_tests.ml | 6 ++++++ 2 files changed, 8 insertions(+) create mode 100644 src/test/contracts/let_in_multi_bind.mligo diff --git a/src/test/contracts/let_in_multi_bind.mligo b/src/test/contracts/let_in_multi_bind.mligo new file mode 100644 index 000000000..5555b7ae1 --- /dev/null +++ b/src/test/contracts/let_in_multi_bind.mligo @@ -0,0 +1,2 @@ +let sum (p: int * int) : int = + let i, result = p in i + result diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 05a95463d..d0931a3cf 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1795,6 +1795,11 @@ let type_tuple_destruct () : unit result = let%bind () = expect_eq program "type_tuple_d_2" (e_unit ()) (e_string "helloworld") in ok () +let let_in_multi_bind () : unit result = + let%bind program = mtype_file "./contracts/let_in_multi_bind.mligo" in + let%bind () = expect_eq program "sum" (e_tuple [e_int 10; e_int 10]) (e_int 20) + in ok () + let main = test_suite "Integration (End to End)" [ test "key hash" key_hash ; test "chain id" chain_id ; @@ -1933,4 +1938,5 @@ let main = test_suite "Integration (End to End)" [ test "deep_access (ligo)" deep_access_ligo; test "entrypoints (ligo)" entrypoints_ligo ; test "type tuple destruct (mligo)" type_tuple_destruct ; + test "let in multi-bind (mligo)" let_in_multi_bind ; ] From 48a3bebadd5dcec068677a2580e3090eb3d79b4f Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Tue, 24 Dec 2019 14:54:22 -0800 Subject: [PATCH 2/4] Working rough draft of let ... in multi-bind --- src/passes/2-simplify/cameligo.ml | 59 +++++++++++++++++++++---------- 1 file changed, 41 insertions(+), 18 deletions(-) diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-simplify/cameligo.ml index 530b46042..aa7753789 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-simplify/cameligo.ml @@ -22,25 +22,20 @@ let get_value : 'a Raw.reg -> 'a = fun x -> x.value module Errors = struct let wrong_pattern expected_name actual = let title () = "wrong pattern" in - let message () = "" in + let message () = + match actual with + | Raw.PTuple _ -> "tuple" + | Raw.PRecord _ -> "record" + | Raw.PList _ -> "list" + | Raw.PBytes _ -> "bytes" + | _ -> "other" + in let data = [ ("expected", fun () -> expected_name); ("actual_loc" , fun () -> Format.asprintf "%a" Location.pp_lift @@ Raw.pattern_to_region actual) ] in error ~data title message - let multiple_patterns construct (patterns: Raw.pattern list) = - let title () = "multiple patterns" in - let message () = - Format.asprintf "multiple patterns in \"%s\" are not supported yet" construct in - let patterns_loc = - List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) - Region.ghost patterns in - let data = [ - ("patterns_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc) - ] in - error ~data title message - let unknown_predefined_type name = let title () = "type constants" in let message () = @@ -160,10 +155,17 @@ let rec expr_to_typed_expr : Raw.expr -> _ = function | EAnnot {value={inside=e,_,t; _}; _} -> ok (e, Some t) | e -> ok (e , None) -let patterns_to_var : Raw.pattern nseq -> _ = fun ps -> +let rec patterns_to_typed_vars : Raw.pattern nseq -> _ = fun ps -> match ps with - | pattern, [] -> pattern_to_var pattern - | _ -> fail @@ multiple_patterns "let" (nseq_to_list ps) + | pattern, [] -> + begin + match pattern with + | Raw.PPar pp -> patterns_to_typed_vars (pp.value.inside, []) + | Raw.PTuple pt -> bind_map_list pattern_to_typed_var (npseq_to_list pt.value) + | Raw.PVar _ -> bind_list [pattern_to_typed_var pattern] + | other -> (fail @@ wrong_pattern "bla bla" other) + end + | hd, tl -> bind_map_list pattern_to_typed_var (nseq_to_list (hd, tl)) let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> trace (simple_info "simplifying this type expression...") @@ @@ -254,7 +256,7 @@ let rec simpl_expression : Raw.ELetIn e -> let Raw.{binding; body; _} = e.value in let Raw.{binders; lhs_type; let_rhs; _} = binding in - let%bind variable = patterns_to_var binders in + let%bind variables = patterns_to_typed_vars binders in let%bind ty_opt = bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in let%bind rhs = simpl_expression let_rhs in @@ -263,7 +265,28 @@ let rec simpl_expression : None -> rhs | Some ty -> e_annotation rhs ty in let%bind body = simpl_expression body in - return @@ e_let_in (Var.of_name variable.value , None) rhs' body + let prepare_variable (ty_var: Raw.variable * Raw.type_expr option) = + let variable, ty_opt = ty_var in + let var_expr = Var.of_name variable.value in + let%bind ty_expr_opt = + match ty_opt with + | Some ty -> bind_map_option simpl_type_expression (Some ty) + | None -> ok None + in ok (var_expr, ty_expr_opt) + in + let%bind prep_vars = bind_list (List.map prepare_variable variables) in + let rec chain_let_in variables body : _ = + match variables with + | hd :: [] -> + if (List.length prep_vars = 1) + then e_let_in hd rhs' body + else e_let_in hd (e_accessor rhs' [Access_tuple ((List.length prep_vars) - 1)]) body + | hd :: tl -> + e_let_in hd + (e_accessor rhs' [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)]) + (chain_let_in tl body) + | [] -> body (* Make this an error *) + in ok (chain_let_in prep_vars body) | Raw.EAnnot a -> let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in let%bind expr' = simpl_expression expr in From 2d9de2aef0d223605acefa2dcf0b845ec98ab828 Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Tue, 24 Dec 2019 15:35:05 -0800 Subject: [PATCH 3/4] Clean up let ... in multi-bind --- src/passes/2-simplify/cameligo.ml | 29 +++++++++++++++++++--- src/test/contracts/let_in_multi_bind.mligo | 3 +++ src/test/integration_tests.ml | 9 ++++++- 3 files changed, 37 insertions(+), 4 deletions(-) diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-simplify/cameligo.ml index aa7753789..5d902b5d8 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-simplify/cameligo.ml @@ -36,6 +36,18 @@ module Errors = struct ] in error ~data title message + let multiple_patterns construct (patterns: Raw.pattern list) = + let title () = "multiple patterns" in + let message () = + Format.asprintf "multiple patterns in \"%s\" are not supported yet" construct in + let patterns_loc = + List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) + Region.ghost patterns in + let data = [ + ("patterns_loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc) + ] in + error ~data title message + let unknown_predefined_type name = let title () = "type constants" in let message () = @@ -123,6 +135,12 @@ module Errors = struct fun () -> Format.asprintf "%a" Location.pp_lift @@ region) ] in error ~data title message + + let corner_case description = + let title () = "corner case" in + let message () = description in + error title message + end open Errors @@ -165,7 +183,7 @@ let rec patterns_to_typed_vars : Raw.pattern nseq -> _ = fun ps -> | Raw.PVar _ -> bind_list [pattern_to_typed_var pattern] | other -> (fail @@ wrong_pattern "bla bla" other) end - | hd, tl -> bind_map_list pattern_to_typed_var (nseq_to_list (hd, tl)) + | _ -> fail @@ multiple_patterns "let" (nseq_to_list ps) let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> trace (simple_info "simplifying this type expression...") @@ @@ -275,7 +293,12 @@ let rec simpl_expression : in ok (var_expr, ty_expr_opt) in let%bind prep_vars = bind_list (List.map prepare_variable variables) in - let rec chain_let_in variables body : _ = + let%bind () = + if (List.length prep_vars) = 0 + then fail @@ corner_case "let ... in without variables passed parsing stage" + else ok () + in + let rec chain_let_in variables body : expression = match variables with | hd :: [] -> if (List.length prep_vars = 1) @@ -285,7 +308,7 @@ let rec simpl_expression : e_let_in hd (e_accessor rhs' [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)]) (chain_let_in tl body) - | [] -> body (* Make this an error *) + | [] -> body (* Precluded by corner case assertion above *) in ok (chain_let_in prep_vars body) | Raw.EAnnot a -> let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in diff --git a/src/test/contracts/let_in_multi_bind.mligo b/src/test/contracts/let_in_multi_bind.mligo index 5555b7ae1..e61dc14a7 100644 --- a/src/test/contracts/let_in_multi_bind.mligo +++ b/src/test/contracts/let_in_multi_bind.mligo @@ -1,2 +1,5 @@ let sum (p: int * int) : int = let i, result = p in i + result + +let sum2 (p: string * string * string * string) : int = + let a, b, c, d = p in a ^ b ^ c ^ d diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index d0931a3cf..f6b58f237 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1797,7 +1797,14 @@ let type_tuple_destruct () : unit result = let let_in_multi_bind () : unit result = let%bind program = mtype_file "./contracts/let_in_multi_bind.mligo" in - let%bind () = expect_eq program "sum" (e_tuple [e_int 10; e_int 10]) (e_int 20) + let%bind () = expect_eq program "sum" (e_tuple [e_int 10; e_int 10]) (e_int 20) in + let%bind () = expect_eq program "sum2" + (e_tuple + [e_string "my" ; + e_string "name" ; + e_string "is" ; + e_string "bob" ]) + (e_string "mynameisbob") in ok () let main = test_suite "Integration (End to End)" [ From e1ecb36e61bb4af8ce238007f84581c72e40e775 Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Thu, 26 Dec 2019 21:06:24 -0800 Subject: [PATCH 4/4] Have let ... in evaluate right hand side first during multi-bind --- src/passes/2-simplify/cameligo.ml | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-simplify/cameligo.ml index 5d902b5d8..1d2b5571e 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-simplify/cameligo.ml @@ -181,7 +181,7 @@ let rec patterns_to_typed_vars : Raw.pattern nseq -> _ = fun ps -> | Raw.PPar pp -> patterns_to_typed_vars (pp.value.inside, []) | Raw.PTuple pt -> bind_map_list pattern_to_typed_var (npseq_to_list pt.value) | Raw.PVar _ -> bind_list [pattern_to_typed_var pattern] - | other -> (fail @@ wrong_pattern "bla bla" other) + | other -> (fail @@ wrong_pattern "parenthetical, tuple, or variable" other) end | _ -> fail @@ multiple_patterns "let" (nseq_to_list ps) @@ -278,10 +278,11 @@ let rec simpl_expression : let%bind ty_opt = bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in let%bind rhs = simpl_expression let_rhs in - let rhs' = + let rhs_b = Var.fresh ~name: "rhs" () in + let rhs',rhs_b_expr = match ty_opt with - None -> rhs - | Some ty -> e_annotation rhs ty in + None -> rhs, e_variable rhs_b + | Some ty -> (e_annotation rhs ty), e_annotation (e_variable rhs_b) ty in let%bind body = simpl_expression body in let prepare_variable (ty_var: Raw.variable * Raw.type_expr option) = let variable, ty_opt = ty_var in @@ -298,18 +299,26 @@ let rec simpl_expression : then fail @@ corner_case "let ... in without variables passed parsing stage" else ok () in + let rhs_b_expr = (* We only want to evaluate the rhs first if multi-bind *) + if List.length prep_vars = 1 + then rhs' else rhs_b_expr + in let rec chain_let_in variables body : expression = match variables with | hd :: [] -> if (List.length prep_vars = 1) - then e_let_in hd rhs' body - else e_let_in hd (e_accessor rhs' [Access_tuple ((List.length prep_vars) - 1)]) body + then e_let_in hd rhs_b_expr body + else e_let_in hd (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - 1)]) body | hd :: tl -> e_let_in hd - (e_accessor rhs' [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)]) + (e_accessor rhs_b_expr [Access_tuple ((List.length prep_vars) - (List.length tl) - 1)]) (chain_let_in tl body) | [] -> body (* Precluded by corner case assertion above *) - in ok (chain_let_in prep_vars body) + in + if List.length prep_vars = 1 + then ok (chain_let_in prep_vars body) + (* Bind the right hand side so we only evaluate it once *) + else ok (e_let_in (rhs_b, ty_opt) rhs' (chain_let_in prep_vars body)) | Raw.EAnnot a -> let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in let%bind expr' = simpl_expression expr in