From 99f9546a92705beb417d7af88f0eb4f0b229a91d Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 9 Apr 2024 13:29:53 +0200 Subject: [PATCH] Refactor destruct-node: pattern case Simplification of the `destruct node` function by moving the case of destruct in the presence of a pattern in a dedicated function. --- src/analysis/destruct.ml | 193 +++++++++++++++++++-------------------- 1 file changed, 93 insertions(+), 100 deletions(-) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index dbc4bddef..95da87dd8 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -523,6 +523,98 @@ let destruct_expression loc config source parents expr = 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, unmangling_tables) -> + (* 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 parents generated_pattern = + let punned_field = find_field_name_for_punned_field patt parents in + let ppat = filter_pat_attr (Untypeast.untype_pattern generated_pattern) in + let str = print_pretty ?punned_field config source (Pretty_pattern ppat) in + patt.Typedtree.pat_loc, str + +let refine_and_generate_branches patt config source (patterns : Typedtree.pattern list) 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 parents 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 parents 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 parents = + let last_case_loc, patterns = get_every_pattern 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 parents 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 @@ -532,7 +624,6 @@ let rec destruct_record config source selected_node = function raise (Not_allowed (string_of_node selected_node)) and node config source selected_node parents = - let open Extend_protocol.Reader in let loc = Mbrowse.node_loc selected_node in match selected_node with | Record_field (`Expression _, _, _) -> @@ -540,104 +631,6 @@ and node config source selected_node parents = | Expression expr -> destruct_expression loc config source parents expr | 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, unmangling_tables) -> - (* 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 punned_field = find_field_name_for_punned_field patt parents in - let ppat = filter_pat_attr (Untypeast.untype_pattern more_precise) in - let str = print_pretty ?punned_field 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 = after @ rev_before @ new_branches 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_pattern patt config source parents | node -> raise (Not_allowed (string_of_node node))