gazagnaire.org
Find and remove dead code and unused APIs in OCaml projects
1(* AST-based location finding using compiler-libs *)
2
3module T = Types
4open Parsetree
5module Log = (val Logs.src_log (Logs.Src.create "prune.locate") : Logs.LOG)
6
7(* Type definitions *)
8
9type field_info = {
10 field_name : string;
11 full_field_bounds : T.location; (* Full bounds including everything *)
12 enclosing_record : T.location; (* Location of the enclosing record {} *)
13 total_fields : int; (* Total number of fields in the record *)
14 context : [ `Type_definition | `Record_construction ];
15}
16
17type type_def_info = {
18 type_name : string;
19 type_keyword_loc : T.location;
20 equals_loc : T.location option;
21 kind : [ `Abstract | `Record | `Variant | `Alias ];
22 full_bounds : T.location;
23}
24
25(* Exceptions for early termination in visitors *)
26exception Found_field of field_info
27exception Found_type_def of type_def_info
28exception Found_location of T.location
29
30(* Error helper functions *)
31let err fmt = Fmt.kstr (fun e -> Error (`Msg e)) fmt
32let err_expected_impl file = err "Expected implementation file: %s" file
33let err_expected_intf file = err "Expected interface file: %s" file
34let err_field_not_found = err "Field not found at position"
35let err_no_type_def = err "No type definition found at position"
36let err_no_sig_item = err "No signature item found at position"
37let err_no_struct_item = err "No structure item found at position"
38let err_no_value_binding = err "No value binding found at position"
39let err_no_enclosing_record = err "Could not find enclosing record"
40
41(* Basic utilities *)
42
43let rec longident_last = function
44 | Longident.Lident s -> s
45 | Longident.Ldot (_, s) -> s.txt
46 | Longident.Lapply (_, l) -> longident_last l.txt
47
48let location_of_loc file (loc : Location.t) : T.location =
49 T.location file ~line:loc.loc_start.pos_lnum
50 ~start_col:(loc.loc_start.pos_cnum - loc.loc_start.pos_bol)
51 ~end_line:loc.loc_end.pos_lnum
52 ~end_col:(loc.loc_end.pos_cnum - loc.loc_end.pos_bol)
53
54(* AST cache access *)
55
56let ast_entry ~cache file =
57 match Cache.ast cache file with
58 | Ok (Implementation ast) -> Ok ast
59 | Ok (Interface _) -> err_expected_impl file
60 | Error e -> Error e
61
62let interface_ast ~cache file =
63 match Cache.ast cache file with
64 | Ok (Interface ast) -> Ok ast
65 | Ok (Implementation _) -> err_expected_intf file
66 | Error e -> Error e
67
68(* Generic AST traversal helpers *)
69
70let location_contains loc ~line ~col =
71 loc.T.start_line <= line && loc.T.end_line >= line
72 && (loc.T.start_line < line || loc.T.start_col <= col)
73 && (loc.T.end_line > line || loc.T.end_col >= col)
74
75(* Check if loc1 is contained within loc2 (loc1 is more specific) *)
76let is_loc1_contained_in_loc2 loc1 loc2 =
77 loc1.T.start_line > loc2.T.start_line
78 || loc1.T.start_line = loc2.T.start_line
79 && loc1.T.start_col >= loc2.T.start_col
80 || loc1.T.end_line < loc2.T.end_line
81 || (loc1.T.end_line = loc2.T.end_line && loc1.T.end_col <= loc2.T.end_col)
82
83let to_full_lines loc =
84 T.location loc.T.file ~line:loc.T.start_line ~end_line:loc.T.end_line
85 ~start_col:0 ~end_col:max_int
86
87(* Field handling *)
88
89let extend_field_bounds field_loc next_item_loc is_last_field =
90 if is_last_field then
91 (* For last field, extend to one character before the record end *)
92 T.extend field_loc ~end_line:next_item_loc.T.end_line
93 ~end_col:(next_item_loc.T.end_col - 1)
94 else
95 (* For other fields, extend to the start of the next field *)
96 T.extend field_loc ~end_line:next_item_loc.T.start_line
97 ~end_col:next_item_loc.T.start_col
98
99let field_in_type file type_decl ~line ~col ~field_name =
100 match type_decl.ptype_kind with
101 | Ptype_record label_decls ->
102 let record_loc = location_of_loc file type_decl.ptype_loc in
103 let total_fields = List.length label_decls in
104
105 (* Use List.find_mapi to avoid array allocation *)
106 let rec find_with_index i = function
107 | [] -> None
108 | ld :: rest ->
109 let name_loc = location_of_loc file ld.pld_name.loc in
110 if
111 ld.pld_name.txt = field_name
112 && location_contains name_loc ~line ~col
113 then
114 let full_loc = location_of_loc file ld.pld_loc in
115 let next_loc =
116 if i = total_fields - 1 then record_loc
117 else
118 match rest with
119 | next_ld :: _ -> location_of_loc file next_ld.pld_loc
120 | [] -> record_loc
121 in
122 let extended =
123 extend_field_bounds full_loc next_loc (i = total_fields - 1)
124 in
125 Some
126 {
127 field_name = ld.pld_name.txt;
128 full_field_bounds = extended;
129 enclosing_record = record_loc;
130 total_fields;
131 context = `Type_definition;
132 }
133 else find_with_index (i + 1) rest
134 in
135 find_with_index 0 label_decls
136 | _ -> None
137
138let field_in_record file expr ~line ~col ~field_name =
139 match expr.pexp_desc with
140 | Pexp_record (fields, _) ->
141 let record_loc = location_of_loc file expr.pexp_loc in
142 let total_fields = List.length fields in
143
144 (* Use recursive function to avoid array allocation *)
145 let rec find_with_index i = function
146 | [] -> None
147 | ((lid : Longident.t Asttypes.loc), expr) :: rest ->
148 let field_loc = location_of_loc file lid.loc in
149 let name = longident_last lid.txt in
150 if name = field_name && location_contains field_loc ~line ~col then
151 let value_loc = location_of_loc file expr.pexp_loc in
152 let full_loc = T.merge field_loc value_loc in
153 let next_loc =
154 if i = total_fields - 1 then record_loc
155 else
156 match rest with
157 | (next_lid, _) :: _ -> location_of_loc file next_lid.loc
158 | [] -> record_loc
159 in
160 let extended =
161 extend_field_bounds full_loc next_loc (i = total_fields - 1)
162 in
163 Some
164 {
165 field_name = name;
166 full_field_bounds = extended;
167 enclosing_record = record_loc;
168 total_fields;
169 context = `Record_construction;
170 }
171 else find_with_index (i + 1) rest
172 in
173 find_with_index 0 fields
174 | _ -> None
175
176(* Type definition handling *)
177
178(* Get type keyword location *)
179let type_keyword_loc file item =
180 let item_loc = location_of_loc file item.pstr_loc in
181 T.extend item_loc ~end_line:item_loc.start_line
182 ~end_col:(item_loc.start_col + 4)
183(* "type" *)
184
185(* Get equals location for type definition *)
186let equals_loc file td =
187 match (td.ptype_kind, td.ptype_manifest) with
188 | Ptype_abstract, Some _ | Ptype_record _, _ | Ptype_variant _, _ ->
189 let name_loc = location_of_loc file td.ptype_name.loc in
190 Some
191 (T.location file ~line:name_loc.end_line
192 ~start_col:(name_loc.end_col + 1) ~end_line:name_loc.end_line
193 ~end_col:(name_loc.end_col + 2))
194 | _ -> None
195
196(* Get type definition kind *)
197let type_kind td =
198 match td.ptype_kind with
199 | Ptype_abstract -> if td.ptype_manifest <> None then `Alias else `Abstract
200 | Ptype_record _ -> `Record
201 | Ptype_variant _ -> `Variant
202 | Ptype_open -> `Abstract
203
204(* Process type declaration and create type_def_info *)
205let process_type_decl file item td loc =
206 let type_keyword_loc = type_keyword_loc file item in
207 let equals_loc = equals_loc file td in
208 let kind = type_kind td in
209 {
210 type_name = td.ptype_name.txt;
211 type_keyword_loc;
212 equals_loc;
213 kind;
214 full_bounds = loc;
215 }
216
217let type_definition file ast ~line ~col =
218 let iter =
219 {
220 Ast_iterator.default_iterator with
221 structure_item =
222 (fun self item ->
223 (match item.pstr_desc with
224 | Pstr_type (_, type_decls) ->
225 List.iter
226 (fun td ->
227 let loc = location_of_loc file td.ptype_loc in
228 if location_contains loc ~line ~col then
229 let type_def_info = process_type_decl file item td loc in
230 raise (Found_type_def type_def_info))
231 type_decls
232 | _ -> ());
233 Ast_iterator.default_iterator.structure_item self item);
234 }
235 in
236
237 try
238 iter.structure iter ast;
239 None
240 with Found_type_def info -> Some info
241
242(* Structure/signature item bounds *)
243
244let structure_item_bounds file ast ~line ~col =
245 List.find_map
246 (fun item ->
247 let loc = location_of_loc file item.pstr_loc in
248 if location_contains loc ~line ~col then
249 (* Return just the item bounds - comments will be added by
250 extend_location_with_comments *)
251 Some (to_full_lines loc)
252 else None)
253 ast
254
255let rec value_in_module file module_type ~line ~col =
256 match module_type.pmty_desc with
257 | Pmty_signature items ->
258 (* Look for value declarations inside this module signature *)
259 List.find_map
260 (fun item ->
261 match item.psig_desc with
262 | Psig_value vd ->
263 let loc = location_of_loc file vd.pval_loc in
264 if location_contains loc ~line ~col then
265 (* Found the value declaration *)
266 Some (to_full_lines loc)
267 else None
268 | Psig_module md ->
269 (* Recursively check inside nested modules *)
270 value_in_module file md.pmd_type ~line ~col
271 | _ -> None)
272 items
273 | _ -> None
274
275let signature_item_bounds file ast ~line ~col =
276 Log.debug (fun m ->
277 m "find_signature_item_bounds: looking for item at %s:%d:%d" file line col);
278 List.find_map
279 (fun item ->
280 let loc = location_of_loc file item.psig_loc in
281 Log.debug (fun m ->
282 m " Checking item at %d:%d-%d:%d" loc.start_line loc.start_col
283 loc.end_line loc.end_col);
284 if location_contains loc ~line ~col then (
285 Log.debug (fun m -> m " Found matching item!");
286 match item.psig_desc with
287 | Psig_value _ ->
288 (* For values, return just the value declaration bounds *)
289 Some (to_full_lines loc)
290 | Psig_module md -> (
291 (* Check if we're inside a module - if so, find the specific
292 value *)
293 match value_in_module file md.pmd_type ~line ~col with
294 | Some bounds -> Some bounds
295 | None ->
296 (* Not inside a value, return the whole module *)
297 Some (to_full_lines loc))
298 | _ ->
299 (* For other items (types, exceptions, etc.), return normal
300 bounds *)
301 Some (to_full_lines loc))
302 else None)
303 ast
304
305(* Public API *)
306
307let field_info ~cache ~file ~line ~col ~field_name =
308 match ast_entry ~cache file with
309 | Error e -> Error e
310 | Ok ast -> (
311 let iter =
312 {
313 Ast_iterator.default_iterator with
314 type_declaration =
315 (fun self td ->
316 (match field_in_type file td ~line ~col ~field_name with
317 | Some info -> raise (Found_field info)
318 | None -> ());
319 Ast_iterator.default_iterator.type_declaration self td);
320 expr =
321 (fun self e ->
322 (match field_in_record file e ~line ~col ~field_name with
323 | Some info -> raise (Found_field info)
324 | None -> ());
325 Ast_iterator.default_iterator.expr self e);
326 }
327 in
328
329 try
330 iter.structure iter ast;
331 err_field_not_found
332 with Found_field info -> Ok info)
333
334let type_definition_info ~cache ~file ~line ~col =
335 match ast_entry ~cache file with
336 | Error e -> Error e
337 | Ok ast -> (
338 match type_definition file ast ~line ~col with
339 | None -> err_no_type_def
340 | Some info -> Ok info)
341
342let item_with_docs ~cache ~file ~line ~col =
343 if Filename.check_suffix file ".mli" then
344 match interface_ast ~cache file with
345 | Error e -> Error e
346 | Ok ast -> (
347 match signature_item_bounds file ast ~line ~col with
348 | None -> err_no_sig_item
349 | Some bounds ->
350 (* Extend with doc comments if needed *)
351 Ok (Comments.extend_location_with_comments cache file bounds))
352 else
353 match ast_entry ~cache file with
354 | Error e -> Error e
355 | Ok ast -> (
356 match structure_item_bounds file ast ~line ~col with
357 | None -> err_no_struct_item
358 | Some bounds ->
359 Ok (Comments.extend_location_with_comments cache file bounds))
360
361let value_binding ~cache ~file ~line ~col =
362 match ast_entry ~cache file with
363 | Error e -> Error e
364 | Ok ast -> (
365 let iter =
366 {
367 Ast_iterator.default_iterator with
368 value_binding =
369 (fun self vb ->
370 let loc = location_of_loc file vb.pvb_loc in
371 if location_contains loc ~line ~col then
372 raise (Found_location loc)
373 else Ast_iterator.default_iterator.value_binding self vb);
374 }
375 in
376 try
377 iter.structure iter ast;
378 err_no_value_binding
379 with Found_location loc ->
380 Ok (Comments.extend_location_with_comments cache file loc))
381
382let enclosing_record ~cache ~file ~line ~col =
383 match ast_entry ~cache file with
384 | Error e -> Error e
385 | Ok ast -> (
386 let innermost = ref None in
387 let iter =
388 {
389 Ast_iterator.default_iterator with
390 expr =
391 (fun self e ->
392 (match e.pexp_desc with
393 | Pexp_record (_, _) -> (
394 let loc = location_of_loc file e.pexp_loc in
395 if location_contains loc ~line ~col then
396 (* Update innermost if this record is smaller/more
397 specific *)
398 match !innermost with
399 | None -> innermost := Some loc
400 | Some prev_loc ->
401 (* If this location is contained within the previous
402 one, it's more specific *)
403 if is_loc1_contained_in_loc2 loc prev_loc then
404 innermost := Some loc)
405 | _ -> ());
406 Ast_iterator.default_iterator.expr self e);
407 }
408 in
409
410 iter.structure iter ast;
411 match !innermost with
412 | None -> err_no_enclosing_record
413 | Some loc -> Ok loc)