Skip to content

Commit

Permalink
Refactor destruct-node: pattern case
Browse files Browse the repository at this point in the history 
Simplification of the `destruct node` function by moving the case of
destruct in the presence of a pattern in a dedicated function.
  • Loading branch information
@xvw
xvw committed Apr 9, 2024
1 parent 34310f5 commit 99f9546
Showing 1 changed file with 93 additions and 100 deletions.
193 changes: 93 additions & 100 deletions src/analysis/destruct.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -532,112 +624,13 @@ 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 _, _, _) ->
destruct_record 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))

0 comments on commit 99f9546

Please sign in to comment.