From 7fb42fc3d5b60124ec91dbd0ed9eba1783b7f5b4 Mon Sep 17 00:00:00 2001 From: Ulysse <5031221+voodoos@users.noreply.github.com> Date: Tue, 16 Apr 2024 10:50:08 +0200 Subject: [PATCH 1/3] Merge pull request #10 from xvw/handle-destruct-in-function-arg Handle destruct in function arg --- src/analysis/destruct.ml | 367 ++++++++++++------------ src/ocaml/parsing/location_aux.ml | 4 + src/ocaml/parsing/location_aux.mli | 4 + tests/test-dirs/destruct/destruct-fun.t | 231 +++++++++++++++ 4 files changed, 427 insertions(+), 179 deletions(-) create mode 100644 tests/test-dirs/destruct/destruct-fun.t diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index c9a7f3250..3ae3206c3 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -255,57 +255,79 @@ let rec get_match = function let s = Mbrowse.print_node () parent in raise (Not_allowed s) -let rec get_every_pattern = function + +let collect_every_pattern_for_expression parent = + let patterns = + Mbrowse.fold_node (fun env node acc -> + match node with + | Pattern _ -> raise (Not_allowed ("pattern in function argument")) + | Case _ -> + Mbrowse.fold_node (fun _env node acc -> + match node with + | Pattern p -> + let ill_typed_pred = Typedtree.{ f = fun p -> + List.memq Msupport.incorrect_attribute ~set:p.pat_attributes } + in + if Typedtree.exists_general_pattern ill_typed_pred p + then raise Ill_typed + else begin + match Typedtree.classify_pattern p with + | Value -> (p : Typedtree.pattern) :: acc + | Computation -> + begin + match Typedtree.split_pattern p with + | Some p, _ -> (p : Typedtree.pattern) :: acc + | None, _ -> acc + end + end + | _ -> acc + ) env node acc + | _ -> acc + ) Env.empty parent [] + in + let loc = Mbrowse.fold_node (fun _ node acc -> + let open Location in + let loc = Mbrowse.node_loc node in + if Lexing.compare_pos loc.loc_end acc.loc_end > 0 then loc else acc + ) Env.empty parent Location.none + in loc, patterns + +let collect_function_pattern loc param_pattern = + match param_pattern.Typedtree.fp_kind with + | Typedtree.Tparam_pat pattern -> + loc, [pattern] + | Typedtree.Tparam_optional_default _ -> + raise (Not_allowed "value_binding") + +let rec get_every_pattern loc = function | [] -> assert false | parent :: parents -> match parent with | Case _ | Pattern _ -> (* We are still in the same branch, going up. *) - get_every_pattern parents + get_every_pattern loc parents | Expression { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _, _, _) ; _} when Ident.name id = "*type-error*" -> raise (Ill_typed) + | Expression { exp_desc = Typedtree.Texp_function (params, _body); _ } -> + (* So we need to deal with the case where we're either in the body of a + function, or in a function parameter. *) + begin + match + List.find_some ~f:(fun param -> + Location_aux.included ~into:param.Typedtree.fp_loc loc + ) params with + | Some pattern -> + (* In parameter case *) + collect_function_pattern loc pattern + | None -> + (* In function body *) + collect_every_pattern_for_expression parent + end | Expression _ -> (* We are on the right node *) - let patterns : Typedtree.pattern list = - Mbrowse.fold_node (fun env node acc -> - match node with - | Pattern _ -> - raise (Not_allowed ("pattern in function argument")) - | Case _ -> - Mbrowse.fold_node (fun _env node acc -> - match node with - | Pattern p -> - let ill_typed_pred : Typedtree.pattern_predicate = - { f = fun p -> - List.memq Msupport.incorrect_attribute - ~set:p.pat_attributes } - in - if Typedtree.exists_general_pattern ill_typed_pred p then - raise Ill_typed; - begin match Typedtree.classify_pattern p with - | Value -> let p : Typedtree.pattern = p in p :: acc - | Computation -> let val_p, _ = Typedtree.split_pattern p in - (* We ignore computation patterns *) - begin match val_p with - | Some val_p -> val_p :: acc - | None -> acc - end - end - | _ -> acc - ) env node acc - | _ -> acc - ) Env.empty parent [] - in - let loc = - Mbrowse.fold_node (fun _ node acc -> - let open Location in - let loc = Mbrowse.node_loc node in - if Lexing.compare_pos loc.loc_end acc.loc_end > 0 then loc else acc - ) Env.empty parent Location.none - in - loc, patterns + collect_every_pattern_for_expression parent | _ -> (* We were not in a match *) let s = Mbrowse.print_node () parent in @@ -577,149 +599,136 @@ module Conv = struct (ps, constrs, labels) end +let destruct_expression loc config source parents expr = + let ty = expr.Typedtree.exp_type in + let pexp = filter_expr_attr (Untypeast.untype_expression expr) in + let () = + log ~title:"node_expression" "%a" + Logger.fmt (fun fmt -> Printast.expression 0 fmt pexp) + in + let needs_parentheses, result = + if is_package (Types.Transient_expr.repr ty) then + let mode = Ast_helper.Mod.unpack pexp in + false, Ast_helper.Exp.letmodule_no_opt "M" mode placeholder + else + let ps = gen_patterns expr.Typedtree.exp_env ty in + let cases = List.map ps ~f:(fun patt -> + let pc_lhs = filter_pat_attr (Untypeast.untype_pattern patt) in + { Parsetree. pc_lhs ; pc_guard = None ; pc_rhs = placeholder } + ) in + needs_parentheses parents, Ast_helper.Exp.match_ pexp cases + in + let str = Mreader.print_pretty config source (Pretty_expression result) in + let str = if needs_parentheses then "(" ^ str ^ ")" else str in + loc, str + +let refine_partial_match last_case_loc config source patterns = + let cases = List.map patterns ~f:(fun pat -> + let _pat, constrs, labels = Conv.conv pat in + let unmangling_tables = constrs, labels in + (* Unmangling and prefixing *) + let pat = qualify_constructors ~unmangling_tables Printtyp.shorten_type_path pat in + (* Untyping and casing *) + let ppat = filter_pat_attr (Untypeast.untype_pattern pat) in + Ast_helper.Exp.case ppat placeholder + ) in + let loc = Location.{ last_case_loc with loc_start = last_case_loc.loc_end } in + let str = Mreader.print_pretty config source (Pretty_case_list cases) in + loc, str + +let filter_new_branches new_branches patterns = + let unused = Parmatch.return_unused patterns in + List.fold_left unused ~init:new_branches ~f:(fun branches u -> + match u with + | `Unused p -> List.remove ~phys:true p branches + | `Unused_subs (p, lst) -> + List.map branches ~f:(fun branch -> + if branch != p then branch else + List.fold_left lst ~init:branch ~f:rm_sub)) + +let refine_current_pattern patt config source generated_pattern = + let ppat = filter_pat_attr (Untypeast.untype_pattern generated_pattern) in + let str = Mreader.print_pretty config source (Pretty_pattern ppat) in + patt.Typedtree.pat_loc, str + +let refine_and_generate_branches patt config source patterns sub_patterns = + let rev_before, after, top_patt = find_branch patterns patt in + let new_branches = + List.map sub_patterns ~f:(fun by -> subst_patt patt ~by top_patt) + in + let patterns = after @ rev_before @ new_branches in + match filter_new_branches new_branches patterns with + | [] -> raise Useless_refine + | p :: ps -> + let p = List.fold_left ps ~init:p ~f:(fun acc p -> + Tast_helper.Pat.pat_or + top_patt.Typedtree.pat_env + top_patt.Typedtree.pat_type acc p) + in + (* Format.eprintf "por %a \n%!" (Printtyped.pattern 0) p; *) + let ppat = filter_pat_attr (Untypeast.untype_pattern p) in + (* Format.eprintf "ppor %a \n%!" (Pprintast.pattern) ppat; *) + let str = Mreader.print_pretty config source (Pretty_pattern ppat) in + (* Format.eprintf "STR: %s \n %!" str; *) + top_patt.Typedtree.pat_loc, str + +let refine_complete_match + (type a) (patt: a Typedtree.general_pattern) + config source patterns = + match Typedtree.classify_pattern patt with + | Computation -> raise (Not_allowed ("computation pattern")) + | Value -> + let _: Typedtree.value Typedtree.general_pattern = patt in + if not (destructible patt) then raise Nothing_to_do + else + let ty = patt.Typedtree.pat_type in + begin match gen_patterns patt.Typedtree.pat_env ty with + | [] -> assert false + | [more_precise_pattern] -> + (* If only one pattern is generated, then we're only refining the + current pattern, not generating new branches. *) + refine_current_pattern patt config source more_precise_pattern + | sub_patterns -> + (* If more than one pattern is generated, then we're generating new + branches. *) + refine_and_generate_branches patt config source patterns sub_patterns + end + +let destruct_pattern + (type a) (patt: a Typedtree.general_pattern) + config source loc parents = + let last_case_loc, patterns = get_every_pattern loc parents in + (* Printf.eprintf "tot %d o%!"(List.length patterns); *) + let () = List.iter patterns ~f:(fun p -> + let p = filter_pat_attr (Untypeast.untype_pattern p) in + log ~title:"EXISTING" "%t" + (fun () -> Mreader.print_pretty config source (Pretty_pattern p))) + in + let pss = List.map patterns ~f:(fun x -> [ x ]) in + let m, e_typ = get_match parents in + let pred = Typecore.partial_pred ~lev:Btype.generic_level m.Typedtree.exp_env e_typ in + match Parmatch.complete_partial ~pred pss with + | [] -> + (* The match is already complete, we try to refine it *) + refine_complete_match patt config source patterns + | patterns -> + refine_partial_match last_case_loc config source patterns + +let rec destruct_record config source selected_node = function + | Expression { exp_desc = Texp_field _; _ } as parent :: rest -> + node config source parent rest + | Expression e :: rest -> + node config source (Expression e) rest + | _ -> + raise (Not_allowed (string_of_node selected_node)) - -let rec node config source selected_node parents = - let open Extend_protocol.Reader in +and node config source selected_node parents = let loc = Mbrowse.node_loc selected_node in match selected_node with | Record_field (`Expression _, _, _) -> - begin match parents with - | Expression { exp_desc = Texp_field _; _ } as parent :: rest -> - node config source parent rest - | Expression e :: rest -> - node config source (Expression e) rest - | _ -> - raise (Not_allowed (string_of_node selected_node)) - end + destruct_record config source selected_node parents | Expression expr -> - let ty = expr.Typedtree.exp_type in - let pexp = filter_expr_attr (Untypeast.untype_expression expr) in - log ~title:"node_expression" "%a" - Logger.fmt (fun fmt -> Printast.expression 0 fmt pexp); - let needs_parentheses, result = - if is_package (Types.Transient_expr.repr ty) then ( - let mode = Ast_helper.Mod.unpack pexp in - false, Ast_helper.Exp.letmodule_no_opt "M" mode placeholder - ) else ( - let ps = gen_patterns expr.Typedtree.exp_env ty in - let cases = - List.map ps ~f:(fun patt -> - let pc_lhs = filter_pat_attr (Untypeast.untype_pattern patt) in - { Parsetree. pc_lhs ; pc_guard = None ; pc_rhs = placeholder } - ) - in - needs_parentheses parents, Ast_helper.Exp.match_ pexp cases - ) - in - let str = Mreader.print_pretty - config source (Pretty_expression result) in - let str = if needs_parentheses then "(" ^ str ^ ")" else str in - loc, str - | Pattern patt -> - begin let last_case_loc, patterns = get_every_pattern parents in - (* Printf.eprintf "tot %d o%!"(List.length patterns); *) - List.iter patterns ~f:(fun p -> - let p = filter_pat_attr (Untypeast.untype_pattern p) in - log ~title:"EXISTING" "%t" - (fun () -> Mreader.print_pretty config source (Pretty_pattern p)) - ) ; - let pss = List.map patterns ~f:(fun x -> [ x ]) in - let m, e_typ = get_match parents in - let pred = Typecore.partial_pred - ~lev:Btype.generic_level - m.Typedtree.exp_env - e_typ - in - begin match Parmatch.complete_partial ~pred pss with - | _ :: _ as patterns -> - let cases = - List.map patterns ~f:(fun pat -> - let _pat, constrs, labels = Conv.conv pat in - let unmangling_tables = constrs, labels in - (* Unmangling and prefixing *) - let pat = - qualify_constructors ~unmangling_tables - Printtyp.shorten_type_path pat - in - - (* Untyping and casing *) - let ppat = filter_pat_attr (Untypeast.untype_pattern pat) in - Ast_helper.Exp.case ppat placeholder - ) - in - let loc = - let open Location in - { last_case_loc with loc_start = last_case_loc.loc_end } - in - - (* Pretty printing *) - let str = Mreader.print_pretty config source (Pretty_case_list cases) in - loc, str - | [] -> - (* The match is already complete, we try to refine it *) - begin match Typedtree.classify_pattern patt with - | Computation -> raise (Not_allowed ("computation pattern")); - | Value -> - let _patt : Typedtree.value Typedtree.general_pattern = patt in - if not (destructible patt) then raise Nothing_to_do else - let ty = patt.Typedtree.pat_type in - begin match gen_patterns patt.Typedtree.pat_env ty with - | [] -> - (* gen_patterns might raise Not_allowed, but should never return [] *) - assert false - | [ more_precise ] -> - (* If only one pattern is generated, then we're only refining the - current pattern, not generating new branches. *) - let ppat = filter_pat_attr (Untypeast.untype_pattern more_precise) in - let str = Mreader.print_pretty - config source (Pretty_pattern ppat) in - patt.Typedtree.pat_loc, str - | sub_patterns -> - let rev_before, after, top_patt = - find_branch patterns patt - in - let new_branches = - List.map sub_patterns ~f:(fun by -> - subst_patt patt ~by top_patt - ) - in - let patterns = - List.rev_append rev_before - (List.append new_branches after) - in - let unused = Parmatch.return_unused patterns in - let new_branches = - List.fold_left unused ~init:new_branches ~f:(fun branches u -> - match u with - | `Unused p -> List.remove ~phys:true p branches - | `Unused_subs (p, lst) -> - List.map branches ~f:(fun branch -> - if branch != p then branch else - List.fold_left lst ~init:branch ~f:rm_sub - ) - ) - in - (* List.iter ~f:(Format.eprintf "multi cp %a \n%!" (Printtyped.pattern 0)) new_branches ; *) - match new_branches with - | [] -> raise Useless_refine - | p :: ps -> - let p = - List.fold_left ps ~init:p ~f:(fun acc p -> - Tast_helper.Pat.pat_or top_patt.Typedtree.pat_env - top_patt.Typedtree.pat_type acc p - ) - in - (* Format.eprintf "por %a \n%!" (Printtyped.pattern 0) p; *) - let ppat = filter_pat_attr (Untypeast.untype_pattern p) in - (* Format.eprintf "ppor %a \n%!" (Pprintast.pattern) ppat; *) - let str = Mreader.print_pretty - config source (Pretty_pattern ppat) in - (* Format.eprintf "STR: %s \n %!" str; *) - top_patt.Typedtree.pat_loc, str - end - end - end - end + destruct_expression loc config source parents expr + | Pattern patt -> destruct_pattern patt config source loc parents | node -> raise (Not_allowed (string_of_node node)) diff --git a/src/ocaml/parsing/location_aux.ml b/src/ocaml/parsing/location_aux.ml index 966ebdd3f..5a9ec92d8 100644 --- a/src/ocaml/parsing/location_aux.ml +++ b/src/ocaml/parsing/location_aux.ml @@ -46,6 +46,10 @@ let compare_pos pos loc = else 0 +let included ~into:parent_loc child_loc = +Lexing.compare_pos child_loc.loc_start parent_loc.loc_start >= 0 && + Lexing.compare_pos parent_loc.loc_end child_loc.loc_end >= 0 + let union l1 l2 = if l1 = Location.none then l2 else if l2 = Location.none then l1 diff --git a/src/ocaml/parsing/location_aux.mli b/src/ocaml/parsing/location_aux.mli index 7d99d36a0..d6164b2cd 100644 --- a/src/ocaml/parsing/location_aux.mli +++ b/src/ocaml/parsing/location_aux.mli @@ -42,6 +42,10 @@ val union : t -> t -> t (** Like location_union, but keep loc_ghost'ness of first argument *) val extend : t -> t -> t +(** [included ~into:parent child] returns [true] if [child] is included + in [parent]. Otherwise returns [false]. *) +val included : into:t -> t -> bool + (** Filter valid errors, log invalid ones *) val prepare_errors : exn list -> Location.error list diff --git a/tests/test-dirs/destruct/destruct-fun.t b/tests/test-dirs/destruct/destruct-fun.t new file mode 100644 index 000000000..4625b82fe --- /dev/null +++ b/tests/test-dirs/destruct/destruct-fun.t @@ -0,0 +1,231 @@ +Test case-analysis on a function parameter: + + $ cat >fun.ml < let f x (bb : bool) y = something + > EOF + + $ $MERLIN single case-analysis -start 1:10 -end 1:11 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 9 + }, + "end": { + "line": 1, + "col": 11 + } + }, + "false|true" + ], + "notifications": [] + } + + $ cat >fun.ml < let _ = match true with _ as bb -> bb + > EOF + + $ $MERLIN single case-analysis -start 1:24 -end 1:25 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 24 + }, + "end": { + "line": 1, + "col": 31 + } + }, + "(false as bb)|(true as bb)" + ], + "notifications": [] + } + + $ cat >fun.ml < let f x ((false as bb) : bool) y = something + > EOF + + $ $MERLIN single case-analysis -start 1:11 -end 1:15 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 15 + }, + "end": { + "line": 1, + "col": 15 + } + }, + "|true -> _" + ], + "notifications": [] + } + + $ cat >fun.ml < let f x (_ as bb : bool) y = something + > EOF + + $ $MERLIN single case-analysis -start 1:10 -end 1:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 9 + }, + "end": { + "line": 1, + "col": 16 + } + }, + "((false as bb) : bool)|((true as bb) : bool)" + ], + "notifications": [] + } + + $ cat >fun.ml < type t = { foo: int } + > let f a (b: t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "{ foo }" + ], + "notifications": [] + } + + $ cat >fun.ml < type t = Foo + > let f a (b: t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "Foo" + ], + "notifications": [] + } + + $ cat >fun.ml < type t = Foo of int option * string + > let f a (b: t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr '\n' ' ' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "Foo (_,_)" + ], + "notifications": [] + } + + $ cat >fun.ml < type t = Foo of { foo: int; bar: string } + > let f a (b: t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr '\n' ' ' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "Foo _" + ], + "notifications": [] + } + + $ cat >fun.ml < type _ t = Foo : int t | Bar : float t + > let f a (b: int t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "Foo" + ], + "notifications": [] + } From f1f9bec2ab169c42f995ff93883c4d3bce995d06 Mon Sep 17 00:00:00 2001 From: Liam Stevenson Date: Tue, 14 May 2024 14:55:06 -0400 Subject: [PATCH 2/3] Resolve merge conflicts --- src/analysis/destruct.ml | 2 +- tests/test-dirs/destruct/fun.t | 13 ------------- 2 files changed, 1 insertion(+), 14 deletions(-) delete mode 100644 tests/test-dirs/destruct/fun.t diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index 3ae3206c3..a1a5efea7 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -310,7 +310,7 @@ let rec get_every_pattern loc = function | Expression { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _, _, _) ; _} when Ident.name id = "*type-error*" -> raise (Ill_typed) - | Expression { exp_desc = Typedtree.Texp_function (params, _body); _ } -> + | Expression { exp_desc = Typedtree.Texp_function {params; _}; _ } -> (* So we need to deal with the case where we're either in the body of a function, or in a function parameter. *) begin diff --git a/tests/test-dirs/destruct/fun.t b/tests/test-dirs/destruct/fun.t deleted file mode 100644 index 0d4e3f9d6..000000000 --- a/tests/test-dirs/destruct/fun.t +++ /dev/null @@ -1,13 +0,0 @@ -Test case-analysis in the middle of a [fun]. - - $ cat >fun.ml < let f x (bb : bool) y = something - > EOF - - $ $MERLIN single case-analysis -start 1:10 -end 1:11 -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' - { - "class": "error", - "value": "Destruct not allowed on pattern in function argument", - "notifications": [] - } From a870c36a1ece2d7d96959ecbd148618b21ddd9c6 Mon Sep 17 00:00:00 2001 From: Liam Stevenson Date: Tue, 14 May 2024 14:59:27 -0400 Subject: [PATCH 3/3] Revert error message --- src/analysis/destruct.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index a1a5efea7..454f37436 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -260,7 +260,7 @@ let collect_every_pattern_for_expression parent = let patterns = Mbrowse.fold_node (fun env node acc -> match node with - | Pattern _ -> raise (Not_allowed ("pattern in function argument")) + | Pattern _ -> (* Not expected here *) raise Nothing_to_do | Case _ -> Mbrowse.fold_node (fun _env node acc -> match node with