From 13bc083d1548de031b191a980ac45ed4909b20ca Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Thu, 10 Sep 2026 18:24:31 +0200 Subject: [PATCH 1/2] [src] improve cppo usage Gather most of the uses in Utils.Compat, in dedicated functions (either conversions or getters). Sort the branches in version descending order. If the conditional branches are close enough, do not repeat the bounds. If the #else stands out enough, do not convert it into #elif. If all the versions should be accounted without #else, add an #else that throws an #error. --- check/src/io.cppo.ml | 6 +- src/deadArg.ml | 98 ++++++++----------- src/deadArg.mli | 12 --- src/deadCode.ml | 124 ++++++++++------------- src/deadLexiFi.ml | 24 +++-- src/deadObj.ml | 43 ++++---- src/deadSign.ml | 60 +++++------- src/state/file_infos.ml | 6 +- src/state/location_dependencies.ml | 34 ++++--- src/state/location_dependencies.mli | 6 +- src/utils.ml | 147 +++++++++++++++++++++++++--- src/utils.mli | 79 ++++++++++++++- 12 files changed, 381 insertions(+), 258 deletions(-) diff --git a/check/src/io.cppo.ml b/check/src/io.cppo.ml index a78ee2c..7390a21 100644 --- a/check/src/io.cppo.ml +++ b/check/src/io.cppo.ml @@ -9,12 +9,12 @@ let isatty fd = #endscope -#if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 1, 0) +#if OCAML_VERSION >= (5, 1, 0) +let input_lines = In_channel.input_lines +#else let [@tail_mod_cons] rec input_lines ic = (* reproduce https://github.com/ocaml/ocaml/blob/5.3.0/stdlib/in_channel.ml#L195 *) match In_channel.input_line ic with | Some line -> line :: input_lines ic | None -> [] -#elif OCAML_VERSION >= (5, 1, 0) && OCAML_VERSION < (5, 6, 0) -let input_lines = In_channel.input_lines #endif diff --git a/src/deadArg.ml b/src/deadArg.ml index 0219b2d..f99b259 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -70,22 +70,6 @@ let deferrable_register_use label expr builddir loc last_loc count_tbl = else register_use () else register_use () -let options_of_args args = - #if OCAML_VERSION >= (5, 4, 0) && OCAML_VERSION < (5, 6, 0) - (* Texp_apply's args changed in OCaml 5.4, from expression option - to arg_or_omitted. This does the reverse conversion *) - let args = - List.map - (fun (lab, arg) -> - match arg with - | Arg expr -> lab, Some expr - | Omitted _ -> lab, None - ) - args - in - #endif - args - let rec register_uses builddir loc args = List.iter (fun (_, e) -> Option.iter (register_higher_order_uses builddir) e) @@ -148,10 +132,10 @@ and register_higher_order_uses builddir e = in let$ (c_lhs, c_rhs) = match expr.exp_desc with - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - | Texp_function {cases = [case]; _} -> - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 2, 0) | Texp_function (_, Tfunction_cases {cases = [case]; _}) -> + #else + | Texp_function {cases = [case]; _} -> #endif Some (case.c_lhs, case.c_rhs) | _ -> None @@ -161,7 +145,7 @@ and register_higher_order_uses builddir e = if c_lhs.pat_loc.loc_ghost && c_rhs.exp_loc.loc_ghost && expr.exp_loc.loc_ghost then - let args = options_of_args args in + let args = Utils.Compat.options_of_args args in register_uses builddir ident_loc args | _ -> () ) @@ -178,7 +162,9 @@ let register_uses val_loc args = let rec bind loc expr = let state = State.get_current () in match expr.exp_desc with - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) + #if OCAML_VERSION >= (5, 2, 0) + | Texp_function (params, body) -> bind_function loc params body + #else | Texp_function {arg_label; cases; _} -> let expr_loc = expr.exp_loc.Location.loc_start in bind_function loc expr_loc arg_label cases @@ -203,9 +189,6 @@ let rec bind loc expr = expr.exp_attributes in if is_default expr then bind loc in_expr - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) - | Texp_function (params, body) -> - bind_function loc params body #endif | exp_desc when Config.must_report_opt_args state.config @@ -222,34 +205,26 @@ let rec bind loc expr = VdNode.merge_locs loc loc2 | _ -> () -and bind_function loc = +and register_optional_param state loc = function + | Asttypes.Optional s + when Config.must_report_opt_args state.State.config -> + let (opts, next) = VdNode.get loc in + VdNode.update loc (s :: opts, next) + | _ -> () + +and arg_type arg_label pat_type = + match arg_label with + | Asttypes.Optional _ -> + (* The type of optional arguments is wrapped in option *) + begin match get_deep_desc pat_type with + | Tconstr (_, [typ], _) -> typ + | _ -> pat_type + end + | _ -> pat_type + +#if OCAML_VERSION >= (5, 2, 0) +and bind_function loc params body = let state = State.get_current () in - let register_optional_param = function - | Asttypes.Optional s - when Config.must_report_opt_args state.config -> - let (opts, next) = VdNode.get loc in - VdNode.update loc (s :: opts, next) - | _ -> () - in - let arg_type arg_label pat_type = - match arg_label with - | Asttypes.Optional _ -> - (* The type of optional arguments is wrapped in option *) - begin match get_deep_desc pat_type with - | Tconstr (_, [typ], _) -> typ - | _ -> pat_type - end - | _ -> pat_type - in - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - fun expr_loc arg_label -> function - | {c_lhs = {pat_type; _}; c_rhs; _}::[] -> - let arg_type = arg_type arg_label pat_type in - DeadType.check_style arg_type expr_loc; - register_optional_param arg_label; - bind loc c_rhs - | _ -> () - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) let process_params params = let check_param_style arg_loc arg_label = function | Tparam_pat {pat_type; _} @@ -260,7 +235,7 @@ and bind_function loc = List.iter (fun {fp_kind; fp_arg_label; fp_loc; _} -> check_param_style fp_loc fp_arg_label fp_kind; - register_optional_param fp_arg_label + register_optional_param state loc fp_arg_label ) params in @@ -270,10 +245,21 @@ and bind_function loc = bind loc exp | _ -> () in - fun params body -> - process_params params; - process_body body - #endif + process_params params; + process_body body +#elif OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) +and bind_function loc expr_loc arg_label cases = + let state = State.get_current () in + match cases with + | {c_lhs = {pat_type; _}; c_rhs; _}::[] -> + let arg_type = arg_type arg_label pat_type in + DeadType.check_style arg_type expr_loc; + register_optional_param state loc arg_label; + bind loc c_rhs + | _ -> () +#else +#error "unsupported version" +#endif (******** WRAPPING ********) diff --git a/src/deadArg.mli b/src/deadArg.mli index 23e7543..c7c7a9b 100644 --- a/src/deadArg.mli +++ b/src/deadArg.mli @@ -27,18 +27,6 @@ val eocb : unit -> unit locations, their respective files. [eocb] = end of code base. *) -val options_of_args : - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 4, 0) - (Asttypes.arg_label * expression option) list - #elif OCAML_VERSION >= (5, 4, 0) && OCAML_VERSION < (5, 6, 0) - (Asttypes.arg_label * (expression, unit) arg_or_omitted) list - #endif - -> (Asttypes.arg_label * expression option) list -(** Convert Texp_apply's args representation to its OCaml 5.3 representation. - In particular, the type of a single arg changed in OCaml 5.4, from - expression option to arg_or_omitted. This does the reverse conversion. -*) - val register_uses : Lexing.position -> (Asttypes.arg_label * expression option) list -> unit (** An optional argument is used if it is required match a signature, or if it diff --git a/src/deadCode.ml b/src/deadCode.ml index 73095ba..049b00a 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -35,24 +35,23 @@ let main_files = Hashtbl.create 256 (* names -> paths *) let rec treat_exp exp args = match exp.exp_desc with | Texp_apply (exp, in_args) -> - let in_args = DeadArg.options_of_args in_args in + let in_args = Utils.Compat.options_of_args in_args in treat_exp exp (in_args @ args) | Texp_ident (_, _, {Types.val_loc = {Location.loc_start = loc; _}; _}) | Texp_field (_, _, {lbl_loc = {Location.loc_start = loc; _}; _}) -> DeadArg.register_uses loc args - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 3, 0) - | Texp_match (_, comp_l, _) -> - let val_l = [] in (* effect cases appear in OCaml 5.3 *) - #elif OCAML_VERSION >= (5, 3, 0) && OCAML_VERSION < (5, 6, 0) - | Texp_match (_, comp_l, val_l, _) -> - #endif - let process_cases l = - List.iter (fun {c_rhs = exp; _} -> treat_exp exp args) l - in - process_cases comp_l; - process_cases val_l + | Texp_match _ as exp_desc -> + begin match Utils.Compat.get_match_data exp_desc with + | None -> assert false + | Some (_, comp_l, val_l, _) -> + let process_cases l = + List.iter (fun {c_rhs = exp; _} -> treat_exp exp args) l + in + process_cases comp_l; + process_cases val_l + end | Texp_ifthenelse (_, exp_then, exp_else) -> treat_exp exp_then args; @@ -68,24 +67,23 @@ let value_binding super self x = let at_eof_saved = !DeadArg.at_eof in DeadArg.at_eof := []; incr depth; - let open Asttypes in begin match x.vb_pat.pat_desc with - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - | Tpat_var (_, {loc; _}) - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) - | Tpat_var (_, {loc; _}, _) - #endif - when not loc.Location.loc_ghost -> - let loc = loc.Location.loc_start in - begin match x.vb_expr.exp_desc with - | Texp_ident (_, _, {val_loc; _}) when not val_loc.Location.loc_ghost -> - let val_loc = val_loc.Location.loc_start in - VdNode.merge_locs loc val_loc; - DeadObj.add_equal loc val_loc - | _ -> - let exp = x.vb_expr in - DeadArg.bind loc exp; - DeadObj.add_var loc exp + | Tpat_var _ as pat_desc -> + begin match Utils.Compat.get_var_data pat_desc with + | None -> assert false + | Some (_, {loc=pat_loc; _}, _) -> + if not pat_loc.Location.loc_ghost then + let pat_loc = pat_loc.Location.loc_start in + match x.vb_expr.exp_desc with + | Texp_ident (_, _, {val_loc; _}) + when not val_loc.Location.loc_ghost -> + let val_loc = val_loc.Location.loc_start in + VdNode.merge_locs pat_loc val_loc; + DeadObj.add_equal pat_loc val_loc + | _ -> + let exp = x.vb_expr in + DeadArg.bind pat_loc exp; + DeadObj.add_var pat_loc exp end | _ -> () end; @@ -125,25 +123,11 @@ let structure_item super self i = r -let id_of_var : type k . k pattern_desc -> Ident.t option = function +let id_of_var pat_desc = (* helper function to extract the var's id in tpat_var and tpat_alias(tpat_any) patterns for all OCaml versions *) - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - | Tpat_var (id, _) - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) - | Tpat_var (id, _, _) - #endif - (* x *) - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - | Tpat_alias ({pat_desc=Tpat_any; _}, id, _) - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 4, 0) - | Tpat_alias ({pat_desc=Tpat_any; _}, id, _, _) - #elif OCAML_VERSION >= (5, 4, 0) && OCAML_VERSION < (5, 6, 0) - | Tpat_alias ({pat_desc=Tpat_any; _}, id, _, _, _) - #endif - (* (x: t) *) - -> Some id - | _ -> None + Utils.Compat.get_var_data pat_desc + |> Option.map (fun (id, _, _) -> id) let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern -> k general_pattern = @@ -154,16 +138,9 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - let u s = register_style pat_loc (Printf.sprintf "unit pattern %s" s) in - let open Asttypes in if DeadType.is_unit p.pat_type && sections.style.unit_pat then begin match p.pat_desc with | Tpat_construct _ -> () - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - | Tpat_var (_, {txt = "eta"; _}) - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) - | Tpat_var (_, {txt = "eta"; _}, _) - #endif - when p.pat_loc = Location.none -> () | Tpat_any -> if state.config.underscore then u "_" | Tpat_value tpat_arg -> begin match (tpat_arg :> value general_pattern) with @@ -171,21 +148,22 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - | _ -> u "!!pattern!!" end | var -> - match id_of_var var with + match id_of_var var with | Some id -> let txt = Ident.name id in - if check_underscore txt then u txt + if txt = "eta" && p.pat_loc = Location.none then () + else if check_underscore txt then u txt | None -> u "!!pattern!!" end; begin match p.pat_desc with | Tpat_record (l, _) -> List.iter (fun (_, lab, _) -> - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 4, 0) - let lab : Types.label_description = lab in - #elif OCAML_VERSION >= (5, 4, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 4, 0) (* The type of lab moved in OCaml 5.4 *) let lab : Data_types.label_description = lab in + #else + let lab : Types.label_description = lab in #endif let lab_loc = lab.lbl_loc.Location.loc_start in if exported ~is_type:true sections.types lab_loc then @@ -229,7 +207,7 @@ let expr super self e = | Texp_apply (exp, args) -> - let args = DeadArg.options_of_args args in + let args = Utils.Compat.options_of_args args in if Config.must_report_opt_args state.config then treat_exp exp args; begin match exp.exp_desc with @@ -254,21 +232,19 @@ let expr super self e = "let () = ... in ... (=> use sequence)" end - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 3, 0) - | Texp_match (_, [{c_lhs; _}], _) - #elif OCAML_VERSION >= (5, 3, 0) && OCAML_VERSION < (5, 6, 0) - | Texp_match (_, [{c_lhs; _}], [], _) - #endif - when DeadType.is_unit c_lhs.pat_type && sections.style.seq -> - begin match c_lhs.pat_desc with - | Tpat_value tpat_arg -> - begin match (tpat_arg :> value general_pattern) with - | {pat_desc=Tpat_construct _; _} -> - register_style - c_lhs.pat_loc.Location.loc_start - "let () = ... in ... (=> use sequence)" - | _ -> () - end + | Texp_match _ as exp_desc when sections.style.seq -> + begin match Utils.Compat.get_match_data exp_desc with + | None -> assert false + | Some (_, {c_lhs={pat_desc=Tpat_value v_pat; _} as c_lhs; _}::[], [], _) + when DeadType.is_unit c_lhs.pat_type -> + (* split pattern matching for type checking *) + begin match (v_pat :> value general_pattern) with + | {pat_desc=Tpat_construct _; _} -> + register_style + c_lhs.pat_loc.Location.loc_start + "let () = ... in ... (=> use sequence)" + | _ -> () + end | _ -> () end diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index 6f8ff48..4c16038 100644 --- a/src/deadLexiFi.ml +++ b/src/deadLexiFi.ml @@ -47,14 +47,16 @@ module Extension = struct let sig_value (value : Types.value_description) = let add strct = match strct.pstr_desc with - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 3, 0) - | Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _, _)); - _}, _) -> - #elif OCAML_VERSION >= (5, 3, 0) && OCAML_VERSION < (5, 6, 0) - | Pstr_eval ({pexp_desc = Pexp_constant {pconst_desc= (Pconst_string (s, _, _)); _}; - _}, _) -> - #endif - hashtbl_add_unique_to_list str s value.val_loc.loc_start + | Pstr_eval ({pexp_desc; _}, _) -> + begin match pexp_desc with + #if OCAML_VERSION >= (5, 3, 0) + | Pexp_constant {pconst_desc= (Pconst_string (s, _, _)); _} -> + #else + | Pexp_constant (Pconst_string (s, _, _)) -> + #endif + hashtbl_add_unique_to_list str s value.val_loc.loc_start + | _ -> () + end | _ -> () in let add = function @@ -135,11 +137,7 @@ module Extension = struct match get_deep_desc typ with | Tarrow (_, t, _, _) -> process (p, t, call_site) | Ttuple ts -> - #if OCAML_VERSION >= (5, 4, 0) && OCAML_VERSION < (5, 6, 0) - (* Ttuple's ts' content changed in OCaml 5.4, from type_expr to - (string option * type_expr). This does the reverse conversion *) - let ts = List.map snd ts in - #endif + let ts = Utils.Compat.unlabel_tuple ts in List.iter (fun t -> process (p, t, call_site)) ts | Tconstr (path, ts, _) -> let name = Path.name path in diff --git a/src/deadObj.ml b/src/deadObj.ml index 0e7e199..9c4a1e1 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -144,13 +144,12 @@ let rec treat_fields action typ = match get_deep_desc typ with let rec repr_exp expr f = match expr.exp_desc with + | Texp_function _ as exp_desc -> + begin match Utils.Compat.get_function_bodies exp_desc with + | [] -> assert false + | expr::_ -> repr_exp expr f + end | Texp_sequence (_, expr) - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - | Texp_function {cases = {c_rhs=expr; _}::_ ; _} - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) - | Texp_function (_, Tfunction_cases { cases = {c_rhs=expr; _}::_ ; _ }) - | Texp_function (_, Tfunction_body expr) - #endif | Texp_let (_, _, expr) | Texp_apply (expr, _) -> repr_exp expr f | _ -> f expr @@ -292,17 +291,16 @@ let add_var loc expr = | Texp_ident (_, _, {Types.val_loc; _}) -> `Ident val_loc.Location.loc_start (* Cases not traversed by repr_exp *) - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 3, 0) - | Texp_match (_, cases, _) -> - find_first_case_kind cases - | Texp_try (_, cases) -> - find_first_case_kind cases - #elif OCAML_VERSION >= (5, 3, 0) && OCAML_VERSION < (5, 6, 0) - | Texp_match (_, cases, _, _) -> - find_first_case_kind cases - | Texp_try (_, cases, _) -> - find_first_case_kind cases - #endif + | Texp_match _ as exp_desc -> + begin match Utils.Compat.get_match_data exp_desc with + | None -> assert false + | Some (_, cases, _, _) -> find_first_case_kind cases + end + | Texp_try _ as exp_desc -> + begin match Utils.Compat.get_try_data exp_desc with + | None -> assert false + | Some (_, cases, _) -> find_first_case_kind cases + end | Texp_ifthenelse (_, then_, Some else_) -> find_first_kind [then_; else_] (* Default *) @@ -327,15 +325,8 @@ let class_structure cl_struct = | Tpat_var _ when not pat.pat_loc.Location.loc_ghost -> add_equal pat.pat_loc.Location.loc_start !last_class | _ -> () end; - match pat.pat_desc with - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - | Tpat_alias (pat, _, _) -> - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 4, 0) - | Tpat_alias (pat, _, _, _) -> - #elif OCAML_VERSION >= (5, 4, 0) && OCAML_VERSION < (5, 6, 0) - | Tpat_alias (pat, _, _, _, _) -> - #endif - add_aliases pat + match Utils.Compat.get_alias_data pat.pat_desc with + | Some (pat, _, _, _) -> add_aliases pat | _ -> () in add_aliases cl_struct.cstr_self diff --git a/src/deadSign.ml b/src/deadSign.ml index 475cc5e..78aa961 100644 --- a/src/deadSign.ml +++ b/src/deadSign.ml @@ -169,29 +169,6 @@ let collect_export_from_structure ~path ~comp_unit structure = | Tpat_constant _ | Tpat_variant (_, None, _) -> () - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - | Tpat_var (id, {loc; _}) -> - let uid = Shape.Uid.internal_not_actually_unique in - (* uid appear in OCaml 5.2. Dummy value because we do not rely on it *) - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) - | Tpat_var (id, {loc; _}, uid) -> - #endif - let id = Ident.name id in - let value = value_of pat loc uid in - export export_value ~path id value - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - | Tpat_alias (sub_pat, id, {loc; _}) -> - let uid = Shape.Uid.internal_not_actually_unique in - (* uid appear in OCaml 5.2. Dummy value because we do not rely on it *) - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 4, 0) - | Tpat_alias (sub_pat, id, {loc; _}, uid) -> - #elif OCAML_VERSION >= (5, 4, 0) && OCAML_VERSION < (5, 6, 0) - | Tpat_alias (sub_pat, id, {loc; _}, uid, _) -> - #endif - let id = Ident.name id in - let value = value_of pat loc uid in - export export_value ~path id value; - collect_value ~path sub_pat | Tpat_or (pat, _, _) (* In [P1 | P2], both branches must define the same names. Only the locations of the names in [P1] are used to refer to @@ -200,21 +177,36 @@ let collect_export_from_structure ~path ~comp_unit structure = | Tpat_lazy pat -> collect_value ~path pat | Tpat_tuple pats -> - #if OCAML_VERSION >= (5, 4, 0) && OCAML_VERSION < (5, 6, 0) - (* Tpat_tuple's pats changed in OCaml 5.4, from pat list to - (string option * pat) list. This does the reverse conversion *) - let pats = List.map snd pats in - #endif + let pats = Utils.Compat.unlabel_tuple pats in List.iter (collect_value ~path) pats | Tpat_construct (_, _, pats, _) - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 4, 0) - | Tpat_array pats -> - #elif OCAML_VERSION >= (5, 4, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 4, 0) | Tpat_array (_, pats) -> + #else + | Tpat_array pats -> #endif List.iter (collect_value ~path) pats | Tpat_record (fields, _) -> List.iter (fun (_, _, pat) -> collect_value ~path pat) fields + | (Tpat_var _ | Tpat_alias _) as pat_desc -> + let pseudo_alias_data = + (* similar to Utils.Compat.alias_data but the first field (the + aliased pattern) is None for Tpat_var and Some for Tpat_alias *) + match Utils.Compat.get_var_data pat_desc with + | Some (id, {loc; _}, uid) -> Some (None, id, loc, uid) + | None -> + match Utils.Compat.get_alias_data pat_desc with + | Some (sub_pat, id, loc, uid) -> + Some (Some sub_pat, id, loc, uid) + | None -> None + in + match pseudo_alias_data with + | None -> assert false + | Some (sub_pat, id, loc, uid) -> + let id = Ident.name id in + let value = value_of pat loc uid in + export export_value ~path id value; + Option.iter (collect_value ~path) sub_pat and collect_module ~path m = match m.mod_desc with @@ -226,7 +218,7 @@ let collect_export_from_structure ~path ~comp_unit structure = collect_structure ~path structure | Tmod_functor (_, m) | Tmod_apply (m, _, _) - #if OCAML_VERSION >= (5, 1, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit m (* Constructor introduced in OCaml 5.1 *) #endif | Tmod_constraint (m, _, Tmodtype_implicit, _) -> @@ -316,7 +308,7 @@ let collect_from_include incl_decl = (None, signature) | Tmod_functor (_, mod_expr) | Tmod_apply (mod_expr, _, _) - #if OCAML_VERSION >= (5, 1, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit mod_expr (* Constructor introduced in OCaml 5.1 *) #endif | Tmod_constraint (mod_expr, _, _, _) -> @@ -426,7 +418,7 @@ let collect_eq_from_module_alias ~path module_binding = mt | Tmod_constraint (mod_expr, _, _, _) | Tmod_functor (_, mod_expr) - #if OCAML_VERSION >= (5, 1, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 1, 0) | Tmod_apply_unit mod_expr (* Constructor introduced in OCaml 5.1 *) #endif | Tmod_apply (mod_expr, _, _) -> diff --git a/src/state/file_infos.ml b/src/state/file_infos.ml index f45a6a4..ce0ace6 100644 --- a/src/state/file_infos.ml +++ b/src/state/file_infos.ml @@ -44,10 +44,10 @@ let init_from_all_cm_infos ~cm_file cmt_infos = let cm_infos = match cmt_infos.cmt_annots with | Interface sign -> - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 3, 0) - let cmti_uid_to_decl = Location_dependencies.NA in - #elif OCAML_VERSION >= (5, 3, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 3, 0) let cmti_uid_to_decl = cmt_infos.cmt_uid_to_decl in + #else + let cmti_uid_to_decl = Location_dependencies.NA in #endif Cmti {sign; cmti_uid_to_decl} | Implementation strc -> diff --git a/src/state/location_dependencies.ml b/src/state/location_dependencies.ml index db268ac..a2fdc60 100644 --- a/src/state/location_dependencies.ml +++ b/src/state/location_dependencies.ml @@ -4,20 +4,7 @@ let empty = [] module UidTbl = Shape.Uid.Tbl -#if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 3, 0) - -type uid_to_decl = NA - -let init ~comp_unit_to_path:_ cmt_infos _cmti_uid_to_decl = - match cmt_infos with - | Cmt_format.{cmt_annots = Implementation _; cmt_value_dependencies; _} -> - let loc_of_vd vd = vd.Types.val_loc.loc_start in - cmt_value_dependencies - |> List.map (fun (vd1, vd2) -> loc_of_vd vd1, loc_of_vd vd2) - |> Result.ok - | _ -> Result.error "No implementation found in cmt_infos" - -#elif OCAML_VERSION >= (5, 3, 0) && OCAML_VERSION < (5, 6, 0) +#if OCAML_VERSION >= (5, 3, 0) (* Since OCaml 5.3, cmt_infos.cmt_value_dependencies is not available. We try to reproduce it using the cmti_uid_to_decl and comp_unit_to_path information, respectively found in a .cmti's cmt_infos and built using @@ -42,7 +29,7 @@ let fill_from_cmt_tbl uid_to_decl res_uid_to_loc = let find_opt_external_uid_loc ~comp_unit_to_path = function | Shape.Uid.(Compilation_unit _ | Internal | Predef _) -> None - #if OCAML_VERSION >= (5, 5, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 5, 0) | Local_opaque_item _ -> None #endif | Item {comp_unit; from; _} as uid -> @@ -106,4 +93,21 @@ let init ~comp_unit_to_path cmt_infos cmti_uid_to_decl = |> Result.ok | _ -> Result.error "No implementation found in cmt_infos" + +#elif OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 3, 0) + +type uid_to_decl = NA + +let init ~comp_unit_to_path:_ cmt_infos _cmti_uid_to_decl = + match cmt_infos with + | Cmt_format.{cmt_annots = Implementation _; cmt_value_dependencies; _} -> + let loc_of_vd vd = vd.Types.val_loc.loc_start in + cmt_value_dependencies + |> List.map (fun (vd1, vd2) -> loc_of_vd vd1, loc_of_vd vd2) + |> Result.ok + | _ -> Result.error "No implementation found in cmt_infos" + + +#else +#error "unsupported version" #endif diff --git a/src/state/location_dependencies.mli b/src/state/location_dependencies.mli index bce18d2..d3f2225 100644 --- a/src/state/location_dependencies.mli +++ b/src/state/location_dependencies.mli @@ -3,15 +3,15 @@ type t = (Lexing.position * Lexing.position) list val empty : t (** No signature read *) -#if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 3, 0) +#if OCAML_VERSION >= (5, 3, 0) +type uid_to_decl = Typedtree.item_declaration Shape.Uid.Tbl.t +#else (* The corresponding [cmt_infos.cmt_uid_to_decl] is introduced in OCaml 5.2 but not used until OCaml 5.3 (see {!init} below). We still provide a constructor to keep the state representation as uniform as possible. *) type uid_to_decl = NA -#elif OCAML_VERSION >= (5, 3, 0) && OCAML_VERSION < (5, 6, 0) -type uid_to_decl = Typedtree.item_declaration Shape.Uid.Tbl.t #endif val init : diff --git a/src/utils.ml b/src/utils.ml index 6a4bd76..62e0cac 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -10,7 +10,9 @@ module Filepath = struct | _ -> filepath let unit filepath = - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 3, 0) + #if OCAML_VERSION >= (5, 3, 0) + Unit_info.lax_modname_from_source filepath + #else (* reproduce https://github.com/ocaml/ocaml/blob/5.3/parsing/unit_info.ml#L60 *) let remove_all_ext basename = match String.index basename '.' with @@ -18,8 +20,6 @@ module Filepath = struct | exception Not_found -> basename in filepath |> Filename.basename |> remove_all_ext |> String.capitalize_ascii - #elif OCAML_VERSION >= (5, 3, 0) && OCAML_VERSION < (5, 6, 0) - Unit_info.lax_modname_from_source filepath #endif type kind = @@ -38,10 +38,10 @@ module Filepath = struct ) else if Sys.is_directory filepath then Dir else if Filename.check_suffix filepath ".cmti" then Cmti - else if Filename.check_suffix filepath ".cmt" then - let cmti = Filename.remove_extension filepath ^ ".cmti" in - if Sys.file_exists cmti then Cmt_with_mli - else Cmt_without_mli + else if Filename.check_suffix filepath ".cmt" then + let cmti = Filename.remove_extension filepath ^ ".cmti" in + if Sys.file_exists cmti then Cmt_with_mli + else Cmt_without_mli else Ignore end @@ -72,23 +72,23 @@ module Envaux = struct let force_setup () = Lazy.force !setup type paths = - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - string list - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 2, 0) Load_path.paths + #else + string list #endif let init_load_path paths = - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 0, 0) - Load_path.init paths - #elif OCAML_VERSION >= (5, 0, 0) && OCAML_VERSION < (5, 2, 0) - let auto_include = Load_path.no_auto_include in - Load_path.init ~auto_include paths - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 2, 0) let auto_include = Load_path.no_auto_include in let visible = paths.Load_path.visible in let hidden = paths.Load_path.hidden in Load_path.init ~auto_include ~visible ~hidden + #elif OCAML_VERSION >= (5, 0, 0) + let auto_include = Load_path.no_auto_include in + Load_path.init ~auto_include paths + #else + Load_path.init paths #endif let set_loadpaths paths = @@ -102,3 +102,118 @@ module Envaux = struct force_setup (); Envaux.env_of_only_summary env end + +module Compat = struct + + open Typedtree + + (* Conversions *) + + let unlabel_tuple fields = + #if OCAML_VERSION >= (5, 4, 0) + List.map snd fields + #else + fields + #endif + + let options_of_args args = + #if OCAML_VERSION >= (5, 4, 0) + (* Texp_apply's args changed in OCaml 5.4, from expression option + to arg_or_omitted. This does the reverse conversion *) + let args = + List.map + (fun (lab, arg) -> + match arg with + | Arg expr -> lab, Some expr + | Omitted _ -> lab, None + ) + args + in + #endif + args + + (* Getters *) + + #if OCAML_VERSION < (5, 2, 0) + let dummy_uid = Shape.Uid.internal_not_actually_unique + (* A uid field appears in multiple constructors in OCaml 5.2. + This dummy value serves as replacement. We do not rely on its value + but need it to exist for typing. *) + #endif + + type alias_data = value general_pattern * Ident.t * Location.t * Shape.Uid.t + + let get_alias_data : type k . k pattern_desc -> alias_data option = function + #if OCAML_VERSION >= (5, 4, 0) + | Tpat_alias (pat, id, {loc; _}, uid, _) -> + #elif OCAML_VERSION >= (5, 2, 0) + | Tpat_alias (pat, id, {loc; _}, uid) -> + #else + | Tpat_alias (pat, id, {loc; _}) -> + let uid = dummy_uid in + #endif + Some (pat, id, loc, uid) + | _ -> None + + type var_data = Ident.t * string Location.loc * Shape.Uid.t + + let get_var_data : type k . k pattern_desc -> var_data option = function + (* x *) + #if OCAML_VERSION >= (5, 2, 0) + | Tpat_var (id, loc, uid) -> + #else + | Tpat_var (id, loc) -> + let uid = dummy_uid in + #endif + Some (id, loc, uid) + (* (x: t) *) + #if OCAML_VERSION >= (5, 4, 0) + | Tpat_alias ({pat_desc=Tpat_any; _}, id, loc, uid, _) -> + #elif OCAML_VERSION >= (5, 2, 0) + | Tpat_alias ({pat_desc=Tpat_any; _}, id, loc, uid) -> + #else + | Tpat_alias ({pat_desc=Tpat_any; _}, id, loc) -> + let uid = dummy_uid in + #endif + Some (id, loc, uid) + | _ -> None + + type match_data = + expression * computation case list * value case list * partial + + let get_match_data = function + #if OCAML_VERSION >= (5, 3, 0) + | Texp_match (exp, reg_cases, eff_cases, partial) -> + #else + | Texp_match (exp, reg_cases, partial) -> + let eff_cases = [] in (* effect cases appear in OCaml 5.3 *) + #endif + Some (exp, reg_cases, eff_cases, partial) + | _ -> None + + type try_data = + expression * value case list * value case list + + let get_try_data = function + #if OCAML_VERSION >= (5, 3, 0) + | Texp_try (exp, reg_cases, eff_cases) -> + #else + | Texp_try (exp, reg_cases) -> + let eff_cases = [] in (* effect cases appear in OCaml 5.3 *) + #endif + Some (exp, reg_cases, eff_cases) + | _ -> None + + type function_bodies = expression list + + let get_function_bodies = function + #if OCAML_VERSION >= (5, 2, 0) + | Texp_function (_, Tfunction_body expr) -> expr::[] + | Texp_function (_, Tfunction_cases { cases ; _ }) -> + #else + | Texp_function {cases ; _} -> + #endif + List.map (fun {c_rhs; _} -> c_rhs) cases + | _ -> [] + +end diff --git a/src/utils.mli b/src/utils.mli index e5d20e4..1c31e96 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -43,10 +43,10 @@ module StringSet : Set.S with type elt = String.t module Envaux : sig type paths = - #if OCAML_VERSION >= (4, 14, 0) && OCAML_VERSION < (5, 2, 0) - string list - #elif OCAML_VERSION >= (5, 2, 0) && OCAML_VERSION < (5, 6, 0) + #if OCAML_VERSION >= (5, 2, 0) Load_path.paths + #else + string list #endif val set_loadpaths : paths -> unit @@ -57,3 +57,76 @@ module Envaux : sig (** Same as Envaux.env_of_only_summary but ensures the paths submitted in set_loadpaths are actually set. *) end + +module Compat : sig + + open Typedtree + + #if OCAML_VERSION >= (5, 4, 0) + val unlabel_tuple : ('a * 'b) list -> 'b list + #else + val unlabel_tuple : 'a list -> 'a list + #endif + (** Tuple's field representation changed in OCaml 5.4, with the + introduction of labelled tuples. This converts a tuple's fields back + into the pre-5.4 representation. *) + +val options_of_args : + #if OCAML_VERSION >= (5, 4, 0) + (Asttypes.arg_label * (expression, unit) arg_or_omitted) list + #else + (Asttypes.arg_label * expression option) list + #endif + -> (Asttypes.arg_label * expression option) list + (** Apply's arguments representation changed in OCaml 5.4, from + expression option to arg_or_omitted. This does the reverse conversion *) + + type alias_data = value general_pattern * Ident.t * Location.t * Shape.Uid.t + + val get_alias_data : 'k . 'k pattern_desc -> alias_data option + (** [get_alias_data pat] returns [None] if [pat <> Tpat_alias _]. + Otherwise it extracts the different components of Tpat_alias. + If OCaml < 5.2, the [Uid.t] field is a dummy value. + If OCaml >= 5.4, the last field of Tpat_alias is discarded. + *) + + type var_data = Ident.t * string Location.loc * Shape.Uid.t + + val get_var_data : 'k . 'k pattern_desc -> var_data option + (** [get_var_data pat] returns [None] if + [pat <> Tpat_var _ && pat <> Tpat_alias(Tpat_any)]. + Otherwise it extracts the different components of Tpat_var. + If OCaml < 5.2, the [Uid.t] field is a dummy value. + [Tpat_alias(Tpat_any)] is considered equivalent to a [Tpat_var] + because in OCaml < 5.5, constrained vars ([x : t]) are translated + in this pattern. + *) + + type match_data = + expression * computation case list * value case list * partial + + val get_match_data : expression_desc -> match_data option + (** [get_match_data exp] returns [None] if [pat <> Texp_match]. + Otherwise it extracts the different components of Texp_match. + If OCaml < 5.3, the [value case list] field is en empty list. + *) + + type try_data = + expression * value case list * value case list + + val get_try_data : expression_desc -> try_data option + (** [get_try_data exp] returns [None] if [pat <> Texp_try]. + Otherwise it extracts the different components of Texp_try. + If OCaml < 5.3, the second [value case list] field is en empty list. + *) + + type function_bodies = expression list + + val get_function_bodies : expression_desc -> function_bodies + (** [get_function_bodies exp] returns [[]] if [pat <> Texp_function]. + Otherwise it returns the expression of the function body. + If there are multiple cases, then the returned list contains all the + alternative expressions.. + *) + +end From 20dd0e08a8c41fcd12450d5448d3781e74a96f53 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Fri, 11 Sep 2026 16:50:59 +0200 Subject: [PATCH 2/2] [src][utils] improve the compat getters Instead of systematically returning an option, they now return a result, and a dedicated error gadt `'a invalid_arg` is introduced. In addition, getters have a `*_exn` variant to directly unwrap the result when the argument is already known to have the right shape. --- src/deadCode.ml | 51 ++++++++++++++++--------------------- src/deadObj.ml | 18 ++++++------- src/deadSign.ml | 25 ++++++++---------- src/utils.ml | 67 ++++++++++++++++++++++++++++++++++++++----------- src/utils.mli | 59 +++++++++++++++++++++++++++++++------------ 5 files changed, 136 insertions(+), 84 deletions(-) diff --git a/src/deadCode.ml b/src/deadCode.ml index 049b00a..0b5cecf 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -43,15 +43,12 @@ let rec treat_exp exp args = DeadArg.register_uses loc args | Texp_match _ as exp_desc -> - begin match Utils.Compat.get_match_data exp_desc with - | None -> assert false - | Some (_, comp_l, val_l, _) -> - let process_cases l = - List.iter (fun {c_rhs = exp; _} -> treat_exp exp args) l - in - process_cases comp_l; - process_cases val_l - end + let (_, comp_l, val_l, _) = Utils.Compat.get_match_data_exn exp_desc in + let process_cases l = + List.iter (fun {c_rhs = exp; _} -> treat_exp exp args) l + in + process_cases comp_l; + process_cases val_l | Texp_ifthenelse (_, exp_then, exp_else) -> treat_exp exp_then args; @@ -67,23 +64,18 @@ let value_binding super self x = let at_eof_saved = !DeadArg.at_eof in DeadArg.at_eof := []; incr depth; - begin match x.vb_pat.pat_desc with - | Tpat_var _ as pat_desc -> - begin match Utils.Compat.get_var_data pat_desc with - | None -> assert false - | Some (_, {loc=pat_loc; _}, _) -> - if not pat_loc.Location.loc_ghost then - let pat_loc = pat_loc.Location.loc_start in - match x.vb_expr.exp_desc with - | Texp_ident (_, _, {val_loc; _}) - when not val_loc.Location.loc_ghost -> - let val_loc = val_loc.Location.loc_start in - VdNode.merge_locs pat_loc val_loc; - DeadObj.add_equal pat_loc val_loc - | _ -> - let exp = x.vb_expr in - DeadArg.bind pat_loc exp; - DeadObj.add_var pat_loc exp + begin match Utils.Compat.get_var_data x.vb_pat.pat_desc with + | Ok (_, {loc=pat_loc; _}, _) when not pat_loc.Location.loc_ghost -> + let pat_loc = pat_loc.Location.loc_start in + begin match x.vb_expr.exp_desc with + | Texp_ident (_, _, {val_loc; _}) when not val_loc.Location.loc_ghost -> + let val_loc = val_loc.Location.loc_start in + VdNode.merge_locs pat_loc val_loc; + DeadObj.add_equal pat_loc val_loc + | _ -> + let exp = x.vb_expr in + DeadArg.bind pat_loc exp; + DeadObj.add_var pat_loc exp end | _ -> () end; @@ -127,6 +119,7 @@ let id_of_var pat_desc = (* helper function to extract the var's id in tpat_var and tpat_alias(tpat_any) patterns for all OCaml versions *) Utils.Compat.get_var_data pat_desc + |> Result.to_option |> Option.map (fun (id, _, _) -> id) @@ -233,9 +226,9 @@ let expr super self e = end | Texp_match _ as exp_desc when sections.style.seq -> - begin match Utils.Compat.get_match_data exp_desc with - | None -> assert false - | Some (_, {c_lhs={pat_desc=Tpat_value v_pat; _} as c_lhs; _}::[], [], _) + let (_, comp_l, val_l, _) = Utils.Compat.get_match_data_exn exp_desc in + begin match comp_l, val_l with + | {c_lhs={pat_desc=Tpat_value v_pat; _} as c_lhs; _}::[], [] when DeadType.is_unit c_lhs.pat_type -> (* split pattern matching for type checking *) begin match (v_pat :> value general_pattern) with diff --git a/src/deadObj.ml b/src/deadObj.ml index 9c4a1e1..b4b9ac3 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -146,8 +146,8 @@ let rec repr_exp expr f = match expr.exp_desc with | Texp_function _ as exp_desc -> begin match Utils.Compat.get_function_bodies exp_desc with - | [] -> assert false - | expr::_ -> repr_exp expr f + | Ok (expr::_) -> repr_exp expr f + | _ -> assert false end | Texp_sequence (_, expr) | Texp_let (_, _, expr) @@ -292,15 +292,11 @@ let add_var loc expr = `Ident val_loc.Location.loc_start (* Cases not traversed by repr_exp *) | Texp_match _ as exp_desc -> - begin match Utils.Compat.get_match_data exp_desc with - | None -> assert false - | Some (_, cases, _, _) -> find_first_case_kind cases - end + let (_, cases, _, _) = Utils.Compat.get_match_data_exn exp_desc in + find_first_case_kind cases | Texp_try _ as exp_desc -> - begin match Utils.Compat.get_try_data exp_desc with - | None -> assert false - | Some (_, cases, _) -> find_first_case_kind cases - end + let (_, cases, _) = Utils.Compat.get_try_data_exn exp_desc in + find_first_case_kind cases | Texp_ifthenelse (_, then_, Some else_) -> find_first_kind [then_; else_] (* Default *) @@ -326,7 +322,7 @@ let class_structure cl_struct = add_equal pat.pat_loc.Location.loc_start !last_class | _ -> () end; match Utils.Compat.get_alias_data pat.pat_desc with - | Some (pat, _, _, _) -> add_aliases pat + | Ok (pat, _, _, _) -> add_aliases pat | _ -> () in add_aliases cl_struct.cstr_self diff --git a/src/deadSign.ml b/src/deadSign.ml index 78aa961..e870a74 100644 --- a/src/deadSign.ml +++ b/src/deadSign.ml @@ -189,24 +189,21 @@ let collect_export_from_structure ~path ~comp_unit structure = | Tpat_record (fields, _) -> List.iter (fun (_, _, pat) -> collect_value ~path pat) fields | (Tpat_var _ | Tpat_alias _) as pat_desc -> - let pseudo_alias_data = + let sub_pat, id, loc, uid = (* similar to Utils.Compat.alias_data but the first field (the aliased pattern) is None for Tpat_var and Some for Tpat_alias *) match Utils.Compat.get_var_data pat_desc with - | Some (id, {loc; _}, uid) -> Some (None, id, loc, uid) - | None -> - match Utils.Compat.get_alias_data pat_desc with - | Some (sub_pat, id, loc, uid) -> - Some (Some sub_pat, id, loc, uid) - | None -> None + | Ok (id, {loc; _}, uid) -> (None, id, loc, uid) + | Error _ -> + let (sub_pat, id, loc, uid) = + Utils.Compat.get_alias_data_exn pat_desc + in + (Some sub_pat, id, loc, uid) in - match pseudo_alias_data with - | None -> assert false - | Some (sub_pat, id, loc, uid) -> - let id = Ident.name id in - let value = value_of pat loc uid in - export export_value ~path id value; - Option.iter (collect_value ~path) sub_pat + let id = Ident.name id in + let value = value_of pat loc uid in + export export_value ~path id value; + Option.iter (collect_value ~path) sub_pat and collect_module ~path m = match m.mod_desc with diff --git a/src/utils.ml b/src/utils.ml index 62e0cac..690fe02 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -134,6 +134,11 @@ module Compat = struct (* Getters *) + type _ invalid_arg = + | Unexpected_pattern : string * 'k pattern_desc -> 'k pattern_desc invalid_arg + | Unexpected_expression : + string * expression_desc -> expression_desc invalid_arg + #if OCAML_VERSION < (5, 2, 0) let dummy_uid = Shape.Uid.internal_not_actually_unique (* A uid field appears in multiple constructors in OCaml 5.2. @@ -141,9 +146,11 @@ module Compat = struct but need it to exist for typing. *) #endif + type ('k, 'a) pat_getter = 'k pattern_desc -> ('a, 'k pattern_desc invalid_arg) result + type alias_data = value general_pattern * Ident.t * Location.t * Shape.Uid.t - let get_alias_data : type k . k pattern_desc -> alias_data option = function + let get_alias_data : type k . (k, alias_data) pat_getter = function #if OCAML_VERSION >= (5, 4, 0) | Tpat_alias (pat, id, {loc; _}, uid, _) -> #elif OCAML_VERSION >= (5, 2, 0) @@ -152,12 +159,18 @@ module Compat = struct | Tpat_alias (pat, id, {loc; _}) -> let uid = dummy_uid in #endif - Some (pat, id, loc, uid) - | _ -> None + Result.Ok (pat, id, loc, uid) + | pat_desc -> + let msg = "get_alias_data expects a Tpat_alias" in + let err = Unexpected_pattern (msg, pat_desc) in + Result.Error err + + let get_alias_data_exn pat_desc = + get_alias_data pat_desc |> Result.get_ok type var_data = Ident.t * string Location.loc * Shape.Uid.t - let get_var_data : type k . k pattern_desc -> var_data option = function + let get_var_data : type k . (k, var_data) pat_getter = function (* x *) #if OCAML_VERSION >= (5, 2, 0) | Tpat_var (id, loc, uid) -> @@ -165,7 +178,7 @@ module Compat = struct | Tpat_var (id, loc) -> let uid = dummy_uid in #endif - Some (id, loc, uid) + Result.ok (id, loc, uid) (* (x: t) *) #if OCAML_VERSION >= (5, 4, 0) | Tpat_alias ({pat_desc=Tpat_any; _}, id, loc, uid, _) -> @@ -175,8 +188,17 @@ module Compat = struct | Tpat_alias ({pat_desc=Tpat_any; _}, id, loc) -> let uid = dummy_uid in #endif - Some (id, loc, uid) - | _ -> None + Result.ok (id, loc, uid) + | pat_desc -> + let msg = "get_var_data expects a Tpat_var or Tpat_alias(Tpat_any)" in + let err = Unexpected_pattern (msg, pat_desc) in + Result.Error err + + let get_var_data_exn pat_desc = + get_var_data pat_desc |> Result.get_ok + + type 'a exp_getter = + expression_desc -> ('a, expression_desc invalid_arg) result type match_data = expression * computation case list * value case list * partial @@ -188,8 +210,14 @@ module Compat = struct | Texp_match (exp, reg_cases, partial) -> let eff_cases = [] in (* effect cases appear in OCaml 5.3 *) #endif - Some (exp, reg_cases, eff_cases, partial) - | _ -> None + Result.Ok (exp, reg_cases, eff_cases, partial) + | exp_desc -> + let msg = "get_match_data expects a Texp_match" in + let err = Unexpected_expression (msg, exp_desc) in + Result.Error err + + let get_match_data_exn exp_desc = + get_match_data exp_desc |> Result.get_ok type try_data = expression * value case list * value case list @@ -201,19 +229,30 @@ module Compat = struct | Texp_try (exp, reg_cases) -> let eff_cases = [] in (* effect cases appear in OCaml 5.3 *) #endif - Some (exp, reg_cases, eff_cases) - | _ -> None + Result.Ok (exp, reg_cases, eff_cases) + | exp_desc -> + let msg = "get_try_data expects a Texp_try" in + let err = Unexpected_expression (msg, exp_desc) in + Result.Error err + + let get_try_data_exn exp_desc = + get_try_data exp_desc |> Result.get_ok type function_bodies = expression list let get_function_bodies = function #if OCAML_VERSION >= (5, 2, 0) - | Texp_function (_, Tfunction_body expr) -> expr::[] + | Texp_function (_, Tfunction_body expr) -> + Result.ok [expr] | Texp_function (_, Tfunction_cases { cases ; _ }) -> #else | Texp_function {cases ; _} -> #endif - List.map (fun {c_rhs; _} -> c_rhs) cases - | _ -> [] + let bodies = List.map (fun {c_rhs; _} -> c_rhs) cases in + Result.ok bodies + | exp_desc -> + let msg = "get_function_bodies expects a Texp_function" in + let err = Unexpected_expression (msg, exp_desc) in + Result.Error err end diff --git a/src/utils.mli b/src/utils.mli index 1c31e96..883691c 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -81,52 +81,79 @@ val options_of_args : (** Apply's arguments representation changed in OCaml 5.4, from expression option to arg_or_omitted. This does the reverse conversion *) + type _ invalid_arg = + | Unexpected_pattern : string * 'k pattern_desc -> 'k pattern_desc invalid_arg + (** Used by pattern_desc getters *) + | Unexpected_expression : + string * expression_desc -> expression_desc invalid_arg + (** Used by expression_desc getters *) + + type ('k, 'a) pat_getter = 'k pattern_desc -> ('a, 'k pattern_desc invalid_arg) result + type alias_data = value general_pattern * Ident.t * Location.t * Shape.Uid.t - val get_alias_data : 'k . 'k pattern_desc -> alias_data option - (** [get_alias_data pat] returns [None] if [pat <> Tpat_alias _]. - Otherwise it extracts the different components of Tpat_alias. + val get_alias_data : 'k . ('k, alias_data) pat_getter + (** [get_alias_data pat] expects a [Tpat_alias]. + It returns [Error Unexpected_pattern] otherwise. + It extracts the different components of Tpat_alias. If OCaml < 5.2, the [Uid.t] field is a dummy value. If OCaml >= 5.4, the last field of Tpat_alias is discarded. *) + val get_alias_data_exn : 'k . 'k pattern_desc -> alias_data + (** same as [get_alias_data] but raises instead of returning an Error *) + type var_data = Ident.t * string Location.loc * Shape.Uid.t - val get_var_data : 'k . 'k pattern_desc -> var_data option - (** [get_var_data pat] returns [None] if - [pat <> Tpat_var _ && pat <> Tpat_alias(Tpat_any)]. - Otherwise it extracts the different components of Tpat_var. + val get_var_data : 'k . ('k, var_data) pat_getter + (** [get_var_data pat] expects a [Tpat_var] or a [Tpat_alias(Tpat_any)]. + It returns [Error Unexpected_pattern] otherwise. + It extracts the different components of Tpat_var. If OCaml < 5.2, the [Uid.t] field is a dummy value. [Tpat_alias(Tpat_any)] is considered equivalent to a [Tpat_var] because in OCaml < 5.5, constrained vars ([x : t]) are translated in this pattern. *) + val get_var_data_exn : 'k . 'k pattern_desc -> var_data + (** same as [get_var_data] but raises instead of returning an Error *) + + type 'a exp_getter = + expression_desc -> ('a, expression_desc invalid_arg) result + type match_data = expression * computation case list * value case list * partial - val get_match_data : expression_desc -> match_data option - (** [get_match_data exp] returns [None] if [pat <> Texp_match]. + val get_match_data : match_data exp_getter + (** [get_match_data exp] expects a [Texp_match]. + It returns [Error Unexpected_expression] otherwise. Otherwise it extracts the different components of Texp_match. If OCaml < 5.3, the [value case list] field is en empty list. *) - type try_data = - expression * value case list * value case list + val get_match_data_exn : expression_desc -> match_data + (** same as [get_match_data] but raises instead of returning an Error *) + + type try_data = expression * value case list * value case list - val get_try_data : expression_desc -> try_data option - (** [get_try_data exp] returns [None] if [pat <> Texp_try]. + val get_try_data : try_data exp_getter + (** [get_try_data exp] expects a [Texp_try]. + It returns [Error Unexpected_expression] otherwise. Otherwise it extracts the different components of Texp_try. If OCaml < 5.3, the second [value case list] field is en empty list. *) + val get_try_data_exn : expression_desc -> try_data + (** same as [get_try_data] but raises instead of returning an Error *) + type function_bodies = expression list - val get_function_bodies : expression_desc -> function_bodies - (** [get_function_bodies exp] returns [[]] if [pat <> Texp_function]. + val get_function_bodies : function_bodies exp_getter + (** [get_function_bodies exp] expects a [Texp_function]. + It returns [Error Unexpected_expression] otherwise. Otherwise it returns the expression of the function body. If there are multiple cases, then the returned list contains all the - alternative expressions.. + alternative expressions. *) end