gazagnaire.org
Find and remove dead code and unused APIs in OCaml projects
1(* Core types and utilities for prune *)
2
3(* Error helper functions *)
4let err fmt = Fmt.kstr (fun e -> Error (`Msg e)) fmt
5
6(* {2 Location information} *)
7
8type location = {
9 file : string;
10 start_line : int;
11 start_col : int;
12 end_line : int;
13 end_col : int;
14}
15
16let extend ?start_line ~end_line ?end_col location =
17 let start_line =
18 match start_line with None -> location.start_line | Some n -> n
19 in
20 let end_col = match end_col with None -> location.end_col | Some n -> n in
21 { location with start_line; end_line; end_col }
22
23let merge loc1 loc2 =
24 assert (loc1.file = loc2.file);
25 {
26 file = loc1.file;
27 start_line = min loc1.start_line loc2.start_line;
28 start_col =
29 (if loc1.start_line < loc2.start_line then loc1.start_col
30 else if loc2.start_line < loc1.start_line then loc2.start_col
31 else min loc1.start_col loc2.start_col);
32 end_line = max loc1.end_line loc2.end_line;
33 end_col =
34 (if loc1.end_line > loc2.end_line then loc1.end_col
35 else if loc2.end_line > loc1.end_line then loc2.end_col
36 else max loc1.end_col loc2.end_col);
37 }
38
39let relativize_path ~root_dir path =
40 let root_dir = Fpath.v root_dir in
41 let path_fpath = Fpath.v path in
42 match Fpath.(relativize ~root:root_dir path_fpath) with
43 | None -> path (* If can't relativize, return original path string *)
44 | Some rel ->
45 let rel_str = Fpath.to_string rel in
46 (* Remove ./ prefix with simple string manipulation since Fpath doesn't do
47 it *)
48 if String.length rel_str >= 2 && String.sub rel_str 0 2 = "./" then
49 String.sub rel_str 2 (String.length rel_str - 2)
50 else rel_str
51
52let location ~line ?(end_line = line) ~start_col ~end_col file =
53 (* Normalize file path to remove ./ prefix if present *)
54 let normalized_file =
55 if String.length file >= 2 && String.sub file 0 2 = "./" then
56 String.sub file 2 (String.length file - 2)
57 else file
58 in
59 { file = normalized_file; start_line = line; start_col; end_line; end_col }
60
61let pp_location ppf loc =
62 if loc.start_line = loc.end_line then
63 Fmt.pf ppf "%s:%d:%d-%d" loc.file loc.start_line loc.start_col loc.end_col
64 else
65 Fmt.pf ppf "%s:%d:%d-%d:%d" loc.file loc.start_line loc.start_col
66 loc.end_line loc.end_col
67
68(* {2 Symbol information} *)
69
70type symbol_kind =
71 | Value (* Functions, variables, etc. *)
72 | Type (* Type declarations *)
73 | Module (* Module declarations *)
74 | Constructor (* Variant constructors *)
75 | Field (* Record fields *)
76
77let string_of_symbol_kind = function
78 | Value -> "value"
79 | Type -> "type"
80 | Module -> "module"
81 | Constructor -> "constructor"
82 | Field -> "field"
83
84let symbol_kind_of_string = function
85 | "Value" -> Some Value
86 | "Type" -> Some Type
87 | "Module" -> Some Module
88 | "Constructor" -> Some Constructor
89 | "Field" -> Some Field
90 | "Exn" ->
91 Some Constructor (* Exception constructors are treated as constructors *)
92 | "Signature" -> Some Module (* Module signatures are treated as modules *)
93 | _ -> None
94
95type symbol_info = { name : string; kind : symbol_kind; location : location }
96
97(* {2 Occurrence information} *)
98
99type usage_classification =
100 | Unused
101 | Used_only_in_excluded (* Used only in excluded directories *)
102 | Used (* Used in at least one non-excluded location *)
103 | Unknown
104(* Cannot determine usage via occurrences (e.g., modules, exceptions) *)
105
106let pp_usage_classification fmt = function
107 | Unused -> Fmt.string fmt "unused"
108 | Used_only_in_excluded -> Fmt.string fmt "excluded-only"
109 | Used -> Fmt.string fmt "used"
110 | Unknown -> Fmt.string fmt "unknown"
111
112type occurrence_info = {
113 symbol : symbol_info;
114 occurrences : int;
115 locations : location list;
116 usage_class : usage_classification;
117}
118
119(* {2 Statistics} *)
120
121type stats = {
122 mli_exports_removed : int;
123 ml_implementations_removed : int;
124 iterations : int;
125 lines_removed : int;
126}
127
128let empty_stats =
129 {
130 mli_exports_removed = 0;
131 ml_implementations_removed = 0;
132 iterations = 0;
133 lines_removed = 0;
134 }
135
136let pp_stats fmt stats =
137 if stats.iterations = 0 then ()
138 (* Don't print anything - already handled by success message *)
139 else
140 Fmt.pf fmt
141 "Summary: removed %d export%s and %d implementation%s in %d iteration%s \
142 (%d line%s total)"
143 stats.mli_exports_removed
144 (if stats.mli_exports_removed = 1 then "" else "s")
145 stats.ml_implementations_removed
146 (if stats.ml_implementations_removed = 1 then "" else "s")
147 stats.iterations
148 (if stats.iterations = 1 then "" else "s")
149 stats.lines_removed
150 (if stats.lines_removed = 1 then "" else "s")
151
152(* {2 Warning information} *)
153
154type warning_type =
155 | Unused_value (* Warning 32: unused value declaration *)
156 | Unused_type (* Warning 34: unused type declaration *)
157 | Unused_open (* Warning 33: unused open statement *)
158 | Unused_constructor (* Warning 37: unused constructor *)
159 | Unused_exception (* Warning 38: unused exception declaration *)
160 | Unused_field (* Warning 69: unused record field definition *)
161 | Unnecessary_mutable
162 (* Warning 69: mutable record field that is never mutated *)
163 | Signature_mismatch (* Compiler error: value required but not provided *)
164 | Unbound_field (* Compiler error: unbound record field *)
165
166(* Precision of location information from compiler warnings/errors *)
167type location_precision =
168 | Exact_definition
169 (* Location covers the full definition that should be removed. Doc comments
170 should be removed as they document the definition. *)
171 | Exact_statement
172 (* Location covers a full statement (like open) that should be removed. No
173 doc comments to remove as statements don't have doc comments. *)
174 | Needs_enclosing_definition
175 (* Location is just an identifier, needs merlin enclosing to find full
176 definition. Doc comments should be removed after finding enclosing. *)
177 | Needs_field_usage_parsing
178(* Location is field name in record construction, needs special parsing. No doc
179 comments removal as we're removing usage, not definition. *)
180
181let precision_of_warning_type = function
182 | Unused_value -> Needs_enclosing_definition
183 | Unused_type -> Exact_definition
184 | Unused_open -> Exact_statement
185 | Unused_constructor -> Exact_definition
186 | Unused_exception -> Needs_enclosing_definition
187 | Unused_field ->
188 Exact_statement
189 (* Precise character-level location for field definition *)
190 | Unnecessary_mutable ->
191 Exact_statement (* Precise character-level location for mutable keyword *)
192 | Signature_mismatch -> Exact_definition
193 | Unbound_field -> Needs_field_usage_parsing
194
195let symbol_kind_of_warning = function
196 | Unused_value -> Value
197 | Unused_type -> Type
198 | Unused_open -> Module (* Open statements relate to modules *)
199 | Unused_constructor -> Constructor
200 | Unused_exception -> Constructor (* Exceptions are constructors *)
201 | Unused_field -> Field
202 | Unnecessary_mutable -> Field
203 | Signature_mismatch -> Value (* Usually values, but could be other kinds *)
204 | Unbound_field -> Field (* Field usage that needs to be removed *)
205
206let pp_warning_type fmt = function
207 | Unused_value -> Fmt.string fmt "Unused_value"
208 | Unused_type -> Fmt.string fmt "Unused_type"
209 | Unused_open -> Fmt.string fmt "Unused_open"
210 | Unused_constructor -> Fmt.string fmt "Unused_constructor"
211 | Unused_exception -> Fmt.string fmt "Unused_exception"
212 | Unused_field -> Fmt.string fmt "Unused_field"
213 | Unnecessary_mutable -> Fmt.string fmt "Unnecessary_mutable"
214 | Signature_mismatch -> Fmt.string fmt "Signature_mismatch"
215 | Unbound_field -> Fmt.string fmt "Unbound_field"
216
217type warning_info = {
218 location : location;
219 name : string;
220 warning_type : warning_type;
221 location_precision : location_precision;
222}
223
224let pp_location_precision fmt = function
225 | Exact_definition -> Fmt.string fmt "Exact_definition"
226 | Exact_statement -> Fmt.string fmt "Exact_statement"
227 | Needs_enclosing_definition -> Fmt.string fmt "Needs_enclosing_definition"
228 | Needs_field_usage_parsing -> Fmt.string fmt "Needs_field_usage_parsing"
229
230let pp_warning_info fmt w =
231 Fmt.pf fmt
232 "{ location = %a; name = %S; warning_type = %a; location_precision = %a }"
233 pp_location w.location w.name pp_warning_type w.warning_type
234 pp_location_precision w.location_precision
235
236(* {2 Build tracking} *)
237
238type build_result = {
239 success : bool;
240 output : string;
241 exit_code : int;
242 warnings : warning_info list; (* Parsed warnings from build output *)
243}
244
245type context = {
246 last_build_result : build_result option;
247 previous_errors : string list; (* Track error messages to detect loops *)
248}
249
250(* {2 Error handling} *)
251
252type error = [ `Msg of string | `Build_error of context ]
253
254let pp_error ppf = function
255 | `Msg s -> Fmt.pf ppf "%s" s
256 | `Build_error _ctx -> Fmt.pf ppf "Build failed"
257
258let empty_context = { last_build_result = None; previous_errors = [] }
259
260let update_build_result ctx result =
261 { ctx with last_build_result = Some result }
262
263let last_build_result ctx = ctx.last_build_result
264
265(* Build error classification *)
266type build_error_type =
267 | No_error
268 | Fixable_errors of warning_info list
269 | Other_errors of string
270
271(* {2 Merlin response types} *)
272
273(* Outline item from merlin *)
274type outline_item = {
275 kind : symbol_kind;
276 name : string;
277 location : location;
278 children : outline_item list option;
279}
280
281(* Merlin response types *)
282type outline_response = outline_item list
283type occurrences_response = location list
284
285(* {2 JSON schemas for merlin responses using jsont} *)
286
287(* Position in source: {line: int, col: int} *)
288type position = { line : int; col : int }
289
290let position_jsont =
291 Jsont.Object.map ~kind:"position" (fun line col -> { line; col })
292 |> Jsont.Object.mem "line" Jsont.int ~enc:(fun p -> p.line)
293 |> Jsont.Object.mem "col" Jsont.int ~enc:(fun p -> p.col)
294 |> Jsont.Object.finish
295
296(* Raw outline item from merlin (before converting to our types) *)
297type raw_outline_item = {
298 raw_kind : string;
299 raw_name : string;
300 raw_start : position;
301 raw_end : position option;
302 raw_children : raw_outline_item list;
303}
304
305let rec raw_outline_item_jsont =
306 lazy
307 (Jsont.Object.map ~kind:"outline_item"
308 (fun raw_kind raw_name raw_start raw_end raw_children ->
309 { raw_kind; raw_name; raw_start; raw_end; raw_children })
310 |> Jsont.Object.mem "kind" Jsont.string ~enc:(fun i -> i.raw_kind)
311 |> Jsont.Object.mem "name" Jsont.string ~enc:(fun i -> i.raw_name)
312 |> Jsont.Object.mem "start" position_jsont ~enc:(fun i -> i.raw_start)
313 |> Jsont.Object.opt_mem "end" position_jsont ~enc:(fun i -> i.raw_end)
314 |> Jsont.Object.mem "children"
315 (Jsont.list (Jsont.rec' raw_outline_item_jsont))
316 ~dec_absent:[]
317 ~enc:(fun i -> i.raw_children)
318 |> Jsont.Object.skip_unknown |> Jsont.Object.finish)
319
320let raw_outline_item_jsont = Lazy.force raw_outline_item_jsont
321
322(* Merlin outline response: {class: string, value: outline_item list} *)
323type raw_outline_response = {
324 outline_class : string option;
325 outline_value : raw_outline_item list;
326}
327
328let raw_outline_response_jsont =
329 Jsont.Object.map ~kind:"outline_response" (fun outline_class outline_value ->
330 { outline_class; outline_value })
331 |> Jsont.Object.opt_mem "class" Jsont.string ~enc:(fun r -> r.outline_class)
332 |> Jsont.Object.mem "value" (Jsont.list raw_outline_item_jsont) ~enc:(fun r ->
333 r.outline_value)
334 |> Jsont.Object.skip_unknown |> Jsont.Object.finish
335
336(* Raw occurrence from merlin *)
337type raw_occurrence = {
338 occ_start : position;
339 occ_end : position option;
340 occ_file : string option;
341}
342
343let raw_occurrence_jsont =
344 Jsont.Object.map ~kind:"occurrence" (fun occ_start occ_end occ_file ->
345 { occ_start; occ_end; occ_file })
346 |> Jsont.Object.mem "start" position_jsont ~enc:(fun o -> o.occ_start)
347 |> Jsont.Object.opt_mem "end" position_jsont ~enc:(fun o -> o.occ_end)
348 |> Jsont.Object.opt_mem "file" Jsont.string ~enc:(fun o -> o.occ_file)
349 |> Jsont.Object.skip_unknown |> Jsont.Object.finish
350
351(* Merlin occurrences response *)
352type raw_occurrences_response = {
353 occurrences_class : string option;
354 occurrences_value : raw_occurrence list;
355}
356
357let raw_occurrences_response_jsont =
358 Jsont.Object.map ~kind:"occurrences_response"
359 (fun occurrences_class occurrences_value ->
360 { occurrences_class; occurrences_value })
361 |> Jsont.Object.opt_mem "class" Jsont.string ~enc:(fun r ->
362 r.occurrences_class)
363 |> Jsont.Object.mem "value" (Jsont.list raw_occurrence_jsont) ~enc:(fun r ->
364 r.occurrences_value)
365 |> Jsont.Object.skip_unknown |> Jsont.Object.finish
366
367(* Convert raw outline item to our outline_item type *)
368let rec convert_outline_item ~file raw =
369 match symbol_kind_of_string raw.raw_kind with
370 | None -> None (* Unknown kind, skip *)
371 | Some kind ->
372 let start_line = raw.raw_start.line in
373 let start_col = raw.raw_start.col in
374 let end_line, end_col =
375 match raw.raw_end with
376 | Some p -> (p.line, p.col)
377 | None -> (start_line, start_col)
378 in
379 let location = { file; start_line; start_col; end_line; end_col } in
380 let children =
381 match raw.raw_children with
382 | [] -> None
383 | items ->
384 let converted =
385 List.filter_map (convert_outline_item ~file) items
386 in
387 if converted = [] then None else Some converted
388 in
389 Some { kind; name = raw.raw_name; location; children }
390
391(* Convert raw occurrence to location *)
392let convert_occurrence ~root_dir raw =
393 let file =
394 match raw.occ_file with Some f -> relativize_path ~root_dir f | None -> ""
395 in
396 let start_line = raw.occ_start.line in
397 let start_col = raw.occ_start.col in
398 let end_line, end_col =
399 match raw.occ_end with
400 | Some p -> (p.line, p.col)
401 | None -> (start_line, start_col)
402 in
403 location file ~line:start_line ~end_line ~start_col ~end_col
404
405(* Check if json is null *)
406let is_json_null = function Jsont.Null _ -> true | _ -> false
407
408(* Public API: decode outline response from Jsont.json *)
409let outline_response_of_json ~file json =
410 if is_json_null json then Ok []
411 else
412 match Jsont.Json.decode raw_outline_response_jsont json with
413 | Ok raw ->
414 Ok (List.filter_map (convert_outline_item ~file) raw.outline_value)
415 | Error e -> err "Invalid outline response: %s" e
416
417(* Public API: decode occurrences response from Jsont.json *)
418let occurrences_response_of_json ~root_dir json =
419 if is_json_null json then Ok []
420 else
421 match Jsont.Json.decode raw_occurrences_response_jsont json with
422 | Ok raw ->
423 Ok (List.map (convert_occurrence ~root_dir) raw.occurrences_value)
424 | Error e -> err "Invalid occurrences response: %s" e