diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-simplify/cameligo.ml index 9b047239d..762215450 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-simplify/cameligo.ml @@ -10,7 +10,6 @@ module Option = Simple_utils.Option open Combinators -type 'a nseq = 'a * 'a list let nseq_to_list (hd, tl) = hd :: tl let npseq_to_list (hd, tl) = hd :: (List.map snd tl) let npseq_to_nelist (hd, tl) = hd, (List.map snd tl) @@ -23,12 +22,13 @@ module Errors = struct let wrong_pattern expected_name actual = let title () = "wrong pattern" in let message () = - match actual with - | Raw.PTuple _ -> "tuple" - | Raw.PRecord _ -> "record" - | Raw.PList _ -> "list" - | Raw.PBytes _ -> "bytes" - | _ -> "other" + match actual with + | Raw.PVar v -> v.value + | Raw.PTuple _ -> "tuple" + | Raw.PRecord _ -> "record" + | Raw.PList _ -> "list" + | Raw.PBytes _ -> "bytes" + | _ -> "other" in let data = [ ("expected", fun () -> expected_name); @@ -36,15 +36,14 @@ 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 unsuppported_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 = 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) + ("loc", fun () -> Format.asprintf "%a" Location.pp_lift @@ patterns_loc) ] in error ~data title message @@ -154,7 +153,7 @@ let rec pattern_to_var : Raw.pattern -> _ = fun p -> | Raw.PPar p -> pattern_to_var p.value.inside | Raw.PVar v -> ok v | Raw.PWild r -> ok @@ ({ region = r ; value = "_" } : Raw.variable) - | _ -> fail @@ wrong_pattern "var" p + | _ -> fail @@ wrong_pattern "single var" p let rec pattern_to_typed_var : Raw.pattern -> _ = fun p -> match p with @@ -166,24 +165,19 @@ let rec pattern_to_typed_var : Raw.pattern -> _ = fun p -> ) | Raw.PVar v -> ok (v , None) | Raw.PWild r -> ok (({ region = r ; value = "_" } : Raw.variable) , None) - | _ -> fail @@ wrong_pattern "typed variable" p + | _ -> fail @@ wrong_pattern "single typed variable" p let rec expr_to_typed_expr : Raw.expr -> _ = function EPar e -> expr_to_typed_expr e.value.inside | EAnnot {value={inside=e,_,t; _}; _} -> ok (e, Some t) | e -> ok (e , None) -let rec patterns_to_typed_vars : Raw.pattern nseq -> _ = fun ps -> - match ps with - | 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 "parenthetical, tuple, or variable" other) - end - | _ -> fail @@ multiple_patterns "let" (nseq_to_list ps) +let rec tuple_pattern_to_typed_vars : Raw.pattern -> _ = fun pattern -> + match pattern with + | Raw.PPar pp -> tuple_pattern_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 "parenthetical, tuple, or variable" other) let rec simpl_type_expression : Raw.type_expr -> type_expression result = fun te -> trace (simple_info "simplifying this type expression...") @@ @@ -274,7 +268,10 @@ 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 variables = patterns_to_typed_vars binders in + begin match binders with + (* let p = rhs in body *) + | (p, []) -> + let%bind variables = tuple_pattern_to_typed_vars p 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 @@ -319,6 +316,11 @@ let rec simpl_expression : 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)) + + (* let f p1 ps... = rhs in body *) + | (f, p1 :: ps) -> + fail @@ unsuppported_let_in_function (f :: p1 :: ps) + end | Raw.EAnnot a -> let Raw.{inside=expr, _, type_expr; _}, loc = r_split a in let%bind expr' = simpl_expression expr in @@ -484,6 +486,28 @@ and simpl_fun lamb' : expr result = let (lamb , loc) = r_split lamb' in let%bind args' = let args = nseq_to_list lamb.binders in + let args = (* Handle case where we have tuple destructure in params *) + match lamb.binders with + (* TODO: currently works only if there is one param *) + | (Raw.PPar pp, []) -> + let pt = pp.value.inside in + (match pt with + | Raw.PTyped pt -> + begin + match pt.value.pattern with + | Raw.PVar _ -> args + | Raw.PTuple _ -> + [Raw.PTyped + {region=Region.ghost; + value= + { pt.value with pattern= + Raw.PVar {region=Region.ghost; + value="#P"}}}] + | _ -> args + end + | _ -> args) + | _ -> args + in let%bind p_args = bind_map_list pattern_to_typed_var args in let aux ((var : Raw.variable) , ty_opt) = match var.value , ty_opt with @@ -502,7 +526,41 @@ and simpl_fun lamb' : expr result = | [ single ] -> ( let (binder , input_type) = (Var.of_name (fst single).value , snd single) in - let%bind (body , body_type) = expr_to_typed_expr lamb.body in + let%bind body = + let original_args = nseq_to_list lamb.binders in + let destruct = List.hd original_args in + match destruct with (* Handle tuple parameter destructuring *) + | Raw.PPar pp -> + (match pp.value.inside with + | Raw.PTyped pt -> + let vars = pt.value in + (match vars.pattern with + | PTuple vars -> + let let_in_binding: Raw.let_binding = + {binders = (PTuple vars, []) ; + lhs_type=None; + eq=Region.ghost; + let_rhs=(Raw.EVar {region=Region.ghost; value="#P"}); + } + in + let let_in: Raw.let_in = + {kwd_let= Region.ghost; + binding= let_in_binding; + kwd_in= Region.ghost; + body= lamb.body; + } + in + ok (Raw.ELetIn + { + region=Region.ghost; + value=let_in + }) + | Raw.PVar _ -> ok lamb.body + | _ -> ok lamb.body) + | _ -> ok lamb.body) + | _ -> ok lamb.body + in + let%bind (body , body_type) = expr_to_typed_expr body in let%bind output_type = bind_map_option simpl_type_expression body_type in let%bind result = simpl_expression body in diff --git a/src/test/contracts/tuple_param_destruct.mligo b/src/test/contracts/tuple_param_destruct.mligo new file mode 100644 index 000000000..6dfe30fe4 --- /dev/null +++ b/src/test/contracts/tuple_param_destruct.mligo @@ -0,0 +1 @@ +let sum (result, i : int * int) : int = result + i diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index f6b58f237..d5b1c940c 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 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 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 @@ -1946,4 +1951,5 @@ let main = test_suite "Integration (End to End)" [ test "entrypoints (ligo)" entrypoints_ligo ; test "type tuple destruct (mligo)" type_tuple_destruct ; test "let in multi-bind (mligo)" let_in_multi_bind ; + test "tuple param destruct (mligo)" tuple_param_destruct ; ]