diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index ef090779..190eb0aa 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 a02f4868..237c7f09 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/threshold-3-0.5/threshold-3-0.5.ref b/check/threshold-3-0.5/threshold-3-0.5.ref index 518f3410..c7ac50fd 100644 --- a/check/threshold-3-0.5/threshold-3-0.5.ref +++ b/check/threshold-3-0.5/threshold-3-0.5.ref @@ -1051,12 +1051,9 @@ Nothing else to report in this section ./examples/using_make/dir/anonFn2.mli:2: ?a (2/3 calls) ./examples/using_make/dir/anonFn2.mli:2: ?b (2/3 calls) ./examples/using_make/dir/match_opt.ml:1: ?b (2/3 calls) - ./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) @@ -1252,7 +1249,6 @@ Nothing else to report in this section ./examples/using_make/dir/anonFn.mli:3: ?a (1/2 calls) ./examples/using_make/dir/anonFn.mli:3: ?b (1/2 calls) ./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) diff --git a/dead_code_analyzer.opam b/dead_code_analyzer.opam index 2ae96e5e..116ede5d 100644 --- a/dead_code_analyzer.opam +++ b/dead_code_analyzer.opam @@ -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 2969ca19..c884e43f 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/docs/exported_values/HELLO_WORLD.md b/docs/exported_values/HELLO_WORLD.md index 22935a56..47e031f7 100644 --- a/docs/exported_values/HELLO_WORLD.md +++ b/docs/exported_values/HELLO_WORLD.md @@ -20,15 +20,14 @@ without any external use. The reference file for this example is [`hello_world_without_intf.ml`](../../examples/docs/exported_values/hello_world/hello_world_without_intf.ml). -The compilation command to produce `hello_world_without_intf.cmi` and -`hello_world_without_intf.cmt` is : +The compilation command to produce `hello_world_without_intf.cmt` is : ``` ocamlopt -bin-annot hello_world_without_intf.ml ``` The analysis command is : ``` -dead_code_analyzer --nothing -E all hello_world_without_intf.cmi hello_world_without_intf.cmt +dead_code_analyzer --nothing -E all hello_world_without_intf.cmt ``` ## First run @@ -62,7 +61,7 @@ reported location: `File "hello_world_without_intf.ml", line 8` Analyze : ``` -$ dead_code_analyzer --nothing -E all hello_world_without_intf.cmi hello_world_without_intf.cmt +$ dead_code_analyzer --nothing -E all hello_world_without_intf.cmt Scanning files... [DONE] @@ -100,7 +99,7 @@ Compile and analyze : ``` $ ocamlopt -bin-annot hello_world_without_intf.ml -$ dead_code_analyzer --nothing -E all hello_world_without_intf.cmi hello_world_without_intf.cmt +$ dead_code_analyzer --nothing -E all hello_world_without_intf.cmt Scanning files... [DONE] @@ -136,7 +135,7 @@ Compile and analyze : ``` $ ocamlopt -bin-annot hello_world_without_intf.ml -$ dead_code_analyzer --nothing -E all hello_world_without_intf.cmi hello_world_without_intf.cmt +$ dead_code_analyzer --nothing -E all hello_world_without_intf.cmt Scanning files... [DONE] @@ -160,14 +159,14 @@ The reference files for this example are [`hello_world_with_intf.mli`](../../examples/docs/exported_values/hello_world/hello_world_with_intf.mli) and [`hello_world_with_intf.ml`](../../examples/docs/exported_values/hello_world/hello_world_with_intf.ml) -The compilation command to produce `hello_world.cmi` and `hello_world.cmt` is : +The compilation command to produce `hello_world.cmti` and `hello_world.cmt` is : ``` ocamlopt -bin-annot hello_world_with_intf.mli hello_world_with_intf.ml ``` The analysis command is : ``` -dead_code_analyzer --nothing -E all hello_world.cmi hello_world.cmt +dead_code_analyzer --nothing -E all hello_world.cmti hello_world.cmt ``` ## First run @@ -199,7 +198,7 @@ File "hello_world_with_intf.ml", line 8, characters 6-19: ^^^^^^^^^^^^^ Warning 26 [unused-var]: unused variable goodbye_world. -$ dead_code_analyzer --nothing -E all hello_world.cmi hello_world.cmt +$ dead_code_analyzer --nothing -E all hello_world.cmti hello_world.cmt Scanning files... [DONE] @@ -246,7 +245,7 @@ let () = Compile and analyze : ``` $ ocamlopt -bin-annot hello_world_with_intf.ml -$ dead_code_analyzer --nothing -E all hello_world.cmi hello_world.cmt +$ dead_code_analyzer --nothing -E all hello_world.cmti hello_world.cmt Scanning files... [DONE] @@ -284,14 +283,14 @@ The reference files for this example are [`hello_world_lib.ml`](../../examples/docs/exported_values/hello_world/hello_world_lib.ml), and [`hello_world_bin.ml`](../../examples/docs/exported_values/hello_world/hello_world_bin.ml) -The compilation command to produce the necessary `.cmi` and `.cmt` files is : +The compilation command to produce the necessary `.cmti` and `.cmt` files is : ``` ocamlopt -bin-annot hello_world_lib.mli hello_world_lib.ml hello_world_bin.ml ``` The analysis command is : ``` -dead_code_analyzer --nothing -E all hello_world_lib.cmi hello_world_lib.cmt hello_world_bin.cmi hello_world_bin.cmt +dead_code_analyzer --nothing -E all hello_world_lib.cmti hello_world_lib.cmt hello_world_bin.cmti hello_world_bin.cmt ``` > [!NOTE] @@ -330,7 +329,7 @@ File "hello_world_bin.ml", line 5, characters 6-19: ^^^^^^^^^^^^^ Warning 26 [unused-var]: unused variable goodbye_world. -$ dead_code_analyzer --nothing -E all hello_world_lib.cmi hello_world_lib.cmt hello_world_bin.cmi hello_world_bin.cmt +$ dead_code_analyzer --nothing -E all hello_world_lib.cmti hello_world_lib.cmt hello_world_bin.cmti hello_world_bin.cmt Scanning files... [DONE] @@ -383,7 +382,7 @@ Compile and analyze : ``` $ ocamlopt -bin-annot hello_world_lib.mli hello_world_lib.ml hello_world_bin.ml -$ dead_code_analyzer --nothing -E all hello_world_lib.cmi hello_world_lib.cmt hello_world_bin.cmi hello_world_bin.cmt +$ dead_code_analyzer --nothing -E all hello_world_lib.cmti hello_world_lib.cmt hello_world_bin.cmti hello_world_bin.cmt Scanning files... [DONE] @@ -425,7 +424,7 @@ Compile and analyze : ``` $ ocamlopt -bin-annot hello_world_lib.mli hello_world_lib.ml hello_world_bin.ml -$ dead_code_analyzer --nothing -E all hello_world_lib.cmi hello_world_lib.cmt hello_world_bin.cmi hello_world_bin.cmt +$ dead_code_analyzer --nothing -E all hello_world_lib.cmti hello_world_lib.cmt hello_world_bin.cmti hello_world_bin.cmt Scanning files... [DONE] @@ -458,7 +457,7 @@ reach a satisfying codebase. The reference files for this example are all those listed previously. -The compilation command to produce the necessary `.cmi` and `.cmt` files, +The compilation command to produce the necessary `.cmti` and `.cmt` files, and the desired warnings is the combination of all the previous ones : ``` ocamlopt -w +32 -bin-annot hello_world_without_intf.ml hello_world_with_intf.mli hello_world_with_intf.ml hello_world_lib.mli hello_world_lib.ml hello_world_bin.ml @@ -476,7 +475,7 @@ dead_code_analyzer --nothing -E all . > [!TIP] > As we can see in the compilation command, there is a large number of files to -> list. Instead of listing all the `.cmi` and `.cmt` files in the command line, +> list. Instead of listing all the `.cmti` and `.cmt` files in the command line, > the analyzer accepts directories as arguments and will analyze all the > relevant files it can find in them. diff --git a/dune-project b/dune-project index 3eb6ae40..6ce3b6fa 100644 --- a/dune-project +++ b/dune-project @@ -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/config/config.ml b/src/config/config.ml index ce0dd485..77855674 100644 --- a/src/config/config.ml +++ b/src/config/config.ml @@ -108,7 +108,7 @@ let normalize_path path = let rec add_filepaths acc path = match Utils.Filepath.kind ~exclude:(fun _ -> false) path with - | Cmi | Cmt -> Utils.StringSet.add path acc + | Cmti | Cmt_without_mli | Cmt_with_mli -> Utils.StringSet.add path acc | Dir -> Sys.readdir path |> Array.fold_left diff --git a/src/deadCode.ml b/src/deadCode.ml index a05a491b..f8a29882 100644 --- a/src/deadCode.ml +++ b/src/deadCode.ml @@ -24,7 +24,7 @@ open DeadCommon (******** ATTRIBUTES ********) -let bad_files = ref [] (* unreadable cmi/cmt files *) +let bad_files = ref [] (* unreadable cmti/cmt files *) let main_files = Hashtbl.create 256 (* names -> paths *) @@ -98,7 +98,7 @@ let rec collect_export ~context path u stock = function | Sig_modtype _, _ -> in_modtype, In_modtyp (id, loc) | _, _ -> stock, In_module (id, loc) in - DeadMod.sign t + Utils.signature_of_modtype t |> List.iter (collect_export ~context (id :: path) u stock) | _ -> () @@ -112,8 +112,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; @@ -191,9 +195,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 @@ -302,7 +306,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 && sections.style.seq -> begin match c_lhs.pat_desc with | Tpat_value tpat_arg -> @@ -387,28 +391,24 @@ let regabs state = hashtbl_add_unique_to_list main_files (Utils.Filepath.unit fn) () -let read_interface fn cmi_infos state = let open Cmi_format in - try - regabs state; - 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 - else - Utils.Filepath.unit fn - in - let module_id = - State.File_infos.get_modname state.file_infos - |> Ident.create_persistent - in - let f = - collect_export ~context:Toplevel [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 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 + else + Utils.Filepath.unit fn + in + let module_id = + State.File_infos.get_modname state.file_infos + |> Ident.create_persistent + in + let f = + collect_export ~context:Toplevel [module_id] u decs + in + List.iter f signature; + last_loc := Lexing.dummy_pos (* Merge a location's references to another one's *) @@ -483,65 +483,69 @@ let load_file fn state = (* TODO: stateful computations should take and return the state when possible *) state in + let add_bad_file err fn = + if state.State.config.verbose then + Printf.eprintf "%s\n%!" err; + bad_files := fn :: !bad_files + in + let process_interface fn = + last_loc := Lexing.dummy_pos; + if state.State.config.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 state.State.config.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 Config.must_report_section state.config.sections.exported_values then + let sourceunit = + State.File_infos.get_sourceunit state.file_infos + in + let in_sourceunit (pos : Lexing.position) = + String.equal (Utils.Filepath.unit pos.pos_fname) sourceunit + in + List.filter_map + (fun (loc1, loc2) -> + if in_sourceunit loc1 || in_sourceunit loc2 then + Some (loc1, loc2) + else None + ) + state.file_infos.location_dependencies + else [] + in + eof loc_dep + ) + in let exclude filepath = Config.is_excluded filepath state.State.config in match Utils.Filepath.kind ~exclude fn with - | Cmi when !DeadCommon.declarations -> - last_loc := Lexing.dummy_pos; - 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 ? *) - | Some cmi_infos -> read_interface fn cmi_infos state - ) - - | Cmt -> - let open Cmt_format in - last_loc := Lexing.dummy_pos; - 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 - | 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 Config.must_report_section state.config.sections.exported_values then - let sourceunit = - State.File_infos.get_sourceunit state.file_infos - in - let in_sourceunit (pos : Lexing.position) = - String.equal (Utils.Filepath.unit pos.pos_fname) sourceunit - in - List.filter_map - (fun (vd1, vd2) -> - let loc1 = vd1.Types.val_loc.Location.loc_start in - let loc2 = vd2.Types.val_loc.Location.loc_start in - if in_sourceunit loc1 || in_sourceunit loc2 then - Some (loc1, loc2) - else None - ) - 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 -> (* TODO : better error handling *) failwith ("Internal error : Unexpected directory " - ^ fn ^ ". Only .cmi and .cmt are expected") - + ^ fn ^ ". Only .cmti and .cmt are expected") | _ -> state @@ -685,15 +689,16 @@ let report_style () = (* Option parsing and processing *) let run_analysis state = - let process_file filename state = + let process_file state filename = let state = load_file filename state in State.update state; state in Printf.eprintf "Scanning files...\n%!"; - Utils.StringSet.fold + Utils.StringSet.elements state.State.config.paths_to_analyze + |> List.rev + |> List.fold_left process_file - state.State.config.paths_to_analyze state let () = diff --git a/src/deadCommon.ml b/src/deadCommon.ml index 7db05bac..08277c24 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -388,7 +388,7 @@ let export ?(sep = ".") path u stock id loc = ^ sep ^ (Ident.name id) in - (* a .cmi file can contain locations from other files. + (* a .cmti file can contain locations from other files. For instance: module M : Set.S with type elt = int will create value definitions whose location is in set.mli diff --git a/src/deadLexiFi.ml b/src/deadLexiFi.ml index 2fd31876..f76ac0b9 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 84742948..6d0fd9a3 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/cmt.ml b/src/state/cmt.ml new file mode 100644 index 00000000..cf67e257 --- /dev/null +++ b/src/state/cmt.ml @@ -0,0 +1,66 @@ +module Cache = struct + (** O(1) addition and retrieval *) + + type ('k, 'v) t = + { store : ('k, 'v) Hashtbl.t + (** filepath -> cmi_cmt_infos *) + ; capacity : int (** n <= capacity *) + ; mutable hit : int + ; mutable miss : int + } + + let create capacity = + { store = Hashtbl.create capacity + ; capacity + ; hit = 0 + ; miss = 0 + } + + let find_opt (cache : ('k, 'v) t) (key : 'k) : 'v option = + let res = Hashtbl.find_opt cache.store key in + if Option.is_some res then cache.hit <- cache.hit + 1 + else (cache.miss <- cache.miss + 1); + res + + let add cache key value = + if Hashtbl.length cache.store = cache.capacity then + Hashtbl.reset cache.store; + Hashtbl.replace cache.store key value + +end + +let read_no_cache filepath = + match Cmt_format.read filepath with + | exception _ -> Result.error (filepath ^ ": error reading file") + | _, None -> Result.error (filepath ^ ": cmt_infos not found") + | cmi_infos, Some cmt_infos -> + Result.ok (cmi_infos, cmt_infos) + +type cmi_cmt_infos = Cmi_format.cmi_infos option * Cmt_format.cmt_infos + +let cache_cmt : ((string * string), (string * cmi_cmt_infos)) Cache.t = Cache.create 64 + +let read filepath = + let comp_unit = Utils.Filepath.unit filepath in + let ext = Filename.extension filepath in + match Cache.find_opt cache_cmt (ext, comp_unit) with + | Some (fp, res) when String.equal fp filepath -> Result.ok res + | _ -> + read_no_cache filepath + |> Result.map (fun cmi_cmt_infos -> + Cache.add cache_cmt (ext, comp_unit) (filepath, cmi_cmt_infos); + cmi_cmt_infos) + +let find_cached_from_comp_unit comp_unit ext = + Cache.find_opt cache_cmt (ext, comp_unit) + |> Option.map snd + +let cached_cmti comp_unit = + find_cached_from_comp_unit comp_unit ".cmti" + +let cached_cmt comp_unit = + find_cached_from_comp_unit comp_unit ".cmt" + +let print_cache_stats () = + print_endline (Printf.sprintf "CMT CACHE : hit = %i ; miss = %i" + cache_cmt.hit cache_cmt.miss) diff --git a/src/state/cmt.mli b/src/state/cmt.mli new file mode 100644 index 00000000..97996a7a --- /dev/null +++ b/src/state/cmt.mli @@ -0,0 +1,9 @@ +type cmi_cmt_infos = Cmi_format.cmi_infos option * Cmt_format.cmt_infos + +val read : string -> (cmi_cmt_infos, string) Result.t + +val cached_cmti : string -> cmi_cmt_infos option + +val cached_cmt : string -> cmi_cmt_infos option + +val print_cache_stats : unit -> unit diff --git a/src/state/file_infos.ml b/src/state/file_infos.ml index 4a3eace1..b0efac82 100644 --- a/src/state/file_infos.ml +++ b/src/state/file_infos.ml @@ -1,211 +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 Utils.Filepath.remove_pp cmt_infos.cmt_sourcefile |> Option.map (Filename.concat builddir) 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.Filepath.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 `Different - in - let fname_of_candidate = function - | `Different -> None - | `Identical fname - | `Suffix fname -> Some fname + match Cmt.read cm_file with + | Error _ as err -> err + | Ok (cmi_infos, 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 ~cm_paths 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 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 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 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 - | (`Identical _ as candidate), _ - | _, (`Identical _ as candidate) -> - (* best candidate found *) - fname_of_candidate candidate - | `Different, candidate - | candidate, `Different - | _, candidate -> - find_sourcename candidate items + let+ location_dependencies = + Location_dependencies.init ~cm_paths cmt_infos cmti_uid_to_decl in - find_sourcename `Different 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 sourcepath = - (* Try to find a sourcepath in the cmi_infos *) - let cmi_unit = Utils.Filepath.unit cmi_file in - let sourcefname = sourcefname_of_cmi_infos cmi_unit cmi_infos in - match sourcefname, builddir with - | Some fname, Some builddir -> Some (Filename.concat builddir fname) - | _, _ -> sourcefname - in - match sourcepath with - | Some _ -> sourcepath - | None -> - (* There is no satisfying sourcepath in the cmi_infos. - Try to retrieve the sourecpath using with_cmt. - *) - let sourcepath_of_cmt cmt_file sourcepath = - (* When producing .cmt files for .ml files, the compiler also produces - .cmti files for .mli files. Hence, if a .cmti exists, we assume the - .mli does. - *) - if Sys.file_exists (cmt_file ^ "i") then sourcepath ^ "i" - else sourcepath - in - Option.bind with_cmt - (fun {sourcepath; cmti_file; _} -> - Option.map (sourcepath_of_cmt cmti_file) sourcepath - ) - + let file_infos = + {file_infos with cmt_struct; cmti_uid_to_decl; location_dependencies} 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") + file_infos, cmt_infos -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_paths 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_paths 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 ~cm_paths cmt_file in + let+ location_dependencies = + Location_dependencies.init ~cm_paths 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 ~cm_paths 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 ~cm_paths 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_paths 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 -> + | Some sourcepath -> sourcepath + | 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.Filepath.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 8e29bb87..209dcddc 100644 --- a/src/state/file_infos.mli +++ b/src/state/file_infos.mli @@ -1,32 +1,38 @@ -(** 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]. +val init : cm_paths: Utils.StringSet.t -> string -> (t, string) result +(** [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. *) + describing the issue. + [cm_paths] is used to load external cm files if necessary. *) -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 +val change_file : cm_paths: Utils.StringSet.t -> t -> string -> (t, string) result +(** [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 - [init t] *) + [cmti_infos] or [cmt_infos] is available. Otherwise, it is the result of + [init t]. + [cm_paths] is used to load external cm files if necessary. *) -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 00000000..b69f9033 --- /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 loc_opt_of_item_decl = function + | Typedtree.Value {val_loc = loc; _} + | Typedtree.Value_binding {vb_pat = {pat_loc = loc; _}; _} -> + Some loc.loc_start + | _ -> None + +let fill_from_cmt_tbl uid_to_decl res_uid_to_loc = + let add_uid_loc uid item_decl = + let loc = loc_opt_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 find_opt_external_uid_loc ~cm_paths = function + | Shape.Uid.(Compilation_unit _ | Internal | Predef _) -> None + | Item {comp_unit; from; _} as uid -> + let ( let* ) x f = Option.bind x f in + let cached = + match from with + | Unit_info.Intf -> Cmt.cached_cmti comp_unit + | Unit_info.Impl -> Cmt.cached_cmt comp_unit + in + let read_from_path () = + let* cm_path = + Utils.StringSet.elements cm_paths + |> List.rev + |> List.find_opt (fun path -> Utils.Filepath.unit path = comp_unit) + in + Cmt.read cm_path |> Result.to_option + in + let* cmi_cmt_infos = + match cached with + | Some _ as some -> some + | None -> read_from_path () + in + let cmt_infos = snd cmi_cmt_infos in + let cmt_uid_to_decl = cmt_infos.cmt_uid_to_decl in + let* item_decl = UidTbl.find_opt cmt_uid_to_decl uid in + loc_opt_of_item_decl item_decl + +let cmt_decl_dep_to_loc_dep ~cm_paths 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 = + match UidTbl.find_opt uid_to_loc uid with + | Some _ as loc -> loc + | None -> find_opt_external_uid_loc ~cm_paths 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 + let res = List.filter_map convert_pair cmt_decl_dep in + res + +let init ~cm_paths cmt_infos cmti_uid_to_decl = + match cmt_infos.Cmt_format.cmt_annots with + | Implementation _ -> + 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_cmt_tbl cmt_infos.cmt_uid_to_decl + |> fill_from_cmti_tbl + |> cmt_decl_dep_to_loc_dep ~cm_paths 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 00000000..80046876 --- /dev/null +++ b/src/state/location_dependencies.mli @@ -0,0 +1,20 @@ +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 : + cm_paths: Utils.StringSet.t + -> Cmt_format.cmt_infos + -> uid_to_decl option + -> (t, string) result +(** [init ~cm_paths 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. + [cm_paths] is used to load external cm files if necessary. *) diff --git a/src/state/state.ml b/src/state/state.ml index 1418a125..8b71b2bd 100644 --- a/src/state/state.ml +++ b/src/state/state.ml @@ -13,20 +13,22 @@ let init config = let update_config config state = {state with config} -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 + let cm_paths = state.config.paths_to_analyze in + 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 ~cm_paths file_infos cm_file in Result.map (fun file_infos -> {state with file_infos}) file_infos else - let file_infos = File_infos.init cmti_file in + let file_infos = File_infos.init ~cm_paths cm_file in Result.map (fun file_infos -> {state with file_infos}) file_infos (** Analysis' state *) diff --git a/src/utils.ml b/src/utils.ml index bb524456..df300c1c 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -10,11 +10,12 @@ module Filepath = struct | _ -> filepath let unit filepath = - Unit_info.modname_from_source filepath + Unit_info.lax_modname_from_source filepath type kind = - | Cmi - | Cmt + | Cmti + | Cmt_without_mli + | Cmt_with_mli | Dir | Ignore @@ -26,9 +27,20 @@ module Filepath = struct Ignore ) else if Sys.is_directory filepath then Dir - else if Filename.check_suffix filepath ".cmi" then Cmi - else if Filename.check_suffix filepath ".cmt" then Cmt + else if Filename.check_suffix filepath ".cmti" then Cmti + else if Filename.check_suffix filepath ".cmt" then + let cmti = Filename.remove_extension filepath ^ ".cmti" in + if Sys.file_exists cmti then Cmt_with_mli + else Cmt_without_mli else Ignore end +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 + | _ -> [] + module StringSet = Set.Make(String) diff --git a/src/utils.mli b/src/utils.mli index f9fe1424..1d506e9f 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -10,8 +10,9 @@ module Filepath : sig (** [unit filepath] estimates the compilation unit of [filepath] *) type kind = - | Cmi (** .cmi file *) - | Cmt (** .cmt file *) + | Cmti (** .cmti file *) + | Cmt_without_mli (** .cmt file of .ml only module *) + | Cmt_with_mli (** .cmt file of module with .mli *) | Dir (** Directory *) | Ignore (** Irrelevant for the analyzer *) @@ -22,4 +23,13 @@ module Filepath : sig Other kinds are self explanatory. *) end +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. *) + module StringSet : Set.S with type elt = String.t