From a4cb46e92929db601e63d6471849d482afaee499 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Mon, 2 Feb 2026 14:32:04 +0100 Subject: [PATCH 01/12] [src][config][1/n] move `DeadFlag` into `Config` and write its mli This is the first of a series of commits aiming at extracting configuration related code from the analysis code. NOTE: There are multiple end goals at stake : - for the user interface, its specification should be rigidified to avoid confusion on command lines such as `dead_code_analyzer --nothing -E all path1 -M all path2` which would currently mean "analyze path1 for the exported values only and path2 for both the exported values and the methods". Ideally, it should be simplified to "analyze path1 and path2 for exported values and methods" and encourage the use of `dead_code_analyzer --nothing -E all -M all path1 path2` instead. - for the configuration, it should appear as immutable in order to facilitate debugging and accessing its information. - for the analysis, the end goal is to be able to split the analysis in 2 passes : 1. on the interfaces to gather all the declarations 2. on the implementations to gather all the references. They are currently interlaced (actually, for each compilation unit, we first process the interface and then the implementation). This split combined with a more robust configuration should help transition to OCaml 5.3 --- src/{deadFlag.ml => config/config.ml} | 6 +- src/config/config.mli | 100 ++++++++++++++++++++++++++ src/deadArg.ml | 6 +- src/deadCode.ml | 96 ++++++++++++------------- src/deadCommon.ml | 30 ++++---- src/deadLexiFi.ml | 4 +- src/deadMod.ml | 8 +-- src/deadObj.ml | 4 +- src/deadType.ml | 6 +- 9 files changed, 180 insertions(+), 80 deletions(-) rename src/{deadFlag.ml => config/config.ml} (97%) create mode 100644 src/config/config.mli diff --git a/src/deadFlag.ml b/src/config/config.ml similarity index 97% rename from src/deadFlag.ml rename to src/config/config.ml index 3452f7d4..9f5b550f 100644 --- a/src/deadFlag.ml +++ b/src/config/config.ml @@ -7,10 +7,10 @@ (* *) (***************************************************************************) -type threshold = {exceptions: int; percentage: float; optional: [`Percent | `Both]} +type threshold = {percentage: float; exceptions: int; optional: [`Percent | `Both]} -type opt = {print: bool; call_sites: bool; threshold: threshold} +type opt = {print: bool; threshold: threshold; call_sites: bool} let opta = ref { print = false; @@ -121,7 +121,7 @@ let update_style s = aux (list_of_opt s) -type basic = {print: bool; call_sites: bool; threshold: int} +type basic = {print: bool; threshold: int; call_sites: bool} let exported : basic ref = ref ({ print = true; diff --git a/src/config/config.mli b/src/config/config.mli new file mode 100644 index 00000000..f9bf625c --- /dev/null +++ b/src/config/config.mli @@ -0,0 +1,100 @@ +(** Configuration of the analyzer *) + +(** {2 Sections configuration} *) + +(** {3 Main sections} *) + +type basic = + { print: bool (** Report section *) + ; threshold: int + (** Report subsections for elements used up to [!threshold] *) + ; call_sites: bool (** Print call sites in the [!threshold]-related subsections *) + } + +val exported : basic ref +(** Configuration for the unused exported values *) + +val obj : basic ref +(** Configuration for the methods *) + +val typ : basic ref +(** Configuration for the constructors/record fields *) + +val update_basic : string -> basic ref -> string -> unit +(** [update_basic sec_arg section arg] updates the configuration of [section] according + to the [arg] specification. [sec_arg] is the command line argument + associated with the [section] *) + +(** {3 Optional argument sections} *) + +type threshold = + { percentage: float + (** Subsections for opt args always/never used except at most + [percentage] of the time will be reported *) + ; exceptions: int + (** Only optional arguments always/never used except at most + [exceptions] times will be reported in the subsections *) + ; optional: [`Percent | `Both] (** Threshold mode *) + } + +type opt = + { print: bool (** Report section *) + ; threshold: threshold + (** Report subsections for opt args always/never used up to [!threshold] *) + ; call_sites: bool (** Print call sites in the [!threshold]-related subsections *) + } + +val opta : opt ref +(** Configuration for the optional arguments always used *) + +val optn : opt ref +(** Configuration for the optional arguments never used *) + +val update_opt : opt ref -> string -> unit +(** [update_opt section arg] updates the configuration of [section] according + to the [arg] specification *) + +(** {3 Stylistic issues section} *) + +type style = + { opt_arg: bool (** Report [val f : _ -> (... -> (... -> ?_:_ -> ...) -> ...] *) + ; unit_pat: bool (** Report unit pattern *) + ; seq: bool (** Report [let () = ... in ... (=> use sequence)] *) + ; binding: bool (** Report [let x = ... in x (=> useless binding)] *) + } + +val style : style ref +(** Configuration for the stylistic issues *) + +val update_style : string -> unit +(** [update_style arg] updates [!style] according to the [arg] specification *) + +(** {2 General configuration} *) + +val verbose : bool ref +(** Display additional information during the analaysis. [false] by default. *) + +val set_verbose : unit -> unit +(** Set [verbose] to [true] *) + +val underscore : bool ref +(** Keep track of elements with names starting with [_]. [false] by default. *) + +val set_underscore : unit -> unit +(** Set [underscore] to [true] *) + +val internal : bool ref +(** Keep track of internal uses for exported values. [false] by default. *) + +val set_internal : unit -> unit +(** Set [internal] to [true] *) + +val exclude : string -> unit +(** [exclude path] excludse [path] from the analysis *) + +val is_excluded : string -> bool +(** [is_excluded path] indicates if [path] is excluded from the analysis. + Excluding a path is done with [exclude path]. *) + +val directories : string list ref +(** Paths to explore for references only *) diff --git a/src/deadArg.ml b/src/deadArg.ml index 52216448..15fa610c 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -162,7 +162,7 @@ let rec bind loc expr = DeadType.check_style pat_type expr.exp_loc.Location.loc_start in let register_optional_param = function - | Asttypes.Optional s when DeadFlag.(!optn.print || !opta.print) -> + | Asttypes.Optional s when Config.(!optn.print || !opta.print) -> let (opts, next) = VdNode.get loc in VdNode.update loc (s :: opts, next) | _ -> () @@ -181,7 +181,7 @@ let rec bind loc expr = | _ -> () ) | exp_desc - when (!DeadFlag.optn.print || !DeadFlag.opta.print) + when (!Config.optn.print || !Config.opta.print) && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> let ( let$ ) x f = Option.iter f x in let$ loc2 = @@ -198,6 +198,6 @@ let rec bind loc expr = (******** WRAPPING ********) let wrap f x y = - if DeadFlag.(!optn.print || !opta.print) then f x y else () + if Config.(!optn.print || !opta.print) then f x y else () let register_uses val_loc args = wrap register_uses val_loc args diff --git a/src/deadCode.ml b/src/deadCode.ml index f64b7e5a..8dcc1d33 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -36,7 +36,7 @@ let rec collect_export ?(mod_type = false) path u stock = function | Sig_value (id, ({Types.val_loc; val_type; _} as value), _) when not val_loc.Location.loc_ghost -> let should_export stock loc = - !DeadFlag.exported.DeadFlag.print + !Config.exported.Config.print && (* do not add the loc in decs if it belongs to a module type *) ( stock != decs || not (Hashtbl.mem in_modtype loc.Location.loc_start) @@ -131,12 +131,12 @@ let structure_item super self i = let state = State.get_current () in let open Asttypes in begin match i.str_desc with - | Tstr_type (_, l) when !DeadFlag.typ.DeadFlag.print -> + | Tstr_type (_, l) when !Config.typ.Config.print -> List.iter DeadType.tstr l | Tstr_module {mb_name = {txt = Some txt; _}; _} -> mods := txt :: !mods; DeadMod.defined := String.concat "." (List.rev !mods) :: !DeadMod.defined - | Tstr_class l when !DeadFlag.obj.DeadFlag.print -> List.iter DeadObj.tstr l + | Tstr_class l when !Config.obj.Config.print -> List.iter DeadObj.tstr l | Tstr_include i -> let collect_include signature = let prev_last_loc = !last_loc in @@ -177,13 +177,13 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - register_style pat_loc (Printf.sprintf "unit pattern %s" s) in let open Asttypes in - if DeadType.is_unit p.pat_type && !DeadFlag.style.DeadFlag.unit_pat then begin + if DeadType.is_unit p.pat_type && !Config.style.Config.unit_pat then begin match p.pat_desc with | Tpat_construct _ -> () | Tpat_var (_, {txt = "eta"; loc = _}, _) when p.pat_loc = Location.none -> () | Tpat_var (_, {txt; _}, _) -> if check_underscore txt then u txt - | Tpat_any -> if not !DeadFlag.underscore then u "_" + | Tpat_any -> if not !Config.underscore then u "_" | Tpat_value tpat_arg -> begin match (tpat_arg :> value general_pattern) with | {pat_desc=Tpat_construct _; _} -> () @@ -195,7 +195,7 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - | Tpat_record (l, _) -> List.iter (fun (_, {Types.lbl_loc = {Location.loc_start = lab_loc; _}; _}, _) -> - if exported DeadFlag.typ lab_loc then + if exported Config.typ lab_loc then DeadType.collect_references lab_loc pat_loc ) l @@ -218,12 +218,12 @@ let expr super self e = !DeadLexiFi.ttype_of e | Texp_ident (_, _, {Types.val_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}) - when exported DeadFlag.exported loc -> + when exported Config.exported loc -> LocHash.add_set references loc exp_loc | Texp_field (_, _, {lbl_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}) | Texp_construct (_, {cstr_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}, _) - when exported DeadFlag.typ loc -> + when exported Config.typ loc -> DeadType.collect_references loc exp_loc | Texp_send (e2, Tmeth_name meth) -> @@ -234,7 +234,7 @@ let expr super self e = | Texp_apply (exp, args) -> - if DeadFlag.(!opta.print || !optn.print) then treat_exp exp args; + if Config.(!opta.print || !optn.print) then treat_exp exp args; begin match exp.exp_desc with | Texp_ident (_, _, {Types.val_loc; _}) when val_loc.Location.loc_ghost -> (* The node is due to lookup preparation @@ -248,7 +248,7 @@ let expr super self e = end | Texp_let (_, [{vb_pat; _}], _) - when DeadType.is_unit vb_pat.pat_type && !DeadFlag.style.DeadFlag.seq -> + when DeadType.is_unit vb_pat.pat_type && !Config.style.Config.seq -> begin match vb_pat.pat_desc with | Tpat_var (id, _, _) when not (check_underscore (Ident.name id)) -> () | _ -> @@ -258,7 +258,7 @@ let expr super self e = end | Texp_match (_, [{c_lhs; _}], _) - when DeadType.is_unit c_lhs.pat_type && !DeadFlag.style.DeadFlag.seq -> + when DeadType.is_unit c_lhs.pat_type && !Config.style.Config.seq -> begin match c_lhs.pat_desc with | Tpat_value tpat_arg -> begin match (tpat_arg :> value general_pattern) with @@ -276,7 +276,7 @@ let expr super self e = [{vb_pat = {pat_desc = Tpat_var (id1, _, _); pat_loc = {loc_start = loc; _}; _}; _}], {exp_desc = Texp_ident (Path.Pident id2, _, _); exp_extra = []; _}) when id1 = id2 - && !DeadFlag.style.DeadFlag.binding + && !Config.style.Config.binding && check_underscore (Ident.name id1) -> register_style loc "let x = ... in x (=> useless binding)" @@ -339,7 +339,7 @@ let kind fn = if not (Sys.file_exists fn) then begin prerr_endline ("Warning: '" ^ fn ^ "' not found"); `Ignore - end else if DeadFlag.is_excluded fn then `Ignore + end else if Config.is_excluded fn then `Ignore else if Sys.is_directory fn then `Dir else if Filename.check_suffix fn ".cmi" then `Cmi else if Filename.check_suffix fn ".cmt" then `Cmt @@ -356,9 +356,9 @@ let regabs state = let read_interface fn cmi_infos state = let open Cmi_format in try regabs state; - if !DeadFlag.exported.DeadFlag.print - || !DeadFlag.obj.DeadFlag.print - || !DeadFlag.typ.DeadFlag.print + if !Config.exported.Config.print + || !Config.obj.Config.print + || !Config.typ.Config.print then let u = if State.File_infos.has_sourcepath state.file_infos then @@ -397,7 +397,7 @@ let assoc decs (loc1, loc2) = || not (is_implem fn && has_iface fn) in if fn1 <> _none && fn2 <> _none && loc1 <> loc2 then begin - if (!DeadFlag.internal || fn1 <> fn2) && is_implem fn1 && is_implem fn2 then + if (!Config.internal || fn1 <> fn2) && is_implem fn1 && is_implem fn2 then DeadCommon.LocHash.merge_set references loc2 references loc1; if is_iface fn1 loc1 then begin if is_iface fn2 loc2 then @@ -455,7 +455,7 @@ let rec load_file state fn = match kind fn with | `Cmi when !DeadCommon.declarations -> last_loc := Lexing.dummy_pos; - if !DeadFlag.verbose then Printf.eprintf "Scanning %s\n%!" fn; + if !Config.verbose then Printf.eprintf "Scanning %s\n%!" fn; init_and_continue state fn (fun state -> match state.file_infos.cmi_infos with | None -> () (* TODO error handling ? *) @@ -465,7 +465,7 @@ let rec load_file state fn = | `Cmt -> let open Cmt_format in last_loc := Lexing.dummy_pos; - if !DeadFlag.verbose then Printf.eprintf "Scanning %s\n%!" fn; + if !Config.verbose then Printf.eprintf "Scanning %s\n%!" fn; init_and_continue state fn (fun state -> regabs state; match state.file_infos.cmt_infos with @@ -483,7 +483,7 @@ let rec load_file state fn = ignore (collect_references.Tast_mapper.structure collect_references x); let loc_dep = - if !DeadFlag.exported.DeadFlag.print then + if !Config.exported.Config.print then List.rev_map (fun (vd1, vd2) -> (vd1.Types.val_loc.Location.loc_start, vd2.Types.val_loc.Location.loc_start) @@ -546,12 +546,12 @@ let analyze_opt_args () = let report_opt_args s l = let opt = - if s = "NEVER" then !DeadFlag.optn - else !DeadFlag.opta + if s = "NEVER" then !Config.optn + else !Config.opta in let percent = percent opt in let rec report_opt_args nb_call = - let open DeadFlag in + let open Config in let l = List.filter (fun (_, _, _, slot, ratio, _) -> let ratio = 1. -. ratio in if opt.threshold.optional = `Both then @@ -608,7 +608,7 @@ let report_opt_args s l = in report_opt_args 0 -let report_unused_exported () = report_basic decs "UNUSED EXPORTED VALUES" !DeadFlag.exported +let report_unused_exported () = report_basic decs "UNUSED EXPORTED VALUES" !Config.exported let report_style () = @@ -632,9 +632,9 @@ let report_style () = (* Option parsing and processing *) let parse () = let update_all print () = - DeadFlag.( + Config.( update_style ((if print = "all" then "+" else "-") ^ "all"); - update_basic "-E" DeadFlag.exported print; + update_basic "-E" Config.exported print; update_basic "-M" obj print; update_basic "-T" typ print; update_opt opta print; @@ -650,18 +650,18 @@ let parse () = (* any extra argument can be accepted by any option using some * although it doesn't necessary affects the results (e.g. -O 3+4) *) Arg.(parse - [ "--exclude", String DeadFlag.exclude, " Exclude given path from research."; + [ "--exclude", String Config.exclude, " Exclude given path from research."; "--references", - String (fun dir -> DeadFlag.directories := dir :: !DeadFlag.directories), + String (fun dir -> Config.directories := dir :: !Config.directories), " Consider given path to collect references."; - "--underscore", Unit DeadFlag.set_underscore, " Show names starting with an underscore"; + "--underscore", Unit Config.set_underscore, " Show names starting with an underscore"; - "--verbose", Unit DeadFlag.set_verbose, " Verbose mode (ie., show scanned files)"; - "-v", Unit DeadFlag.set_verbose, " See --verbose"; + "--verbose", Unit Config.set_verbose, " Verbose mode (ie., show scanned files)"; + "-v", Unit Config.set_verbose, " See --verbose"; - "--internal", Unit DeadFlag.set_internal, + "--internal", Unit Config.set_internal, " Keep internal uses as exported values uses when the interface is given. \ This is the default behaviour when only the implementation is found"; @@ -670,7 +670,7 @@ let parse () = "--all", Unit (update_all "all"), " Enable all warnings"; "-A", Unit (update_all "all"), " See --all"; - "-E", String (DeadFlag.update_basic "-E" DeadFlag.exported), + "-E", String (Config.update_basic "-E" Config.exported), " Enable/Disable unused exported values warnings.\n \ can be:\n\ \tall\n\ @@ -678,11 +678,11 @@ let parse () = \t\"threshold:\": report elements used up to the given integer\n\ \t\"calls:\": like threshold + show call sites"; - "-M", String (DeadFlag.update_basic "-M" DeadFlag.obj), + "-M", String (Config.update_basic "-M" Config.obj), " Enable/Disable unused methods warnings.\n \ See option -E for the syntax of "; - "-Oa", String (DeadFlag.update_opt DeadFlag.opta), + "-Oa", String (Config.update_opt Config.opta), " Enable/Disable optional arguments always used warnings.\n \ can be:\n\ \tall\n\ @@ -695,11 +695,11 @@ let parse () = must be respected for the element to be reported\n\ \t\"percent:\": percent of valid cases to be reported"; - "-On", String (DeadFlag.update_opt DeadFlag.optn), + "-On", String (Config.update_opt Config.optn), " Enable/Disable optional arguments never used warnings.\n \ See option -Oa for the syntax of "; - "-S", String (DeadFlag.update_style), + "-S", String (Config.update_style), " Enable/Disable coding style warnings.\n \ Delimiters '+' and '-' determine if the following option is to enable or disable.\n \ Options (can be used together):\n\ @@ -709,7 +709,7 @@ let parse () = \tunit: unit pattern\n\ \tall: bind & opt & seq & unit"; - "-T", String (DeadFlag.update_basic "-T" DeadFlag.typ), + "-T", String (Config.update_basic "-T" Config.typ), " Enable/Disable unused constructors/records fields warnings.\n \ See option -E for the syntax of "; @@ -724,27 +724,27 @@ try parse (); let run_on_references_only state = DeadCommon.declarations := false; - let oldstyle = !DeadFlag.style in - DeadFlag.update_style "-all"; - List.fold_left load_file state !DeadFlag.directories + let oldstyle = !Config.style in + Config.update_style "-all"; + List.fold_left load_file state !Config.directories |> ignore; - DeadFlag.style := oldstyle + Config.style := oldstyle in run_on_references_only (State.get_current ()); Printf.eprintf " [DONE]\n\n%!"; - let open DeadFlag in + let open Config in !DeadLexiFi.prepare_report DeadType.decs; - if !DeadFlag.exported.print then report_unused_exported (); + if !Config.exported.print then report_unused_exported (); DeadObj.report(); DeadType.report(); - if !DeadFlag.opta.DeadFlag.print || !DeadFlag.optn.DeadFlag.print + if !Config.opta.Config.print || !Config.optn.Config.print then begin let tmp = analyze_opt_args () in - if !DeadFlag.opta.print then report_opt_args "ALWAYS" tmp; - if !DeadFlag.optn.print then report_opt_args "NEVER" tmp end; - if [@warning "-44"] DeadFlag.(!style.opt_arg || !style.unit_pat + if !Config.opta.print then report_opt_args "ALWAYS" tmp; + if !Config.optn.print then report_opt_args "NEVER" tmp end; + if [@warning "-44"] Config.(!style.opt_arg || !style.unit_pat || !style.seq || !style.binding) then report_style (); if !bad_files <> [] then begin diff --git a/src/deadCommon.ml b/src/deadCommon.ml index 83c10e66..355dc5b1 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -84,7 +84,7 @@ let is_ghost loc = || loc.Lexing.pos_fname = _none || loc.Lexing.pos_fname = "" -let check_underscore name = not !DeadFlag.underscore || name.[0] <> '_' +let check_underscore name = not !Config.underscore || name.[0] <> '_' let hashtbl_find_list hashtbl key = Hashtbl.find_all hashtbl key @@ -140,15 +140,15 @@ let rec get_deep_desc typ = | t -> t -let exported (flag : DeadFlag.basic ref) loc = +let exported (flag : Config.basic ref) loc = let state = State.get_current () in let fn = loc.Lexing.pos_fname in let sourceunit = State.File_infos.get_sourceunit state.file_infos in - !flag.DeadFlag.print + !flag.Config.print && LocHash.find_set references loc - |> LocSet.cardinal <= !flag.DeadFlag.threshold - && (flag == DeadFlag.typ - || !DeadFlag.internal + |> LocSet.cardinal <= !flag.Config.threshold + && (flag == Config.typ + || !Config.internal || fn.[String.length fn - 1] = 'i' || sourceunit <> Utils.unit fn || not (file_exists (fn ^ "i"))) @@ -432,17 +432,17 @@ let pretty_print_call () = let ghost = ref false in function ghost := true -let percent (opt : DeadFlag.opt) base = - let open DeadFlag in +let percent (opt : Config.opt) base = + let open Config in 1. -. (float_of_int base) *. (1. -. opt.threshold.percentage) /. 10. (* Base pattern for reports *) -let report s ~(opt: DeadFlag.opt) ?(extra = "Called") l continue nb_call pretty_print reporter = +let report s ~(opt: Config.opt) ?(extra = "Called") l continue nb_call pretty_print reporter = if nb_call = 0 || l <> [] then begin section ~sub:(nb_call <> 0) @@ (if nb_call = 0 then s - else if DeadFlag.(opt.threshold.optional) = `Both || extra = "Called" + else if Config.(opt.threshold.optional) = `Both || extra = "Called" then Printf.sprintf "%s: %s %d time(s)" s extra nb_call else Printf.sprintf "%s: at least %3.2f%% of the time" s (100. *. percent opt nb_call)); @@ -454,7 +454,7 @@ let report s ~(opt: DeadFlag.opt) ?(extra = "Called") l continue nb_call pretty_ else (print_newline () |> separator) -let report_basic ?folder decs title (flag:DeadFlag.basic) = +let report_basic ?folder decs title (flag:Config.basic) = let folder = match folder with | Some folder -> folder | None -> fun nb_call -> fun loc (builddir, path) acc -> @@ -497,22 +497,22 @@ let report_basic ?folder decs title (flag:DeadFlag.basic) = if change fn then print_newline (); prloc ~fn loc; print_string path; - if call_sites <> [] && flag.DeadFlag.call_sites then + if call_sites <> [] && flag.Config.call_sites then print_string " Call sites:"; print_newline (); - if flag.DeadFlag.call_sites then begin + if flag.Config.call_sites then begin List.fast_sort compare call_sites |> List.iter (pretty_print_call ()); if nb_call <> 0 then print_newline () end in - let continue nb_call = nb_call < flag.DeadFlag.threshold in + let continue nb_call = nb_call < flag.Config.threshold in let s = if nb_call = 0 then title else "ALMOST " ^ title in - report s ~opt:(!DeadFlag.opta) l continue nb_call pretty_print reportn + report s ~opt:(!Config.opta) l continue nb_call pretty_print reportn in reportn 0 diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index 68b48c0e..3e408bcf 100644 --- a/src/deadLexiFi.ml +++ b/src/deadLexiFi.ml @@ -123,7 +123,7 @@ let () = hashtbl_find_list str strin |> List.iter (fun loc -> - if exported DeadFlag.exported loc then + if exported Config.exported loc then LocHash.add_set references loc pos ) ) @@ -163,7 +163,7 @@ let () = else get_type s (pos - 1) in List.iter - ( if exported DeadFlag.typ loc then LocHash.add_set references loc + ( if exported Config.typ loc then LocHash.add_set references loc else ignore ) (hashtbl_find_list dyn_used (get_type path (String.length path - 1))) diff --git a/src/deadMod.ml b/src/deadMod.ml index 33a1679d..7ab93e33 100644 --- a/src/deadMod.ml +++ b/src/deadMod.ml @@ -70,9 +70,9 @@ let expr m = match m.mod_desc with let is_obj = String.contains x '#' in let is_type = not is_obj && DeadType.is_type x in let relevant_report_enabled = - if is_obj then !DeadFlag.obj.DeadFlag.print - else if is_type then exported DeadFlag.typ loc - else exported DeadFlag.exported loc + if is_obj then !Config.obj.Config.print + else if is_type then exported Config.typ loc + else exported Config.exported loc in let value_is_expected_by_modtype = List.mem x l1 || l1 = [] in if value_is_expected_by_modtype && relevant_report_enabled then @@ -86,6 +86,6 @@ let expr m = match m.mod_desc with let expr m = if [@warning "-44"] - DeadFlag.(!exported.print || !typ.print || !obj.print) then + Config.(!exported.print || !typ.print || !obj.print) then expr m else () diff --git a/src/deadObj.ml b/src/deadObj.ml index 2c084fca..e986a3c7 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -474,7 +474,7 @@ let report () = else acc in - report_basic ~folder decs "UNUSED METHODS" !DeadFlag.obj + report_basic ~folder decs "UNUSED METHODS" !Config.obj @@ -482,7 +482,7 @@ let report () = let wrap f x = - if !DeadFlag.obj.print then f x else () + if !Config.obj.print then f x else () let collect_export path u stock ?obj ?cltyp loc = wrap (collect_export path u stock ~obj ~cltyp) loc diff --git a/src/deadType.ml b/src/deadType.ml index 2902b1b3..4aa215f6 100644 --- a/src/deadType.ml +++ b/src/deadType.ml @@ -102,7 +102,7 @@ let collect_references loc exp_loc = (* Look for bad style typing *) let rec check_style t loc = let state = State.get_current() in - if !DeadFlag.style.DeadFlag.opt_arg then + if !Config.style.Config.opt_arg then match get_deep_desc t with | Tarrow (lab, _, t, _) -> begin match lab with @@ -167,13 +167,13 @@ let tstr typ = | _ -> () -let report () = report_basic decs "UNUSED CONSTRUCTORS/RECORD FIELDS" !DeadFlag.typ +let report () = report_basic decs "UNUSED CONSTRUCTORS/RECORD FIELDS" !Config.typ (******** WRAPPING ********) let wrap f x = - if DeadFlag.(!typ.print) then f x else () + if Config.(!typ.print) then f x else () let collect_export path u stock t = wrap (collect_export path u stock) t let tstr typ = wrap tstr typ From e90f03b0c5d869ac144e0f37be77193d5cbee36e Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Mon, 2 Feb 2026 17:02:44 +0100 Subject: [PATCH 02/12] [src][config][2/n] unify opt args and main sections config The main sections config was a structure with fields `print`, `threshold`, and `call_sites`. The opt args sections config was a structure with fields `print`, `threshold`, and `call_sites`. The only difference between the 2 is the type of `threshold`. Hence, they can be grouped under a same record type with `threshold`'s type as parameter. Additionally, having the `threshold` and `call_sites` fields mandatory does not make sense when the main usage of the tool does not require them, and the `print` field would express if the reports were activated for the section. Hence, the sections configuration is simplified to express the 3 states it can be in more explicitly : - deactivated (`Off`) - activated without threshold (`On`) - activated with threshold (`Threshold _`) The `threshold` and `call_sites` information are now only available in the `Threshold` mode, where they make sense. --- src/config/config.ml | 210 ++++++++++++++++++++---------------------- src/config/config.mli | 51 ++++++---- src/deadArg.ml | 6 +- src/deadCode.ml | 74 ++++++++------- src/deadCommon.ml | 35 ++++--- src/deadMod.ml | 4 +- src/deadObj.ml | 2 +- src/deadType.ml | 2 +- 8 files changed, 204 insertions(+), 180 deletions(-) diff --git a/src/config/config.ml b/src/config/config.ml index 9f5b550f..2aaa0db4 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -7,79 +7,78 @@ (* *) (***************************************************************************) -type threshold = {percentage: float; exceptions: int; optional: [`Percent | `Both]} +type 'threshold section = + | Off + | On + | Threshold of 'threshold threshold_section + +and 'threshold threshold_section = + { threshold: 'threshold + ; call_sites: bool + } +let is_activated = function + | Off -> false + | _ -> true -type opt = {print: bool; threshold: threshold; call_sites: bool} -let opta = ref - { - print = false; - call_sites = false; - threshold = - { - exceptions = 0; - percentage = 1.; - optional = `Percent - }; - } -let optn = ref - { - print = false; - call_sites = false; - threshold = - { - exceptions = 0; - percentage = 1.; - optional = `Percent - }; +let has_activated l = List.exists is_activated l + +let call_sites_activated = function + | Threshold {call_sites; _} -> call_sites + | _ -> false + +type opt_threshold = + { percentage: float + ; exceptions: int + ; optional: [`Percent | `Both] } +type opt_section = opt_threshold section -let update_opt opt s = - let threshold s = - let len = String.length s in - if len > 5 && String.sub s 0 5 = "both:" then begin - let limits = String.sub s 5 (String.length s - 5) in - let thr = - let rec loop s pos len = - if len = String.length s then s - else if s.[pos] = ',' then String.sub s (pos - len) len - else loop s (pos + 1) (len + 1) - in loop limits 0 0 +let opta = ref Off +let optn = ref Off + +let update_opt opt = function + | "all" -> opt := On + | "nothing" -> opt := Off + | arg -> + let raise_bad_arg msg = + (* TODO: improve error reporting *) + raise (Arg.Bad ("-Ox: " ^ msg)) in - let pos = String.length thr + 1 in - let pct = String.sub limits pos (String.length limits - pos) in - opt := {!opt with threshold={!opt.threshold with optional = `Both}}; - let thr = String.trim thr in - let pct = String.trim pct in - try - opt := {!opt with threshold = {!opt.threshold with exceptions = int_of_string thr}}; - opt := {!opt with threshold = {!opt.threshold with percentage = float_of_string pct}} - with Failure _ -> raise (Arg.Bad ("-Ox: wrong arguments: " ^ limits)) - end - else if len > 8 && String.sub s 0 8 = "percent:" then - let pct = String.sub s 8 (String.length s - 8) |> String.trim in - try opt := {!opt with threshold={!opt.threshold with percentage = float_of_string pct}} - with Failure _ -> raise (Arg.Bad ("-Ox: wrong argument: " ^ pct)) - else raise (Arg.Bad ("-Ox: unknown option " ^ s)) - in - match s with - | "all" -> opt := {!opt with print = true} - | "nothing" -> opt := {!opt with print = false} - | s -> - opt := {!opt with print = true}; - let s = - if String.length s > 6 && String.sub s 0 6 = "calls:" then begin - opt := {!opt with call_sites = true}; - String.sub s 6 (String.length s - 6) - end - else s + let call_sites, arg = + if String.starts_with ~prefix:"calls" arg then + let arg = String.sub arg 6 (String.length arg - 6) in + (true, arg) + else (false, arg) in - threshold s; - if !opt.threshold.exceptions < 0 then - raise (Arg.Bad ("-Ox: number of exceptions must be >= 0")) - else if !opt.threshold.percentage > 1. || !opt.threshold.percentage < 0. then - raise (Arg.Bad ("-Ox: percentage must be >= 0.0 and <= 1.0")) + let threshold = + let len = String.length arg in + if String.starts_with ~prefix:"both:" arg then + let limits = String.sub arg 5 (len - 5) in + match Scanf.sscanf limits "%u , %F" (fun i f -> (i, f)) with + | exception Scanf.Scan_failure _ + | exception Failure _ + | exception End_of_file -> + (* TODO: improve error handling/reporting *) + raise_bad_arg ("wrong arguments: " ^ limits) + | exceptions, percentage -> + {percentage; exceptions; optional = `Both} + else if String.starts_with ~prefix:"percent:" arg then + let percentage = String.sub arg 8 (len - 8) |> String.trim in + match float_of_string percentage with + | exception Failure _ -> + (* TODO: improve error handling/reporting *) + raise_bad_arg ("wrong argument: " ^ percentage) + | percentage -> + {percentage; exceptions = 0; optional = `Percent} + else raise_bad_arg ("unknown option " ^ arg) + in + if threshold.exceptions < 0 then + raise_bad_arg "number of exceptions must be >= 0"; + if threshold.percentage > 1. || threshold.percentage < 0. then + raise_bad_arg "percentage must be >= 0.0 and <= 1.0"; + opt := Threshold {threshold; call_sites} type style = {opt_arg: bool; unit_pat: bool; seq: bool; binding: bool} @@ -121,50 +120,43 @@ let update_style s = aux (list_of_opt s) -type basic = {print: bool; threshold: int; call_sites: bool} -let exported : basic ref = ref - ({ - print = true; - call_sites = false; - threshold = 0 - } : basic) - - -let obj = ref - ({ - print = true; - call_sites = false; - threshold = 0; - } : basic) - - -let typ : basic ref = ref - ({ - print = true; - call_sites = false; - threshold = 0 - } : basic) - - -let update_basic opt (flag : basic ref) = function - | "all" -> flag := {!flag with print = true} - | "nothing" -> flag := {!flag with print = false} - | s -> - flag := {!flag with print = true}; - let threshold = - let len = String.length s in - if len > 6 && String.sub s 0 6 = "calls:" then begin - flag := {!flag with call_sites = true}; - String.sub s 6 (String.length s - 6) - end - else if len > 10 && String.sub s 0 10 = "threshold:" then - String.sub s 10 (String.length s - 10) - else raise (Arg.Bad (opt ^ ": unknown option: " ^ s)) +type main_section = int section + +let exported : main_section ref = ref On + +let obj : main_section ref = ref On + +let typ : main_section ref = ref On + + +let get_main_threshold = function + | Threshold {threshold; _} -> threshold + | _ -> 0 + +let update_main opt (flag : main_section ref) = function + | "all" -> flag := On + | "nothing" -> flag := Off + | arg -> + let raise_bad_arg msg = + raise (Arg.Bad (opt ^ ": " ^ msg)) + in + let threshold_section = + let call_sites, threshold = + let len = String.length arg in + if String.starts_with ~prefix:"calls:" arg then + (true, String.sub arg 6 (len - 6)) + else if String.starts_with ~prefix:"threshold:" arg then + (false, String.sub arg 10 (len - 10)) + else raise_bad_arg ("unknown option: " ^ arg) + in + match String.trim threshold |> int_of_string with + | exception Failure _ -> + raise_bad_arg ("expected an integer; got; Got " ^ threshold) + | n when n < 0 -> + raise_bad_arg ("integer should be >= 0; Got " ^ string_of_int n) + | threshold -> {threshold; call_sites} in - let threshold = String.trim threshold |> int_of_string in - if threshold < 0 then - raise (Arg.Bad (opt ^ ": integer should be >= 0; Got " ^ string_of_int threshold)) - else flag := {!flag with threshold} + flag := Threshold threshold_section let verbose = ref false diff --git a/src/config/config.mli b/src/config/config.mli index f9bf625c..f5e555cc 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -2,32 +2,52 @@ (** {2 Sections configuration} *) -(** {3 Main sections} *) +type 'threshold section = + | Off (** Disabled *) + | On (** Enabled *) + | Threshold of 'threshold threshold_section (** Enabled with threshold *) -type basic = - { print: bool (** Report section *) - ; threshold: int +and 'threshold threshold_section = + { threshold: 'threshold (** Report subsections for elements used up to [!threshold] *) ; call_sites: bool (** Print call sites in the [!threshold]-related subsections *) } -val exported : basic ref +val is_activated : _ section -> bool +(** [is_activated sec] returns `true` if the section must be reported *) + +val has_activated : _ section list -> bool +(** [has_activated secs] returns `true` if one of the sections must be reported *) + +val call_sites_activated : _ section -> bool +(** [call_sites_activated sec] returns `true` if call sites must be reported in + thresholded subsections *) + +(** {3 Main sections} *) + +type main_section = int section + +val exported : main_section ref (** Configuration for the unused exported values *) -val obj : basic ref +val obj : main_section ref (** Configuration for the methods *) -val typ : basic ref +val typ : main_section ref (** Configuration for the constructors/record fields *) -val update_basic : string -> basic ref -> string -> unit +val update_main : string -> main_section ref -> string -> unit (** [update_basic sec_arg section arg] updates the configuration of [section] according to the [arg] specification. [sec_arg] is the command line argument associated with the [section] *) +val get_main_threshold : int section -> int +(** [get_main_threshold main_sec] returns the threshold if + [main_sec = Threshold _], [0] otherwise. *) + (** {3 Optional argument sections} *) -type threshold = +type opt_threshold = { percentage: float (** Subsections for opt args always/never used except at most [percentage] of the time will be reported *) @@ -37,20 +57,15 @@ type threshold = ; optional: [`Percent | `Both] (** Threshold mode *) } -type opt = - { print: bool (** Report section *) - ; threshold: threshold - (** Report subsections for opt args always/never used up to [!threshold] *) - ; call_sites: bool (** Print call sites in the [!threshold]-related subsections *) - } +type opt_section = opt_threshold section -val opta : opt ref +val opta : opt_section ref (** Configuration for the optional arguments always used *) -val optn : opt ref +val optn : opt_section ref (** Configuration for the optional arguments never used *) -val update_opt : opt ref -> string -> unit +val update_opt : opt_section ref -> string -> unit (** [update_opt section arg] updates the configuration of [section] according to the [arg] specification *) diff --git a/src/deadArg.ml b/src/deadArg.ml index 15fa610c..850a3e7c 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -162,7 +162,7 @@ let rec bind loc expr = DeadType.check_style pat_type expr.exp_loc.Location.loc_start in let register_optional_param = function - | Asttypes.Optional s when Config.(!optn.print || !opta.print) -> + | Asttypes.Optional s when Config.(has_activated [!optn; !opta]) -> let (opts, next) = VdNode.get loc in VdNode.update loc (s :: opts, next) | _ -> () @@ -181,7 +181,7 @@ let rec bind loc expr = | _ -> () ) | exp_desc - when (!Config.optn.print || !Config.opta.print) + when Config.(has_activated [!optn; !opta]) && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> let ( let$ ) x f = Option.iter f x in let$ loc2 = @@ -198,6 +198,6 @@ let rec bind loc expr = (******** WRAPPING ********) let wrap f x y = - if Config.(!optn.print || !opta.print) then f x y else () + if Config.(has_activated [!optn; !opta]) then f x y else () let register_uses val_loc args = wrap register_uses val_loc args diff --git a/src/deadCode.ml b/src/deadCode.ml index 8dcc1d33..2c35561a 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -36,7 +36,7 @@ let rec collect_export ?(mod_type = false) path u stock = function | Sig_value (id, ({Types.val_loc; val_type; _} as value), _) when not val_loc.Location.loc_ghost -> let should_export stock loc = - !Config.exported.Config.print + Config.(is_activated !exported) && (* do not add the loc in decs if it belongs to a module type *) ( stock != decs || not (Hashtbl.mem in_modtype loc.Location.loc_start) @@ -131,12 +131,12 @@ let structure_item super self i = let state = State.get_current () in let open Asttypes in begin match i.str_desc with - | Tstr_type (_, l) when !Config.typ.Config.print -> + | Tstr_type (_, l) when Config.(is_activated !typ) -> List.iter DeadType.tstr l | Tstr_module {mb_name = {txt = Some txt; _}; _} -> mods := txt :: !mods; DeadMod.defined := String.concat "." (List.rev !mods) :: !DeadMod.defined - | Tstr_class l when !Config.obj.Config.print -> List.iter DeadObj.tstr l + | Tstr_class l when Config.(is_activated !obj) -> List.iter DeadObj.tstr l | Tstr_include i -> let collect_include signature = let prev_last_loc = !last_loc in @@ -234,7 +234,7 @@ let expr super self e = | Texp_apply (exp, args) -> - if Config.(!opta.print || !optn.print) then treat_exp exp args; + if Config.(has_activated [!opta; !optn]) then treat_exp exp args; begin match exp.exp_desc with | Texp_ident (_, _, {Types.val_loc; _}) when val_loc.Location.loc_ghost -> (* The node is due to lookup preparation @@ -356,10 +356,7 @@ let regabs state = let read_interface fn cmi_infos state = let open Cmi_format in try regabs state; - if !Config.exported.Config.print - || !Config.obj.Config.print - || !Config.typ.Config.print - then + if Config.(has_activated [!exported; !obj; !typ]) then let u = if State.File_infos.has_sourcepath state.file_infos then State.File_infos.get_sourceunit state.file_infos @@ -483,7 +480,7 @@ let rec load_file state fn = ignore (collect_references.Tast_mapper.structure collect_references x); let loc_dep = - if !Config.exported.Config.print then + if Config.(is_activated !exported) then List.rev_map (fun (vd1, vd2) -> (vd1.Types.val_loc.Location.loc_start, vd2.Types.val_loc.Location.loc_start) @@ -549,15 +546,22 @@ let report_opt_args s l = if s = "NEVER" then !Config.optn else !Config.opta in - let percent = percent opt in let rec report_opt_args nb_call = let open Config in let l = List.filter (fun (_, _, _, slot, ratio, _) -> let ratio = 1. -. ratio in - if opt.threshold.optional = `Both then - ratio >= opt.threshold.percentage && check_length nb_call slot - else ratio >= percent nb_call - && (opt.threshold.percentage >= 1. || ratio < (percent (nb_call - 1)))) + match opt with + | Off -> + (* TODO: better error handling *) + failwith "Trying to report a deactivated opt args section" + | On -> ratio >= 1. && nb_call = 0 + | Threshold {threshold = {percentage; optional = `Both; _}; _} -> + ratio >= percentage && check_length nb_call slot + | Threshold {threshold; _} -> + let percent = percent threshold in + + ratio >= percent nb_call + && (threshold.percentage >= 1. || ratio < (percent (nb_call - 1)))) @@ List.map (fun (builddir, loc, lab, slot) -> let l = if s = "NEVER" then slot.with_val else slot.without_val in @@ -586,18 +590,22 @@ let report_opt_args s l = prloc ~fn loc; print_string ("?" ^ lab); if ratio <> 0. then begin Printf.printf " (%d/%d calls)" (total - List.length slot) total; - if opt.call_sites then print_string " Exceptions:" + if Config.call_sites_activated opt then print_string " Exceptions:" end; print_newline (); - if opt.call_sites then begin + if Config.call_sites_activated opt then begin List.iter (pretty_print_call ()) slot; if nb_call <> 0 then print_newline () end in let continue nb_call = - opt.threshold.optional = `Both && nb_call < opt.threshold.exceptions - || opt.threshold.optional = `Percent && percent nb_call > opt.threshold.percentage + match opt with + | Off | On -> false + | Threshold {threshold = {optional = `Both; exceptions; _}; _} -> + nb_call < exceptions + | Threshold {threshold; _} -> + percent threshold nb_call > threshold.percentage in let s = (if nb_call > 0 then "OPTIONAL ARGUMENTS: ALMOST " @@ -634,9 +642,9 @@ let parse () = let update_all print () = Config.( update_style ((if print = "all" then "+" else "-") ^ "all"); - update_basic "-E" Config.exported print; - update_basic "-M" obj print; - update_basic "-T" typ print; + update_main "-E" Config.exported print; + update_main "-M" obj print; + update_main "-T" typ print; update_opt opta print; update_opt optn print) in @@ -670,7 +678,7 @@ let parse () = "--all", Unit (update_all "all"), " Enable all warnings"; "-A", Unit (update_all "all"), " See --all"; - "-E", String (Config.update_basic "-E" Config.exported), + "-E", String (Config.update_main "-E" Config.exported), " Enable/Disable unused exported values warnings.\n \ can be:\n\ \tall\n\ @@ -678,7 +686,7 @@ let parse () = \t\"threshold:\": report elements used up to the given integer\n\ \t\"calls:\": like threshold + show call sites"; - "-M", String (Config.update_basic "-M" Config.obj), + "-M", String (Config.update_main "-M" Config.obj), " Enable/Disable unused methods warnings.\n \ See option -E for the syntax of "; @@ -709,7 +717,7 @@ let parse () = \tunit: unit pattern\n\ \tall: bind & opt & seq & unit"; - "-T", String (Config.update_basic "-T" Config.typ), + "-T", String (Config.update_main "-T" Config.typ), " Enable/Disable unused constructors/records fields warnings.\n \ See option -E for the syntax of "; @@ -734,18 +742,18 @@ try Printf.eprintf " [DONE]\n\n%!"; - let open Config in !DeadLexiFi.prepare_report DeadType.decs; - if !Config.exported.print then report_unused_exported (); + if Config.(is_activated !exported) then report_unused_exported (); DeadObj.report(); DeadType.report(); - if !Config.opta.Config.print || !Config.optn.Config.print - then begin - let tmp = analyze_opt_args () in - if !Config.opta.print then report_opt_args "ALWAYS" tmp; - if !Config.optn.print then report_opt_args "NEVER" tmp end; - if [@warning "-44"] Config.(!style.opt_arg || !style.unit_pat - || !style.seq || !style.binding) then report_style (); + if Config.(has_activated [!opta; !optn]) then begin + let tmp = analyze_opt_args () in + if Config.(is_activated !opta) then report_opt_args "ALWAYS" tmp; + if Config.(is_activated !optn) then report_opt_args "NEVER" tmp + end; + if [@warning "-44"] + Config.(!style.opt_arg || !style.unit_pat || !style.seq || !style.binding) + then report_style (); if !bad_files <> [] then begin let oc = open_out_bin "remove_bad_files.sh" in diff --git a/src/deadCommon.ml b/src/deadCommon.ml index 355dc5b1..333b8644 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -140,13 +140,13 @@ let rec get_deep_desc typ = | t -> t -let exported (flag : Config.basic ref) loc = +let exported (flag : Config.main_section ref) loc = let state = State.get_current () in let fn = loc.Lexing.pos_fname in let sourceunit = State.File_infos.get_sourceunit state.file_infos in - !flag.Config.print + Config.is_activated !flag && LocHash.find_set references loc - |> LocSet.cardinal <= !flag.Config.threshold + |> LocSet.cardinal <= Config.get_main_threshold !flag && (flag == Config.typ || !Config.internal || fn.[String.length fn - 1] = 'i' @@ -432,20 +432,29 @@ let pretty_print_call () = let ghost = ref false in function ghost := true -let percent (opt : Config.opt) base = +let percent (opt_threshold : Config.opt_threshold) base = let open Config in - 1. -. (float_of_int base) *. (1. -. opt.threshold.percentage) /. 10. + 1. -. (float_of_int base) *. (1. -. opt_threshold.percentage) /. 10. (* Base pattern for reports *) -let report s ~(opt: Config.opt) ?(extra = "Called") l continue nb_call pretty_print reporter = +let report s ~(opt: Config.opt_section) ?(extra = "Called") l continue nb_call pretty_print reporter = if nb_call = 0 || l <> [] then begin section ~sub:(nb_call <> 0) @@ (if nb_call = 0 then s - else if Config.(opt.threshold.optional) = `Both || extra = "Called" - then + else if String.equal extra "Called" then Printf.sprintf "%s: %s %d time(s)" s extra nb_call - else Printf.sprintf "%s: at least %3.2f%% of the time" s (100. *. percent opt nb_call)); + else match opt with + | Threshold {threshold; _} -> + if threshold.optional = `Both || extra = "Called" + then + Printf.sprintf "%s: %s %d time(s)" s extra nb_call + else + let percent = 100. *. percent threshold nb_call in + Printf.sprintf "%s: at least %3.2f%% of the time" s percent + | _ -> + (* TODO: better error handling *) + failwith "Trying to report subsections but not threshold is found"); List.iter pretty_print l; if continue nb_call then (if l <> [] then print_endline "--------" else ()) |> print_newline |> print_newline @@ -454,7 +463,7 @@ let report s ~(opt: Config.opt) ?(extra = "Called") l continue nb_call pretty_pr else (print_newline () |> separator) -let report_basic ?folder decs title (flag:Config.basic) = +let report_basic ?folder decs title (flag:Config.main_section) = let folder = match folder with | Some folder -> folder | None -> fun nb_call -> fun loc (builddir, path) acc -> @@ -497,17 +506,17 @@ let report_basic ?folder decs title (flag:Config.basic) = if change fn then print_newline (); prloc ~fn loc; print_string path; - if call_sites <> [] && flag.Config.call_sites then + if call_sites <> [] && Config.call_sites_activated flag then print_string " Call sites:"; print_newline (); - if flag.Config.call_sites then begin + if Config.call_sites_activated flag then begin List.fast_sort compare call_sites |> List.iter (pretty_print_call ()); if nb_call <> 0 then print_newline () end in - let continue nb_call = nb_call < flag.Config.threshold in + let continue nb_call = nb_call < Config.get_main_threshold flag in let s = if nb_call = 0 then title else "ALMOST " ^ title diff --git a/src/deadMod.ml b/src/deadMod.ml index 7ab93e33..73d3d08a 100644 --- a/src/deadMod.ml +++ b/src/deadMod.ml @@ -70,7 +70,7 @@ let expr m = match m.mod_desc with let is_obj = String.contains x '#' in let is_type = not is_obj && DeadType.is_type x in let relevant_report_enabled = - if is_obj then !Config.obj.Config.print + if is_obj then Config.(is_activated !obj) else if is_type then exported Config.typ loc else exported Config.exported loc in @@ -86,6 +86,6 @@ let expr m = match m.mod_desc with let expr m = if [@warning "-44"] - Config.(!exported.print || !typ.print || !obj.print) then + Config.(has_activated [!exported; !typ; !obj]) then expr m else () diff --git a/src/deadObj.ml b/src/deadObj.ml index e986a3c7..6107fa40 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -482,7 +482,7 @@ let report () = let wrap f x = - if !Config.obj.print then f x else () + if Config.(is_activated !obj) then f x else () let collect_export path u stock ?obj ?cltyp loc = wrap (collect_export path u stock ~obj ~cltyp) loc diff --git a/src/deadType.ml b/src/deadType.ml index 4aa215f6..349f7853 100644 --- a/src/deadType.ml +++ b/src/deadType.ml @@ -173,7 +173,7 @@ let report () = report_basic decs "UNUSED CONSTRUCTORS/RECORD FIELDS" !Config.ty (******** WRAPPING ********) let wrap f x = - if Config.(!typ.print) then f x else () + if Config.(is_activated !typ) then f x else () let collect_export path u stock t = wrap (collect_export path u stock) t let tstr typ = wrap tstr typ From d7bc4f86be4b301776ea9fcdd4bb8876b0f2049d Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Tue, 3 Feb 2026 12:05:58 +0100 Subject: [PATCH 03/12] [src][config][3/n] split opt args threshold type It was a structure with fields `percentage`, `exceptions` and `optional`. The `optional` field was actually a mode selection (` `Both` or ` `Percent`). If the mode was ` `Both`, then the `exceptions` field would be used. Otherwise, only `percentage` would. Rather than having this implicit semantic with everything at hand all the time, the type is now properly split in 2 constructors : `Both` and `Percent`, which both only hold the relevant information. --- src/config/config.ml | 26 +++++++++++++++----------- src/config/config.mli | 14 ++++++-------- src/deadCode.ml | 12 ++++++------ src/deadCommon.ml | 13 +++++++------ 4 files changed, 34 insertions(+), 31 deletions(-) diff --git a/src/config/config.ml b/src/config/config.ml index 2aaa0db4..acb72eda 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -28,10 +28,8 @@ let call_sites_activated = function | _ -> false type opt_threshold = - { percentage: float - ; exceptions: int - ; optional: [`Percent | `Both] - } + | Percent of float + | Both of (int * float) type opt_section = opt_threshold section @@ -52,6 +50,13 @@ let update_opt opt = function (true, arg) else (false, arg) in + let check_percentage p = + if p > 1. || p < 0. then + raise_bad_arg "percentage must be >= 0.0 and <= 1.0" + in + let check_nb_exceptions n = + if n < 0 then raise_bad_arg "number of exceptions must be >= 0" + in let threshold = let len = String.length arg in if String.starts_with ~prefix:"both:" arg then @@ -62,8 +67,10 @@ let update_opt opt = function | exception End_of_file -> (* TODO: improve error handling/reporting *) raise_bad_arg ("wrong arguments: " ^ limits) - | exceptions, percentage -> - {percentage; exceptions; optional = `Both} + | (nb_exceptions, percentage) as limits -> + check_percentage percentage; + check_nb_exceptions nb_exceptions; + Both limits else if String.starts_with ~prefix:"percent:" arg then let percentage = String.sub arg 8 (len - 8) |> String.trim in match float_of_string percentage with @@ -71,13 +78,10 @@ let update_opt opt = function (* TODO: improve error handling/reporting *) raise_bad_arg ("wrong argument: " ^ percentage) | percentage -> - {percentage; exceptions = 0; optional = `Percent} + check_percentage percentage; + Percent percentage else raise_bad_arg ("unknown option " ^ arg) in - if threshold.exceptions < 0 then - raise_bad_arg "number of exceptions must be >= 0"; - if threshold.percentage > 1. || threshold.percentage < 0. then - raise_bad_arg "percentage must be >= 0.0 and <= 1.0"; opt := Threshold {threshold; call_sites} diff --git a/src/config/config.mli b/src/config/config.mli index f5e555cc..a79b11f9 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -48,14 +48,12 @@ val get_main_threshold : int section -> int (** {3 Optional argument sections} *) type opt_threshold = - { percentage: float - (** Subsections for opt args always/never used except at most - [percentage] of the time will be reported *) - ; exceptions: int - (** Only optional arguments always/never used except at most - [exceptions] times will be reported in the subsections *) - ; optional: [`Percent | `Both] (** Threshold mode *) - } + | Percent of float + (** Subsections for opt args always/never used at least [float] percent of + the time will be reported *) + | Both of (int * float) + (** Subsections for opt args always/never used with at most [int] + exceptions and at least [float] percent of the time will be reported *) type opt_section = opt_threshold section diff --git a/src/deadCode.ml b/src/deadCode.ml index 2c35561a..6c48234b 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -555,13 +555,13 @@ let report_opt_args s l = (* TODO: better error handling *) failwith "Trying to report a deactivated opt args section" | On -> ratio >= 1. && nb_call = 0 - | Threshold {threshold = {percentage; optional = `Both; _}; _} -> + | Threshold {threshold = Both (_, percentage); _} -> ratio >= percentage && check_length nb_call slot - | Threshold {threshold; _} -> + | Threshold {threshold = Percent percentage as threshold; _} -> let percent = percent threshold in ratio >= percent nb_call - && (threshold.percentage >= 1. || ratio < (percent (nb_call - 1)))) + && (percentage >= 1. || ratio < (percent (nb_call - 1)))) @@ List.map (fun (builddir, loc, lab, slot) -> let l = if s = "NEVER" then slot.with_val else slot.without_val in @@ -602,10 +602,10 @@ let report_opt_args s l = let continue nb_call = match opt with | Off | On -> false - | Threshold {threshold = {optional = `Both; exceptions; _}; _} -> + | Threshold {threshold = Both (exceptions, _); _} -> nb_call < exceptions - | Threshold {threshold; _} -> - percent threshold nb_call > threshold.percentage + | Threshold {threshold = Percent percentage as threshold; _} -> + percent threshold nb_call > percentage in let s = (if nb_call > 0 then "OPTIONAL ARGUMENTS: ALMOST " diff --git a/src/deadCommon.ml b/src/deadCommon.ml index 333b8644..dc4f94fa 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -433,8 +433,11 @@ let pretty_print_call () = let ghost = ref false in function let percent (opt_threshold : Config.opt_threshold) base = - let open Config in - 1. -. (float_of_int base) *. (1. -. opt_threshold.percentage) /. 10. + let percentage = + match opt_threshold with + | Percent p | Both (_, p) -> p + in + 1. -. (float_of_int base) *. (1. -. percentage) /. 10. (* Base pattern for reports *) @@ -445,11 +448,9 @@ let report s ~(opt: Config.opt_section) ?(extra = "Called") l continue nb_call p else if String.equal extra "Called" then Printf.sprintf "%s: %s %d time(s)" s extra nb_call else match opt with - | Threshold {threshold; _} -> - if threshold.optional = `Both || extra = "Called" - then + | Threshold {threshold = Both _; _} -> Printf.sprintf "%s: %s %d time(s)" s extra nb_call - else + | Threshold {threshold; _} -> let percent = 100. *. percent threshold nb_call in Printf.sprintf "%s: at least %3.2f%% of the time" s percent | _ -> From 8f59b2443da16b5af3bef91bd8cbe06c751a98bc Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Tue, 3 Feb 2026 18:48:54 +0100 Subject: [PATCH 04/12] [src][config][4/n] create the `Config.config` value It contains all the configuration. For now it simply regroup all the configuration values that were found independently `Config`. The extra indirection makes the code heavier to read for now. The section configuration fields are still `ref`. Hence the `!(config._)` constructs. The other ones are now mutable fields. --- src/config/config.ml | 135 ++++++++++++++++++++++-------------------- src/config/config.mli | 47 ++++++--------- src/deadArg.ml | 6 +- src/deadCode.ml | 79 ++++++++++++------------ src/deadCommon.ml | 8 +-- src/deadLexiFi.ml | 4 +- src/deadMod.ml | 8 +-- src/deadObj.ml | 4 +- src/deadType.ml | 7 ++- 9 files changed, 150 insertions(+), 148 deletions(-) diff --git a/src/config/config.ml b/src/config/config.ml index acb72eda..7eb19424 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -27,14 +27,77 @@ let call_sites_activated = function | Threshold {call_sites; _} -> call_sites | _ -> false + +type main_section = int section + type opt_threshold = | Percent of float | Both of (int * float) type opt_section = opt_threshold section -let opta = ref Off -let optn = ref Off +type style = {opt_arg: bool; unit_pat: bool; seq: bool; binding: bool} + +type t = + { mutable verbose : bool + ; mutable internal : bool + ; mutable underscore : bool + ; mutable directories : string list + ; exported : main_section ref + ; obj : main_section ref + ; typ : main_section ref + ; opta : opt_section ref + ; optn : opt_section ref + ; style : style ref + } + +let config = + { verbose = false + ; internal = false + ; underscore = false + ; directories = [] + ; exported = ref On + ; obj = ref On + ; typ = ref On + ; opta = ref Off + ; optn = ref Off + ; style = ref + { opt_arg = false + ; unit_pat = false + ; seq = false + ; binding = false + } + } + +let get_main_threshold = function + | Threshold {threshold; _} -> threshold + | _ -> 0 + +let update_main opt (flag : main_section ref) = function + | "all" -> flag := On + | "nothing" -> flag := Off + | arg -> + let raise_bad_arg msg = + raise (Arg.Bad (opt ^ ": " ^ msg)) + in + let threshold_section = + let call_sites, threshold = + let len = String.length arg in + if String.starts_with ~prefix:"calls:" arg then + (true, String.sub arg 6 (len - 6)) + else if String.starts_with ~prefix:"threshold:" arg then + (false, String.sub arg 10 (len - 10)) + else raise_bad_arg ("unknown option: " ^ arg) + in + match String.trim threshold |> int_of_string with + | exception Failure _ -> + raise_bad_arg ("expected an integer; got; Got " ^ threshold) + | n when n < 0 -> + raise_bad_arg ("integer should be >= 0; Got " ^ string_of_int n) + | threshold -> {threshold; call_sites} + in + flag := Threshold threshold_section + let update_opt opt = function | "all" -> opt := On @@ -85,26 +148,18 @@ let update_opt opt = function opt := Threshold {threshold; call_sites} -type style = {opt_arg: bool; unit_pat: bool; seq: bool; binding: bool} -let style = ref - { - opt_arg = false; - unit_pat = false; - seq = false; - binding = false; - } - let update_style s = + let style = config.style in let rec aux = function - | (b, "opt")::l -> style := {!style with opt_arg = b}; + | (b, "opt")::l -> style := {!style with opt_arg = b}; aux l | (b, "unit")::l -> style := {!style with unit_pat = b}; aux l - | (b, "seq")::l -> style := {!style with seq = b}; + | (b, "seq")::l -> style := {!style with seq = b}; aux l | (b, "bind")::l -> style := {!style with binding = b}; aux l - | (b, "all")::l -> style := {unit_pat = b; opt_arg = b; seq = b; binding = b}; + | (b, "all")::l -> style := {unit_pat = b; opt_arg = b; seq = b; binding = b}; aux l | (_, "")::l -> aux l | (_, s)::_ -> raise (Arg.Bad ("-S: unknown option: " ^ s)) @@ -123,55 +178,12 @@ let update_style s = in aux (list_of_opt s) - -type main_section = int section - -let exported : main_section ref = ref On - -let obj : main_section ref = ref On - -let typ : main_section ref = ref On - - -let get_main_threshold = function - | Threshold {threshold; _} -> threshold - | _ -> 0 - -let update_main opt (flag : main_section ref) = function - | "all" -> flag := On - | "nothing" -> flag := Off - | arg -> - let raise_bad_arg msg = - raise (Arg.Bad (opt ^ ": " ^ msg)) - in - let threshold_section = - let call_sites, threshold = - let len = String.length arg in - if String.starts_with ~prefix:"calls:" arg then - (true, String.sub arg 6 (len - 6)) - else if String.starts_with ~prefix:"threshold:" arg then - (false, String.sub arg 10 (len - 10)) - else raise_bad_arg ("unknown option: " ^ arg) - in - match String.trim threshold |> int_of_string with - | exception Failure _ -> - raise_bad_arg ("expected an integer; got; Got " ^ threshold) - | n when n < 0 -> - raise_bad_arg ("integer should be >= 0; Got " ^ string_of_int n) - | threshold -> {threshold; call_sites} - in - flag := Threshold threshold_section - - -let verbose = ref false -let set_verbose () = verbose := true +let set_verbose () = config.verbose <- true (* Print name starting with '_' *) -let underscore = ref true -let set_underscore () = underscore := false +let set_underscore () = config.underscore <- true -let internal = ref false -let set_internal () = internal := true +let set_internal () = config.internal <- true let normalize_path s = @@ -200,6 +212,3 @@ let exclude, is_excluded = let exclude s = Hashtbl.replace tbl (normalize_path s) () in let is_excluded s = Hashtbl.mem tbl (normalize_path s) in exclude, is_excluded - - -let directories : string list ref = ref [] diff --git a/src/config/config.mli b/src/config/config.mli index a79b11f9..fccd2e10 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -27,15 +27,6 @@ val call_sites_activated : _ section -> bool type main_section = int section -val exported : main_section ref -(** Configuration for the unused exported values *) - -val obj : main_section ref -(** Configuration for the methods *) - -val typ : main_section ref -(** Configuration for the constructors/record fields *) - val update_main : string -> main_section ref -> string -> unit (** [update_basic sec_arg section arg] updates the configuration of [section] according to the [arg] specification. [sec_arg] is the command line argument @@ -57,12 +48,6 @@ type opt_threshold = type opt_section = opt_threshold section -val opta : opt_section ref -(** Configuration for the optional arguments always used *) - -val optn : opt_section ref -(** Configuration for the optional arguments never used *) - val update_opt : opt_section ref -> string -> unit (** [update_opt section arg] updates the configuration of [section] according to the [arg] specification *) @@ -76,29 +61,38 @@ type style = ; binding: bool (** Report [let x = ... in x (=> useless binding)] *) } -val style : style ref -(** Configuration for the stylistic issues *) val update_style : string -> unit (** [update_style arg] updates [!style] according to the [arg] specification *) (** {2 General configuration} *) -val verbose : bool ref -(** Display additional information during the analaysis. [false] by default. *) +type t = + { mutable verbose : bool (** Display additional information during the analaysis *) + ; mutable internal : bool (** Keep track of internal uses for exported values *) + ; mutable underscore : bool (** Keep track of elements with names starting with [_] *) + ; mutable directories : string list (** Paths to explore for references only *) + ; exported : main_section ref (** Configuration for the unused exported values *) + ; obj : main_section ref (** Configuration for the methods *) + ; typ : main_section ref (** Configuration for the constructors/record fields *) + ; opta : opt_section ref (** Configuration for the optional arguments always used *) + ; optn : opt_section ref (** Configuration for the optional arguments never used *) + ; style : style ref (** Configuration for the stylistic issues *) + } + +val config : t +(** Configuration for the analysis. + By default [verbose], [internal], and [underscore] are [false] + By default [exported], [obj], and [typ] are [On]. + By default [opta], [optn] are [Off]. + By default all of the fileds in [style] are false. *) val set_verbose : unit -> unit (** Set [verbose] to [true] *) -val underscore : bool ref -(** Keep track of elements with names starting with [_]. [false] by default. *) - val set_underscore : unit -> unit (** Set [underscore] to [true] *) -val internal : bool ref -(** Keep track of internal uses for exported values. [false] by default. *) - val set_internal : unit -> unit (** Set [internal] to [true] *) @@ -108,6 +102,3 @@ val exclude : string -> unit val is_excluded : string -> bool (** [is_excluded path] indicates if [path] is excluded from the analysis. Excluding a path is done with [exclude path]. *) - -val directories : string list ref -(** Paths to explore for references only *) diff --git a/src/deadArg.ml b/src/deadArg.ml index 850a3e7c..83e2f1ae 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -162,7 +162,7 @@ let rec bind loc expr = DeadType.check_style pat_type expr.exp_loc.Location.loc_start in let register_optional_param = function - | Asttypes.Optional s when Config.(has_activated [!optn; !opta]) -> + | Asttypes.Optional s when Config.(has_activated [!(config.optn); !(config.opta)]) -> let (opts, next) = VdNode.get loc in VdNode.update loc (s :: opts, next) | _ -> () @@ -181,7 +181,7 @@ let rec bind loc expr = | _ -> () ) | exp_desc - when Config.(has_activated [!optn; !opta]) + when Config.(has_activated [!(config.optn); !(config.opta)]) && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> let ( let$ ) x f = Option.iter f x in let$ loc2 = @@ -198,6 +198,6 @@ let rec bind loc expr = (******** WRAPPING ********) let wrap f x y = - if Config.(has_activated [!optn; !opta]) then f x y else () + if Config.(has_activated [!(config.optn); !(config.opta)]) then f x y else () let register_uses val_loc args = wrap register_uses val_loc args diff --git a/src/deadCode.ml b/src/deadCode.ml index 6c48234b..6a6cf702 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -36,7 +36,7 @@ let rec collect_export ?(mod_type = false) path u stock = function | Sig_value (id, ({Types.val_loc; val_type; _} as value), _) when not val_loc.Location.loc_ghost -> let should_export stock loc = - Config.(is_activated !exported) + Config.(is_activated !(config.exported)) && (* do not add the loc in decs if it belongs to a module type *) ( stock != decs || not (Hashtbl.mem in_modtype loc.Location.loc_start) @@ -131,12 +131,12 @@ let structure_item super self i = let state = State.get_current () in let open Asttypes in begin match i.str_desc with - | Tstr_type (_, l) when Config.(is_activated !typ) -> + | Tstr_type (_, l) when Config.(is_activated !(config.typ)) -> List.iter DeadType.tstr l | Tstr_module {mb_name = {txt = Some txt; _}; _} -> mods := txt :: !mods; DeadMod.defined := String.concat "." (List.rev !mods) :: !DeadMod.defined - | Tstr_class l when Config.(is_activated !obj) -> List.iter DeadObj.tstr l + | Tstr_class l when Config.(is_activated !(config.obj)) -> List.iter DeadObj.tstr l | Tstr_include i -> let collect_include signature = let prev_last_loc = !last_loc in @@ -177,13 +177,13 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - register_style pat_loc (Printf.sprintf "unit pattern %s" s) in let open Asttypes in - if DeadType.is_unit p.pat_type && !Config.style.Config.unit_pat then begin + if DeadType.is_unit p.pat_type && !Config.(config.style).unit_pat then begin match p.pat_desc with | Tpat_construct _ -> () | Tpat_var (_, {txt = "eta"; loc = _}, _) when p.pat_loc = Location.none -> () | Tpat_var (_, {txt; _}, _) -> if check_underscore txt then u txt - | Tpat_any -> if not !Config.underscore then u "_" + | Tpat_any -> if Config.config.underscore then u "_" | Tpat_value tpat_arg -> begin match (tpat_arg :> value general_pattern) with | {pat_desc=Tpat_construct _; _} -> () @@ -195,7 +195,7 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - | Tpat_record (l, _) -> List.iter (fun (_, {Types.lbl_loc = {Location.loc_start = lab_loc; _}; _}, _) -> - if exported Config.typ lab_loc then + if exported Config.config.typ lab_loc then DeadType.collect_references lab_loc pat_loc ) l @@ -218,12 +218,12 @@ let expr super self e = !DeadLexiFi.ttype_of e | Texp_ident (_, _, {Types.val_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}) - when exported Config.exported loc -> + when exported Config.config.exported loc -> LocHash.add_set references loc exp_loc | Texp_field (_, _, {lbl_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}) | Texp_construct (_, {cstr_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}, _) - when exported Config.typ loc -> + when exported Config.config.typ loc -> DeadType.collect_references loc exp_loc | Texp_send (e2, Tmeth_name meth) -> @@ -234,7 +234,7 @@ let expr super self e = | Texp_apply (exp, args) -> - if Config.(has_activated [!opta; !optn]) then treat_exp exp args; + if Config.(has_activated [!(config.opta); !(config.optn)]) then treat_exp exp args; begin match exp.exp_desc with | Texp_ident (_, _, {Types.val_loc; _}) when val_loc.Location.loc_ghost -> (* The node is due to lookup preparation @@ -248,7 +248,7 @@ let expr super self e = end | Texp_let (_, [{vb_pat; _}], _) - when DeadType.is_unit vb_pat.pat_type && !Config.style.Config.seq -> + when DeadType.is_unit vb_pat.pat_type && !Config.(config.style).seq -> begin match vb_pat.pat_desc with | Tpat_var (id, _, _) when not (check_underscore (Ident.name id)) -> () | _ -> @@ -258,7 +258,7 @@ let expr super self e = end | Texp_match (_, [{c_lhs; _}], _) - when DeadType.is_unit c_lhs.pat_type && !Config.style.Config.seq -> + when DeadType.is_unit c_lhs.pat_type && !Config.(config.style).seq -> begin match c_lhs.pat_desc with | Tpat_value tpat_arg -> begin match (tpat_arg :> value general_pattern) with @@ -276,7 +276,7 @@ let expr super self e = [{vb_pat = {pat_desc = Tpat_var (id1, _, _); pat_loc = {loc_start = loc; _}; _}; _}], {exp_desc = Texp_ident (Path.Pident id2, _, _); exp_extra = []; _}) when id1 = id2 - && !Config.style.Config.binding + && !Config.(config.style).binding && check_underscore (Ident.name id1) -> register_style loc "let x = ... in x (=> useless binding)" @@ -356,7 +356,7 @@ let regabs state = let read_interface fn cmi_infos state = let open Cmi_format in try regabs state; - if Config.(has_activated [!exported; !obj; !typ]) then + if Config.(has_activated [!(config.exported); !(config.obj); !(config.typ)]) then let u = if State.File_infos.has_sourcepath state.file_infos then State.File_infos.get_sourceunit state.file_infos @@ -394,7 +394,7 @@ let assoc decs (loc1, loc2) = || not (is_implem fn && has_iface fn) in if fn1 <> _none && fn2 <> _none && loc1 <> loc2 then begin - if (!Config.internal || fn1 <> fn2) && is_implem fn1 && is_implem fn2 then + if (Config.config.internal || fn1 <> fn2) && is_implem fn1 && is_implem fn2 then DeadCommon.LocHash.merge_set references loc2 references loc1; if is_iface fn1 loc1 then begin if is_iface fn2 loc2 then @@ -452,7 +452,7 @@ let rec load_file state fn = match kind fn with | `Cmi when !DeadCommon.declarations -> last_loc := Lexing.dummy_pos; - if !Config.verbose then Printf.eprintf "Scanning %s\n%!" fn; + if Config.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; init_and_continue state fn (fun state -> match state.file_infos.cmi_infos with | None -> () (* TODO error handling ? *) @@ -462,7 +462,7 @@ let rec load_file state fn = | `Cmt -> let open Cmt_format in last_loc := Lexing.dummy_pos; - if !Config.verbose then Printf.eprintf "Scanning %s\n%!" fn; + if Config.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; init_and_continue state fn (fun state -> regabs state; match state.file_infos.cmt_infos with @@ -480,7 +480,7 @@ let rec load_file state fn = ignore (collect_references.Tast_mapper.structure collect_references x); let loc_dep = - if Config.(is_activated !exported) then + if Config.(is_activated !(config.exported)) then List.rev_map (fun (vd1, vd2) -> (vd1.Types.val_loc.Location.loc_start, vd2.Types.val_loc.Location.loc_start) @@ -543,8 +543,8 @@ let analyze_opt_args () = let report_opt_args s l = let opt = - if s = "NEVER" then !Config.optn - else !Config.opta + if s = "NEVER" then !Config.(config.optn) + else !Config.(config.opta) in let rec report_opt_args nb_call = let open Config in @@ -616,7 +616,8 @@ let report_opt_args s l = in report_opt_args 0 -let report_unused_exported () = report_basic decs "UNUSED EXPORTED VALUES" !Config.exported +let report_unused_exported () = + report_basic decs "UNUSED EXPORTED VALUES" !Config.(config.exported) let report_style () = @@ -642,11 +643,11 @@ let parse () = let update_all print () = Config.( update_style ((if print = "all" then "+" else "-") ^ "all"); - update_main "-E" Config.exported print; - update_main "-M" obj print; - update_main "-T" typ print; - update_opt opta print; - update_opt optn print) + update_main "-E" config.exported print; + update_main "-M" config.obj print; + update_main "-T" config.typ print; + update_opt config.opta print; + update_opt config.optn print) in let load_file filename = @@ -661,7 +662,7 @@ let parse () = [ "--exclude", String Config.exclude, " Exclude given path from research."; "--references", - String (fun dir -> Config.directories := dir :: !Config.directories), + String (fun dir -> Config.config.directories <- dir :: Config.config.directories), " Consider given path to collect references."; "--underscore", Unit Config.set_underscore, " Show names starting with an underscore"; @@ -678,7 +679,7 @@ let parse () = "--all", Unit (update_all "all"), " Enable all warnings"; "-A", Unit (update_all "all"), " See --all"; - "-E", String (Config.update_main "-E" Config.exported), + "-E", String (Config.update_main "-E" Config.config.exported), " Enable/Disable unused exported values warnings.\n \ can be:\n\ \tall\n\ @@ -686,11 +687,11 @@ let parse () = \t\"threshold:\": report elements used up to the given integer\n\ \t\"calls:\": like threshold + show call sites"; - "-M", String (Config.update_main "-M" Config.obj), + "-M", String (Config.update_main "-M" Config.config.obj), " Enable/Disable unused methods warnings.\n \ See option -E for the syntax of "; - "-Oa", String (Config.update_opt Config.opta), + "-Oa", String (Config.update_opt Config.config.opta), " Enable/Disable optional arguments always used warnings.\n \ can be:\n\ \tall\n\ @@ -703,7 +704,7 @@ let parse () = must be respected for the element to be reported\n\ \t\"percent:\": percent of valid cases to be reported"; - "-On", String (Config.update_opt Config.optn), + "-On", String (Config.update_opt Config.config.optn), " Enable/Disable optional arguments never used warnings.\n \ See option -Oa for the syntax of "; @@ -717,7 +718,7 @@ let parse () = \tunit: unit pattern\n\ \tall: bind & opt & seq & unit"; - "-T", String (Config.update_main "-T" Config.typ), + "-T", String (Config.update_main "-T" Config.config.typ), " Enable/Disable unused constructors/records fields warnings.\n \ See option -E for the syntax of "; @@ -732,27 +733,27 @@ try parse (); let run_on_references_only state = DeadCommon.declarations := false; - let oldstyle = !Config.style in + let oldstyle = !Config.(config.style) in Config.update_style "-all"; - List.fold_left load_file state !Config.directories + List.fold_left load_file state Config.config.directories |> ignore; - Config.style := oldstyle + Config.config.style := oldstyle in run_on_references_only (State.get_current ()); Printf.eprintf " [DONE]\n\n%!"; !DeadLexiFi.prepare_report DeadType.decs; - if Config.(is_activated !exported) then report_unused_exported (); + if Config.(is_activated !(config.exported)) then report_unused_exported (); DeadObj.report(); DeadType.report(); - if Config.(has_activated [!opta; !optn]) then begin + if Config.(has_activated [!(config.opta); !(config.optn)]) then begin let tmp = analyze_opt_args () in - if Config.(is_activated !opta) then report_opt_args "ALWAYS" tmp; - if Config.(is_activated !optn) then report_opt_args "NEVER" tmp + if Config.(is_activated !(config.opta)) then report_opt_args "ALWAYS" tmp; + if Config.(is_activated !(config.optn)) then report_opt_args "NEVER" tmp end; if [@warning "-44"] - Config.(!style.opt_arg || !style.unit_pat || !style.seq || !style.binding) + Config.(!(config.style).opt_arg || !(config.style).unit_pat || !(config.style).seq || !(config.style).binding) then report_style (); if !bad_files <> [] then begin diff --git a/src/deadCommon.ml b/src/deadCommon.ml index dc4f94fa..c04b8151 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -84,7 +84,7 @@ let is_ghost loc = || loc.Lexing.pos_fname = _none || loc.Lexing.pos_fname = "" -let check_underscore name = not !Config.underscore || name.[0] <> '_' +let check_underscore name = Config.config.underscore || name.[0] <> '_' let hashtbl_find_list hashtbl key = Hashtbl.find_all hashtbl key @@ -147,8 +147,8 @@ let exported (flag : Config.main_section ref) loc = Config.is_activated !flag && LocHash.find_set references loc |> LocSet.cardinal <= Config.get_main_threshold !flag - && (flag == Config.typ - || !Config.internal + && (flag == Config.config.typ + || Config.config.internal || fn.[String.length fn - 1] = 'i' || sourceunit <> Utils.unit fn || not (file_exists (fn ^ "i"))) @@ -522,7 +522,7 @@ let report_basic ?folder decs title (flag:Config.main_section) = if nb_call = 0 then title else "ALMOST " ^ title in - report s ~opt:(!Config.opta) l continue nb_call pretty_print reportn + report s ~opt:(!Config.(config.opta)) l continue nb_call pretty_print reportn in reportn 0 diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index 3e408bcf..d08a2009 100644 --- a/src/deadLexiFi.ml +++ b/src/deadLexiFi.ml @@ -123,7 +123,7 @@ let () = hashtbl_find_list str strin |> List.iter (fun loc -> - if exported Config.exported loc then + if exported Config.config.exported loc then LocHash.add_set references loc pos ) ) @@ -163,7 +163,7 @@ let () = else get_type s (pos - 1) in List.iter - ( if exported Config.typ loc then LocHash.add_set references loc + ( if exported Config.config.typ loc then LocHash.add_set references loc else ignore ) (hashtbl_find_list dyn_used (get_type path (String.length path - 1))) diff --git a/src/deadMod.ml b/src/deadMod.ml index 73d3d08a..7dc4def1 100644 --- a/src/deadMod.ml +++ b/src/deadMod.ml @@ -70,9 +70,9 @@ let expr m = match m.mod_desc with let is_obj = String.contains x '#' in let is_type = not is_obj && DeadType.is_type x in let relevant_report_enabled = - if is_obj then Config.(is_activated !obj) - else if is_type then exported Config.typ loc - else exported Config.exported loc + if is_obj then Config.(is_activated !(config.obj)) + else if is_type then exported Config.config.typ loc + else exported Config.config.exported loc in let value_is_expected_by_modtype = List.mem x l1 || l1 = [] in if value_is_expected_by_modtype && relevant_report_enabled then @@ -86,6 +86,6 @@ let expr m = match m.mod_desc with let expr m = if [@warning "-44"] - Config.(has_activated [!exported; !typ; !obj]) then + Config.(has_activated [!(config.exported); !(config.typ); !(config.obj)]) then expr m else () diff --git a/src/deadObj.ml b/src/deadObj.ml index 6107fa40..84ae9f3a 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -474,7 +474,7 @@ let report () = else acc in - report_basic ~folder decs "UNUSED METHODS" !Config.obj + report_basic ~folder decs "UNUSED METHODS" !Config.(config.obj) @@ -482,7 +482,7 @@ let report () = let wrap f x = - if Config.(is_activated !obj) then f x else () + if Config.(is_activated !(config.obj)) then f x else () let collect_export path u stock ?obj ?cltyp loc = wrap (collect_export path u stock ~obj ~cltyp) loc diff --git a/src/deadType.ml b/src/deadType.ml index 349f7853..78845459 100644 --- a/src/deadType.ml +++ b/src/deadType.ml @@ -102,7 +102,7 @@ let collect_references loc exp_loc = (* Look for bad style typing *) let rec check_style t loc = let state = State.get_current() in - if !Config.style.Config.opt_arg then + if !Config.(config.style).opt_arg then match get_deep_desc t with | Tarrow (lab, _, t, _) -> begin match lab with @@ -167,13 +167,14 @@ let tstr typ = | _ -> () -let report () = report_basic decs "UNUSED CONSTRUCTORS/RECORD FIELDS" !Config.typ +let report () = + report_basic decs "UNUSED CONSTRUCTORS/RECORD FIELDS" !Config.(config.typ) (******** WRAPPING ********) let wrap f x = - if Config.(is_activated !typ) then f x else () + if Config.(is_activated !(config.typ)) then f x else () let collect_export path u stock t = wrap (collect_export path u stock) t let tstr typ = wrap tstr typ From 7b01ddba01786675ecad7ea7ba9743d753ae6232 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Tue, 3 Feb 2026 18:59:12 +0100 Subject: [PATCH 05/12] [src][config][5/n] move the command line argument parsing to `Config` --- src/config/config.ml | 83 ++++++++++++++++++++++++++++++++++++++++++ src/config/config.mli | 4 ++ src/deadCode.ml | 85 +------------------------------------------ 3 files changed, 89 insertions(+), 83 deletions(-) diff --git a/src/config/config.ml b/src/config/config.ml index 7eb19424..0050b511 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -212,3 +212,86 @@ let exclude, is_excluded = let exclude s = Hashtbl.replace tbl (normalize_path s) () in let is_excluded s = Hashtbl.mem tbl (normalize_path s) in exclude, is_excluded + + +(* Option parsing and processing *) +let parse_cli process_path = + let update_all print () = + update_style ((if print = "all" then "+" else "-") ^ "all"); + update_main "-E" config.exported print; + update_main "-M" config.obj print; + update_main "-T" config.typ print; + update_opt config.opta print; + update_opt config.optn print + in + + (* any extra argument can be accepted by any option using some + * although it doesn't necessary affects the results (e.g. -O 3+4) *) + Arg.(parse + [ "--exclude", String exclude, " Exclude given path from research."; + + "--references", + String (fun dir -> config.directories <- dir :: config.directories), + " Consider given path to collect references."; + + "--underscore", Unit set_underscore, " Show names starting with an underscore"; + + "--verbose", Unit set_verbose, " Verbose mode (ie., show scanned files)"; + "-v", Unit set_verbose, " See --verbose"; + + "--internal", Unit set_internal, + " Keep internal uses as exported values uses when the interface is given. \ + This is the default behaviour when only the implementation is found"; + + "--nothing", Unit (update_all "nothing"), " Disable all warnings"; + "-a", Unit (update_all "nothing"), " See --nothing"; + "--all", Unit (update_all "all"), " Enable all warnings"; + "-A", Unit (update_all "all"), " See --all"; + + "-E", String (update_main "-E" config.exported), + " Enable/Disable unused exported values warnings.\n \ + can be:\n\ + \tall\n\ + \tnothing\n\ + \t\"threshold:\": report elements used up to the given integer\n\ + \t\"calls:\": like threshold + show call sites"; + + "-M", String (update_main "-M" config.obj), + " Enable/Disable unused methods warnings.\n \ + See option -E for the syntax of "; + + "-Oa", String (update_opt config.opta), + " Enable/Disable optional arguments always used warnings.\n \ + can be:\n\ + \tall\n\ + \tnothing\n\ + \t\n\ + \t\"calls:\" like + show call sites\n \ + can be:\n\ + \t\"both:,\": both the number max of exceptions \ + (given through the integer) and the percent of valid cases (given as a float) \ + must be respected for the element to be reported\n\ + \t\"percent:\": percent of valid cases to be reported"; + + "-On", String (update_opt config.optn), + " Enable/Disable optional arguments never used warnings.\n \ + See option -Oa for the syntax of "; + + "-S", String (update_style), + " Enable/Disable coding style warnings.\n \ + Delimiters '+' and '-' determine if the following option is to enable or disable.\n \ + Options (can be used together):\n\ + \tbind: useless binding\n\ + \topt: optional arg in arg\n\ + \tseq: use sequence\n\ + \tunit: unit pattern\n\ + \tall: bind & opt & seq & unit"; + + "-T", String (update_main "-T" config.typ), + " Enable/Disable unused constructors/records fields warnings.\n \ + See option -E for the syntax of "; + + ] + (Printf.eprintf "Scanning files...\n%!"; + process_path) + ("Usage: " ^ Sys.argv.(0) ^ " \nOptions are:")) diff --git a/src/config/config.mli b/src/config/config.mli index fccd2e10..73923c3f 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -102,3 +102,7 @@ val exclude : string -> unit val is_excluded : string -> bool (** [is_excluded path] indicates if [path] is excluded from the analysis. Excluding a path is done with [exclude path]. *) + +val parse_cli : (string -> unit) -> unit +(** [parse_cli process_path] updates the [config] according to the command line + arguments and processes each input path using [process_path] *) diff --git a/src/deadCode.ml b/src/deadCode.ml index 6a6cf702..4670b795 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -640,93 +640,12 @@ let report_style () = (* Option parsing and processing *) let parse () = - let update_all print () = - Config.( - update_style ((if print = "all" then "+" else "-") ^ "all"); - update_main "-E" config.exported print; - update_main "-M" config.obj print; - update_main "-T" config.typ print; - update_opt config.opta print; - update_opt config.optn print) - in - - let load_file filename = + let process_file filename = let state = State.get_current () in let state = load_file state filename in State.update state in - - (* any extra argument can be accepted by any option using some - * although it doesn't necessary affects the results (e.g. -O 3+4) *) - Arg.(parse - [ "--exclude", String Config.exclude, " Exclude given path from research."; - - "--references", - String (fun dir -> Config.config.directories <- dir :: Config.config.directories), - " Consider given path to collect references."; - - "--underscore", Unit Config.set_underscore, " Show names starting with an underscore"; - - "--verbose", Unit Config.set_verbose, " Verbose mode (ie., show scanned files)"; - "-v", Unit Config.set_verbose, " See --verbose"; - - "--internal", Unit Config.set_internal, - " Keep internal uses as exported values uses when the interface is given. \ - This is the default behaviour when only the implementation is found"; - - "--nothing", Unit (update_all "nothing"), " Disable all warnings"; - "-a", Unit (update_all "nothing"), " See --nothing"; - "--all", Unit (update_all "all"), " Enable all warnings"; - "-A", Unit (update_all "all"), " See --all"; - - "-E", String (Config.update_main "-E" Config.config.exported), - " Enable/Disable unused exported values warnings.\n \ - can be:\n\ - \tall\n\ - \tnothing\n\ - \t\"threshold:\": report elements used up to the given integer\n\ - \t\"calls:\": like threshold + show call sites"; - - "-M", String (Config.update_main "-M" Config.config.obj), - " Enable/Disable unused methods warnings.\n \ - See option -E for the syntax of "; - - "-Oa", String (Config.update_opt Config.config.opta), - " Enable/Disable optional arguments always used warnings.\n \ - can be:\n\ - \tall\n\ - \tnothing\n\ - \t\n\ - \t\"calls:\" like + show call sites\n \ - can be:\n\ - \t\"both:,\": both the number max of exceptions \ - (given through the integer) and the percent of valid cases (given as a float) \ - must be respected for the element to be reported\n\ - \t\"percent:\": percent of valid cases to be reported"; - - "-On", String (Config.update_opt Config.config.optn), - " Enable/Disable optional arguments never used warnings.\n \ - See option -Oa for the syntax of "; - - "-S", String (Config.update_style), - " Enable/Disable coding style warnings.\n \ - Delimiters '+' and '-' determine if the following option is to enable or disable.\n \ - Options (can be used together):\n\ - \tbind: useless binding\n\ - \topt: optional arg in arg\n\ - \tseq: use sequence\n\ - \tunit: unit pattern\n\ - \tall: bind & opt & seq & unit"; - - "-T", String (Config.update_main "-T" Config.config.typ), - " Enable/Disable unused constructors/records fields warnings.\n \ - See option -E for the syntax of "; - - ] - (Printf.eprintf "Scanning files...\n%!"; - load_file) - ("Usage: " ^ Sys.argv.(0) ^ " \nOptions are:")) - + Config.parse_cli process_file let () = try From b1ba29dd2a710d6a861819a738fd80f751a0b0f1 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Wed, 4 Feb 2026 11:08:19 +0100 Subject: [PATCH 06/12] [src][config][6/n] config's content is immutable `Config.config` is now a ref and its fields are neither `mutable` nor `ref`. Additionally, now that the cli parsing is in `Config`, `Config`'s API is reduced as to not expose the "update" functions. Only `update_style` remains for now. --- src/config/config.ml | 123 ++++++++++++++++++++++++++---------------- src/config/config.mli | 43 ++++----------- src/deadArg.ml | 6 +-- src/deadCode.ml | 56 +++++++++---------- src/deadCommon.ml | 14 ++--- src/deadLexiFi.ml | 4 +- src/deadMod.ml | 8 +-- src/deadObj.ml | 4 +- src/deadType.ml | 6 +-- 9 files changed, 138 insertions(+), 126 deletions(-) diff --git a/src/config/config.ml b/src/config/config.ml index 0050b511..d4c2e2b7 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -39,29 +39,29 @@ type opt_section = opt_threshold section type style = {opt_arg: bool; unit_pat: bool; seq: bool; binding: bool} type t = - { mutable verbose : bool - ; mutable internal : bool - ; mutable underscore : bool - ; mutable directories : string list - ; exported : main_section ref - ; obj : main_section ref - ; typ : main_section ref - ; opta : opt_section ref - ; optn : opt_section ref - ; style : style ref + { verbose : bool + ; internal : bool + ; underscore : bool + ; directories : string list + ; exported : main_section + ; obj : main_section + ; typ : main_section + ; opta : opt_section + ; optn : opt_section + ; style : style } -let config = +let config = ref { verbose = false ; internal = false ; underscore = false ; directories = [] - ; exported = ref On - ; obj = ref On - ; typ = ref On - ; opta = ref Off - ; optn = ref Off - ; style = ref + ; exported = On + ; obj = On + ; typ = On + ; opta = Off + ; optn = Off + ; style = { opt_arg = false ; unit_pat = false ; seq = false @@ -73,9 +73,9 @@ let get_main_threshold = function | Threshold {threshold; _} -> threshold | _ -> 0 -let update_main opt (flag : main_section ref) = function - | "all" -> flag := On - | "nothing" -> flag := Off +let parse_main opt = function + | "all" -> On + | "nothing" -> Off | arg -> let raise_bad_arg msg = raise (Arg.Bad (opt ^ ": " ^ msg)) @@ -96,12 +96,24 @@ let update_main opt (flag : main_section ref) = function raise_bad_arg ("integer should be >= 0; Got " ^ string_of_int n) | threshold -> {threshold; call_sites} in - flag := Threshold threshold_section + Threshold threshold_section +let update_exported cli_opt arg = + let exported = parse_main cli_opt arg in + config := {!config with exported} -let update_opt opt = function - | "all" -> opt := On - | "nothing" -> opt := Off +let update_obj cli_opt arg = + let obj = parse_main cli_opt arg in + config := {!config with obj} + +let update_typ cli_opt arg = + let typ = parse_main cli_opt arg in + config := {!config with typ} + + +let parse_opt = function + | "all" -> On + | "nothing" -> Off | arg -> let raise_bad_arg msg = (* TODO: improve error reporting *) @@ -145,21 +157,38 @@ let update_opt opt = function Percent percentage else raise_bad_arg ("unknown option " ^ arg) in - opt := Threshold {threshold; call_sites} + Threshold {threshold; call_sites} + +let update_opta arg = + let opta = parse_opt arg in + config := {!config with opta} + +let update_optn arg = + let optn = parse_opt arg in + config := {!config with optn} let update_style s = - let style = config.style in let rec aux = function - | (b, "opt")::l -> style := {!style with opt_arg = b}; + | (b, "opt")::l -> + let style = {!config.style with opt_arg = b} in + config := {!config with style}; aux l - | (b, "unit")::l -> style := {!style with unit_pat = b}; + | (b, "unit")::l -> + let style = {!config.style with unit_pat = b} in + config := {!config with style}; aux l - | (b, "seq")::l -> style := {!style with seq = b}; + | (b, "seq")::l -> + let style = {!config.style with seq = b} in + config := {!config with style}; aux l - | (b, "bind")::l -> style := {!style with binding = b}; + | (b, "bind")::l -> + let style = {!config.style with binding = b} in + config := {!config with style}; aux l - | (b, "all")::l -> style := {unit_pat = b; opt_arg = b; seq = b; binding = b}; + | (b, "all")::l -> + let style = {unit_pat = b; opt_arg = b; seq = b; binding = b} in + config := {!config with style}; aux l | (_, "")::l -> aux l | (_, s)::_ -> raise (Arg.Bad ("-S: unknown option: " ^ s)) @@ -178,12 +207,12 @@ let update_style s = in aux (list_of_opt s) -let set_verbose () = config.verbose <- true +let set_verbose () = config := {!config with verbose = true} (* Print name starting with '_' *) -let set_underscore () = config.underscore <- true +let set_underscore () = config := {!config with underscore = true} -let set_internal () = config.internal <- true +let set_internal () = config := {!config with internal = true} let normalize_path s = @@ -218,11 +247,11 @@ let exclude, is_excluded = let parse_cli process_path = let update_all print () = update_style ((if print = "all" then "+" else "-") ^ "all"); - update_main "-E" config.exported print; - update_main "-M" config.obj print; - update_main "-T" config.typ print; - update_opt config.opta print; - update_opt config.optn print + update_exported "-E" print; + update_obj "-M" print; + update_typ "-T" print; + update_opta print; + update_optn print in (* any extra argument can be accepted by any option using some @@ -231,7 +260,11 @@ let parse_cli process_path = [ "--exclude", String exclude, " Exclude given path from research."; "--references", - String (fun dir -> config.directories <- dir :: config.directories), + String + (fun dir -> + let directories = dir :: !config.directories in + config := {!config with directories} + ), " Consider given path to collect references."; "--underscore", Unit set_underscore, " Show names starting with an underscore"; @@ -248,7 +281,7 @@ let parse_cli process_path = "--all", Unit (update_all "all"), " Enable all warnings"; "-A", Unit (update_all "all"), " See --all"; - "-E", String (update_main "-E" config.exported), + "-E", String (update_exported "-E"), " Enable/Disable unused exported values warnings.\n \ can be:\n\ \tall\n\ @@ -256,11 +289,11 @@ let parse_cli process_path = \t\"threshold:\": report elements used up to the given integer\n\ \t\"calls:\": like threshold + show call sites"; - "-M", String (update_main "-M" config.obj), + "-M", String (update_obj "-M"), " Enable/Disable unused methods warnings.\n \ See option -E for the syntax of "; - "-Oa", String (update_opt config.opta), + "-Oa", String (update_opta), " Enable/Disable optional arguments always used warnings.\n \ can be:\n\ \tall\n\ @@ -273,7 +306,7 @@ let parse_cli process_path = must be respected for the element to be reported\n\ \t\"percent:\": percent of valid cases to be reported"; - "-On", String (update_opt config.optn), + "-On", String (update_optn), " Enable/Disable optional arguments never used warnings.\n \ See option -Oa for the syntax of "; @@ -287,7 +320,7 @@ let parse_cli process_path = \tunit: unit pattern\n\ \tall: bind & opt & seq & unit"; - "-T", String (update_main "-T" config.typ), + "-T", String (update_typ "-T"), " Enable/Disable unused constructors/records fields warnings.\n \ See option -E for the syntax of "; diff --git a/src/config/config.mli b/src/config/config.mli index 73923c3f..06625597 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -27,11 +27,6 @@ val call_sites_activated : _ section -> bool type main_section = int section -val update_main : string -> main_section ref -> string -> unit -(** [update_basic sec_arg section arg] updates the configuration of [section] according - to the [arg] specification. [sec_arg] is the command line argument - associated with the [section] *) - val get_main_threshold : int section -> int (** [get_main_threshold main_sec] returns the threshold if [main_sec = Threshold _], [0] otherwise. *) @@ -48,10 +43,6 @@ type opt_threshold = type opt_section = opt_threshold section -val update_opt : opt_section ref -> string -> unit -(** [update_opt section arg] updates the configuration of [section] according - to the [arg] specification *) - (** {3 Stylistic issues section} *) type style = @@ -68,37 +59,25 @@ val update_style : string -> unit (** {2 General configuration} *) type t = - { mutable verbose : bool (** Display additional information during the analaysis *) - ; mutable internal : bool (** Keep track of internal uses for exported values *) - ; mutable underscore : bool (** Keep track of elements with names starting with [_] *) - ; mutable directories : string list (** Paths to explore for references only *) - ; exported : main_section ref (** Configuration for the unused exported values *) - ; obj : main_section ref (** Configuration for the methods *) - ; typ : main_section ref (** Configuration for the constructors/record fields *) - ; opta : opt_section ref (** Configuration for the optional arguments always used *) - ; optn : opt_section ref (** Configuration for the optional arguments never used *) - ; style : style ref (** Configuration for the stylistic issues *) + { verbose : bool (** Display additional information during the analaysis *) + ; internal : bool (** Keep track of internal uses for exported values *) + ; underscore : bool (** Keep track of elements with names starting with [_] *) + ; directories : string list (** Paths to explore for references only *) + ; exported : main_section (** Configuration for the unused exported values *) + ; obj : main_section (** Configuration for the methods *) + ; typ : main_section (** Configuration for the constructors/record fields *) + ; opta : opt_section (** Configuration for the optional arguments always used *) + ; optn : opt_section (** Configuration for the optional arguments never used *) + ; style : style (** Configuration for the stylistic issues *) } -val config : t +val config : t ref (** Configuration for the analysis. By default [verbose], [internal], and [underscore] are [false] By default [exported], [obj], and [typ] are [On]. By default [opta], [optn] are [Off]. By default all of the fileds in [style] are false. *) -val set_verbose : unit -> unit -(** Set [verbose] to [true] *) - -val set_underscore : unit -> unit -(** Set [underscore] to [true] *) - -val set_internal : unit -> unit -(** Set [internal] to [true] *) - -val exclude : string -> unit -(** [exclude path] excludse [path] from the analysis *) - val is_excluded : string -> bool (** [is_excluded path] indicates if [path] is excluded from the analysis. Excluding a path is done with [exclude path]. *) diff --git a/src/deadArg.ml b/src/deadArg.ml index 83e2f1ae..6277c6c5 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -162,7 +162,7 @@ let rec bind loc expr = DeadType.check_style pat_type expr.exp_loc.Location.loc_start in let register_optional_param = function - | Asttypes.Optional s when Config.(has_activated [!(config.optn); !(config.opta)]) -> + | Asttypes.Optional s when Config.(has_activated [!config.optn; !config.opta]) -> let (opts, next) = VdNode.get loc in VdNode.update loc (s :: opts, next) | _ -> () @@ -181,7 +181,7 @@ let rec bind loc expr = | _ -> () ) | exp_desc - when Config.(has_activated [!(config.optn); !(config.opta)]) + when Config.(has_activated [!config.optn; !config.opta]) && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> let ( let$ ) x f = Option.iter f x in let$ loc2 = @@ -198,6 +198,6 @@ let rec bind loc expr = (******** WRAPPING ********) let wrap f x y = - if Config.(has_activated [!(config.optn); !(config.opta)]) then f x y else () + if Config.(has_activated [!config.optn; !config.opta]) then f x y else () let register_uses val_loc args = wrap register_uses val_loc args diff --git a/src/deadCode.ml b/src/deadCode.ml index 4670b795..bde13ddf 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -36,7 +36,7 @@ let rec collect_export ?(mod_type = false) path u stock = function | Sig_value (id, ({Types.val_loc; val_type; _} as value), _) when not val_loc.Location.loc_ghost -> let should_export stock loc = - Config.(is_activated !(config.exported)) + Config.(is_activated !config.exported) && (* do not add the loc in decs if it belongs to a module type *) ( stock != decs || not (Hashtbl.mem in_modtype loc.Location.loc_start) @@ -131,12 +131,12 @@ let structure_item super self i = let state = State.get_current () in let open Asttypes in begin match i.str_desc with - | Tstr_type (_, l) when Config.(is_activated !(config.typ)) -> + | Tstr_type (_, l) when Config.(is_activated !config.typ) -> List.iter DeadType.tstr l | Tstr_module {mb_name = {txt = Some txt; _}; _} -> mods := txt :: !mods; DeadMod.defined := String.concat "." (List.rev !mods) :: !DeadMod.defined - | Tstr_class l when Config.(is_activated !(config.obj)) -> List.iter DeadObj.tstr l + | Tstr_class l when Config.(is_activated !config.obj) -> List.iter DeadObj.tstr l | Tstr_include i -> let collect_include signature = let prev_last_loc = !last_loc in @@ -177,13 +177,13 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - register_style pat_loc (Printf.sprintf "unit pattern %s" s) in let open Asttypes in - if DeadType.is_unit p.pat_type && !Config.(config.style).unit_pat then begin + if DeadType.is_unit p.pat_type && !Config.config.style.unit_pat then begin match p.pat_desc with | Tpat_construct _ -> () | Tpat_var (_, {txt = "eta"; loc = _}, _) when p.pat_loc = Location.none -> () | Tpat_var (_, {txt; _}, _) -> if check_underscore txt then u txt - | Tpat_any -> if Config.config.underscore then u "_" + | Tpat_any -> if !Config.config.underscore then u "_" | Tpat_value tpat_arg -> begin match (tpat_arg :> value general_pattern) with | {pat_desc=Tpat_construct _; _} -> () @@ -195,7 +195,7 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - | Tpat_record (l, _) -> List.iter (fun (_, {Types.lbl_loc = {Location.loc_start = lab_loc; _}; _}, _) -> - if exported Config.config.typ lab_loc then + if exported ~is_type:true !Config.config.typ lab_loc then DeadType.collect_references lab_loc pat_loc ) l @@ -218,12 +218,12 @@ let expr super self e = !DeadLexiFi.ttype_of e | Texp_ident (_, _, {Types.val_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}) - when exported Config.config.exported loc -> + when exported !Config.config.exported loc -> LocHash.add_set references loc exp_loc | Texp_field (_, _, {lbl_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}) | Texp_construct (_, {cstr_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}, _) - when exported Config.config.typ loc -> + when exported ~is_type:true !Config.config.typ loc -> DeadType.collect_references loc exp_loc | Texp_send (e2, Tmeth_name meth) -> @@ -234,7 +234,7 @@ let expr super self e = | Texp_apply (exp, args) -> - if Config.(has_activated [!(config.opta); !(config.optn)]) then treat_exp exp args; + if Config.(has_activated [!config.opta; !config.optn]) then treat_exp exp args; begin match exp.exp_desc with | Texp_ident (_, _, {Types.val_loc; _}) when val_loc.Location.loc_ghost -> (* The node is due to lookup preparation @@ -248,7 +248,7 @@ let expr super self e = end | Texp_let (_, [{vb_pat; _}], _) - when DeadType.is_unit vb_pat.pat_type && !Config.(config.style).seq -> + when DeadType.is_unit vb_pat.pat_type && !Config.config.style.seq -> begin match vb_pat.pat_desc with | Tpat_var (id, _, _) when not (check_underscore (Ident.name id)) -> () | _ -> @@ -258,7 +258,7 @@ let expr super self e = end | Texp_match (_, [{c_lhs; _}], _) - when DeadType.is_unit c_lhs.pat_type && !Config.(config.style).seq -> + when DeadType.is_unit c_lhs.pat_type && !Config.config.style.seq -> begin match c_lhs.pat_desc with | Tpat_value tpat_arg -> begin match (tpat_arg :> value general_pattern) with @@ -276,7 +276,7 @@ let expr super self e = [{vb_pat = {pat_desc = Tpat_var (id1, _, _); pat_loc = {loc_start = loc; _}; _}; _}], {exp_desc = Texp_ident (Path.Pident id2, _, _); exp_extra = []; _}) when id1 = id2 - && !Config.(config.style).binding + && !Config.config.style.binding && check_underscore (Ident.name id1) -> register_style loc "let x = ... in x (=> useless binding)" @@ -356,7 +356,7 @@ let regabs state = let read_interface fn cmi_infos state = let open Cmi_format in try regabs state; - if Config.(has_activated [!(config.exported); !(config.obj); !(config.typ)]) then + if Config.(has_activated [!config.exported; !config.obj; !config.typ]) then let u = if State.File_infos.has_sourcepath state.file_infos then State.File_infos.get_sourceunit state.file_infos @@ -394,7 +394,7 @@ let assoc decs (loc1, loc2) = || not (is_implem fn && has_iface fn) in if fn1 <> _none && fn2 <> _none && loc1 <> loc2 then begin - if (Config.config.internal || fn1 <> fn2) && is_implem fn1 && is_implem fn2 then + if (!Config.config.internal || fn1 <> fn2) && is_implem fn1 && is_implem fn2 then DeadCommon.LocHash.merge_set references loc2 references loc1; if is_iface fn1 loc1 then begin if is_iface fn2 loc2 then @@ -452,7 +452,7 @@ let rec load_file state fn = match kind fn with | `Cmi when !DeadCommon.declarations -> last_loc := Lexing.dummy_pos; - if Config.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; + if !Config.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; init_and_continue state fn (fun state -> match state.file_infos.cmi_infos with | None -> () (* TODO error handling ? *) @@ -462,7 +462,7 @@ let rec load_file state fn = | `Cmt -> let open Cmt_format in last_loc := Lexing.dummy_pos; - if Config.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; + if !Config.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; init_and_continue state fn (fun state -> regabs state; match state.file_infos.cmt_infos with @@ -480,7 +480,7 @@ let rec load_file state fn = ignore (collect_references.Tast_mapper.structure collect_references x); let loc_dep = - if Config.(is_activated !(config.exported)) then + if Config.(is_activated !config.exported) then List.rev_map (fun (vd1, vd2) -> (vd1.Types.val_loc.Location.loc_start, vd2.Types.val_loc.Location.loc_start) @@ -543,8 +543,8 @@ let analyze_opt_args () = let report_opt_args s l = let opt = - if s = "NEVER" then !Config.(config.optn) - else !Config.(config.opta) + if s = "NEVER" then !Config.config.optn + else !Config.config.opta in let rec report_opt_args nb_call = let open Config in @@ -617,7 +617,7 @@ let report_opt_args s l = let report_unused_exported () = - report_basic decs "UNUSED EXPORTED VALUES" !Config.(config.exported) + report_basic decs "UNUSED EXPORTED VALUES" !Config.config.exported let report_style () = @@ -652,27 +652,27 @@ try parse (); let run_on_references_only state = DeadCommon.declarations := false; - let oldstyle = !Config.(config.style) in + let oldstyle = !Config.config.style in Config.update_style "-all"; - List.fold_left load_file state Config.config.directories + List.fold_left load_file state !Config.config.directories |> ignore; - Config.config.style := oldstyle + Config.(config := {!config with style = oldstyle}) in run_on_references_only (State.get_current ()); Printf.eprintf " [DONE]\n\n%!"; !DeadLexiFi.prepare_report DeadType.decs; - if Config.(is_activated !(config.exported)) then report_unused_exported (); + if Config.(is_activated !config.exported) then report_unused_exported (); DeadObj.report(); DeadType.report(); - if Config.(has_activated [!(config.opta); !(config.optn)]) then begin + if Config.(has_activated [!config.opta; !config.optn]) then begin let tmp = analyze_opt_args () in - if Config.(is_activated !(config.opta)) then report_opt_args "ALWAYS" tmp; - if Config.(is_activated !(config.optn)) then report_opt_args "NEVER" tmp + if Config.(is_activated !config.opta) then report_opt_args "ALWAYS" tmp; + if Config.(is_activated !config.optn) then report_opt_args "NEVER" tmp end; if [@warning "-44"] - Config.(!(config.style).opt_arg || !(config.style).unit_pat || !(config.style).seq || !(config.style).binding) + Config.(!config.style.opt_arg || !config.style.unit_pat || !config.style.seq || !config.style.binding) then report_style (); if !bad_files <> [] then begin diff --git a/src/deadCommon.ml b/src/deadCommon.ml index c04b8151..f0a85e87 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -84,7 +84,7 @@ let is_ghost loc = || loc.Lexing.pos_fname = _none || loc.Lexing.pos_fname = "" -let check_underscore name = Config.config.underscore || name.[0] <> '_' +let check_underscore name = !Config.config.underscore || name.[0] <> '_' let hashtbl_find_list hashtbl key = Hashtbl.find_all hashtbl key @@ -140,15 +140,15 @@ let rec get_deep_desc typ = | t -> t -let exported (flag : Config.main_section ref) loc = +let exported ?(is_type = false) (flag : Config.main_section) loc = let state = State.get_current () in let fn = loc.Lexing.pos_fname in let sourceunit = State.File_infos.get_sourceunit state.file_infos in - Config.is_activated !flag + Config.is_activated flag && LocHash.find_set references loc - |> LocSet.cardinal <= Config.get_main_threshold !flag - && (flag == Config.config.typ - || Config.config.internal + |> LocSet.cardinal <= Config.get_main_threshold flag + && (is_type + || !Config.config.internal || fn.[String.length fn - 1] = 'i' || sourceunit <> Utils.unit fn || not (file_exists (fn ^ "i"))) @@ -522,7 +522,7 @@ let report_basic ?folder decs title (flag:Config.main_section) = if nb_call = 0 then title else "ALMOST " ^ title in - report s ~opt:(!Config.(config.opta)) l continue nb_call pretty_print reportn + report s ~opt:(!Config.config.opta) l continue nb_call pretty_print reportn in reportn 0 diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index d08a2009..df5d31aa 100644 --- a/src/deadLexiFi.ml +++ b/src/deadLexiFi.ml @@ -123,7 +123,7 @@ let () = hashtbl_find_list str strin |> List.iter (fun loc -> - if exported Config.config.exported loc then + if exported !Config.config.exported loc then LocHash.add_set references loc pos ) ) @@ -163,7 +163,7 @@ let () = else get_type s (pos - 1) in List.iter - ( if exported Config.config.typ loc then LocHash.add_set references loc + ( if exported ~is_type:true !Config.config.typ loc then LocHash.add_set references loc else ignore ) (hashtbl_find_list dyn_used (get_type path (String.length path - 1))) diff --git a/src/deadMod.ml b/src/deadMod.ml index 7dc4def1..6c9bc206 100644 --- a/src/deadMod.ml +++ b/src/deadMod.ml @@ -70,9 +70,9 @@ let expr m = match m.mod_desc with let is_obj = String.contains x '#' in let is_type = not is_obj && DeadType.is_type x in let relevant_report_enabled = - if is_obj then Config.(is_activated !(config.obj)) - else if is_type then exported Config.config.typ loc - else exported Config.config.exported loc + if is_obj then Config.(is_activated !config.obj) + else if is_type then exported ~is_type !Config.config.typ loc + else exported !Config.config.exported loc in let value_is_expected_by_modtype = List.mem x l1 || l1 = [] in if value_is_expected_by_modtype && relevant_report_enabled then @@ -86,6 +86,6 @@ let expr m = match m.mod_desc with let expr m = if [@warning "-44"] - Config.(has_activated [!(config.exported); !(config.typ); !(config.obj)]) then + Config.(has_activated [!config.exported; !config.typ; !config.obj]) then expr m else () diff --git a/src/deadObj.ml b/src/deadObj.ml index 84ae9f3a..2eff7672 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -474,7 +474,7 @@ let report () = else acc in - report_basic ~folder decs "UNUSED METHODS" !Config.(config.obj) + report_basic ~folder decs "UNUSED METHODS" !Config.config.obj @@ -482,7 +482,7 @@ let report () = let wrap f x = - if Config.(is_activated !(config.obj)) then f x else () + if Config.(is_activated !config.obj) then f x else () let collect_export path u stock ?obj ?cltyp loc = wrap (collect_export path u stock ~obj ~cltyp) loc diff --git a/src/deadType.ml b/src/deadType.ml index 78845459..dbcb2bbe 100644 --- a/src/deadType.ml +++ b/src/deadType.ml @@ -102,7 +102,7 @@ let collect_references loc exp_loc = (* Look for bad style typing *) let rec check_style t loc = let state = State.get_current() in - if !Config.(config.style).opt_arg then + if !Config.config.style.opt_arg then match get_deep_desc t with | Tarrow (lab, _, t, _) -> begin match lab with @@ -168,13 +168,13 @@ let tstr typ = let report () = - report_basic decs "UNUSED CONSTRUCTORS/RECORD FIELDS" !Config.(config.typ) + report_basic decs "UNUSED CONSTRUCTORS/RECORD FIELDS" !Config.config.typ (******** WRAPPING ********) let wrap f x = - if Config.(is_activated !(config.typ)) then f x else () + if Config.(is_activated !config.typ) then f x else () let collect_export path u stock t = wrap (collect_export path u stock) t let tstr typ = wrap tstr typ From ee97de466fea726361455a5e4ef0eb051de5456a Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Wed, 4 Feb 2026 13:07:49 +0100 Subject: [PATCH 07/12] [src][config][7/n] extract sections config to their own module The new `Config.Sections` module exposes an immutable API for the sections configuration. The sections configuration is now exposed through `Config.config.sections`. --- src/config/config.ml | 220 +++++++--------------------------------- src/config/config.mli | 56 ++-------- src/config/sections.ml | 195 +++++++++++++++++++++++++++++++++++ src/config/sections.mli | 91 +++++++++++++++++ src/deadArg.ml | 8 +- src/deadCode.ml | 60 ++++++----- src/deadCommon.ml | 12 ++- src/deadLexiFi.ml | 5 +- src/deadMod.ml | 11 +- src/deadObj.ml | 4 +- src/deadType.ml | 9 +- 11 files changed, 394 insertions(+), 277 deletions(-) create mode 100644 src/config/sections.ml create mode 100644 src/config/sections.mli diff --git a/src/config/config.ml b/src/config/config.ml index d4c2e2b7..52fe1d42 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -7,48 +7,22 @@ (* *) (***************************************************************************) -type 'threshold section = - | Off - | On - | Threshold of 'threshold threshold_section - -and 'threshold threshold_section = - { threshold: 'threshold - ; call_sites: bool - } - -let is_activated = function - | Off -> false - | _ -> true - -let has_activated l = List.exists is_activated l - -let call_sites_activated = function - | Threshold {call_sites; _} -> call_sites - | _ -> false - +module Sections = Sections -type main_section = int section +let is_activated = Sections.is_activated -type opt_threshold = - | Percent of float - | Both of (int * float) +let has_activated = Sections.has_activated -type opt_section = opt_threshold section +let call_sites_activated = Sections.call_sites_activated -type style = {opt_arg: bool; unit_pat: bool; seq: bool; binding: bool} +let get_main_threshold = Sections.get_main_threshold type t = { verbose : bool ; internal : bool ; underscore : bool ; directories : string list - ; exported : main_section - ; obj : main_section - ; typ : main_section - ; opta : opt_section - ; optn : opt_section - ; style : style + ; sections : Sections.t } let config = ref @@ -56,156 +30,32 @@ let config = ref ; internal = false ; underscore = false ; directories = [] - ; exported = On - ; obj = On - ; typ = On - ; opta = Off - ; optn = Off - ; style = - { opt_arg = false - ; unit_pat = false - ; seq = false - ; binding = false - } + ; sections = Sections.default } -let get_main_threshold = function - | Threshold {threshold; _} -> threshold - | _ -> 0 - -let parse_main opt = function - | "all" -> On - | "nothing" -> Off - | arg -> - let raise_bad_arg msg = - raise (Arg.Bad (opt ^ ": " ^ msg)) - in - let threshold_section = - let call_sites, threshold = - let len = String.length arg in - if String.starts_with ~prefix:"calls:" arg then - (true, String.sub arg 6 (len - 6)) - else if String.starts_with ~prefix:"threshold:" arg then - (false, String.sub arg 10 (len - 10)) - else raise_bad_arg ("unknown option: " ^ arg) - in - match String.trim threshold |> int_of_string with - | exception Failure _ -> - raise_bad_arg ("expected an integer; got; Got " ^ threshold) - | n when n < 0 -> - raise_bad_arg ("integer should be >= 0; Got " ^ string_of_int n) - | threshold -> {threshold; call_sites} - in - Threshold threshold_section - -let update_exported cli_opt arg = - let exported = parse_main cli_opt arg in - config := {!config with exported} - -let update_obj cli_opt arg = - let obj = parse_main cli_opt arg in - config := {!config with obj} - -let update_typ cli_opt arg = - let typ = parse_main cli_opt arg in - config := {!config with typ} - - -let parse_opt = function - | "all" -> On - | "nothing" -> Off - | arg -> - let raise_bad_arg msg = - (* TODO: improve error reporting *) - raise (Arg.Bad ("-Ox: " ^ msg)) - in - let call_sites, arg = - if String.starts_with ~prefix:"calls" arg then - let arg = String.sub arg 6 (String.length arg - 6) in - (true, arg) - else (false, arg) - in - let check_percentage p = - if p > 1. || p < 0. then - raise_bad_arg "percentage must be >= 0.0 and <= 1.0" - in - let check_nb_exceptions n = - if n < 0 then raise_bad_arg "number of exceptions must be >= 0" - in - let threshold = - let len = String.length arg in - if String.starts_with ~prefix:"both:" arg then - let limits = String.sub arg 5 (len - 5) in - match Scanf.sscanf limits "%u , %F" (fun i f -> (i, f)) with - | exception Scanf.Scan_failure _ - | exception Failure _ - | exception End_of_file -> - (* TODO: improve error handling/reporting *) - raise_bad_arg ("wrong arguments: " ^ limits) - | (nb_exceptions, percentage) as limits -> - check_percentage percentage; - check_nb_exceptions nb_exceptions; - Both limits - else if String.starts_with ~prefix:"percent:" arg then - let percentage = String.sub arg 8 (len - 8) |> String.trim in - match float_of_string percentage with - | exception Failure _ -> - (* TODO: improve error handling/reporting *) - raise_bad_arg ("wrong argument: " ^ percentage) - | percentage -> - check_percentage percentage; - Percent percentage - else raise_bad_arg ("unknown option " ^ arg) - in - Threshold {threshold; call_sites} +let update_exported_values arg = + let sections = Sections.update_exported_values arg !config.sections in + config := {!config with sections} + +let update_methods arg = + let sections = Sections.update_methods arg !config.sections in + config := {!config with sections} + +let update_types arg = + let sections = Sections.update_types arg !config.sections in + config := {!config with sections} let update_opta arg = - let opta = parse_opt arg in - config := {!config with opta} + let sections = Sections.update_opta arg !config.sections in + config := {!config with sections} let update_optn arg = - let optn = parse_opt arg in - config := {!config with optn} - - -let update_style s = - let rec aux = function - | (b, "opt")::l -> - let style = {!config.style with opt_arg = b} in - config := {!config with style}; - aux l - | (b, "unit")::l -> - let style = {!config.style with unit_pat = b} in - config := {!config with style}; - aux l - | (b, "seq")::l -> - let style = {!config.style with seq = b} in - config := {!config with style}; - aux l - | (b, "bind")::l -> - let style = {!config.style with binding = b} in - config := {!config with style}; - aux l - | (b, "all")::l -> - let style = {unit_pat = b; opt_arg = b; seq = b; binding = b} in - config := {!config with style}; - aux l - | (_, "")::l -> aux l - | (_, s)::_ -> raise (Arg.Bad ("-S: unknown option: " ^ s)) - | [] -> () - in - let list_of_opt str = - try - let rec split acc pos len = - if str.[pos] <> '+' && str.[pos] <> '-' then - split acc (pos - 1) (len + 1) - else let acc = (str.[pos] = '+', String.trim (String.sub str (pos + 1) len)) :: acc in - if pos > 0 then split acc (pos - 1) 0 - else acc - in split [] (String.length str - 1) 0 - with _ -> raise (Arg.Bad ("options' arguments must start with a delimiter (`+' or `-')")) - in - aux (list_of_opt s) + let sections = Sections.update_optn arg !config.sections in + config := {!config with sections} + +let update_style arg = + let sections = Sections.update_style arg !config.sections in + config := {!config with sections} let set_verbose () = config := {!config with verbose = true} @@ -247,9 +97,9 @@ let exclude, is_excluded = let parse_cli process_path = let update_all print () = update_style ((if print = "all" then "+" else "-") ^ "all"); - update_exported "-E" print; - update_obj "-M" print; - update_typ "-T" print; + update_exported_values print; + update_methods print; + update_types print; update_opta print; update_optn print in @@ -281,7 +131,7 @@ let parse_cli process_path = "--all", Unit (update_all "all"), " Enable all warnings"; "-A", Unit (update_all "all"), " See --all"; - "-E", String (update_exported "-E"), + "-E", String update_exported_values, " Enable/Disable unused exported values warnings.\n \ can be:\n\ \tall\n\ @@ -289,11 +139,11 @@ let parse_cli process_path = \t\"threshold:\": report elements used up to the given integer\n\ \t\"calls:\": like threshold + show call sites"; - "-M", String (update_obj "-M"), + "-M", String update_methods, " Enable/Disable unused methods warnings.\n \ See option -E for the syntax of "; - "-Oa", String (update_opta), + "-Oa", String update_opta, " Enable/Disable optional arguments always used warnings.\n \ can be:\n\ \tall\n\ @@ -306,11 +156,11 @@ let parse_cli process_path = must be respected for the element to be reported\n\ \t\"percent:\": percent of valid cases to be reported"; - "-On", String (update_optn), + "-On", String update_optn, " Enable/Disable optional arguments never used warnings.\n \ See option -Oa for the syntax of "; - "-S", String (update_style), + "-S", String update_style, " Enable/Disable coding style warnings.\n \ Delimiters '+' and '-' determine if the following option is to enable or disable.\n \ Options (can be used together):\n\ @@ -320,7 +170,7 @@ let parse_cli process_path = \tunit: unit pattern\n\ \tall: bind & opt & seq & unit"; - "-T", String (update_typ "-T"), + "-T", String update_types, " Enable/Disable unused constructors/records fields warnings.\n \ See option -E for the syntax of "; diff --git a/src/config/config.mli b/src/config/config.mli index 06625597..a9675654 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -2,57 +2,22 @@ (** {2 Sections configuration} *) -type 'threshold section = - | Off (** Disabled *) - | On (** Enabled *) - | Threshold of 'threshold threshold_section (** Enabled with threshold *) +module Sections = Sections -and 'threshold threshold_section = - { threshold: 'threshold - (** Report subsections for elements used up to [!threshold] *) - ; call_sites: bool (** Print call sites in the [!threshold]-related subsections *) - } - -val is_activated : _ section -> bool +val is_activated : _ Sections.section -> bool (** [is_activated sec] returns `true` if the section must be reported *) -val has_activated : _ section list -> bool +val has_activated : _ Sections.section list -> bool (** [has_activated secs] returns `true` if one of the sections must be reported *) -val call_sites_activated : _ section -> bool +val call_sites_activated : _ Sections.section -> bool (** [call_sites_activated sec] returns `true` if call sites must be reported in thresholded subsections *) -(** {3 Main sections} *) - -type main_section = int section - -val get_main_threshold : int section -> int +val get_main_threshold : int Sections.section -> int (** [get_main_threshold main_sec] returns the threshold if [main_sec = Threshold _], [0] otherwise. *) -(** {3 Optional argument sections} *) - -type opt_threshold = - | Percent of float - (** Subsections for opt args always/never used at least [float] percent of - the time will be reported *) - | Both of (int * float) - (** Subsections for opt args always/never used with at most [int] - exceptions and at least [float] percent of the time will be reported *) - -type opt_section = opt_threshold section - -(** {3 Stylistic issues section} *) - -type style = - { opt_arg: bool (** Report [val f : _ -> (... -> (... -> ?_:_ -> ...) -> ...] *) - ; unit_pat: bool (** Report unit pattern *) - ; seq: bool (** Report [let () = ... in ... (=> use sequence)] *) - ; binding: bool (** Report [let x = ... in x (=> useless binding)] *) - } - - val update_style : string -> unit (** [update_style arg] updates [!style] according to the [arg] specification *) @@ -63,20 +28,13 @@ type t = ; internal : bool (** Keep track of internal uses for exported values *) ; underscore : bool (** Keep track of elements with names starting with [_] *) ; directories : string list (** Paths to explore for references only *) - ; exported : main_section (** Configuration for the unused exported values *) - ; obj : main_section (** Configuration for the methods *) - ; typ : main_section (** Configuration for the constructors/record fields *) - ; opta : opt_section (** Configuration for the optional arguments always used *) - ; optn : opt_section (** Configuration for the optional arguments never used *) - ; style : style (** Configuration for the stylistic issues *) + ; sections : Sections.t (** Config for the different report sections *) } val config : t ref (** Configuration for the analysis. By default [verbose], [internal], and [underscore] are [false] - By default [exported], [obj], and [typ] are [On]. - By default [opta], [optn] are [Off]. - By default all of the fileds in [style] are false. *) + By default [sections] is [Sections.default] *) val is_excluded : string -> bool (** [is_excluded path] indicates if [path] is excluded from the analysis. diff --git a/src/config/sections.ml b/src/config/sections.ml new file mode 100644 index 00000000..078d8093 --- /dev/null +++ b/src/config/sections.ml @@ -0,0 +1,195 @@ +type t = + { exported_values : main_section + ; methods : main_section + ; types : main_section + ; opta : opt_args_section + ; optn : opt_args_section + ; style : style_section + } + +and main_section = int section + +and opt_args_section = opt_args_threshold section +and opt_args_threshold = + | Percent of float + | Both of (int * float) + +and 'threshold section = + | Off + | On + | Threshold of 'threshold thresholded_section + +and 'threshold thresholded_section = + { threshold: 'threshold + ; call_sites: bool + } + +and style_section = + { opt_arg: bool + ; unit_pat: bool + ; seq: bool + ; binding: bool + } + + +let default = + { exported_values = On + ; methods = On + ; types = On + ; opta = Off + ; optn = Off + ; style = + { opt_arg = false + ; unit_pat = false + ; seq = false + ; binding = false + } + } + +let is_activated = function + | Off -> false + | On | Threshold _ -> true + +let has_activated l = + List.exists is_activated l + +let call_sites_activated = function + | Threshold {call_sites; _} -> call_sites + | On | Off -> false + +let get_main_threshold = function + | Threshold {threshold; _} -> threshold + | On | Off -> 0 + +let parse_main_section cli_opt = function + | "all" -> On + | "nothing" -> Off + | arg -> + let raise_bad_arg msg = + raise (Arg.Bad (cli_opt ^ ": " ^ msg)) + in + let threshold_section = + let call_sites, threshold = + let len = String.length arg in + if String.starts_with ~prefix:"calls:" arg then + (true, String.sub arg 6 (len - 6)) + else if String.starts_with ~prefix:"threshold:" arg then + (false, String.sub arg 10 (len - 10)) + else raise_bad_arg ("unknown option: " ^ arg) + in + match String.trim threshold |> int_of_string with + | exception Failure _ -> + raise_bad_arg ("expected an integer; got; Got " ^ threshold) + | n when n < 0 -> + raise_bad_arg ("integer should be >= 0; Got " ^ string_of_int n) + | threshold -> {threshold; call_sites} + in + Threshold threshold_section + +let update_exported_values arg sections = + let exported_values = parse_main_section "-E" arg in + {sections with exported_values} + +let update_methods arg sections = + let methods = parse_main_section "-M" arg in + {sections with methods} + +let update_types arg sections = + let types = parse_main_section "-T" arg in + {sections with types} + + +let parse_opt_section = function + | "all" -> On + | "nothing" -> Off + | arg -> + let raise_bad_arg msg = + (* TODO: improve error reporting *) + raise (Arg.Bad ("-Ox: " ^ msg)) + in + let call_sites, arg = + if String.starts_with ~prefix:"calls" arg then + let arg = String.sub arg 6 (String.length arg - 6) in + (true, arg) + else (false, arg) + in + let check_percentage p = + if p > 1. || p < 0. then + raise_bad_arg "percentage must be >= 0.0 and <= 1.0" + in + let check_nb_exceptions n = + if n < 0 then raise_bad_arg "number of exceptions must be >= 0" + in + let threshold = + let len = String.length arg in + if String.starts_with ~prefix:"both:" arg then + let limits = String.sub arg 5 (len - 5) in + match Scanf.sscanf limits "%u , %F" (fun i f -> (i, f)) with + | exception Scanf.Scan_failure _ + | exception Failure _ + | exception End_of_file -> + (* TODO: improve error handling/reporting *) + raise_bad_arg ("wrong arguments: " ^ limits) + | (nb_exceptions, percentage) as limits -> + check_percentage percentage; + check_nb_exceptions nb_exceptions; + Both limits + else if String.starts_with ~prefix:"percent:" arg then + let percentage = String.sub arg 8 (len - 8) |> String.trim in + match float_of_string percentage with + | exception Failure _ -> + (* TODO: improve error handling/reporting *) + raise_bad_arg ("wrong argument: " ^ percentage) + | percentage -> + check_percentage percentage; + Percent percentage + else raise_bad_arg ("unknown option " ^ arg) + in + Threshold {threshold; call_sites} + +let update_opta arg sections = + let opta = parse_opt_section arg in + {sections with opta} + +let update_optn arg sections = + let optn = parse_opt_section arg in + {sections with optn} + + +let update_style arg style = + let rec aux style = function + | (b, "opt")::l -> + let style = {style with opt_arg = b} in + aux style l + | (b, "unit")::l -> + let style = {style with unit_pat = b} in + aux style l + | (b, "seq")::l -> + let style = {style with seq = b} in + aux style l + | (b, "bind")::l -> + let style = {style with binding = b} in + aux style l + | (b, "all")::l -> + let style = {unit_pat = b; opt_arg = b; seq = b; binding = b} in + aux style l + | (_, "")::l -> aux style l + | (_, s)::_ -> raise (Arg.Bad ("-S: unknown option: " ^ s)) + | [] -> style + in + let list_of_opt arg = + try + let rec split acc pos len = + if arg.[pos] <> '+' && arg.[pos] <> '-' then + split acc (pos - 1) (len + 1) + else let acc = (arg.[pos] = '+', String.trim (String.sub arg (pos + 1) len)) :: acc in + if pos > 0 then split acc (pos - 1) 0 + else acc + in split [] (String.length arg - 1) 0 + with _ -> raise (Arg.Bad ("options' arguments must start with a delimiter (`+' or `-')")) + in + aux style (list_of_opt arg) + +let update_style arg sections = + let style = update_style arg sections.style in + {sections with style} diff --git a/src/config/sections.mli b/src/config/sections.mli new file mode 100644 index 00000000..45d2994a --- /dev/null +++ b/src/config/sections.mli @@ -0,0 +1,91 @@ +type t = + { exported_values : main_section (** Exported values section config *) + ; methods : main_section (** Methods section config *) + ; types : main_section (** Constructors/fields section config *) + ; opta : opt_args_section (** Opt args always used section config *) + ; optn : opt_args_section (** Opt args always used section config *) + ; style : style_section (** Stylistic issues section config *) + } + +and main_section = int section + +and opt_args_section = opt_args_threshold section +and opt_args_threshold = + | Percent of float + (** Subsections for opt args always/never used at least [float] percent of + the time will be reported *) + | Both of (int * float) + (** Subsections for opt args always/never used with at most [int] + exceptions and at least [float] percent of the time will be reported *) + +and 'threshold section = + | Off (** Disabled *) + | On (** Enabled *) + | Threshold of 'threshold thresholded_section + (** Report elements up to [!'threshold] *) + +and 'threshold thresholded_section = + { threshold: 'threshold + (** Report subsections for elements used up to [!threshold] *) + ; call_sites: bool + (** Print call sites in the [!threshold]-related subsections *) + } + +and style_section = + { opt_arg: bool (** Report [val f : _ -> (... -> (... -> ?_:_ -> ...) -> ...] *) + ; unit_pat: bool (** Report unit pattern *) + ; seq: bool (** Report [let () = ... in ... (=> use sequence)] *) + ; binding: bool (** Report [let x = ... in x (=> useless binding)] *) + } + +val default : t +(** Default sections configuration. + [exported], [obj], and [typ] are [On]. + [opta], [optn] are [Off]. + All of the fileds in [style] are false. *) + +val is_activated : _ section -> bool +(** [is_activated sec] returns `true` if the section must be reported *) + +val has_activated : _ section list -> bool +(** [has_activated secs] returns `true` if one of the sections must be reported *) + +val call_sites_activated : _ section -> bool +(** [call_sites_activated sec] returns `true` if call sites must be reported in + thresholded subsections *) + + +val get_main_threshold : int section -> int +(** [get_main_threshold main_sec] returns the threshold if + [main_sec = Threshold _], [0] otherwise. *) + + +val update_exported_values : string -> t -> t +(** [update_exported_values arg sections] configures the [exported_values] + section according to [arg] and returns an updated version of [sections]. + [arg]'s specification is the one for the command line option "-E" *) + +val update_methods : string -> t -> t +(** [update_exported_values arg sections] configures the [exported_values] + section according to [arg] and returns an updated version of [sections] + [arg]'s specification is the one for the command line option "-M" *) + +val update_types : string -> t -> t +(** [update_exported_values arg sections] configures the [exported_values] + section according to [arg] and returns an updated version of [sections] + [arg]'s specification is the one for the command line option "-T" *) + +val update_opta : string -> t -> t +(** [update_exported_values arg sections] configures the [exported_values] + section according to [arg] and returns an updated version of [sections] + [arg]'s specification is the one for the command line option "-Oa" *) + +val update_optn : string -> t -> t +(** [update_exported_values arg sections] configures the [exported_values] + section according to [arg] and returns an updated version of [sections] + [arg]'s specification is the one for the command line option "-On" *) + +val update_style : string -> t -> t +(** [update_exported_values arg sections] configures the [exported_values] + section according to [arg] and returns an updated version of [sections] + [arg]'s specification is the one for the command line option "-S" *) diff --git a/src/deadArg.ml b/src/deadArg.ml index 6277c6c5..2bc89f1b 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -154,6 +154,7 @@ let register_uses val_loc args = register_uses builddir val_loc args let rec bind loc expr = + let sections = !Config.config.sections in match expr.exp_desc with | Texp_function (params, body) -> ( let check_param_style = function @@ -162,7 +163,7 @@ let rec bind loc expr = DeadType.check_style pat_type expr.exp_loc.Location.loc_start in let register_optional_param = function - | Asttypes.Optional s when Config.(has_activated [!config.optn; !config.opta]) -> + | Asttypes.Optional s when Config.has_activated [sections.optn; sections.opta] -> let (opts, next) = VdNode.get loc in VdNode.update loc (s :: opts, next) | _ -> () @@ -181,7 +182,7 @@ let rec bind loc expr = | _ -> () ) | exp_desc - when Config.(has_activated [!config.optn; !config.opta]) + when Config.has_activated [sections.optn; sections.opta] && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> let ( let$ ) x f = Option.iter f x in let$ loc2 = @@ -198,6 +199,7 @@ let rec bind loc expr = (******** WRAPPING ********) let wrap f x y = - if Config.(has_activated [!config.optn; !config.opta]) then f x y else () + let sections = !Config.config.sections in + if Config.has_activated [sections.optn; sections.opta] then f x y else () let register_uses val_loc args = wrap register_uses val_loc args diff --git a/src/deadCode.ml b/src/deadCode.ml index bde13ddf..f90b84a5 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -36,7 +36,7 @@ let rec collect_export ?(mod_type = false) path u stock = function | Sig_value (id, ({Types.val_loc; val_type; _} as value), _) when not val_loc.Location.loc_ghost -> let should_export stock loc = - Config.(is_activated !config.exported) + Config.(is_activated !config.sections.exported_values) && (* do not add the loc in decs if it belongs to a module type *) ( stock != decs || not (Hashtbl.mem in_modtype loc.Location.loc_start) @@ -129,14 +129,16 @@ let value_binding super self x = let structure_item super self i = let state = State.get_current () in + let sections = !Config.config.sections in let open Asttypes in begin match i.str_desc with - | Tstr_type (_, l) when Config.(is_activated !config.typ) -> + | Tstr_type (_, l) when Config.is_activated sections.types -> List.iter DeadType.tstr l | Tstr_module {mb_name = {txt = Some txt; _}; _} -> mods := txt :: !mods; DeadMod.defined := String.concat "." (List.rev !mods) :: !DeadMod.defined - | Tstr_class l when Config.(is_activated !config.obj) -> List.iter DeadObj.tstr l + | Tstr_class l when Config.is_activated sections.methods -> + List.iter DeadObj.tstr l | Tstr_include i -> let collect_include signature = let prev_last_loc = !last_loc in @@ -172,12 +174,13 @@ let structure_item super self i = let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern -> k general_pattern = fun super self p -> + let sections = !Config.config.sections in let pat_loc = p.pat_loc.Location.loc_start in 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 && !Config.config.style.unit_pat then begin + if DeadType.is_unit p.pat_type && sections.style.unit_pat then begin match p.pat_desc with | Tpat_construct _ -> () | Tpat_var (_, {txt = "eta"; loc = _}, _) @@ -195,7 +198,7 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - | Tpat_record (l, _) -> List.iter (fun (_, {Types.lbl_loc = {Location.loc_start = lab_loc; _}; _}, _) -> - if exported ~is_type:true !Config.config.typ lab_loc then + if exported ~is_type:true sections.types lab_loc then DeadType.collect_references lab_loc pat_loc ) l @@ -205,6 +208,7 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - let expr super self e = + let sections = !Config.config.sections in let rec extra = function | [] -> () | (Texp_coerce (_, typ), _, _)::l -> DeadObj.coerce e typ.ctyp_type; extra l @@ -218,12 +222,12 @@ let expr super self e = !DeadLexiFi.ttype_of e | Texp_ident (_, _, {Types.val_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}) - when exported !Config.config.exported loc -> + when exported sections.exported_values loc -> LocHash.add_set references loc exp_loc | Texp_field (_, _, {lbl_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}) | Texp_construct (_, {cstr_loc = {Location.loc_start = loc; loc_ghost = false; _}; _}, _) - when exported ~is_type:true !Config.config.typ loc -> + when exported ~is_type:true sections.types loc -> DeadType.collect_references loc exp_loc | Texp_send (e2, Tmeth_name meth) -> @@ -234,7 +238,8 @@ let expr super self e = | Texp_apply (exp, args) -> - if Config.(has_activated [!config.opta; !config.optn]) then treat_exp exp args; + if Config.has_activated [sections.opta; sections.optn] then + treat_exp exp args; begin match exp.exp_desc with | Texp_ident (_, _, {Types.val_loc; _}) when val_loc.Location.loc_ghost -> (* The node is due to lookup preparation @@ -248,7 +253,7 @@ let expr super self e = end | Texp_let (_, [{vb_pat; _}], _) - when DeadType.is_unit vb_pat.pat_type && !Config.config.style.seq -> + when DeadType.is_unit vb_pat.pat_type && sections.style.seq -> begin match vb_pat.pat_desc with | Tpat_var (id, _, _) when not (check_underscore (Ident.name id)) -> () | _ -> @@ -258,7 +263,7 @@ let expr super self e = end | Texp_match (_, [{c_lhs; _}], _) - when DeadType.is_unit c_lhs.pat_type && !Config.config.style.seq -> + 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 @@ -276,7 +281,7 @@ let expr super self e = [{vb_pat = {pat_desc = Tpat_var (id1, _, _); pat_loc = {loc_start = loc; _}; _}; _}], {exp_desc = Texp_ident (Path.Pident id2, _, _); exp_extra = []; _}) when id1 = id2 - && !Config.config.style.binding + && sections.style.binding && check_underscore (Ident.name id1) -> register_style loc "let x = ... in x (=> useless binding)" @@ -356,7 +361,10 @@ let regabs state = let read_interface fn cmi_infos state = let open Cmi_format in try regabs state; - if Config.(has_activated [!config.exported; !config.obj; !config.typ]) then + let sections = !Config.config.sections in + if + Config.has_activated [sections.exported_values; sections.methods; sections.types] + then let u = if State.File_infos.has_sourcepath state.file_infos then State.File_infos.get_sourceunit state.file_infos @@ -480,7 +488,7 @@ let rec load_file state fn = ignore (collect_references.Tast_mapper.structure collect_references x); let loc_dep = - if Config.(is_activated !config.exported) then + if Config.(is_activated !config.sections.exported_values) then List.rev_map (fun (vd1, vd2) -> (vd1.Types.val_loc.Location.loc_start, vd2.Types.val_loc.Location.loc_start) @@ -543,11 +551,10 @@ let analyze_opt_args () = let report_opt_args s l = let opt = - if s = "NEVER" then !Config.config.optn - else !Config.config.opta + if s = "NEVER" then !Config.config.sections.optn + else !Config.config.sections.opta in let rec report_opt_args nb_call = - let open Config in let l = List.filter (fun (_, _, _, slot, ratio, _) -> let ratio = 1. -. ratio in match opt with @@ -617,7 +624,10 @@ let report_opt_args s l = let report_unused_exported () = - report_basic decs "UNUSED EXPORTED VALUES" !Config.config.exported + report_basic + decs + "UNUSED EXPORTED VALUES" + !Config.config.sections.exported_values let report_style () = @@ -652,27 +662,29 @@ try parse (); let run_on_references_only state = DeadCommon.declarations := false; - let oldstyle = !Config.config.style in + let oldsections = !Config.config.sections in Config.update_style "-all"; List.fold_left load_file state !Config.config.directories |> ignore; - Config.(config := {!config with style = oldstyle}) + Config.(config := {!config with sections = oldsections}) in run_on_references_only (State.get_current ()); Printf.eprintf " [DONE]\n\n%!"; !DeadLexiFi.prepare_report DeadType.decs; - if Config.(is_activated !config.exported) then report_unused_exported (); + let sections = !Config.config.sections in + if Config.is_activated sections.exported_values then report_unused_exported (); DeadObj.report(); DeadType.report(); - if Config.(has_activated [!config.opta; !config.optn]) then begin + if Config.has_activated [sections.opta; sections.optn] then begin let tmp = analyze_opt_args () in - if Config.(is_activated !config.opta) then report_opt_args "ALWAYS" tmp; - if Config.(is_activated !config.optn) then report_opt_args "NEVER" tmp + if Config.is_activated sections.opta then report_opt_args "ALWAYS" tmp; + if Config.is_activated sections.optn then report_opt_args "NEVER" tmp end; + let style = sections.style in if [@warning "-44"] - Config.(!config.style.opt_arg || !config.style.unit_pat || !config.style.seq || !config.style.binding) + style.opt_arg || style.unit_pat || style.seq || style.binding then report_style (); if !bad_files <> [] then begin diff --git a/src/deadCommon.ml b/src/deadCommon.ml index f0a85e87..e920a442 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -140,7 +140,7 @@ let rec get_deep_desc typ = | t -> t -let exported ?(is_type = false) (flag : Config.main_section) loc = +let exported ?(is_type = false) (flag : Config.Sections.main_section) loc = let state = State.get_current () in let fn = loc.Lexing.pos_fname in let sourceunit = State.File_infos.get_sourceunit state.file_infos in @@ -432,7 +432,7 @@ let pretty_print_call () = let ghost = ref false in function ghost := true -let percent (opt_threshold : Config.opt_threshold) base = +let percent (opt_threshold : Config.Sections.opt_args_threshold) base = let percentage = match opt_threshold with | Percent p | Both (_, p) -> p @@ -441,7 +441,9 @@ let percent (opt_threshold : Config.opt_threshold) base = (* Base pattern for reports *) -let report s ~(opt: Config.opt_section) ?(extra = "Called") l continue nb_call pretty_print reporter = +let report s ~(opt: Config.Sections.opt_args_section) ?(extra = "Called") l + continue nb_call pretty_print reporter += if nb_call = 0 || l <> [] then begin section ~sub:(nb_call <> 0) @@ (if nb_call = 0 then s @@ -464,7 +466,7 @@ let report s ~(opt: Config.opt_section) ?(extra = "Called") l continue nb_call p else (print_newline () |> separator) -let report_basic ?folder decs title (flag:Config.main_section) = +let report_basic ?folder decs title (flag:Config.Sections.main_section) = let folder = match folder with | Some folder -> folder | None -> fun nb_call -> fun loc (builddir, path) acc -> @@ -522,7 +524,7 @@ let report_basic ?folder decs title (flag:Config.main_section) = if nb_call = 0 then title else "ALMOST " ^ title in - report s ~opt:(!Config.config.opta) l continue nb_call pretty_print reportn + report s ~opt:(!Config.config.sections.opta) l continue nb_call pretty_print reportn in reportn 0 diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index df5d31aa..1a5fb93c 100644 --- a/src/deadLexiFi.ml +++ b/src/deadLexiFi.ml @@ -118,12 +118,13 @@ let () = DeadLexiFi.prepare_report := (fun decs -> + let sections = !Config.config.sections in List.iter (fun (strin, pos) -> hashtbl_find_list str strin |> List.iter (fun loc -> - if exported !Config.config.exported loc then + if exported sections.exported_values loc then LocHash.add_set references loc pos ) ) @@ -163,7 +164,7 @@ let () = else get_type s (pos - 1) in List.iter - ( if exported ~is_type:true !Config.config.typ loc then LocHash.add_set references loc + ( if exported ~is_type:true sections.types loc then LocHash.add_set references loc else ignore ) (hashtbl_find_list dyn_used (get_type path (String.length path - 1))) diff --git a/src/deadMod.ml b/src/deadMod.ml index 6c9bc206..7ed037b1 100644 --- a/src/deadMod.ml +++ b/src/deadMod.ml @@ -70,9 +70,10 @@ let expr m = match m.mod_desc with let is_obj = String.contains x '#' in let is_type = not is_obj && DeadType.is_type x in let relevant_report_enabled = - if is_obj then Config.(is_activated !config.obj) - else if is_type then exported ~is_type !Config.config.typ loc - else exported !Config.config.exported loc + let sections = !Config.config.sections in + if is_obj then Config.is_activated sections.methods + else if is_type then exported ~is_type sections.types loc + else exported sections.exported_values loc in let value_is_expected_by_modtype = List.mem x l1 || l1 = [] in if value_is_expected_by_modtype && relevant_report_enabled then @@ -85,7 +86,9 @@ let expr m = match m.mod_desc with (******** WRAPPING ********) let expr m = + let sections = !Config.config.sections in if [@warning "-44"] - Config.(has_activated [!config.exported; !config.typ; !config.obj]) then + Config.has_activated [sections.exported_values; sections.types; sections.methods] + then expr m else () diff --git a/src/deadObj.ml b/src/deadObj.ml index 2eff7672..85018fad 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -474,7 +474,7 @@ let report () = else acc in - report_basic ~folder decs "UNUSED METHODS" !Config.config.obj + report_basic ~folder decs "UNUSED METHODS" !Config.config.sections.methods @@ -482,7 +482,7 @@ let report () = let wrap f x = - if Config.(is_activated !config.obj) then f x else () + if Config.(is_activated !config.sections.methods) then f x else () let collect_export path u stock ?obj ?cltyp loc = wrap (collect_export path u stock ~obj ~cltyp) loc diff --git a/src/deadType.ml b/src/deadType.ml index dbcb2bbe..a3254d6c 100644 --- a/src/deadType.ml +++ b/src/deadType.ml @@ -102,7 +102,7 @@ let collect_references loc exp_loc = (* Look for bad style typing *) let rec check_style t loc = let state = State.get_current() in - if !Config.config.style.opt_arg then + if !Config.config.sections.style.opt_arg then match get_deep_desc t with | Tarrow (lab, _, t, _) -> begin match lab with @@ -168,13 +168,16 @@ let tstr typ = let report () = - report_basic decs "UNUSED CONSTRUCTORS/RECORD FIELDS" !Config.config.typ + report_basic + decs + "UNUSED CONSTRUCTORS/RECORD FIELDS" + !Config.config.sections.types (******** WRAPPING ********) let wrap f x = - if Config.(is_activated !config.typ) then f x else () + if Config.(is_activated !config.sections.types) then f x else () let collect_export path u stock t = wrap (collect_export path u stock) t let tstr typ = wrap tstr typ From d4568d53b28db9f495da6b8ba02e45c4181880e9 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Wed, 4 Feb 2026 17:42:43 +0100 Subject: [PATCH 08/12] [src][config][8/n] add dedicated `has_*_section_activated` functions This simplifies the code in consumers of the config API --- src/config/config.ml | 8 ++++++++ src/config/config.mli | 9 +++++++-- src/deadArg.ml | 8 +++----- src/deadCode.ml | 7 +++---- src/deadMod.ml | 6 +----- 5 files changed, 22 insertions(+), 16 deletions(-) diff --git a/src/config/config.ml b/src/config/config.ml index 52fe1d42..d9b35eb6 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -33,6 +33,14 @@ let config = ref ; sections = Sections.default } +let has_main_section_activated () = + let sections = !config.sections in + has_activated [sections.exported_values; sections.methods; sections.types] + +let has_opt_args_section_activated () = + let sections = !config.sections in + has_activated [sections.opta; sections.optn] + let update_exported_values arg = let sections = Sections.update_exported_values arg !config.sections in config := {!config with sections} diff --git a/src/config/config.mli b/src/config/config.mli index a9675654..2a6db9c4 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -7,8 +7,13 @@ module Sections = Sections val is_activated : _ Sections.section -> bool (** [is_activated sec] returns `true` if the section must be reported *) -val has_activated : _ Sections.section list -> bool -(** [has_activated secs] returns `true` if one of the sections must be reported *) +val has_main_section_activated : unit -> bool +(** [has_main_section_activated ()] indicates if any of the main sections must + be reported *) + +val has_opt_args_section_activated : unit -> bool +(** [has_opt_args_section_activated ()] indicates if any of the optional + arguments section must be reported *) val call_sites_activated : _ Sections.section -> bool (** [call_sites_activated sec] returns `true` if call sites must be reported in diff --git a/src/deadArg.ml b/src/deadArg.ml index 2bc89f1b..08f2a341 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -154,7 +154,6 @@ let register_uses val_loc args = register_uses builddir val_loc args let rec bind loc expr = - let sections = !Config.config.sections in match expr.exp_desc with | Texp_function (params, body) -> ( let check_param_style = function @@ -163,7 +162,7 @@ let rec bind loc expr = DeadType.check_style pat_type expr.exp_loc.Location.loc_start in let register_optional_param = function - | Asttypes.Optional s when Config.has_activated [sections.optn; sections.opta] -> + | Asttypes.Optional s when Config.has_opt_args_section_activated () -> let (opts, next) = VdNode.get loc in VdNode.update loc (s :: opts, next) | _ -> () @@ -182,7 +181,7 @@ let rec bind loc expr = | _ -> () ) | exp_desc - when Config.has_activated [sections.optn; sections.opta] + when Config.has_opt_args_section_activated () && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> let ( let$ ) x f = Option.iter f x in let$ loc2 = @@ -199,7 +198,6 @@ let rec bind loc expr = (******** WRAPPING ********) let wrap f x y = - let sections = !Config.config.sections in - if Config.has_activated [sections.optn; sections.opta] then f x y else () + if Config.has_opt_args_section_activated () then f x y else () let register_uses val_loc args = wrap register_uses val_loc args diff --git a/src/deadCode.ml b/src/deadCode.ml index f90b84a5..37c3d493 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -238,7 +238,7 @@ let expr super self e = | Texp_apply (exp, args) -> - if Config.has_activated [sections.opta; sections.optn] then + if Config.has_opt_args_section_activated () then treat_exp exp args; begin match exp.exp_desc with | Texp_ident (_, _, {Types.val_loc; _}) @@ -361,9 +361,8 @@ let regabs state = let read_interface fn cmi_infos state = let open Cmi_format in try regabs state; - let sections = !Config.config.sections in if - Config.has_activated [sections.exported_values; sections.methods; sections.types] + Config.has_main_section_activated () then let u = if State.File_infos.has_sourcepath state.file_infos then @@ -677,7 +676,7 @@ try if Config.is_activated sections.exported_values then report_unused_exported (); DeadObj.report(); DeadType.report(); - if Config.has_activated [sections.opta; sections.optn] then begin + if Config.has_opt_args_section_activated () then begin let tmp = analyze_opt_args () in if Config.is_activated sections.opta then report_opt_args "ALWAYS" tmp; if Config.is_activated sections.optn then report_opt_args "NEVER" tmp diff --git a/src/deadMod.ml b/src/deadMod.ml index 7ed037b1..09de08c5 100644 --- a/src/deadMod.ml +++ b/src/deadMod.ml @@ -86,9 +86,5 @@ let expr m = match m.mod_desc with (******** WRAPPING ********) let expr m = - let sections = !Config.config.sections in - if [@warning "-44"] - Config.has_activated [sections.exported_values; sections.types; sections.methods] - then - expr m + if [@warning "-44"] Config.has_main_section_activated () then expr m else () From 6f45f951f33db3e10ac78f8afc27a229b3d19994 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Wed, 4 Feb 2026 18:16:17 +0100 Subject: [PATCH 09/12] [src][config][9/n] add path-related info in the config Peths considered for analysis, to gather references from, and those excluded from the analysis are now available in the config. This step will enable moving to an immutable config and an "out-of-arg-parsing" analysis (analysis is currently triggered during the parsing of arguments). --- src/config/config.ml | 35 +++++++++++++++++++++++++---------- src/config/config.mli | 10 ++++++++-- src/deadCode.ml | 5 ++++- 3 files changed, 37 insertions(+), 13 deletions(-) diff --git a/src/config/config.ml b/src/config/config.ml index d9b35eb6..75b4e7f7 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -17,11 +17,15 @@ let call_sites_activated = Sections.call_sites_activated let get_main_threshold = Sections.get_main_threshold +module StringSet = Set.Make(String) + type t = { verbose : bool ; internal : bool ; underscore : bool - ; directories : string list + ; paths_to_analyze : StringSet.t + ; excluded_paths : StringSet.t + ; references_paths : StringSet.t ; sections : Sections.t } @@ -29,7 +33,9 @@ let config = ref { verbose = false ; internal = false ; underscore = false - ; directories = [] + ; paths_to_analyze = StringSet.empty + ; excluded_paths = StringSet.empty + ; references_paths = StringSet.empty ; sections = Sections.default } @@ -94,11 +100,14 @@ let normalize_path s = in concat_path (norm_path (List.rev (split_path s))) -let exclude, is_excluded = - let tbl = Hashtbl.create 10 in - let exclude s = Hashtbl.replace tbl (normalize_path s) () in - let is_excluded s = Hashtbl.mem tbl (normalize_path s) in - exclude, is_excluded +let exclude path = + let path = normalize_path path in + let excluded_paths = StringSet.add path !config.excluded_paths in + config := {!config with excluded_paths} + +let is_excluded path= + let path = normalize_path path in + StringSet.mem path !config.excluded_paths (* Option parsing and processing *) @@ -112,6 +121,12 @@ let parse_cli process_path = update_optn print in + let process_path path = + let paths_to_analyze = StringSet.add path !config.paths_to_analyze in + config := {!config with paths_to_analyze}; + process_path path + in + (* any extra argument can be accepted by any option using some * although it doesn't necessary affects the results (e.g. -O 3+4) *) Arg.(parse @@ -119,9 +134,9 @@ let parse_cli process_path = "--references", String - (fun dir -> - let directories = dir :: !config.directories in - config := {!config with directories} + (fun path -> + let references_paths = StringSet.add path !config.references_paths in + config := {!config with references_paths} ), " Consider given path to collect references."; diff --git a/src/config/config.mli b/src/config/config.mli index 2a6db9c4..7b33caf2 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -28,11 +28,17 @@ val update_style : string -> unit (** {2 General configuration} *) +module StringSet : Set.S with type elt = String.t + type t = { verbose : bool (** Display additional information during the analaysis *) ; internal : bool (** Keep track of internal uses for exported values *) ; underscore : bool (** Keep track of elements with names starting with [_] *) - ; directories : string list (** Paths to explore for references only *) + ; paths_to_analyze : StringSet.t + (** Paths found in the command line and considered for analysis *) + ; excluded_paths : StringSet.t + (** Paths to exclude from the analysis *) + ; references_paths : StringSet.t (** Paths to explore for references only *) ; sections : Sections.t (** Config for the different report sections *) } @@ -43,7 +49,7 @@ val config : t ref val is_excluded : string -> bool (** [is_excluded path] indicates if [path] is excluded from the analysis. - Excluding a path is done with [exclude path]. *) + Excluding a path is done with the --exclude command line argument. *) val parse_cli : (string -> unit) -> unit (** [parse_cli process_path] updates the [config] according to the command line diff --git a/src/deadCode.ml b/src/deadCode.ml index 37c3d493..e4995eca 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -663,7 +663,10 @@ try DeadCommon.declarations := false; let oldsections = !Config.config.sections in Config.update_style "-all"; - List.fold_left load_file state !Config.config.directories + Config.StringSet.fold + (fun path state -> load_file state path) + !Config.config.references_paths + state |> ignore; Config.(config := {!config with sections = oldsections}) in From 31106a1b910f098836198709596d9e70749a1bde Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Thu, 5 Feb 2026 14:48:16 +0100 Subject: [PATCH 10/12] [src][config][10/n] provide immutable config in state The `Config` API is now immutable. `parse_cli` will produce a new `Config.t` each time rather than update the `Config.config`, and the old `config : t ref` is now simply `default_config : t`. `State.init` now expects a config as argument to produce the initial state. During the analysis, the configuration that must be acounted for is the one in the state. --- src/config/config.ml | 165 ++++++++++++++++++++++++------------------ src/config/config.mli | 38 +++++----- src/deadArg.ml | 11 ++- src/deadCode.ml | 83 ++++++++++++--------- src/deadCommon.ml | 11 ++- src/deadLexiFi.ml | 3 +- src/deadMod.ml | 7 +- src/deadObj.ml | 8 +- src/deadType.ml | 10 ++- src/state/state.ml | 27 ++++--- src/state/state.mli | 15 ++-- 11 files changed, 221 insertions(+), 157 deletions(-) diff --git a/src/config/config.ml b/src/config/config.ml index 75b4e7f7..a9d81815 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -29,7 +29,7 @@ type t = ; sections : Sections.t } -let config = ref +let default_config = { verbose = false ; internal = false ; underscore = false @@ -39,44 +39,44 @@ let config = ref ; sections = Sections.default } -let has_main_section_activated () = - let sections = !config.sections in +let has_main_section_activated config = + let sections = config.sections in has_activated [sections.exported_values; sections.methods; sections.types] -let has_opt_args_section_activated () = - let sections = !config.sections in +let has_opt_args_section_activated config = + let sections = config.sections in has_activated [sections.opta; sections.optn] -let update_exported_values arg = - let sections = Sections.update_exported_values arg !config.sections in - config := {!config with sections} +let update_exported_values arg config = + let sections = Sections.update_exported_values arg config.sections in + {config with sections} -let update_methods arg = - let sections = Sections.update_methods arg !config.sections in - config := {!config with sections} +let update_methods arg config = + let sections = Sections.update_methods arg config.sections in + {config with sections} -let update_types arg = - let sections = Sections.update_types arg !config.sections in - config := {!config with sections} +let update_types arg config = + let sections = Sections.update_types arg config.sections in + {config with sections} -let update_opta arg = - let sections = Sections.update_opta arg !config.sections in - config := {!config with sections} +let update_opta arg config = + let sections = Sections.update_opta arg config.sections in + {config with sections} -let update_optn arg = - let sections = Sections.update_optn arg !config.sections in - config := {!config with sections} +let update_optn arg config = + let sections = Sections.update_optn arg config.sections in + {config with sections} -let update_style arg = - let sections = Sections.update_style arg !config.sections in - config := {!config with sections} +let update_style arg config = + let sections = Sections.update_style arg config.sections in + {config with sections} -let set_verbose () = config := {!config with verbose = true} +let set_verbose config = {config with verbose = true} (* Print name starting with '_' *) -let set_underscore () = config := {!config with underscore = true} +let set_underscore config = {config with underscore = true} -let set_internal () = config := {!config with internal = true} +let set_internal config = {config with internal = true} let normalize_path s = @@ -100,61 +100,75 @@ let normalize_path s = in concat_path (norm_path (List.rev (split_path s))) -let exclude path = +let exclude path config = let path = normalize_path path in - let excluded_paths = StringSet.add path !config.excluded_paths in - config := {!config with excluded_paths} + let excluded_paths = StringSet.add path config.excluded_paths in + {config with excluded_paths} -let is_excluded path= +let is_excluded path config = let path = normalize_path path in - StringSet.mem path !config.excluded_paths - - -(* Option parsing and processing *) -let parse_cli process_path = - let update_all print () = - update_style ((if print = "all" then "+" else "-") ^ "all"); - update_exported_values print; - update_methods print; - update_types print; - update_opta print; - update_optn print + StringSet.mem path config.excluded_paths + +let add_reference_path path config = + let references_paths = StringSet.add path config.references_paths in + {config with references_paths} + +let add_path_to_analyze path config = + let paths_to_analyze = StringSet.add path config.paths_to_analyze in + {config with paths_to_analyze} + +(* Command line parsing *) +let parse_cli () = + let config = ref default_config in + let update_config f x = config := f x !config in + + let update_config_unit f () = config := f !config in + + let update_all arg config = + config + |> update_style ((if arg = "all" then "+" else "-") ^ "all") + |> update_exported_values arg + |> update_methods arg + |> update_types arg + |> update_opta arg + |> update_optn arg in - let process_path path = - let paths_to_analyze = StringSet.add path !config.paths_to_analyze in - config := {!config with paths_to_analyze}; - process_path path - in - - (* any extra argument can be accepted by any option using some - * although it doesn't necessary affects the results (e.g. -O 3+4) *) Arg.(parse - [ "--exclude", String exclude, " Exclude given path from research."; + [ "--exclude", + String (update_config exclude), + " Exclude given path from research."; "--references", - String - (fun path -> - let references_paths = StringSet.add path !config.references_paths in - config := {!config with references_paths} - ), + String (update_config add_reference_path), " Consider given path to collect references."; - "--underscore", Unit set_underscore, " Show names starting with an underscore"; + "--underscore", + Unit (update_config_unit set_underscore), + " Show names starting with an underscore"; - "--verbose", Unit set_verbose, " Verbose mode (ie., show scanned files)"; - "-v", Unit set_verbose, " See --verbose"; + "--verbose", + Unit (update_config_unit set_verbose), + " Verbose mode (ie., show scanned files)"; + "-v", Unit (update_config_unit set_verbose), " See --verbose"; - "--internal", Unit set_internal, + "--internal", + Unit (update_config_unit set_internal), " Keep internal uses as exported values uses when the interface is given. \ This is the default behaviour when only the implementation is found"; - "--nothing", Unit (update_all "nothing"), " Disable all warnings"; - "-a", Unit (update_all "nothing"), " See --nothing"; - "--all", Unit (update_all "all"), " Enable all warnings"; - "-A", Unit (update_all "all"), " See --all"; + "--nothing", + Unit (update_config_unit (update_all "nothing")), + " Disable all warnings"; + "-a", Unit (update_config_unit (update_all "nothing")), " See --nothing"; - "-E", String update_exported_values, + "--all", + Unit (update_config_unit (update_all "all")), + " Enable all warnings"; + "-A", Unit (update_config_unit (update_all "all")), " See --all"; + + "-E", + String (update_config update_exported_values), " Enable/Disable unused exported values warnings.\n \ can be:\n\ \tall\n\ @@ -162,11 +176,13 @@ let parse_cli process_path = \t\"threshold:\": report elements used up to the given integer\n\ \t\"calls:\": like threshold + show call sites"; - "-M", String update_methods, + "-M", + String (update_config update_methods), " Enable/Disable unused methods warnings.\n \ See option -E for the syntax of "; - "-Oa", String update_opta, + "-Oa", + String (update_config update_opta), " Enable/Disable optional arguments always used warnings.\n \ can be:\n\ \tall\n\ @@ -179,11 +195,13 @@ let parse_cli process_path = must be respected for the element to be reported\n\ \t\"percent:\": percent of valid cases to be reported"; - "-On", String update_optn, + "-On", + String (update_config update_optn), " Enable/Disable optional arguments never used warnings.\n \ See option -Oa for the syntax of "; - "-S", String update_style, + "-S", + String (update_config update_style), " Enable/Disable coding style warnings.\n \ Delimiters '+' and '-' determine if the following option is to enable or disable.\n \ Options (can be used together):\n\ @@ -193,11 +211,14 @@ let parse_cli process_path = \tunit: unit pattern\n\ \tall: bind & opt & seq & unit"; - "-T", String update_types, + "-T", + String (update_config update_types), " Enable/Disable unused constructors/records fields warnings.\n \ See option -E for the syntax of "; ] (Printf.eprintf "Scanning files...\n%!"; - process_path) - ("Usage: " ^ Sys.argv.(0) ^ " \nOptions are:")) + update_config add_path_to_analyze) + ("Usage: " ^ Sys.argv.(0) ^ " \nOptions are:")); + + !config diff --git a/src/config/config.mli b/src/config/config.mli index 7b33caf2..070828b5 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -7,25 +7,14 @@ module Sections = Sections val is_activated : _ Sections.section -> bool (** [is_activated sec] returns `true` if the section must be reported *) -val has_main_section_activated : unit -> bool -(** [has_main_section_activated ()] indicates if any of the main sections must - be reported *) - -val has_opt_args_section_activated : unit -> bool -(** [has_opt_args_section_activated ()] indicates if any of the optional - arguments section must be reported *) - val call_sites_activated : _ Sections.section -> bool (** [call_sites_activated sec] returns `true` if call sites must be reported in thresholded subsections *) -val get_main_threshold : int Sections.section -> int +val get_main_threshold : Sections.main_section -> int (** [get_main_threshold main_sec] returns the threshold if [main_sec = Threshold _], [0] otherwise. *) -val update_style : string -> unit -(** [update_style arg] updates [!style] according to the [arg] specification *) - (** {2 General configuration} *) module StringSet : Set.S with type elt = String.t @@ -42,15 +31,28 @@ type t = ; sections : Sections.t (** Config for the different report sections *) } -val config : t ref +val default_config : t (** Configuration for the analysis. By default [verbose], [internal], and [underscore] are [false] By default [sections] is [Sections.default] *) -val is_excluded : string -> bool -(** [is_excluded path] indicates if [path] is excluded from the analysis. +val has_main_section_activated : t -> bool +(** [has_main_section_activated config] indicates if any of the main sections + is activated in [config] *) + +val has_opt_args_section_activated : t -> bool +(** [has_opt_args_section_activated config] indicates if any of the optional + arguments section is activated in [config] *) + +val update_style : string -> t -> t +(** [update_style arg config] returns a [config] with [style] updated according + to the [arg] specification. *) + +val is_excluded : string -> t -> bool +(** [is_excluded path config] indicates if [path] is excluded from the analysis + in [config]. Excluding a path is done with the --exclude command line argument. *) -val parse_cli : (string -> unit) -> unit -(** [parse_cli process_path] updates the [config] according to the command line - arguments and processes each input path using [process_path] *) +val parse_cli : unit -> t +(** [parse_cli ()] returns a fresh configuration filled up according to the + command line arguments *) diff --git a/src/deadArg.ml b/src/deadArg.ml index 08f2a341..3ac3b72f 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -154,6 +154,7 @@ let register_uses val_loc args = register_uses builddir val_loc args let rec bind loc expr = + let state = State.get_current () in match expr.exp_desc with | Texp_function (params, body) -> ( let check_param_style = function @@ -162,7 +163,8 @@ let rec bind loc expr = DeadType.check_style pat_type expr.exp_loc.Location.loc_start in let register_optional_param = function - | Asttypes.Optional s when Config.has_opt_args_section_activated () -> + | Asttypes.Optional s + when Config.has_opt_args_section_activated state.config -> let (opts, next) = VdNode.get loc in VdNode.update loc (s :: opts, next) | _ -> () @@ -181,7 +183,7 @@ let rec bind loc expr = | _ -> () ) | exp_desc - when Config.has_opt_args_section_activated () + when Config.has_opt_args_section_activated state.config && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> let ( let$ ) x f = Option.iter f x in let$ loc2 = @@ -198,6 +200,9 @@ let rec bind loc expr = (******** WRAPPING ********) let wrap f x y = - if Config.has_opt_args_section_activated () then f x y else () + let state = State.get_current () in + if Config.has_opt_args_section_activated state.config then + f x y + else () let register_uses val_loc args = wrap register_uses val_loc args diff --git a/src/deadCode.ml b/src/deadCode.ml index e4995eca..03594dc5 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -35,8 +35,9 @@ let rec collect_export ?(mod_type = false) path u stock = function | Sig_value (id, ({Types.val_loc; val_type; _} as value), _) when not val_loc.Location.loc_ghost -> + let state = State.get_current () in let should_export stock loc = - Config.(is_activated !config.sections.exported_values) + Config.is_activated state.config.sections.exported_values && (* do not add the loc in decs if it belongs to a module type *) ( stock != decs || not (Hashtbl.mem in_modtype loc.Location.loc_start) @@ -129,7 +130,7 @@ let value_binding super self x = let structure_item super self i = let state = State.get_current () in - let sections = !Config.config.sections in + let sections = state.config.sections in let open Asttypes in begin match i.str_desc with | Tstr_type (_, l) when Config.is_activated sections.types -> @@ -174,7 +175,8 @@ let structure_item super self i = let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern -> k general_pattern = fun super self p -> - let sections = !Config.config.sections in + let state = State.get_current () in + let sections = state.config.sections in let pat_loc = p.pat_loc.Location.loc_start in let u s = register_style pat_loc (Printf.sprintf "unit pattern %s" s) @@ -186,7 +188,7 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - | Tpat_var (_, {txt = "eta"; loc = _}, _) when p.pat_loc = Location.none -> () | Tpat_var (_, {txt; _}, _) -> if check_underscore txt then u txt - | Tpat_any -> if !Config.config.underscore then u "_" + | Tpat_any -> if state.config.underscore then u "_" | Tpat_value tpat_arg -> begin match (tpat_arg :> value general_pattern) with | {pat_desc=Tpat_construct _; _} -> () @@ -208,7 +210,8 @@ let pat: type k. Tast_mapper.mapper -> Tast_mapper.mapper -> k general_pattern - let expr super self e = - let sections = !Config.config.sections in + let state = State.get_current () in + let sections = state.config.sections in let rec extra = function | [] -> () | (Texp_coerce (_, typ), _, _)::l -> DeadObj.coerce e typ.ctyp_type; extra l @@ -238,7 +241,7 @@ let expr super self e = | Texp_apply (exp, args) -> - if Config.has_opt_args_section_activated () then + if Config.has_opt_args_section_activated state.config then treat_exp exp args; begin match exp.exp_desc with | Texp_ident (_, _, {Types.val_loc; _}) @@ -341,10 +344,11 @@ let collect_references = (* Tast_mapper *) (* Checks the nature of the file *) let kind fn = + let state = State.get_current () in if not (Sys.file_exists fn) then begin prerr_endline ("Warning: '" ^ fn ^ "' not found"); `Ignore - end else if Config.is_excluded fn then `Ignore + end else if Config.is_excluded fn state.config then `Ignore else if Sys.is_directory fn then `Dir else if Filename.check_suffix fn ".cmi" then `Cmi else if Filename.check_suffix fn ".cmt" then `Cmt @@ -362,7 +366,7 @@ let read_interface fn cmi_infos state = let open Cmi_format in try regabs state; if - Config.has_main_section_activated () + Config.has_main_section_activated state.config then let u = if State.File_infos.has_sourcepath state.file_infos then @@ -401,7 +405,7 @@ let assoc decs (loc1, loc2) = || not (is_implem fn && has_iface fn) in if fn1 <> _none && fn2 <> _none && loc1 <> loc2 then begin - if (!Config.config.internal || fn1 <> fn2) && is_implem fn1 && is_implem fn2 then + if (state.config.internal || fn1 <> fn2) && is_implem fn1 && is_implem fn2 then DeadCommon.LocHash.merge_set references loc2 references loc1; if is_iface fn1 loc1 then begin if is_iface fn2 loc2 then @@ -444,7 +448,7 @@ let eof loc_dep = (* Starting point *) -let rec load_file state fn = +let rec load_file fn state = let init_and_continue state fn f = match State.change_file state fn with | Error msg -> @@ -459,7 +463,7 @@ let rec load_file state fn = match kind fn with | `Cmi when !DeadCommon.declarations -> last_loc := Lexing.dummy_pos; - if !Config.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; + if state.State.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; init_and_continue state fn (fun state -> match state.file_infos.cmi_infos with | None -> () (* TODO error handling ? *) @@ -469,7 +473,7 @@ let rec load_file state fn = | `Cmt -> let open Cmt_format in last_loc := Lexing.dummy_pos; - if !Config.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; + if state.config.verbose then Printf.eprintf "Scanning %s\n%!" fn; init_and_continue state fn (fun state -> regabs state; match state.file_infos.cmt_infos with @@ -487,7 +491,7 @@ let rec load_file state fn = ignore (collect_references.Tast_mapper.structure collect_references x); let loc_dep = - if Config.(is_activated !config.sections.exported_values) then + if Config.is_activated state.config.sections.exported_values then List.rev_map (fun (vd1, vd2) -> (vd1.Types.val_loc.Location.loc_start, vd2.Types.val_loc.Location.loc_start) @@ -503,7 +507,7 @@ let rec load_file state fn = let next = Sys.readdir fn in Array.sort compare next; Array.fold_left - (fun state s -> load_file state (fn ^ "/" ^ s)) + (fun state s -> load_file (fn ^ "/" ^ s) state) state next (* else Printf.eprintf "skipping directory %s\n" fn *) @@ -549,9 +553,10 @@ let analyze_opt_args () = let report_opt_args s l = + let state = State.get_current () in let opt = - if s = "NEVER" then !Config.config.sections.optn - else !Config.config.sections.opta + if s = "NEVER" then state.config.sections.optn + else state.config.sections.opta in let rec report_opt_args nb_call = let l = List.filter @@ -623,10 +628,11 @@ let report_opt_args s l = let report_unused_exported () = + let state = State.get_current () in report_basic decs "UNUSED EXPORTED VALUES" - !Config.config.sections.exported_values + state.config.sections.exported_values let report_style () = @@ -648,38 +654,45 @@ let report_style () = (* Option parsing and processing *) -let parse () = - let process_file filename = - let state = State.get_current () in - let state = load_file state filename in - State.update state +let run_analysis state = + let process_file filename state = + let state = load_file filename state in + State.update state; + state in - Config.parse_cli process_file + Config.StringSet.fold + process_file + state.State.config.paths_to_analyze + state let () = try - parse (); + let config = Config.parse_cli () in + let state = State.init config in + let state = run_analysis state in let run_on_references_only state = DeadCommon.declarations := false; - let oldsections = !Config.config.sections in - Config.update_style "-all"; - Config.StringSet.fold - (fun path state -> load_file state path) - !Config.config.references_paths - state - |> ignore; - Config.(config := {!config with sections = oldsections}) + let no_style_config = Config.update_style "-all" state.State.config in + let state = State.update_config no_style_config state in + let state = + Config.StringSet.fold + load_file + state.config.references_paths + state + in + State.update_config config state in - run_on_references_only (State.get_current ()); + let state = run_on_references_only state in + State.update state; Printf.eprintf " [DONE]\n\n%!"; !DeadLexiFi.prepare_report DeadType.decs; - let sections = !Config.config.sections in + let sections = state.config.sections in if Config.is_activated sections.exported_values then report_unused_exported (); DeadObj.report(); DeadType.report(); - if Config.has_opt_args_section_activated () then begin + if Config.has_opt_args_section_activated state.config then begin let tmp = analyze_opt_args () in if Config.is_activated sections.opta then report_opt_args "ALWAYS" tmp; if Config.is_activated sections.optn then report_opt_args "NEVER" tmp diff --git a/src/deadCommon.ml b/src/deadCommon.ml index e920a442..47f88ba0 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -84,7 +84,9 @@ let is_ghost loc = || loc.Lexing.pos_fname = _none || loc.Lexing.pos_fname = "" -let check_underscore name = !Config.config.underscore || name.[0] <> '_' +let check_underscore name = + let state = State.get_current () in + state.config.underscore || name.[0] <> '_' let hashtbl_find_list hashtbl key = Hashtbl.find_all hashtbl key @@ -148,7 +150,7 @@ let exported ?(is_type = false) (flag : Config.Sections.main_section) loc = && LocHash.find_set references loc |> LocSet.cardinal <= Config.get_main_threshold flag && (is_type - || !Config.config.internal + || state.config.internal || fn.[String.length fn - 1] = 'i' || sourceunit <> Utils.unit fn || not (file_exists (fn ^ "i"))) @@ -466,7 +468,7 @@ let report s ~(opt: Config.Sections.opt_args_section) ?(extra = "Called") l else (print_newline () |> separator) -let report_basic ?folder decs title (flag:Config.Sections.main_section) = +let report_basic ?folder decs title (flag: Config.Sections.main_section) = let folder = match folder with | Some folder -> folder | None -> fun nb_call -> fun loc (builddir, path) acc -> @@ -524,7 +526,8 @@ let report_basic ?folder decs title (flag:Config.Sections.main_section) = if nb_call = 0 then title else "ALMOST " ^ title in - report s ~opt:(!Config.config.sections.opta) l continue nb_call pretty_print reportn + let state = State.get_current () in + report s ~opt:(state.config.sections.opta) l continue nb_call pretty_print reportn in reportn 0 diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index 1a5fb93c..2fd31876 100644 --- a/src/deadLexiFi.ml +++ b/src/deadLexiFi.ml @@ -118,7 +118,8 @@ let () = DeadLexiFi.prepare_report := (fun decs -> - let sections = !Config.config.sections in + let state = State.get_current () in + let sections = state.config.sections in List.iter (fun (strin, pos) -> hashtbl_find_list str strin diff --git a/src/deadMod.ml b/src/deadMod.ml index 09de08c5..9d98de54 100644 --- a/src/deadMod.ml +++ b/src/deadMod.ml @@ -70,7 +70,8 @@ let expr m = match m.mod_desc with let is_obj = String.contains x '#' in let is_type = not is_obj && DeadType.is_type x in let relevant_report_enabled = - let sections = !Config.config.sections in + let state = State.get_current () in + let sections = state.config.sections in if is_obj then Config.is_activated sections.methods else if is_type then exported ~is_type sections.types loc else exported sections.exported_values loc @@ -86,5 +87,7 @@ let expr m = match m.mod_desc with (******** WRAPPING ********) let expr m = - if [@warning "-44"] Config.has_main_section_activated () then expr m + let state = State.get_current () in + if [@warning "-44"] Config.has_main_section_activated state.config then + expr m else () diff --git a/src/deadObj.ml b/src/deadObj.ml index 85018fad..fdab1dc0 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -474,7 +474,8 @@ let report () = else acc in - report_basic ~folder decs "UNUSED METHODS" !Config.config.sections.methods + let state = State.get_current () in + report_basic ~folder decs "UNUSED METHODS" state.config.sections.methods @@ -482,7 +483,10 @@ let report () = let wrap f x = - if Config.(is_activated !config.sections.methods) then f x else () + let state = State.get_current () in + if Config.is_activated state.config.sections.methods then + f x + else () let collect_export path u stock ?obj ?cltyp loc = wrap (collect_export path u stock ~obj ~cltyp) loc diff --git a/src/deadType.ml b/src/deadType.ml index a3254d6c..5a2d444b 100644 --- a/src/deadType.ml +++ b/src/deadType.ml @@ -102,7 +102,7 @@ let collect_references loc exp_loc = (* Look for bad style typing *) let rec check_style t loc = let state = State.get_current() in - if !Config.config.sections.style.opt_arg then + if state.config.sections.style.opt_arg then match get_deep_desc t with | Tarrow (lab, _, t, _) -> begin match lab with @@ -168,16 +168,20 @@ let tstr typ = let report () = + let state = State.get_current () in report_basic decs "UNUSED CONSTRUCTORS/RECORD FIELDS" - !Config.config.sections.types + state.config.sections.types (******** WRAPPING ********) let wrap f x = - if Config.(is_activated !config.sections.types) then f x else () + let state = State.get_current () in + if Config.is_activated state.config.sections.types then + f x + else () let collect_export path u stock t = wrap (collect_export path u stock) t let tstr typ = wrap tstr typ diff --git a/src/state/state.ml b/src/state/state.ml index 65550e1c..1418a125 100644 --- a/src/state/state.ml +++ b/src/state/state.ml @@ -1,14 +1,17 @@ module File_infos = File_infos -type t = { - file_infos : File_infos.t; -} +type t = + { config : Config.t + ; file_infos : File_infos.t + } -let empty = {file_infos = File_infos.empty} +let init config = + { config + ; file_infos = File_infos.empty + } -let init cmti_file = - let file_infos = File_infos.init cmti_file in - Result.map (fun file_infos -> {file_infos}) file_infos +let update_config config state = + {state with config} let change_file state cmti_file = let file_infos = state.file_infos in @@ -21,12 +24,16 @@ let change_file state cmti_file = Result.ok state else if equal_no_ext file_infos.cmti_file cmti_file then let file_infos = File_infos.change_file file_infos cmti_file in - Result.map (fun file_infos -> {file_infos}) file_infos + Result.map (fun file_infos -> {state with file_infos}) file_infos else - init cmti_file + let file_infos = File_infos.init cmti_file in + Result.map (fun file_infos -> {state with file_infos}) file_infos (** Analysis' state *) -let current = ref empty +let current = ref + { config = Config.default_config + ; file_infos = File_infos.empty + } let get_current () = !current diff --git a/src/state/state.mli b/src/state/state.mli index a313e24d..0a3362ec 100644 --- a/src/state/state.mli +++ b/src/state/state.mli @@ -2,15 +2,16 @@ module File_infos = File_infos -type t = { - file_infos : File_infos.t; (** Info about the file being analyzed *) -} +type t = + { config : Config.t (** Configuration of the analysis *) + ; file_infos : File_infos.t (** Info about the file being analyzed *) + } -val empty : t (** The empty state *) +val init : Config.t -> t +(** [init config] initial for an analysis configured by [config] *) -val init : string -> (t, string) result -(** [init cmti_file] initialize a state to analyze [cmti_file]. - See [File_infos.init] for error cases. *) +val update_config : Config.t -> t -> t +(** [update_config config state] changes the analysis configuration *) val change_file : t -> string -> (t, string) result (** [cahnge_file t cmti_file] prepare the analysis to move on to [cmti_file]. From ea0ee8edac93a212a5cd87e47d9f6595db97c802 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Thu, 5 Feb 2026 14:59:25 +0100 Subject: [PATCH 11/12] [src][config][11/n] config types are private This protects the configuration from updates outside the expected canals (the functions in the API) --- src/config/config.mli | 2 +- src/config/sections.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/config/config.mli b/src/config/config.mli index 070828b5..bcf666f9 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -19,7 +19,7 @@ val get_main_threshold : Sections.main_section -> int module StringSet : Set.S with type elt = String.t -type t = +type t = private { verbose : bool (** Display additional information during the analaysis *) ; internal : bool (** Keep track of internal uses for exported values *) ; underscore : bool (** Keep track of elements with names starting with [_] *) diff --git a/src/config/sections.mli b/src/config/sections.mli index 45d2994a..09eeab6c 100644 --- a/src/config/sections.mli +++ b/src/config/sections.mli @@ -1,4 +1,4 @@ -type t = +type t = private { exported_values : main_section (** Exported values section config *) ; methods : main_section (** Methods section config *) ; types : main_section (** Constructors/fields section config *) From 07ca382c1ae3ec62fe3742f763820c19b382c86b Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Thu, 5 Feb 2026 18:48:57 +0100 Subject: [PATCH 12/12] [src][config][12/n] small cleanup after self review + Fix some typos in comments. + Move `StringSet` to `Utils` (for now) + Easier to read `Arg.parse`. + Rename `Config.*_activated` into `Config.must_report_*` + Rewrite `Config.normalize_path` for clarity --- src/config/config.ml | 137 +++++++++++++++++++++------------------- src/config/config.mli | 33 +++++----- src/config/sections.ml | 10 +-- src/config/sections.mli | 27 ++++---- src/deadArg.ml | 6 +- src/deadCode.ml | 36 +++++------ src/deadCommon.ml | 6 +- src/deadMod.ml | 4 +- src/deadObj.ml | 2 +- src/deadType.ml | 2 +- src/state/state.mli | 4 +- src/utils.ml | 1 + src/utils.mli | 2 + 13 files changed, 139 insertions(+), 131 deletions(-) diff --git a/src/config/config.ml b/src/config/config.ml index a9d81815..8192ffb9 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -9,23 +9,21 @@ module Sections = Sections -let is_activated = Sections.is_activated +let must_report_section = Sections.must_report_section let has_activated = Sections.has_activated -let call_sites_activated = Sections.call_sites_activated +let must_report_call_sites = Sections.must_report_call_sites let get_main_threshold = Sections.get_main_threshold -module StringSet = Set.Make(String) - type t = { verbose : bool ; internal : bool ; underscore : bool - ; paths_to_analyze : StringSet.t - ; excluded_paths : StringSet.t - ; references_paths : StringSet.t + ; paths_to_analyze : Utils.StringSet.t + ; excluded_paths : Utils.StringSet.t + ; references_paths : Utils.StringSet.t ; sections : Sections.t } @@ -33,17 +31,17 @@ let default_config = { verbose = false ; internal = false ; underscore = false - ; paths_to_analyze = StringSet.empty - ; excluded_paths = StringSet.empty - ; references_paths = StringSet.empty + ; paths_to_analyze = Utils.StringSet.empty + ; excluded_paths = Utils.StringSet.empty + ; references_paths = Utils.StringSet.empty ; sections = Sections.default } -let has_main_section_activated config = +let must_report_main config = let sections = config.sections in has_activated [sections.exported_values; sections.methods; sections.types] -let has_opt_args_section_activated config = +let must_report_opt_args config = let sections = config.sections in has_activated [sections.opta; sections.optn] @@ -79,49 +77,56 @@ let set_underscore config = {config with underscore = true} let set_internal config = {config with internal = true} -let normalize_path s = - let rec split_path s = - let open Filename in - if s = current_dir_name || s = dirname s then [s] - else (basename s) :: (split_path (dirname s)) - in - let rec norm_path = function - | [] -> [] - | x :: ((y :: _) as yss) when x = y && x = Filename.current_dir_name -> norm_path yss - | x :: xss -> - if x = Filename.current_dir_name then norm_path xss (* strip leading ./ *) +let normalize_path path = + (* remove redundant "." and consecutive dir_sep in path. + E.g. "./foo//bar/./baz" becomes "foo/bar/baz" *) + let split_path path = + let is_end_of_path path = + String.equal path Filename.current_dir_name + || String.equal path (Filename.dirname path) + in + let rec split_path path = + if is_end_of_path path then [path] else - let yss = List.filter (fun x -> x <> Filename.current_dir_name) xss in - x :: yss + let splitted_dirpath = split_path (Filename.dirname path) in + (Filename.basename path) :: splitted_dirpath + in + List.rev (split_path path) in - let rec concat_path = function - | [] -> "" - | x :: xs -> Filename.concat x (concat_path xs) + let remove_redundancies splitted_path = + let reject_empty_and_curr s = + String.equal s "" || String.equal s Filename.current_dir_name + in + List.filter reject_empty_and_curr splitted_path in - concat_path (norm_path (List.rev (split_path s))) + let concat_path splitted_path = + String.concat Filename.dir_sep splitted_path + in + match path |> split_path |> remove_redundancies |> concat_path with + | "" -> Filename.current_dir_name + | normalized_path -> normalized_path let exclude path config = let path = normalize_path path in - let excluded_paths = StringSet.add path config.excluded_paths in + let excluded_paths = Utils.StringSet.add path config.excluded_paths in {config with excluded_paths} let is_excluded path config = let path = normalize_path path in - StringSet.mem path config.excluded_paths + Utils.StringSet.mem path config.excluded_paths let add_reference_path path config = - let references_paths = StringSet.add path config.references_paths in + let references_paths = Utils.StringSet.add path config.references_paths in {config with references_paths} let add_path_to_analyze path config = - let paths_to_analyze = StringSet.add path config.paths_to_analyze in + let paths_to_analyze = Utils.StringSet.add path config.paths_to_analyze in {config with paths_to_analyze} (* Command line parsing *) let parse_cli () = let config = ref default_config in let update_config f x = config := f x !config in - let update_config_unit f () = config := f !config in let update_all arg config = @@ -137,51 +142,51 @@ let parse_cli () = Arg.(parse [ "--exclude", String (update_config exclude), - " Exclude given path from research."; + " Exclude given path from research." - "--references", + ; "--references", String (update_config add_reference_path), - " Consider given path to collect references."; + " Consider given path to collect references." - "--underscore", + ; "--underscore", Unit (update_config_unit set_underscore), - " Show names starting with an underscore"; + " Show names starting with an underscore" - "--verbose", + ; "--verbose", Unit (update_config_unit set_verbose), - " Verbose mode (ie., show scanned files)"; - "-v", Unit (update_config_unit set_verbose), " See --verbose"; + " Verbose mode (ie., show scanned files)" + ; "-v", Unit (update_config_unit set_verbose), " See --verbose" - "--internal", + ; "--internal", Unit (update_config_unit set_internal), " Keep internal uses as exported values uses when the interface is given. \ - This is the default behaviour when only the implementation is found"; + This is the default behaviour when only the implementation is found" - "--nothing", + ; "--nothing", Unit (update_config_unit (update_all "nothing")), - " Disable all warnings"; - "-a", Unit (update_config_unit (update_all "nothing")), " See --nothing"; + " Disable all warnings" + ; "-a", Unit (update_config_unit (update_all "nothing")), " See --nothing" - "--all", + ; "--all", Unit (update_config_unit (update_all "all")), - " Enable all warnings"; - "-A", Unit (update_config_unit (update_all "all")), " See --all"; + " Enable all warnings" + ; "-A", Unit (update_config_unit (update_all "all")), " See --all" - "-E", + ; "-E", String (update_config update_exported_values), " Enable/Disable unused exported values warnings.\n \ can be:\n\ \tall\n\ \tnothing\n\ \t\"threshold:\": report elements used up to the given integer\n\ - \t\"calls:\": like threshold + show call sites"; + \t\"calls:\": like threshold + show call sites" - "-M", + ; "-M", String (update_config update_methods), " Enable/Disable unused methods warnings.\n \ - See option -E for the syntax of "; + See option -E for the syntax of " - "-Oa", + ; "-Oa", String (update_config update_opta), " Enable/Disable optional arguments always used warnings.\n \ can be:\n\ @@ -193,14 +198,14 @@ let parse_cli () = \t\"both:,\": both the number max of exceptions \ (given through the integer) and the percent of valid cases (given as a float) \ must be respected for the element to be reported\n\ - \t\"percent:\": percent of valid cases to be reported"; + \t\"percent:\": percent of valid cases to be reported" - "-On", + ; "-On", String (update_config update_optn), " Enable/Disable optional arguments never used warnings.\n \ - See option -Oa for the syntax of "; + See option -Oa for the syntax of " - "-S", + ; "-S", String (update_config update_style), " Enable/Disable coding style warnings.\n \ Delimiters '+' and '-' determine if the following option is to enable or disable.\n \ @@ -209,16 +214,18 @@ let parse_cli () = \topt: optional arg in arg\n\ \tseq: use sequence\n\ \tunit: unit pattern\n\ - \tall: bind & opt & seq & unit"; + \tall: bind & opt & seq & unit" - "-T", + ; "-T", String (update_config update_types), " Enable/Disable unused constructors/records fields warnings.\n \ - See option -E for the syntax of "; + See option -E for the syntax of " ] - (Printf.eprintf "Scanning files...\n%!"; - update_config add_path_to_analyze) - ("Usage: " ^ Sys.argv.(0) ^ " \nOptions are:")); + ( + update_config add_path_to_analyze + ) + ("Usage: " ^ Sys.argv.(0) ^ " \nOptions are:") + ); !config diff --git a/src/config/config.mli b/src/config/config.mli index bcf666f9..cca086bd 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -4,11 +4,11 @@ module Sections = Sections -val is_activated : _ Sections.section -> bool -(** [is_activated sec] returns `true` if the section must be reported *) +val must_report_section : _ Sections.section -> bool +(** [must_report_section sec] returns `true` if the section must be reported *) -val call_sites_activated : _ Sections.section -> bool -(** [call_sites_activated sec] returns `true` if call sites must be reported in +val must_report_call_sites : _ Sections.section -> bool +(** [must_report_call_sites sec] returns `true` if call sites must be reported in thresholded subsections *) val get_main_threshold : Sections.main_section -> int @@ -17,36 +17,35 @@ val get_main_threshold : Sections.main_section -> int (** {2 General configuration} *) -module StringSet : Set.S with type elt = String.t - type t = private { verbose : bool (** Display additional information during the analaysis *) ; internal : bool (** Keep track of internal uses for exported values *) ; underscore : bool (** Keep track of elements with names starting with [_] *) - ; paths_to_analyze : StringSet.t + ; paths_to_analyze : Utils.StringSet.t (** Paths found in the command line and considered for analysis *) - ; excluded_paths : StringSet.t - (** Paths to exclude from the analysis *) - ; references_paths : StringSet.t (** Paths to explore for references only *) + ; excluded_paths : Utils.StringSet.t (** Paths to exclude from the analysis *) + ; references_paths : Utils.StringSet.t + (** Paths to explore for references only *) ; sections : Sections.t (** Config for the different report sections *) } val default_config : t -(** Configuration for the analysis. +(** Default configuration for the analysis. By default [verbose], [internal], and [underscore] are [false] + By default [paths_to_analyze], [excluded_paths], and [references_paths] are empty. By default [sections] is [Sections.default] *) -val has_main_section_activated : t -> bool -(** [has_main_section_activated config] indicates if any of the main sections +val must_report_main : t -> bool +(** [must_report_main config] indicates if any of the main sections is activated in [config] *) -val has_opt_args_section_activated : t -> bool -(** [has_opt_args_section_activated config] indicates if any of the optional +val must_report_opt_args : t -> bool +(** [must_report_opt_args config] indicates if any of the optional arguments section is activated in [config] *) val update_style : string -> t -> t -(** [update_style arg config] returns a [config] with [style] updated according - to the [arg] specification. *) +(** [update_style arg config] returns a [config] with style section + configuration updated according to the [arg] specification. *) val is_excluded : string -> t -> bool (** [is_excluded path config] indicates if [path] is excluded from the analysis diff --git a/src/config/sections.ml b/src/config/sections.ml index 078d8093..b6483659 100644 --- a/src/config/sections.ml +++ b/src/config/sections.ml @@ -46,14 +46,14 @@ let default = } } -let is_activated = function +let must_report_section = function | Off -> false | On | Threshold _ -> true let has_activated l = - List.exists is_activated l + List.exists must_report_section l -let call_sites_activated = function +let must_report_call_sites = function | Threshold {call_sites; _} -> call_sites | On | Off -> false @@ -61,12 +61,12 @@ let get_main_threshold = function | Threshold {threshold; _} -> threshold | On | Off -> 0 -let parse_main_section cli_opt = function +let parse_main_section main_arg = function | "all" -> On | "nothing" -> Off | arg -> let raise_bad_arg msg = - raise (Arg.Bad (cli_opt ^ ": " ^ msg)) + raise (Arg.Bad (main_arg ^ ": " ^ msg)) in let threshold_section = let call_sites, threshold = diff --git a/src/config/sections.mli b/src/config/sections.mli index 09eeab6c..75094d15 100644 --- a/src/config/sections.mli +++ b/src/config/sections.mli @@ -13,7 +13,7 @@ and opt_args_section = opt_args_threshold section and opt_args_threshold = | Percent of float (** Subsections for opt args always/never used at least [float] percent of - the time will be reported *) + the time will be reported *) | Both of (int * float) (** Subsections for opt args always/never used with at most [int] exceptions and at least [float] percent of the time will be reported *) @@ -40,18 +40,19 @@ and style_section = val default : t (** Default sections configuration. - [exported], [obj], and [typ] are [On]. + [exported_values], [methods], and [types] are [On]. [opta], [optn] are [Off]. - All of the fileds in [style] are false. *) + All of the fields in [style] are false. *) -val is_activated : _ section -> bool -(** [is_activated sec] returns `true` if the section must be reported *) +val must_report_section : _ section -> bool +(** [must_report_section sec] returns [true] if the section must be reported *) val has_activated : _ section list -> bool -(** [has_activated secs] returns `true` if one of the sections must be reported *) +(** [has_activated secs] returns [true] if one of the sections in [sec] is + activated *) -val call_sites_activated : _ section -> bool -(** [call_sites_activated sec] returns `true` if call sites must be reported in +val must_report_call_sites : _ section -> bool +(** [must_report_call_sites sec] returns [true] if call sites must be reported in thresholded subsections *) @@ -66,26 +67,26 @@ val update_exported_values : string -> t -> t [arg]'s specification is the one for the command line option "-E" *) val update_methods : string -> t -> t -(** [update_exported_values arg sections] configures the [exported_values] +(** [update_exported_values arg sections] configures the [methods] section according to [arg] and returns an updated version of [sections] [arg]'s specification is the one for the command line option "-M" *) val update_types : string -> t -> t -(** [update_exported_values arg sections] configures the [exported_values] +(** [update_exported_values arg sections] configures the [types] section according to [arg] and returns an updated version of [sections] [arg]'s specification is the one for the command line option "-T" *) val update_opta : string -> t -> t -(** [update_exported_values arg sections] configures the [exported_values] +(** [update_exported_values arg sections] configures the [opta] section according to [arg] and returns an updated version of [sections] [arg]'s specification is the one for the command line option "-Oa" *) val update_optn : string -> t -> t -(** [update_exported_values arg sections] configures the [exported_values] +(** [update_exported_values arg sections] configures the [optn] section according to [arg] and returns an updated version of [sections] [arg]'s specification is the one for the command line option "-On" *) val update_style : string -> t -> t -(** [update_exported_values arg sections] configures the [exported_values] +(** [update_exported_values arg sections] configures the [style] section according to [arg] and returns an updated version of [sections] [arg]'s specification is the one for the command line option "-S" *) diff --git a/src/deadArg.ml b/src/deadArg.ml index 3ac3b72f..566dbaed 100644 --- a/src/deadArg.ml +++ b/src/deadArg.ml @@ -164,7 +164,7 @@ let rec bind loc expr = in let register_optional_param = function | Asttypes.Optional s - when Config.has_opt_args_section_activated state.config -> + when Config.must_report_opt_args state.config -> let (opts, next) = VdNode.get loc in VdNode.update loc (s :: opts, next) | _ -> () @@ -183,7 +183,7 @@ let rec bind loc expr = | _ -> () ) | exp_desc - when Config.has_opt_args_section_activated state.config + when Config.must_report_opt_args state.config && DeadType.nb_args ~keep:`Opt expr.exp_type > 0 -> let ( let$ ) x f = Option.iter f x in let$ loc2 = @@ -201,7 +201,7 @@ let rec bind loc expr = let wrap f x y = let state = State.get_current () in - if Config.has_opt_args_section_activated state.config then + if Config.must_report_opt_args state.config then f x y else () diff --git a/src/deadCode.ml b/src/deadCode.ml index 03594dc5..8e3393e1 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -37,7 +37,7 @@ let rec collect_export ?(mod_type = false) path u stock = function when not val_loc.Location.loc_ghost -> let state = State.get_current () in let should_export stock loc = - Config.is_activated state.config.sections.exported_values + Config.must_report_section state.config.sections.exported_values && (* do not add the loc in decs if it belongs to a module type *) ( stock != decs || not (Hashtbl.mem in_modtype loc.Location.loc_start) @@ -133,12 +133,12 @@ let structure_item super self i = let sections = state.config.sections in let open Asttypes in begin match i.str_desc with - | Tstr_type (_, l) when Config.is_activated sections.types -> + | Tstr_type (_, l) when Config.must_report_section sections.types -> List.iter DeadType.tstr l | Tstr_module {mb_name = {txt = Some txt; _}; _} -> mods := txt :: !mods; DeadMod.defined := String.concat "." (List.rev !mods) :: !DeadMod.defined - | Tstr_class l when Config.is_activated sections.methods -> + | Tstr_class l when Config.must_report_section sections.methods -> List.iter DeadObj.tstr l | Tstr_include i -> let collect_include signature = @@ -241,7 +241,7 @@ let expr super self e = | Texp_apply (exp, args) -> - if Config.has_opt_args_section_activated state.config then + if Config.must_report_opt_args state.config then treat_exp exp args; begin match exp.exp_desc with | Texp_ident (_, _, {Types.val_loc; _}) @@ -365,9 +365,7 @@ let regabs state = let read_interface fn cmi_infos state = let open Cmi_format in try regabs state; - if - Config.has_main_section_activated state.config - then + if Config.must_report_main state.config then let u = if State.File_infos.has_sourcepath state.file_infos then State.File_infos.get_sourceunit state.file_infos @@ -491,7 +489,7 @@ let rec load_file fn state = ignore (collect_references.Tast_mapper.structure collect_references x); let loc_dep = - if Config.is_activated state.config.sections.exported_values then + if Config.must_report_section state.config.sections.exported_values then List.rev_map (fun (vd1, vd2) -> (vd1.Types.val_loc.Location.loc_start, vd2.Types.val_loc.Location.loc_start) @@ -601,10 +599,10 @@ let report_opt_args s l = prloc ~fn loc; print_string ("?" ^ lab); if ratio <> 0. then begin Printf.printf " (%d/%d calls)" (total - List.length slot) total; - if Config.call_sites_activated opt then print_string " Exceptions:" + if Config.must_report_call_sites opt then print_string " Exceptions:" end; print_newline (); - if Config.call_sites_activated opt then begin + if Config.must_report_call_sites opt then begin List.iter (pretty_print_call ()) slot; if nb_call <> 0 then print_newline () end @@ -660,7 +658,8 @@ let run_analysis state = State.update state; state in - Config.StringSet.fold + Printf.eprintf "Scanning files...\n%!"; + Utils.StringSet.fold process_file state.State.config.paths_to_analyze state @@ -675,7 +674,7 @@ try let no_style_config = Config.update_style "-all" state.State.config in let state = State.update_config no_style_config state in let state = - Config.StringSet.fold + Utils.StringSet.fold load_file state.config.references_paths state @@ -689,18 +688,17 @@ try !DeadLexiFi.prepare_report DeadType.decs; let sections = state.config.sections in - if Config.is_activated sections.exported_values then report_unused_exported (); + if Config.must_report_section sections.exported_values then report_unused_exported (); DeadObj.report(); DeadType.report(); - if Config.has_opt_args_section_activated state.config then begin + if Config.must_report_opt_args state.config then begin let tmp = analyze_opt_args () in - if Config.is_activated sections.opta then report_opt_args "ALWAYS" tmp; - if Config.is_activated sections.optn then report_opt_args "NEVER" tmp + if Config.must_report_section sections.opta then report_opt_args "ALWAYS" tmp; + if Config.must_report_section sections.optn then report_opt_args "NEVER" tmp end; let style = sections.style in - if [@warning "-44"] - style.opt_arg || style.unit_pat || style.seq || style.binding - then report_style (); + if style.opt_arg || style.unit_pat || style.seq || style.binding then + report_style (); if !bad_files <> [] then begin let oc = open_out_bin "remove_bad_files.sh" in diff --git a/src/deadCommon.ml b/src/deadCommon.ml index 47f88ba0..bd9344ad 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -146,7 +146,7 @@ let exported ?(is_type = false) (flag : Config.Sections.main_section) loc = let state = State.get_current () in let fn = loc.Lexing.pos_fname in let sourceunit = State.File_infos.get_sourceunit state.file_infos in - Config.is_activated flag + Config.must_report_section flag && LocHash.find_set references loc |> LocSet.cardinal <= Config.get_main_threshold flag && (is_type @@ -511,10 +511,10 @@ let report_basic ?folder decs title (flag: Config.Sections.main_section) = if change fn then print_newline (); prloc ~fn loc; print_string path; - if call_sites <> [] && Config.call_sites_activated flag then + if call_sites <> [] && Config.must_report_call_sites flag then print_string " Call sites:"; print_newline (); - if Config.call_sites_activated flag then begin + if Config.must_report_call_sites flag then begin List.fast_sort compare call_sites |> List.iter (pretty_print_call ()); if nb_call <> 0 then print_newline () diff --git a/src/deadMod.ml b/src/deadMod.ml index 9d98de54..84742948 100644 --- a/src/deadMod.ml +++ b/src/deadMod.ml @@ -72,7 +72,7 @@ let expr m = match m.mod_desc with let relevant_report_enabled = let state = State.get_current () in let sections = state.config.sections in - if is_obj then Config.is_activated sections.methods + if is_obj then Config.must_report_section sections.methods else if is_type then exported ~is_type sections.types loc else exported sections.exported_values loc in @@ -88,6 +88,6 @@ let expr m = match m.mod_desc with let expr m = let state = State.get_current () in - if [@warning "-44"] Config.has_main_section_activated state.config then + if [@warning "-44"] Config.must_report_main state.config then expr m else () diff --git a/src/deadObj.ml b/src/deadObj.ml index fdab1dc0..cc131d07 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -484,7 +484,7 @@ let report () = let wrap f x = let state = State.get_current () in - if Config.is_activated state.config.sections.methods then + if Config.must_report_section state.config.sections.methods then f x else () diff --git a/src/deadType.ml b/src/deadType.ml index 5a2d444b..1a3b99be 100644 --- a/src/deadType.ml +++ b/src/deadType.ml @@ -179,7 +179,7 @@ let report () = let wrap f x = let state = State.get_current () in - if Config.is_activated state.config.sections.types then + if Config.must_report_section state.config.sections.types then f x else () diff --git a/src/state/state.mli b/src/state/state.mli index 0a3362ec..f9c0bd28 100644 --- a/src/state/state.mli +++ b/src/state/state.mli @@ -8,13 +8,13 @@ type t = } val init : Config.t -> t -(** [init config] initial for an analysis configured by [config] *) +(** [init config] initial state for an analysis configured by [config] *) val update_config : Config.t -> t -> t (** [update_config config state] changes the analysis configuration *) val change_file : t -> string -> (t, string) result -(** [cahnge_file t cmti_file] prepare the analysis to move on to [cmti_file]. +(** [change_file t cmti_file] prepare the analysis to move on to [cmti_file]. See [File_infos.change_file] for error cases. *) val get_current : unit -> t diff --git a/src/utils.ml b/src/utils.ml index dced0d6f..cf66a239 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -8,3 +8,4 @@ let remove_pp fn = let unit fn = Filename.remove_extension (Filename.basename fn) +module StringSet = Set.Make(String) diff --git a/src/utils.mli b/src/utils.mli index c99557e9..ce4b30e9 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -1,3 +1,5 @@ val remove_pp : string -> string val unit : string -> string + +module StringSet : Set.S with type elt = String.t