From 9b0eb636fbfe11ab27319a952ae9c1f0a5ca6bfa Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Tue, 19 Nov 2019 21:13:52 +0000 Subject: [PATCH] Properly typed multi-variable binding simplification Thanks for the help Sanders. :) --- src/passes/2-simplify/ligodity.ml | 108 ++++++++++++++++++++------ src/test/contracts/let_multiple.mligo | 14 ++++ src/test/integration_tests.ml | 20 +++++ 3 files changed, 120 insertions(+), 22 deletions(-) create mode 100644 src/test/contracts/let_multiple.mligo diff --git a/src/passes/2-simplify/ligodity.ml b/src/passes/2-simplify/ligodity.ml index 075113257..219ab41ca 100644 --- a/src/passes/2-simplify/ligodity.ml +++ b/src/passes/2-simplify/ligodity.ml @@ -538,7 +538,7 @@ and simpl_tuple_expression ?loc (lst:Raw.expr list) : expression result = let%bind lst = bind_list @@ List.map simpl_expression lst in return @@ e_tuple ?loc lst -and simpl_declaration : Raw.declaration -> declaration Location.wrap result = +and simpl_declaration : Raw.declaration -> declaration Location.wrap list result = fun t -> let open! Raw in let loc : 'a . 'a Raw.reg -> _ -> _ = @@ -547,33 +547,96 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = | TypeDecl x -> let {name;type_expr} : Raw.type_decl = x.value in let%bind type_expression = simpl_type_expression type_expr in - ok @@ loc x @@ Declaration_type (name.value , type_expression) + ok @@ [loc x @@ Declaration_type (name.value , type_expression)] | Let x -> ( - let _ , binding = x.value in + let binding, _ = r_split x in + let binding = snd binding in let {binders; lhs_type; let_rhs} = binding in + let%bind (hd, _) = + let (hd, tl) = binders in ok (hd, tl) in + match hd with + | PTuple pt -> + let process_variable (var_pair: pattern * Raw.expr) : + Ast_simplified.declaration Location.wrap result = + (let (par_var, rhs_expr) = var_pair in + let%bind (v, v_type) = pattern_to_typed_var par_var in + let%bind v_type_expression = + match v_type with + | Some v_type -> ok @@ (simpl_type_expression v_type) + | None -> fail @@ wrong_pattern "typed var tuple" par_var in + let%bind v_type_expression = v_type_expression in + let%bind simpl_rhs_expr = simpl_expression rhs_expr in + ok @@ loc x @@ Declaration_constant (v.value, Some v_type_expression, simpl_rhs_expr) ) + in let%bind variables = ok @@ npseq_to_list pt.value + in let%bind expr_bind_lst = + match let_rhs with + | ETuple et -> ok @@ npseq_to_list et.value + | EVar v -> (* Handle variable bound to tuple *) + let name = v.value in + let rec gen_access_tuple ?(i: int = 0) + ?(accesses: Raw.expr list = []) (name: string) + : Raw.expr list = + let build_access_expr : Raw.expr = EProj + {region = v.region; + value = + { struct_name = v; + selector = Region.ghost ; + field_path = + ( + (Component + {region = Region.ghost; + value = name, Z.of_int i;} : Raw.selection) + , []); + } + } + in + if i = (List.length variables) then accesses + else + let accesses = + build_access_expr :: accesses + in + gen_access_tuple name ~i: (i + 1) ~accesses + in ok (gen_access_tuple name) + (* TODO: Improve this error message *) + | other -> fail @@ simplifying_expr other + in let%bind decls = + bind_map_list process_variable (List.combine variables expr_bind_lst) + in ok @@ decls + | PPar {region = _ ; value = { lpar = _ ; inside = pt; rpar = _; } } -> + (* Extract parenthetical multi-bind *) + let wild = fst @@ fst @@ r_split x in + simpl_declaration + (Let { + region = x.region; + value = (wild, {binders = (pt, []); + lhs_type = lhs_type; + eq = Region.ghost ; + let_rhs = let_rhs})} + : Raw.declaration) + | _ -> let%bind (var, args) = let%bind (hd, tl) = let hd, tl = binders in ok (hd, tl) in let%bind var = pattern_to_var hd in ok (var , tl) - in - match args with - [] -> - let%bind lhs_type' = - bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in - let%bind rhs' = simpl_expression let_rhs in - ok @@ loc x @@ (Declaration_constant (var.value , lhs_type' , rhs')) - | param1::others -> - let fun_ = { - kwd_fun = Region.ghost; - binders = param1, others; - lhs_type; - arrow = Region.ghost; - body = let_rhs} in - let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in - let%bind rhs' = simpl_expression rhs in - ok @@ loc x @@ (Declaration_constant (var.value , None , rhs')) - ) + in + match args with + | [] -> + let%bind lhs_type' = + bind_map_option (fun (_,te) -> simpl_type_expression te) lhs_type in + let%bind rhs' = simpl_expression let_rhs in + ok @@ [loc x @@ Declaration_constant (var.value , lhs_type' , rhs')] + | param1::others -> + let fun_ = { + kwd_fun = Region.ghost; + binders = param1, others; + lhs_type; + arrow = Region.ghost; + body = let_rhs} in + let rhs = Raw.EFun {region=Region.ghost ; value=fun_} in + let%bind rhs' = simpl_expression rhs in + ok @@ [loc x @@ Declaration_constant (var.value , None , rhs')] + ) and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -> @@ -690,4 +753,5 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = in bind_or (as_option () , as_variant ()) let simpl_program : Raw.ast -> program result = fun t -> - bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl + let%bind decls = bind_list (List.map simpl_declaration @@ nseq_to_list t.decl) in + ok @@ List.concat @@ decls diff --git a/src/test/contracts/let_multiple.mligo b/src/test/contracts/let_multiple.mligo new file mode 100644 index 000000000..588bce0ab --- /dev/null +++ b/src/test/contracts/let_multiple.mligo @@ -0,0 +1,14 @@ +(* Simple test of binding multiple values *) + +let (x: int), (y: int) = 1,2 + +let main (p: unit) : int = x + y + +let ((x : int) , (y :int)) = 3,3 + +let main_paren (p: unit) : int = x + y + +let foobar : (int * int) = (23 , 42) +let (foo : int) , (bar : int) = foobar + +let non_tuple_rhs (p: unit) : int = foo + bar diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 16bb7a666..c615dca86 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1175,6 +1175,25 @@ let website2_mligo () : unit result = e_pair (e_typed_list [] t_operation) (e_int (op 42 n)) in expect_eq_n program "main" make_input make_expected +let mligo_let_multiple () : unit result = + let%bind program = mtype_file "./contracts/let_multiple.mligo" in + let%bind () = + let input = e_unit () in + let expected = e_int 3 in + expect_eq program "main" input expected + in + let%bind () = + let input = e_unit () in + let expected = e_int 6 in + expect_eq program "main_paren" input expected + in + let%bind () = + let input = e_unit () in + let expected = e_int 65 in + expect_eq program "non_tuple_rhs" input expected + in + ok () + let balance_constant () : unit result = let%bind program = type_file "./contracts/balance_constant.ligo" in let input = e_tuple [e_unit () ; e_mutez 0] in @@ -1281,6 +1300,7 @@ let main = test_suite "Integration (End to End)" [ test "website1 ligo" website1_ligo ; test "website2 ligo" website2_ligo ; test "website2 (mligo)" website2_mligo ; + test "let multiple (mligo)" mligo_let_multiple ; test "balance constant" balance_constant ; test "balance constant (mligo)" balance_constant_mligo ; test "simple_access (ligo)" simple_access_ligo;