diff --git a/src/config/config.ml b/src/config/config.ml index ce0dd485..99139184 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -25,6 +25,7 @@ type t = ; excluded_paths : Utils.StringSet.t ; references_paths : Utils.StringSet.t ; sections : Sections.t + ; lexifi : bool } let default_config = @@ -35,6 +36,7 @@ let default_config = ; excluded_paths = Utils.StringSet.empty ; references_paths = Utils.StringSet.empty ; sections = Sections.default + ; lexifi = false } let must_report_main config = @@ -76,6 +78,8 @@ let set_underscore config = {config with underscore = true} let set_internal config = {config with internal = true} +let set_lexifi config = {config with lexifi = true} + let normalize_path path = (* remove redundant "." and consecutive dir_sep in path. @@ -234,6 +238,10 @@ let parse_cli () = " Enable/Disable unused constructors/records fields warnings.\n \ See option -E for the syntax of " + ; "--lexifi", + Unit (update_config_unit set_lexifi), + " Use lexifi's internal extension" + ] ( update_config add_path_to_analyze diff --git a/src/config/config.mli b/src/config/config.mli index 5daa27cd..53ee03eb 100644 --- a/src/config/config.mli +++ b/src/config/config.mli @@ -29,6 +29,7 @@ type t = private ; references_paths : Utils.StringSet.t (** Cmi and cmt filepaths to explore for references only *) ; sections : Sections.t (** Config for the different report sections *) + ; lexifi : bool (** Use lexifi's extension *) } val default_config : t diff --git a/src/deadCode.ml b/src/deadCode.ml index faaf0fa4..600f221b 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -700,6 +700,7 @@ let () = try let config = Config.parse_cli () in let state = State.init config in + if config.lexifi then DeadLexiFi.set_hooks (); let state = run_analysis state in let run_on_references_only state = DeadCommon.declarations := false; diff --git a/src/deadCommon.ml b/src/deadCommon.ml index 7db05bac..bb2fefb9 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -530,35 +530,3 @@ let report_basic ?folder decs title (flag: Config.Sections.main_section) = report s ~opt:(state.config.sections.opta) l continue nb_call pretty_print reportn in reportn 0 - - (******** LEXIFI SPECIALS ********) - -module DeadLexiFi = struct -(* .^. - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - .^. *) -(* / ! \ DO NOT DELETE UNLESS YOU CAN COMPILE WITH `make lexifi' AND YOU KNOW WHAT YOU ARE DOING / ! \ *) -(* /_____\ /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ /_____\ *) - - (* The following hooks are pointing LexiFi's extensions if compiled with `make lexifi'. - * They stay as following otherwise *) - - let sig_value : (Types.value_description -> unit) ref = - ref (fun _ -> ()) - - let export_type : (Lexing.position -> string -> unit) ref = - ref (fun _ _ -> ()) - - let type_ext : (Typedtree.core_type -> unit) ref = - ref (fun _ -> ()) - - let type_decl : (Typedtree.type_declaration -> unit) ref = - ref (fun _ -> ()) - - let tstr_type : (Typedtree.type_declaration -> string -> unit) ref = - ref (fun _ _ -> ()) - - let ttype_of : (Typedtree.expression -> unit) ref = - ref (fun _ -> ()) - - let prepare_report : ((Lexing.position, string * string) Hashtbl.t -> unit) ref = - ref (fun _ -> ()) -end diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index 2fd31876..8b06f971 100644 --- a/src/deadLexiFi.ml +++ b/src/deadLexiFi.ml @@ -7,168 +7,172 @@ (* *) (***************************************************************************) -(** Extensions internally used at LexiFi. *) +module Default = struct + let sig_value _ = () + let export_type _ _ = () + let type_ext _ = () + let type_decl _ = () + let tstr_type _ _ = () + let ttype_of _ = () + let prepare_report _ = () +end -(* .^. - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - .^. *) -(* / ! \ DO NOT DELETE UNLESS YOU CAN COMPILE WITH `make lexifi' AND YOU KNOW WHAT YOU ARE DOING / ! \ *) -(* /_____\ /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ - /!\ /_____\ *) +let sig_value = ref Default.sig_value +let export_type = ref Default.export_type +let type_ext = ref Default.type_ext +let type_decl = ref Default.type_decl +let tstr_type = ref Default.tstr_type +let ttype_of = ref Default.ttype_of +let prepare_report = ref Default.prepare_report -open Parsetree -open Types -open Typedtree +(** Extensions used internally at LexiFi. *) +module Extension = struct -open DeadCommon + open Parsetree + open Types + open Typedtree + open DeadCommon (******** ATTRIBUTES ********) -let dyn_rec = ref [] (* Record names used for dynamic typing and locations of those uses *) -let str = Hashtbl.create 256 -let used = ref [] - -let field_link = Hashtbl.create 256 -let dyn_used = Hashtbl.create 256 - - - -let () = - - DeadLexiFi.sig_value := - (fun value -> - let add strct = match strct.pstr_desc with - | Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _}, _) -> - hashtbl_add_unique_to_list str s value.val_loc.loc_start - | _ -> () - in - let add = function - | {attr_name = {txt = "mlfi.value_approx"; _}; attr_payload = PStr structure; _} -> - List.iter add structure - | _ -> () + let dyn_rec = ref [] (* Record names used for dynamic typing and locations of those uses *) + let str = Hashtbl.create 256 + let used = ref [] + + let field_link = Hashtbl.create 256 + let dyn_used = Hashtbl.create 256 + + let sig_value (value : Types.value_description) = + let add strct = match strct.pstr_desc with + | Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _}, _) -> + hashtbl_add_unique_to_list str s value.val_loc.loc_start + | _ -> () + in + let add = function + | {attr_name = {txt = "mlfi.value_approx"; _}; attr_payload = PStr structure; _} -> + List.iter add structure + | _ -> () + in + List.iter add value.val_attributes + + let type_ext ct = + (* TO CHECK *) + List.iter + (fun {attr_name = {txt; _}; _} -> + used := (txt, ct.ctyp_loc.loc_start) :: !used; + ) + ct.ctyp_attributes + + let type_decl td = + List.iter + (fun {attr_name = {txt; _}; _} -> + used := (txt, td.typ_loc.loc_start) :: !used; + ) + td.typ_type.type_attributes + + let tstr_type typ ctype = + let state = State.get_current () in + let modname = State.File_infos.get_modname state.file_infos in + let path = + let partial_path_rev = + typ.typ_name.Asttypes.txt :: !mods in - List.iter add value.val_attributes - ); - - - DeadLexiFi.type_ext := - (fun ct -> - (* TO CHECK *) - List.iter - (fun {attr_name = {txt; _}; _} -> - used := (txt, ct.ctyp_loc.loc_start) :: !used; - ) - ct.ctyp_attributes - ); - - DeadLexiFi.type_decl := - (fun td -> - List.iter - (fun {attr_name = {txt; _}; _} -> - used := (txt, td.typ_loc.loc_start) :: !used; - ) - td.typ_type.type_attributes - ); - - - DeadLexiFi.tstr_type := - (fun typ ctype -> - let state = State.get_current () in - let modname = State.File_infos.get_modname state.file_infos in - let path = - let partial_path_rev = - typ.typ_name.Asttypes.txt :: !mods - in - modname :: List.rev partial_path_rev - |> String.concat "." + modname :: List.rev partial_path_rev + |> String.concat "." + in + let is_user_defined s = + let l = [_variant; "bool"; "float"; "int"; "string"; "unit"] in + let mod_name = + 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 s 0 0 in - let is_user_defined s = - let l = [_variant; "bool"; "float"; "int"; "string"; "unit"] in - let mod_name = - 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 s 0 0 - in - not (String.contains s ' ') - && (s <> String.capitalize_ascii s && not (List.mem s l) - || String.contains s '.' && mod_name <> "Pervasives") - in - if is_user_defined ctype then - hashtbl_add_to_list field_link path ctype - ); - - - DeadLexiFi.ttype_of := - (fun e -> - let state = State.get_current () in - let modname = State.File_infos.get_modname state.file_infos in - let name = - List.rev (modname :: !mods) - |> String.concat "." - in - let call_site = - if e.exp_loc.Location.loc_ghost then !last_loc - else e.exp_loc.Location.loc_start - in - dyn_rec := (name, e.exp_type, call_site) :: !dyn_rec - ); - - - DeadLexiFi.prepare_report := - (fun decs -> - let state = State.get_current () in - let sections = state.config.sections in - List.iter - (fun (strin, pos) -> - hashtbl_find_list str strin - |> List.iter - (fun loc -> - if exported sections.exported_values loc then - LocHash.add_set references loc pos - ) - ) - !used; - let rec process (p, typ, call_site) = - match get_deep_desc typ with - | Tarrow (_, t, _, _) -> process (p, t, call_site) - | Ttuple ts -> List.iter (fun t -> process (p, t, call_site)) ts - | Tconstr (path, ts, _) -> - let name = Path.name path in - let name = - if String.contains name '.' then name - else p ^ "." ^ name - in - let met = ref [] in - let rec proc name = - if not (List.mem name !met) then begin - met := name :: !met; - name :: List.fold_left (fun acc name -> acc @ (proc name)) [] (hashtbl_find_list field_link name) - end - else [] - in - List.iter - (fun typ -> - hashtbl_add_to_list dyn_used typ call_site - ) - (proc name); - List.iter (fun t -> process (p, t, call_site)) ts - | _ -> () - in - List.iter process !dyn_rec; - Hashtbl.iter - (fun loc (_, path) -> - let rec get_type s pos = - if pos = 0 then s - else if s.[pos] = '.' then String.sub s 0 pos - else get_type s (pos - 1) + not (String.contains s ' ') + && (s <> String.capitalize_ascii s && not (List.mem s l) + || String.contains s '.' && mod_name <> "Pervasives") + in + if is_user_defined ctype then + hashtbl_add_to_list field_link path ctype + + let ttype_of e = + let state = State.get_current () in + let modname = State.File_infos.get_modname state.file_infos in + let name = + List.rev (modname :: !mods) + |> String.concat "." + in + let call_site = + if e.exp_loc.Location.loc_ghost then !last_loc + else e.exp_loc.Location.loc_start + in + dyn_rec := (name, e.exp_type, call_site) :: !dyn_rec + + let prepare_report decs = + let state = State.get_current () in + let sections = state.config.sections in + List.iter + (fun (strin, pos) -> + hashtbl_find_list str strin + |> List.iter + (fun loc -> + if exported sections.exported_values loc then + LocHash.add_set references loc pos + ) + ) + !used; + let rec process (p, typ, call_site) = + match get_deep_desc typ with + | Tarrow (_, t, _, _) -> process (p, t, call_site) + | Ttuple ts -> List.iter (fun t -> process (p, t, call_site)) ts + | Tconstr (path, ts, _) -> + let name = Path.name path in + let name = + if String.contains name '.' then name + else p ^ "." ^ name + in + let met = ref [] in + let rec proc name = + if not (List.mem name !met) then begin + met := name :: !met; + name :: List.fold_left (fun acc name -> acc @ (proc name)) [] (hashtbl_find_list field_link name) + end + else [] in List.iter - ( if exported ~is_type:true sections.types loc then LocHash.add_set references loc - else ignore + (fun typ -> + hashtbl_add_to_list dyn_used typ call_site ) - (hashtbl_find_list dyn_used (get_type path (String.length path - 1))) - ) - decs - ); + (proc name); + List.iter (fun t -> process (p, t, call_site)) ts + | _ -> () + in + List.iter process !dyn_rec; + Hashtbl.iter + (fun loc (_, path) -> + let rec get_type s pos = + if pos = 0 then s + else if s.[pos] = '.' then String.sub s 0 pos + else get_type s (pos - 1) + in + List.iter + ( 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))) + ) + decs + +end + +let set_hooks () = + sig_value := Extension.sig_value; + type_ext := Extension.type_ext; + type_decl := Extension.type_decl; + tstr_type := Extension.tstr_type; + ttype_of := Extension.ttype_of; + prepare_report := Extension.prepare_report diff --git a/src/deadLexiFi.mli b/src/deadLexiFi.mli new file mode 100644 index 00000000..78fb06a5 --- /dev/null +++ b/src/deadLexiFi.mli @@ -0,0 +1,16 @@ +val sig_value : (Types.value_description -> unit) ref + +val export_type : (Lexing.position -> string -> unit) ref + +val type_ext : (Typedtree.core_type -> unit) ref + +val type_decl : (Typedtree.type_declaration -> unit) ref + +val tstr_type : (Typedtree.type_declaration -> string -> unit) ref + +val ttype_of : (Typedtree.expression -> unit) ref + +val prepare_report : ((Lexing.position, string * string) Hashtbl.t -> unit) ref + +val set_hooks : unit -> unit +(** Sets the extensions used internally at LexiFi. *)