diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index ef09077..190eb0a 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -25,7 +25,7 @@ jobs: - name: Set-up OCaml uses: ocaml/setup-ocaml@v3 with: - ocaml-compiler: "5.2" + ocaml-compiler: "5.3" - run: opam install . --deps-only --with-test @@ -45,7 +45,7 @@ jobs: - name: Set-up OCaml uses: ocaml/setup-ocaml@v3 with: - ocaml-compiler: "5.2" + ocaml-compiler: "5.3" - uses: ocaml/setup-ocaml/lint-doc@v3 lint-opam: @@ -56,5 +56,5 @@ jobs: - name: Set-up OCaml uses: ocaml/setup-ocaml@v3 with: - ocaml-compiler: "5.2" + ocaml-compiler: "5.3" - uses: ocaml/setup-ocaml/lint-opam@v3 diff --git a/README.md b/README.md index a02f486..237c7f0 100644 --- a/README.md +++ b/README.md @@ -7,7 +7,7 @@ Dead-code analyzer for OCaml ## Overview The tool assumes that **.mli** files are compiled with **-keep-locs** and **.ml** -files with **-bin-annot**. Exported values are collected by reading .cmi or .cmt +files with **-bin-annot**. Exported values are collected by reading .cmti or .cmt files (depending on the existence of an explicit .mli interface). References to such values are collected by reading typed trees from .cmt files @@ -38,7 +38,7 @@ For more information, see [the documentation](docs/USER_DOC.md) ## Requirements -- Currently tested and working on **OCaml 5.2** +- Currently tested and working on **OCaml 5.3** ## Install diff --git a/check/classic/classic.ref b/check/classic/classic.ref index e6452e5..bc6999b 100644 --- a/check/classic/classic.ref +++ b/check/classic/classic.ref @@ -167,9 +167,9 @@ Nothing else to report in this section .> UNUSED CONSTRUCTORS/RECORD FIELDS: ==================================== -./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused -./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused -./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused +./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused: Not detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:25: constructors.Unused ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:30: constr_with_eq.Unused ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:39: record.unused @@ -534,6 +534,6 @@ Nothing else to report in this section Total: 460 -Success: 460 -Failed: 0 -Ratio: 100.% +Success: 457 +Failed: 3 +Ratio: 99.347826087% diff --git a/check/internal/internal.ref b/check/internal/internal.ref index ef171b0..34c097b 100644 --- a/check/internal/internal.ref +++ b/check/internal/internal.ref @@ -1,6 +1,7 @@ .> UNUSED EXPORTED VALUES: ========================= ./examples/using_dune/preprocessed_lib/preprocessed.mli:1: unused +./examples/using_dune/preprocessed_lib/preprocessed.mli:3: internally_used: Should not be detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:2: unused ./examples/using_dune/unwrapped_lib/opt_args/opt_args.mli:1: unused_fun_with_single_never_used_opt_arg @@ -135,9 +136,9 @@ Nothing else to report in this section .> UNUSED CONSTRUCTORS/RECORD FIELDS: ==================================== -./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused -./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused -./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused +./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused: Not detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:25: constructors.Unused ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:30: constr_with_eq.Unused ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:39: record.unused @@ -501,7 +502,7 @@ Nothing else to report in this section -------------------------------------------------------------------------------- -Total: 430 -Success: 430 -Failed: 0 -Ratio: 100.% +Total: 431 +Success: 427 +Failed: 4 +Ratio: 99.0719257541% diff --git a/check/threshold-1/threshold-1.ref b/check/threshold-1/threshold-1.ref index 1ef3c2f..da07c7d 100644 --- a/check/threshold-1/threshold-1.ref +++ b/check/threshold-1/threshold-1.ref @@ -1,6 +1,7 @@ .> UNUSED EXPORTED VALUES: ========================= ./examples/using_dune/preprocessed_lib/preprocessed.mli:1: unused +./examples/using_dune/preprocessed_lib/preprocessed.mli:3: internally_used: Should not be detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:2: unused ./examples/using_dune/unwrapped_lib/opt_args/opt_args.mli:1: unused_fun_with_single_never_used_opt_arg @@ -103,8 +104,10 @@ ./examples/using_dune/bin/use_wrapped_lib/use_without_class.mli:1: mark_used ./examples/using_dune/bin/use_wrapped_lib/use_wrapped_lib.mli:1: mark_used -./examples/using_dune/preprocessed_lib/preprocessed.mli:3: internally_used +./examples/using_dune/preprocessed_lib/preprocessed.mli:2: used: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:3: internally_used: Not detected ./examples/using_dune/preprocessed_lib/preprocessed.mli:4: externally_used +./examples/using_dune/preprocessed_lib/preprocessed.mli:31: f: Should not be detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:4: internally_used ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:5: externally_used @@ -369,9 +372,9 @@ Nothing else to report in this section .> UNUSED CONSTRUCTORS/RECORD FIELDS: ==================================== -./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused -./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused -./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused +./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused: Not detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:25: constructors.Unused ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:30: constr_with_eq.Unused ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:39: record.unused @@ -441,10 +444,13 @@ Nothing else to report in this section .>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called 1 time(s): ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -./examples/using_dune/preprocessed_lib/preprocessed.mli:16: constructors.Internally_used -./examples/using_dune/preprocessed_lib/preprocessed.mli:17: constructors.Externally_used -./examples/using_dune/preprocessed_lib/preprocessed.mli:25: record.internally_used -./examples/using_dune/preprocessed_lib/preprocessed.mli:26: record.externally_used +./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:16: constructors.Internally_used: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:17: constructors.Externally_used: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:25: record.internally_used: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:26: record.externally_used: Not detected ./examples/using_dune/preprocessed_lib/preprocessed.mli:29: record_with_eq.implicitly_used ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:27: constructors.Internally_used ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:28: constructors.Externally_used @@ -809,7 +815,7 @@ Nothing else to report in this section -------------------------------------------------------------------------------- -Total: 701 -Success: 701 -Failed: 0 -Ratio: 100.% +Total: 707 +Success: 693 +Failed: 14 +Ratio: 98.0198019802% diff --git a/check/threshold-3-0.5/threshold-3-0.5.ref b/check/threshold-3-0.5/threshold-3-0.5.ref index 60e2afc..fcc40be 100644 --- a/check/threshold-3-0.5/threshold-3-0.5.ref +++ b/check/threshold-3-0.5/threshold-3-0.5.ref @@ -1,6 +1,7 @@ .> UNUSED EXPORTED VALUES: ========================= ./examples/using_dune/preprocessed_lib/preprocessed.mli:1: unused +./examples/using_dune/preprocessed_lib/preprocessed.mli:3: internally_used: Should not be detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:2: unused ./examples/using_dune/unwrapped_lib/opt_args/opt_args.mli:1: unused_fun_with_single_never_used_opt_arg @@ -103,8 +104,10 @@ ./examples/using_dune/bin/use_wrapped_lib/use_without_class.mli:1: mark_used ./examples/using_dune/bin/use_wrapped_lib/use_wrapped_lib.mli:1: mark_used -./examples/using_dune/preprocessed_lib/preprocessed.mli:3: internally_used +./examples/using_dune/preprocessed_lib/preprocessed.mli:2: used: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:3: internally_used: Not detected ./examples/using_dune/preprocessed_lib/preprocessed.mli:4: externally_used +./examples/using_dune/preprocessed_lib/preprocessed.mli:31: f: Should not be detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:4: internally_used ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:5: externally_used @@ -239,8 +242,9 @@ .>-> ALMOST UNUSED EXPORTED VALUES: Called 2 time(s): ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -./examples/using_dune/preprocessed_lib/preprocessed.mli:2: used -./examples/using_dune/preprocessed_lib/preprocessed.mli:31: f +./examples/using_dune/preprocessed_lib/preprocessed.mli:2: used: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:31: f: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:6: immediate: Should not be detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:3: used ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:53: f @@ -515,9 +519,9 @@ Nothing else to report in this section .> UNUSED CONSTRUCTORS/RECORD FIELDS: ==================================== -./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused -./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused -./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused +./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused: Not detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:25: constructors.Unused ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:30: constr_with_eq.Unused ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:39: record.unused @@ -587,10 +591,13 @@ Nothing else to report in this section .>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called 1 time(s): ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -./examples/using_dune/preprocessed_lib/preprocessed.mli:16: constructors.Internally_used -./examples/using_dune/preprocessed_lib/preprocessed.mli:17: constructors.Externally_used -./examples/using_dune/preprocessed_lib/preprocessed.mli:25: record.internally_used -./examples/using_dune/preprocessed_lib/preprocessed.mli:26: record.externally_used +./examples/using_dune/preprocessed_lib/preprocessed.mli:14: constructors.Unused: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:16: constructors.Internally_used: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:17: constructors.Externally_used: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:19: constr_with_eq.Unused: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:23: record.unused: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:25: record.internally_used: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:26: record.externally_used: Not detected ./examples/using_dune/preprocessed_lib/preprocessed.mli:29: record_with_eq.implicitly_used ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:27: constructors.Internally_used ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:28: constructors.Externally_used @@ -661,8 +668,12 @@ Nothing else to report in this section .>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called 2 time(s): ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -./examples/using_dune/preprocessed_lib/preprocessed.mli:15: constructors.Used -./examples/using_dune/preprocessed_lib/preprocessed.mli:24: record.used +./examples/using_dune/preprocessed_lib/preprocessed.mli:15: constructors.Used: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:16: constructors.Internally_used: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:17: constructors.Externally_used: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:24: record.used: Not detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:25: record.internally_used: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:26: record.externally_used: Should not be detected ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:26: constructors.Used ./examples/using_dune/preprocessed_lib/preprocessed_no_intf.ml:40: record.used @@ -699,11 +710,14 @@ Nothing else to report in this section -------- - Nothing else to report in this section -------------------------------------------------------------------------------- - - +.>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called 3 time(s): +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +./examples/using_dune/preprocessed_lib/preprocessed.mli:15: constructors.Used: Should not be detected +./examples/using_dune/preprocessed_lib/preprocessed.mli:24: record.used: Should not be detected +Nothing else to report in this section +-------------------------------------------------------------------------------- .> OPTIONAL ARGUMENTS: ALWAYS: ============================= ./examples/using_dune/preprocessed_lib/preprocessed.ml:53: ?always @@ -920,7 +934,6 @@ Nothing else to report in this section ./examples/using_make/dir/matchopt.ml:1: ?x (3/4 calls) ./examples/using_make/dir/ref_fn.ml:1: ?a (2/3 calls) ./examples/using_make/dir/ref_fn.ml:1: ?b (2/3 calls) - ./examples/using_make/matchopt.ml:1: ?x (3/4 calls) ./examples/using_make/opt/sig_struct.ml:2: ?x (2/3 calls) @@ -1107,6 +1120,7 @@ Nothing else to report in this section ./examples/using_make/dir/anonFn2.mli:1: ?b (2/3 calls) ./examples/using_make/dir/matchopt.ml:1: ?y (3/4 calls) ./examples/using_make/dir/matchopt.ml:1: ?z (3/4 calls) + ./examples/using_make/let_in.ml:1: ?b (2/3 calls) ./examples/using_make/matchopt.ml:1: ?y (3/4 calls) ./examples/using_make/matchopt.ml:1: ?z (3/4 calls) @@ -1168,7 +1182,7 @@ Nothing else to report in this section -------------------------------------------------------------------------------- -Total: 988 -Success: 988 -Failed: 0 -Ratio: 100.% +Total: 1001 +Success: 976 +Failed: 25 +Ratio: 97.5024975025% diff --git a/dead_code_analyzer.opam b/dead_code_analyzer.opam index 42d2f78..9465274 100644 --- a/dead_code_analyzer.opam +++ b/dead_code_analyzer.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "1.0.0" +version: "1.0.1" synopsis: "Dead code analyzer for OCaml" maintainer: [ "Alain Frisch " @@ -15,7 +15,7 @@ homepage: "https://github.com/LexiFi/dead_code_analyzer" bug-reports: "https://github.com/LexiFi/dead_code_analyzer/issues" depends: [ "dune" {>= "3.20"} - "ocaml" {>= "5.2" & < "5.3"} + "ocaml" {>= "5.3" & < "5.4"} "odoc" {with-doc} ] build: [ diff --git a/docs/USAGE.md b/docs/USAGE.md index 2969ca1..c884e43 100644 --- a/docs/USAGE.md +++ b/docs/USAGE.md @@ -24,9 +24,9 @@ Calling `dead_code_analyzer --help` provides the following output, describing the main command line aspect, different options available and their effects. -The `` argument is any number of directory, `.cmt` and `.cmi` files. +The `` argument is any number of directory, `.cmt` and `.cmti` files. These files can be produced using the compiler flags `-keep-locs` (on by default) -for `.cmi` and `-bin-annot` for `.cmt`. +for `.cmti` and `-bin-annot` for `.cmt`. The directories are traversed looking for such files. > [!TIP] > If you are using `dune` for your project, the files can be obtained via the @@ -190,15 +190,15 @@ the development. ``` src ├── debug -│   ├── debug.cmi +│   ├── debug.cmti │   ├── debug.cmt │   └── debug.ml -├── foo.cmi +├── foo.cmti ├── foo.cmt ├── foo.ml ├── foo.mli └── lib - ├── lib.cmi + ├── lib.cmti ├── lib.cmt ├── lib.ml └── lib.mli @@ -306,9 +306,9 @@ the file and moves on. - If a file is ignored and it is not obvious why, then opening an issue is welcome. -- If no file is ignored, check that no file is missing. There should be a `.cmi` +- If no file is ignored, check that no file is missing. There should be a `.cmti` and a `.cmt` file for each expected ``. -- If no `.cmi` or `.cmt` file is missing then the false negatives must be due +- If no `.cmti` or `.cmt` file is missing then the false negatives must be due to limitations of the tool and opening an issue is welcome. ## Thresholds diff --git a/dune-project b/dune-project index 035f9ac..a77403a 100644 --- a/dune-project +++ b/dune-project @@ -4,7 +4,7 @@ (generate_opam_files true) -(version 1.0.0) +(version 1.0.1) (maintainers "Alain Frisch " @@ -22,6 +22,6 @@ (synopsis "Dead code analyzer for OCaml") (license MIT) (depends - (ocaml (and (>= 5.2) (< 5.3))) + (ocaml (and (>= 5.3) (< 5.4))) ) ) diff --git a/src/deadCode.ml b/src/deadCode.ml index 8a87659..4504bf3 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -50,7 +50,7 @@ let rec collect_export ?(mod_type = false) path u stock = function | Sig_modtype (id, {Types.mtd_type = Some t; _}, _)) as s -> let collect = match s with Sig_modtype _ -> mod_type | _ -> true in if collect then - DeadMod.sign t + Utils.signature_of_modtype t |> List.iter (collect_export ~mod_type (id :: path) u stock) | _ -> () @@ -64,8 +64,12 @@ let rec treat_exp exp args = | Texp_field (_, _, {lbl_loc = {Location.loc_start = loc; _}; _}) -> DeadArg.register_uses loc args - | Texp_match (_, l, _) -> - List.iter (fun {c_rhs = exp; _} -> treat_exp exp args) l + | Texp_match (_, comp_l, val_l, _) -> + let process_cases l = + List.iter (fun {c_rhs = exp; _} -> treat_exp exp args) l + in + process_cases comp_l; + process_cases val_l | Texp_ifthenelse (_, exp_then, exp_else) -> treat_exp exp_then args; @@ -141,9 +145,9 @@ let structure_item super self i = in let rec includ mod_expr = match mod_expr.mod_desc with - | Tmod_ident (_, _) -> collect_include (DeadMod.sign mod_expr.mod_type) + | Tmod_ident (_, _) -> collect_include (Utils.signature_of_modtype mod_expr.mod_type) | Tmod_structure structure -> collect_include structure.str_type - | Tmod_unpack (_, mod_type) -> collect_include (DeadMod.sign mod_type) + | Tmod_unpack (_, mod_type) -> collect_include (Utils.signature_of_modtype mod_type) | Tmod_functor (_, mod_expr) | Tmod_apply (_, mod_expr, _) | Tmod_apply_unit mod_expr @@ -247,7 +251,7 @@ let expr super self e = "let () = ... in ... (=> use sequence)" end - | Texp_match (_, [{c_lhs; _}], _) + | Texp_match (_, [{c_lhs; _}], [], _) when DeadType.is_unit c_lhs.pat_type && !DeadFlag.style.DeadFlag.seq -> begin match c_lhs.pat_desc with | Tpat_value tpat_arg -> @@ -331,8 +335,11 @@ let kind fn = `Ignore end else if DeadFlag.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 + else if Filename.check_suffix fn ".cmti" then `Cmti + else if Filename.check_suffix fn ".cmt" then + let cmti = Filename.remove_extension fn ^ ".cmti" in + if Sys.file_exists cmti then `Cmt_with_mli + else `Cmt_without_mli else `Ignore @@ -343,31 +350,27 @@ let regabs state = hashtbl_add_unique_to_list main_files (Utils.unit fn) () -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 - then - let u = - if State.File_infos.has_sourcepath state.file_infos then - State.File_infos.get_sourceunit state.file_infos - else - Utils.unit fn - in - let module_id = - State.File_infos.get_modname state.file_infos - |> Ident.create_persistent - in - let f = - collect_export [module_id] u decs - in - List.iter f cmi_infos.cmi_sign; - last_loc := Lexing.dummy_pos - with Cmi_format.Error (Wrong_version_interface _) -> - (*Printf.eprintf "cannot read cmi file: %s\n%!" fn;*) - bad_files := fn :: !bad_files +let read_interface fn signature state = + regabs state; + if !DeadFlag.exported.DeadFlag.print + || !DeadFlag.obj.DeadFlag.print + || !DeadFlag.typ.DeadFlag.print + then + let u = + if State.File_infos.has_sourcepath state.file_infos then + State.File_infos.get_sourceunit state.file_infos + else + Utils.unit fn + in + let module_id = + State.File_infos.get_modname state.file_infos + |> Ident.create_persistent + in + let f = + collect_export [module_id] u decs + in + List.iter f signature; + last_loc := Lexing.dummy_pos (* Merge a location's references to another one's *) @@ -441,58 +444,58 @@ let rec load_file state fn = (* TODO: stateful computations should take and return the state when possible *) state in + let add_bad_file err fn = + if !DeadFlag.verbose then + Printf.eprintf "%s\n%!" err; + bad_files := fn :: !bad_files + in + let process_interface fn = + last_loc := Lexing.dummy_pos; + if !DeadFlag.verbose then Printf.eprintf "Scanning interface from %s\n%!" fn; + init_and_continue state fn (fun state -> + match state.file_infos.cmi_sign with + | None -> add_bad_file "Missing cmi_sign" fn + | Some cmi_sign -> + read_interface fn cmi_sign state + ) + in + let process_implementation fn = + last_loc := Lexing.dummy_pos; + if !DeadFlag.verbose then Printf.eprintf "Scanning implementation from %s\n%!" fn; + init_and_continue state fn (fun state -> + match state.file_infos.cmt_struct with + | None -> add_bad_file "Missing cmt_struct" fn + | Some structure -> + regabs state; + let prepare (loc1, loc2) = + DeadObj.add_equal loc1 loc2; + VdNode.merge_locs ~force:true loc2 loc1 + in + List.iter prepare state.file_infos.location_dependencies; + collect_references.Tast_mapper.structure collect_references structure + |> ignore; + let loc_dep = + if !DeadFlag.exported.DeadFlag.print then + state.file_infos.location_dependencies + else [] + in + eof loc_dep + ) + in match kind fn with - | `Cmi when !DeadCommon.declarations -> - last_loc := Lexing.dummy_pos; - if !DeadFlag.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 ? *) - | Some cmi_infos -> read_interface fn cmi_infos state - ) - - | `Cmt -> - let open Cmt_format in - last_loc := Lexing.dummy_pos; - if !DeadFlag.verbose then Printf.eprintf "Scanning %s\n%!" fn; - init_and_continue state fn (fun state -> - regabs state; - match state.file_infos.cmt_infos with - | None -> bad_files := fn :: !bad_files - | Some {cmt_annots = Implementation x; cmt_value_dependencies; _} -> - let prepare = function - | {Types.val_loc = {Location.loc_start = loc1; loc_ghost = false; _}; _}, - {Types.val_loc = {Location.loc_start = loc2; loc_ghost = false; _}; _} -> - DeadObj.add_equal loc1 loc2; - VdNode.merge_locs ~force:true loc2 loc1 - | _ -> () - in - List.iter prepare cmt_value_dependencies; - - ignore (collect_references.Tast_mapper.structure collect_references x); - - let loc_dep = - if !DeadFlag.exported.DeadFlag.print then - List.rev_map - (fun (vd1, vd2) -> - (vd1.Types.val_loc.Location.loc_start, vd2.Types.val_loc.Location.loc_start) - ) - cmt_value_dependencies - else [] - in - eof loc_dep - | _ -> () (* todo: support partial_implementation? *) - ) - + | `Cmti when !DeadCommon.declarations -> process_interface fn + | `Cmt_with_mli -> process_implementation fn + | `Cmt_without_mli -> + let _state = process_interface fn in + process_implementation fn | `Dir -> let next = Sys.readdir fn in - Array.sort compare next; + Array.sort (fun f1 f2 -> compare f2 f1) next; Array.fold_left (fun state s -> load_file state (fn ^ "/" ^ s)) state next (* else Printf.eprintf "skipping directory %s\n" fn *) - | _ -> state diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index 68b48c0..9621e15 100644 --- a/src/deadLexiFi.ml +++ b/src/deadLexiFi.ml @@ -38,7 +38,8 @@ let () = DeadLexiFi.sig_value := (fun value -> let add strct = match strct.pstr_desc with - | Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _}, _) -> + | Pstr_eval ({pexp_desc = Pexp_constant {pconst_desc= (Pconst_string (s, _, _)); _}; + _}, _) -> hashtbl_add_unique_to_list str s value.val_loc.loc_start | _ -> () in diff --git a/src/deadMod.ml b/src/deadMod.ml index 33a1679..fc10813 100644 --- a/src/deadMod.ml +++ b/src/deadMod.ml @@ -16,14 +16,6 @@ open DeadCommon let defined : string list ref = ref [] - -let rec sign ?(select_param = false) = function - | Mty_signature sg -> sg - | Mty_functor (_, t) when not select_param -> sign t - | Mty_functor (Named (_, t), _) -> sign t - | _ -> [] - - let item maker = function | Sig_value (id, {val_loc = {Location.loc_start= loc; _}; _}, _) -> (Ident.name id, loc)::[] @@ -52,12 +44,12 @@ let item maker = function | _ -> [] let rec make_content typ = - List.map (item make_content) (sign typ) + List.map (item make_content) (Utils.signature_of_modtype typ) |> List.flatten let rec make_arg typ = - List.map (item make_arg) (sign ~select_param:true typ) + List.map (item make_arg) (Utils.signature_of_modtype ~select_param:true typ) |> List.flatten diff --git a/src/state/file_infos.ml b/src/state/file_infos.ml index 19c4948..c96d8ad 100644 --- a/src/state/file_infos.ml +++ b/src/state/file_infos.ml @@ -1,199 +1,152 @@ type t = { - cmti_file : string; - sourcepath : string option; - builddir : string option; + builddir : string; + cm_file : string; + cmi_sign : Types.signature option; + cmt_struct : Typedtree.structure option; + cmti_uid_to_decl : Location_dependencies.uid_to_decl option; + location_dependencies : Location_dependencies.t; modname : string; - cmi_infos : Cmi_format.cmi_infos option; - cmt_infos : Cmt_format.cmt_infos option; + sourcepath : string option; } let empty = { - cmti_file = ""; - sourcepath = None; - builddir = None; + builddir = "!!UNKNOWN_BUILDDIR!!"; + cm_file = ""; + cmi_sign = None; + cmt_struct = None; + cmti_uid_to_decl = None; + location_dependencies = Location_dependencies.empty; modname = "!!UNKNOWN_MODNAME!!"; - cmi_infos = None; - cmt_infos = None; + sourcepath = None; } -(** [init_from_cmt_infos cmt_infos cmt_file] creates a [t] with: - - information from [cmt_infos]; - - [cmti_file = cmt_file]; - - [cmt_infos = Some cmt_infos]. *) -let init_from_cmt_infos cmt_infos cmt_file = +(** [init_from_all_cm_infos ~cm_file ~cmi_infos cmt_infos] creates a [t] with: + - information from [cmt_infos] : [builddir], [modname], [sourcepath]; + - [cm_file]; + - [cmi_sign = Some cm_infos.cmi_sign] if [cmi_infos = Some _]; *) + let init_from_all_cm_infos ~cm_file ~cmi_infos cmt_infos = let builddir = cmt_infos.Cmt_format.cmt_builddir in let sourcepath = Option.map (Filename.concat builddir) cmt_infos.cmt_sourcefile in let modname = cmt_infos.cmt_modname in - {empty with cmti_file = cmt_file; - builddir = Some builddir; - sourcepath; + let cmi_sign = Option.map (fun Cmi_format.{cmi_sign; _} -> cmi_sign) cmi_infos in + {empty with builddir; + cm_file; + cmi_sign; modname; - cmt_infos = Some cmt_infos; - } + sourcepath} -(** [init_from_cmt cmt_file] returns an [Ok t] with [t] filled using - the [cmt_file] (see [init_from_cmt_infos]). +(** [init_from_cm_file cm_file] returns an [Ok t] with [t] filled with general + info expected for both cmt and cmti files, using the [cm_file] (see + [init_from_all_cm_infos]). In case the file does not exist or it cannot be read (see [Cmt_format.read_cmt]) then it returns an [Err msg] with msg a string describing the issue. *) -let init_from_cmt cmt_file = - if not (Sys.file_exists cmt_file) then Result.error (cmt_file ^ ": file not found") +let init_from_cm_file cm_file = + if not (Sys.file_exists cm_file) then Result.error (cm_file ^ ": file not found") else - try - let cmt_infos = Cmt_format.read_cmt cmt_file in - init_from_cmt_infos cmt_infos cmt_file - |> Result.ok - with _ -> Result.error (cmt_file ^ ": cannot read cmt file") - - -let sourcefname_of_cmi_infos cmi_unit cmi_infos = - let candidate_of_fname fname = - let src_unit = Utils.unit fname in - if String.equal src_unit cmi_unit then `Identical fname - else if String.ends_with ~suffix:src_unit cmi_unit then - `Suffix fname - else if String.starts_with ~prefix:src_unit cmi_unit then - `Prefix fname - else `Different fname + match Cmt_format.read cm_file with + | exception _ -> Result.error (cm_file ^ ": error reading file") + | _, None -> Result.error (cm_file ^ ": cmt_infos not found") + | cmi_infos, Some cmt_infos -> + let file_infos = + init_from_all_cm_infos ~cm_file ~cmi_infos cmt_infos + in + Result.ok (file_infos, cmt_infos) + +let ( let* ) x f = Result.bind x f +let ( let+ ) x f = Result.map f x + +let init_from_cmti_file cmti_file = + let+ file_infos, cmt_infos = init_from_cm_file cmti_file in + let cmti_uid_to_decl = Some cmt_infos.cmt_uid_to_decl in + {file_infos with cmti_uid_to_decl} + +let init_from_cmt_file cmt_file = + let* file_infos, cmt_infos = init_from_cm_file cmt_file in + let* cmt_struct = + match cmt_infos.cmt_annots with + | Implementation structure -> Result.ok structure + | _ -> Result.error (cmt_file ^ ": does not contain an implementation") in - let fname_of_candidate = function - | `Default -> None - | `Identical fname - | `Suffix fname - | `Prefix fname - | `Different fname -> Some fname + let cmt_struct = Some cmt_struct in + (* Read the cmti if it exists. We always want to do it in case a user + specified the cmt before the cmti to ensure the location_dependencies + are idempotent. *) + let cmti_uid_to_decl = + let cmti_file = Filename.remove_extension cmt_file ^ ".cmti" in + match init_from_cmti_file cmti_file with + | Error _ -> None + | Ok file_infos -> file_infos.cmti_uid_to_decl in - let get_item_loc (sig_item : Types.signature_item) = - match sig_item with - | Sig_value (_, {val_loc = loc; _}, _) - | Sig_type (_, {type_loc = loc; _}, _, _) - | Sig_typext (_, {ext_loc = loc; _}, _, _) - | Sig_module (_, _, {md_loc = loc; _}, _, _) - | Sig_modtype (_, {mtd_loc = loc; _}, _) - | Sig_class (_, {cty_loc = loc; _}, _, _) - | Sig_class_type (_, {clty_loc = loc; _}, _, _) -> - loc + let+ location_dependencies = + Location_dependencies.init cmt_infos cmti_uid_to_decl in - let rec find_sourcename candidate = function - | [] -> fname_of_candidate candidate - | sig_item::items -> - let loc = get_item_loc sig_item in - if loc.Location.loc_ghost then find_sourcename candidate items - else - let fname = loc.Location.loc_start.pos_fname in - match candidate, candidate_of_fname fname with - | _, `Default -> assert false - | (`Identical _ as candidate), _ - | _, (`Identical _ as candidate) -> - (* best candidate found *) - fname_of_candidate candidate - | `Default, candidate - | `Different _, candidate - | candidate, `Different _ - | `Prefix _, (`Suffix _ as candidate) - | (`Suffix _ as candidate), `Prefix _ - | _, candidate -> - find_sourcename candidate items + let file_infos = + {file_infos with cmt_struct; cmti_uid_to_decl; location_dependencies} in - find_sourcename `Default cmi_infos.Cmi_format.cmi_sign - -(** [init_from_cmi_infos ?with_cmt cmi_infos cmi_file] creates a [t] with: - - information from [cmt_infos]; - - [cmti_file = cmt_file]; - - [cmi_infos = Some cmi_infos]. - Because the [cmi_infos] is not as complete as [cmt_infos] (e.g. it does not - specify the [builddir]), an existing [t] filled using the correpsonding - [cmt_infos] can be passed as argument. In this case, information unavailable - in the [cmi_infos] is read from [with_cmt]. Otherwise, default values are - set for [builddir] and eventually [sourcepath]. *) -let init_from_cmi_infos ?with_cmt cmi_infos cmi_file = - let builddir = Option.bind with_cmt (fun {builddir; _} -> builddir) in - let sourcepath = - let unknown_sourcepath = - Option.bind with_cmt (fun {sourcepath; _} -> sourcepath) - in - let cmi_unit = Utils.unit cmi_file in - let sourcefname = sourcefname_of_cmi_infos cmi_unit cmi_infos in - match sourcefname, builddir with - | None, _ -> unknown_sourcepath - | Some _, None -> sourcefname - | Some fname, Some builddir -> Some (Filename.concat builddir fname) + file_infos, cmt_infos - in - let modname = cmi_infos.cmi_name in - {empty with cmti_file = cmi_file; - builddir; - sourcepath; - modname; - cmi_infos = Some cmi_infos; - } - -(** [init_from_cmi cmi_file] returns an [Ok t] with [t] filled using - the [cmi_file] (see [init_from_cmi_infos]). - In case the file does not exist or it cannot be read (see - [Cmi_format.read_cmi]) then it returns an [Err msg] with msg a string - describing the issue. *) -let init_from_cmi ?with_cmt cmi_file = - if not (Sys.file_exists cmi_file) then Result.error (cmi_file ^ ": file not found") - else - try - let cmi_infos = Cmi_format.read_cmi cmi_file in - init_from_cmi_infos ?with_cmt cmi_infos cmi_file - |> Result.ok - with _ -> Result.error (cmi_file ^ ": cannot read cmi file") - -let init cmti_file = - let no_ext = Filename.remove_extension cmti_file in - match Filename.extension cmti_file with - | ".cmi" -> - let with_cmt = init_from_cmt (no_ext ^ ".cmt") |> Result.to_option in - init_from_cmi ?with_cmt cmti_file +let init cm_file = + match Filename.extension cm_file with | ".cmt" -> - let with_cmi_infos with_cmt = - match init_from_cmi ~with_cmt (no_ext ^ ".cmi") with - | Error _ -> with_cmt - | Ok {cmi_infos; _} -> {with_cmt with cmi_infos} - in - init_from_cmt cmti_file |> Result.map with_cmi_infos - | _ -> Result.error (cmti_file ^ ": not a .cmi or .cmt file") - -let change_file file_infos cmti_file = - let no_ext = Filename.remove_extension cmti_file in - assert(no_ext = Filename.remove_extension file_infos.cmti_file); - match Filename.extension cmti_file, file_infos with - | ".cmi", {cmi_infos=Some cmi_infos; _} -> - let res = init_from_cmi_infos ~with_cmt:file_infos cmi_infos cmti_file in - Result.ok res - | ".cmt", {cmt_infos = Some cmt_infos; cmi_infos; _} -> - let res = init_from_cmt_infos cmt_infos cmti_file in - Result.ok {res with cmi_infos} - | _ -> (* corresponding info is None *) - init cmti_file - -let has_builddir file_infos = Option.is_some file_infos.builddir + let+ file_infos, _ = init_from_cmt_file cm_file in + file_infos + | ".cmti" -> ( + (* Using cmt_infos is not critical. The intent is to mirror the behavior + on cmt files, where both cmt and cmti are read. *) + let filled_with_cmt_infos = + let cmt_file = Filename.remove_extension cm_file ^ ".cmt" in + let* file_infos, cmt_infos = init_from_cmt_file cmt_file in + let+ location_dependencies = + Location_dependencies.init cmt_infos file_infos.cmti_uid_to_decl + in + {file_infos with location_dependencies} + in + match filled_with_cmt_infos with + | Ok {cmt_struct; cmti_uid_to_decl; location_dependencies; _} -> + let+ res, _ = init_from_cm_file cm_file in + {res with cmt_struct; cmti_uid_to_decl; location_dependencies} + | Error _ -> init_from_cmti_file cm_file + ) + | _ -> Result.error (cm_file ^ ": not a .cmti or .cmt file") + +let change_file file_infos cm_file = + let no_ext = Filename.remove_extension cm_file in + assert(no_ext = Filename.remove_extension file_infos.cm_file); + match Filename.extension cm_file, file_infos with + | ".cmt", {cmt_struct = (Some _ as cs); cmi_sign; cmti_uid_to_decl; _} -> + let* res, cmt_infos = init_from_cm_file cm_file in + let+ location_dependencies = + match file_infos.location_dependencies with + | [] -> Location_dependencies.init cmt_infos cmti_uid_to_decl + | loc_dep -> (* They have already been computed *) + Result.ok loc_dep + in + {res with cmt_struct = cs; cmi_sign; cmti_uid_to_decl; location_dependencies} + | ".cmti", {cmti_uid_to_decl = (Some _ as cutd); cmt_struct; location_dependencies; _} -> + let+ res, _ = init_from_cm_file cm_file in + {res with cmti_uid_to_decl = cutd; cmt_struct; location_dependencies} + | _ -> + (* invalid extension or the corresponding info is None *) + init cm_file let has_sourcepath file_infos = Option.is_some file_infos.sourcepath -let get_builddir t = - match t.builddir with - | Some builddir -> builddir - | None -> "!!UNKNOWN_BUILDDIR_FOR<" ^ t.cmti_file ^ ">!!" +let get_builddir t = t.builddir let get_sourcepath t = match t.sourcepath with | Some sourcepath -> sourcepath - | None -> match t.builddir with - | Some builddir -> + | None -> Printf.sprintf "!!UNKNOWN_SOURCEPATH_IN<%s>_FOR_<%s>!!" - builddir - t.cmti_file - | None -> "!!UNKNOWN_SOURCEPATH_FOR<" ^ t.cmti_file ^ ">!!" + t.builddir + t.cm_file let get_sourceunit t = match t.sourcepath with | Some sourcepath -> Utils.unit sourcepath - | None -> "!!UNKNOWN_SOURCEUNIT_FOR<" ^ t.cmti_file ^ ">!!" + | None -> "!!UNKNOWN_SOURCEUNIT_FOR<" ^ t.cm_file ^ ">!!" let get_modname t = t.modname diff --git a/src/state/file_infos.mli b/src/state/file_infos.mli index 8e29bb8..9e38133 100644 --- a/src/state/file_infos.mli +++ b/src/state/file_infos.mli @@ -1,32 +1,36 @@ -(** Information about a analyzable file ([.cmi] or [.cmt] file) *) +(** Information about a analyzable file ([.cmti] or [.cmt] file) *) type t = { - cmti_file : string; (** The filepath currently analyzed *) + builddir : string; (** The [cmt_builddir] *) + cm_file : string; (** The filepath currently analyzed *) + cmi_sign : Types.signature option; (** Extracted from [cmi_infos] *) + cmt_struct : Typedtree.structure option; + (** Extracted from a cmt's [cmt_infos.cmt_annots] *) + cmti_uid_to_decl : Location_dependencies.uid_to_decl option; + (** Extracted from a cmti's [cmt_infos] *) + location_dependencies : Location_dependencies.t; + (** Dependencies similar to [cmt_infos.cmt_value_dependencies] in OCaml 5.2 *) + modname : string; (** Either [cmti_name] or [cmt_modname] *) sourcepath : string option; (** The path to the associated source file *) - builddir : string option; (** The [cmt_builddir] *) - modname : string; (** Either [cmi_name] or [cmt_modname] *) - cmi_infos : Cmi_format.cmi_infos option; - cmt_infos : Cmt_format.cmt_infos option; } val empty : t (** No file info *) val init : string -> (t, string) result -(** [init cmti_file] expects either a [.cmi] or [.cmt] filepath as argument and - returns an [Ok t] with [t] filled using the [cmit_file]. +(** [init cm_file] expects either a [.cmti] or [.cmt] filepath as argument and + returns an [Ok t] with [t] filled using the [cmtit_file]. In case the file does not exist, it cannot be read, or its extension is invalid, then it returns an [Err msg] with msg a string describing the issue. *) val change_file : t -> string -> (t, string) result -(** [change_file t cmti_file] expects either a [.cmi] or a [.cmt] filepath as - argument. [cmti_file] must be the same as [t.cmti_file], ignoring the +(** [change_file t cm_file] expects either a [.cmti] or a [.cmt] filepath as + argument. [cm_file] must be the same as [t.cm_file], ignoring the extension. The returned value is either a simple update of [t] if the necessary - [cmi_infos] or [cmt_infos] is available. Otherwise, it is the result of + [cmti_infos] or [cmt_infos] is available. Otherwise, it is the result of [init t] *) -val has_builddir : t -> bool val has_sourcepath : t -> bool val get_builddir : t -> string diff --git a/src/state/location_dependencies.ml b/src/state/location_dependencies.ml new file mode 100644 index 0000000..2ade7ff --- /dev/null +++ b/src/state/location_dependencies.ml @@ -0,0 +1,80 @@ +type t = (Lexing.position * Lexing.position) list + +let empty = [] + +module UidTbl = Shape.Uid.Tbl + +type uid_to_decl = Typedtree.item_declaration UidTbl.t + +let fill_from_structure (structure : Typedtree.structure) res_uid_to_loc = + let open Types in + let rec fill_from_signature_item = function + | Sig_value (_, {val_loc; val_uid; _}, _) -> + UidTbl.replace res_uid_to_loc val_uid val_loc.loc_start + | Sig_module (_, _, {md_type = modtype; _}, _, _) + | Sig_modtype (_, {mtd_type = Some modtype; _}, _) -> + Utils.signature_of_modtype modtype + |> fill_from_signature + | _ -> () + and fill_from_signature s = + List.iter fill_from_signature_item s + in + let iterator = + let super = Tast_iterator.default_iterator in + let structure_item self struct_item = + let open Typedtree in + begin match struct_item.str_desc with + | Tstr_include {incl_type; _} -> fill_from_signature incl_type + | _ -> () + end; + super.Tast_iterator.structure_item self struct_item + in + {super with structure_item} + in + iterator.structure iterator structure; + res_uid_to_loc + +let fill_from_cmt_tbl uid_to_decl res_uid_to_loc = + let open Typedtree in + let loc_of_item_decl = function + | Value {val_loc = loc; _} + | Value_binding {vb_pat = {pat_loc = loc; _}; _} -> + Some loc.loc_start + | _ -> None + in + let add_uid_loc uid item_decl = + let loc = loc_of_item_decl item_decl in + Option.iter (UidTbl.replace res_uid_to_loc uid) loc + in + UidTbl.iter add_uid_loc uid_to_decl; + res_uid_to_loc + +let cmt_decl_dep_to_loc_dep cmt_decl_dep uid_to_loc = + let convert_pair (_dep_kind, uid_def, uid_decl) = + let ( let* ) x f = Option.bind x f in + let loc_opt_of_uid uid = + UidTbl.find_opt uid_to_loc uid + in + let* def_loc = loc_opt_of_uid uid_def in + let* decl_loc = loc_opt_of_uid uid_decl in + Some (def_loc, decl_loc) + in + List.filter_map convert_pair cmt_decl_dep + +let init cmt_infos cmti_uid_to_decl = + match cmt_infos.Cmt_format.cmt_annots with + | Implementation structure -> + let fill_from_cmti_tbl tbl = + match cmti_uid_to_decl with + | None -> tbl + | Some cmti_uid_to_decl -> + fill_from_cmt_tbl cmti_uid_to_decl tbl + in + (* TODO: Evaluate a generally good size for the tbl ? *) + UidTbl.create 512 + |> fill_from_structure structure + |> fill_from_cmt_tbl cmt_infos.cmt_uid_to_decl + |> fill_from_cmti_tbl + |> cmt_decl_dep_to_loc_dep cmt_infos.cmt_declaration_dependencies + |> Result.ok + | _ -> Result.error "No implementation found in cmt_infos" diff --git a/src/state/location_dependencies.mli b/src/state/location_dependencies.mli new file mode 100644 index 0000000..c6dc3fb --- /dev/null +++ b/src/state/location_dependencies.mli @@ -0,0 +1,15 @@ +type t = (Lexing.position * Lexing.position) list + (** Dependencies similar to [cmt_infos.cmt_value_dependencies] in OCaml 5.2 *) + +val empty : t (** No signature read *) + +type uid_to_decl = Typedtree.item_declaration Shape.Uid.Tbl.t + +val init : Cmt_format.cmt_infos -> uid_to_decl option -> (t, string) result +(** [init cmt_infos cmti_infos cmti_uid_to_decl] expects + [cmt_infos.cmt_annots = Implementation _]. + It reads the [cmt_infos] and the [cmti_uid_to_decl] to retrieve their + and converts [cmt_infos.cmt_declaration_dependencies] into a single [t]. + It returns an [Ok t] with [t] on success. + In case the [cmt_infos] does not contain an implementation, it returns an + [Err msg] with msg a string describing the issue. *) diff --git a/src/state/state.ml b/src/state/state.ml index 65550e1..eeb4966 100644 --- a/src/state/state.ml +++ b/src/state/state.ml @@ -4,26 +4,29 @@ type t = { file_infos : File_infos.t; } -let empty = {file_infos = File_infos.empty} +let empty = { + 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 init cm_file = + let ( let* ) x f = Result.bind x f in + let* file_infos = File_infos.init cm_file in + Result.ok {file_infos} -let change_file state cmti_file = +let change_file state cm_file = let file_infos = state.file_infos in let equal_no_ext filename1 filename2 = let no_ext1 = Filename.remove_extension filename1 in let no_ext2 = Filename.remove_extension filename2 in - no_ext1 = no_ext2 + String.equal no_ext1 no_ext2 in - if file_infos.cmti_file = cmti_file then + if String.equal file_infos.cm_file cm_file then 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 + else if equal_no_ext file_infos.cm_file cm_file then + let file_infos = File_infos.change_file file_infos cm_file in Result.map (fun file_infos -> {file_infos}) file_infos else - init cmti_file + init cm_file (** Analysis' state *) let current = ref empty diff --git a/src/state/state.mli b/src/state/state.mli index a313e24..5db6e8f 100644 --- a/src/state/state.mli +++ b/src/state/state.mli @@ -10,7 +10,7 @@ val empty : t (** The empty state *) val init : string -> (t, string) result (** [init cmti_file] initialize a state to analyze [cmti_file]. - See [File_infos.init] for error cases. *) + See the fields respective [init]s for error cases. *) val change_file : t -> string -> (t, string) result (** [cahnge_file t cmti_file] prepare the analysis to move on to [cmti_file]. diff --git a/src/utils.ml b/src/utils.ml index 0de8687..696b789 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -4,3 +4,10 @@ let unit fn = | ".pp" -> Filename.remove_extension u | _ -> u +let rec signature_of_modtype ?(select_param = false) modtype = + let open Types in + match modtype with + | Mty_signature sg -> sg + | Mty_functor (_, t) when not select_param -> signature_of_modtype t + | Mty_functor (Named (_, t), _) -> signature_of_modtype t + | _ -> [] diff --git a/src/utils.mli b/src/utils.mli index 526dc8d..93a0e95 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -1 +1,11 @@ val unit : string -> string +(** [unit filename] estimates the compilation unit of [filename] *) + +val signature_of_modtype : + ?select_param:bool -> Types.module_type -> Types.signature +(** [signature_of_modtype ?select_param modtype] returns the selected signature + of [modtype]. If [modtype] is a functor, then [select_param] is used to + select either the signature of the parameter or the result of the functor. + Note: [select_param] is [false] by default. If set to [true], it is reset to + [false] after looking for the parameter of the first functor. + There is currently no way to select the parameter of a parameter. *)