Opinionated OCaml linter with Merlin integration for code quality, naming conventions, and style checks
merlint: Remove ppxlib dependency, use Merlin.Dump directly
- Remove ppxlib dependency from merlint, use merlin-lib's AST analysis
via ocaml-merlin's Dump module instead
- Move dump.ml parser from merlint to ocaml-merlin library, adding
dump_ast with typedtree/parsetree fallback
- Add Location, Dump, Outline, Occurrence modules to ocaml-merlin with
proper re-exports from the main Merlin module
- Delete merlin_dump.ml thin wrapper; merlint rules use Merlin.Dump
directly throughout
- Unify Location types between merlint and ocaml-merlin (merlint
re-exports Merlin.Location with custom pp)
- Fix ocaml-block build (Eio/bytesrw API updates)
- Add ocaml-merlin cram tests for outline, occurrences, enclosing
+297
-1137
+3
-2
bin/check_test_integrity.ml
+3
-2
bin/check_test_integrity.ml
···
82
82
if Sys.file_exists cram_dir && Sys.is_directory cram_dir then
83
83
Sys.readdir cram_dir |> Array.to_list
84
84
|> List.filter (fun name ->
85
-
String.ends_with ~suffix:".t" name
86
-
&& Sys.is_directory (Filename.concat cram_dir name))
85
+
String.ends_with ~suffix:".t" name
86
+
&& (not (String.length name > 0 && name.[0] = '.'))
87
+
&& Sys.is_directory (Filename.concat cram_dir name))
87
88
|> List.filter_map extract_error_code
88
89
else []
89
90
+11
-11
bin/generate_docs.ml
+11
-11
bin/generate_docs.ml
···
285
285
let re = Re.Perl.compile_pat pattern in
286
286
Re.all re escaped
287
287
|> List.iter (fun g ->
288
-
let start = Re.Group.start g 0 in
289
-
let stop = Re.Group.stop g 0 in
290
-
let text = Re.Group.get g 0 in
291
-
segments := (start, stop, class_name, text) :: !segments)
288
+
let start = Re.Group.start g 0 in
289
+
let stop = Re.Group.stop g 0 in
290
+
let text = Re.Group.get g 0 in
291
+
segments := (start, stop, class_name, text) :: !segments)
292
292
293
293
let add_keyword_segments escaped segments =
294
294
List.iter
···
296
296
let pattern = Re.Perl.compile_pat (Fmt.str {|\b%s\b|} kw) in
297
297
Re.all pattern escaped
298
298
|> List.iter (fun g ->
299
-
let start = Re.Group.start g 0 in
300
-
let stop = Re.Group.stop g 0 in
301
-
segments := (start, stop, "kw", kw) :: !segments))
299
+
let start = Re.Group.start g 0 in
300
+
let stop = Re.Group.stop g 0 in
301
+
segments := (start, stop, "kw", kw) :: !segments))
302
302
ocaml_keywords
303
303
304
304
let remove_overlapping_segments segments =
···
560
560
</div>|}
561
561
(categories
562
562
|> List.map (fun (name, range, _) ->
563
-
Fmt.str {|<li><a href="#%s">%s (%s)</a></li>|}
564
-
(String.lowercase_ascii name
565
-
|> String.map (fun c -> if c = '/' then '-' else c))
566
-
name range)
563
+
Fmt.str {|<li><a href="#%s">%s (%s)</a></li>|}
564
+
(String.lowercase_ascii name
565
+
|> String.map (fun c -> if c = '/' then '-' else c))
566
+
name range)
567
567
|> String.concat "\n")
568
568
569
569
let generate_error_section rule =
+2
-2
bin/generate_examples_ml.ml
+2
-2
bin/generate_examples_ml.ml
···
65
65
let test_directories cram_dir =
66
66
Sys.readdir cram_dir |> Array.to_list
67
67
|> List.filter (fun e ->
68
-
Filename.check_suffix e ".t"
69
-
&& Sys.is_directory (Filename.concat cram_dir e))
68
+
Filename.check_suffix e ".t"
69
+
&& Sys.is_directory (Filename.concat cram_dir e))
70
70
|> List.sort String.compare
71
71
72
72
let group_files_by_directory files =
+3
-17
bin/main.ml
+3
-17
bin/main.ml
···
10
10
Logs.set_level log_level;
11
11
Logs.set_reporter (Logs_fmt.reporter ~dst:Fmt.stderr ~app:Fmt.stdout ())
12
12
13
-
let check_ocamlmerlin () =
14
-
let cmd = "which ocamlmerlin > /dev/null 2>&1" in
15
-
match Unix.system cmd with Unix.WEXITED 0 -> true | _ -> false
16
-
17
13
let terminal_width () =
18
14
try
19
15
let ic = Unix.open_process_in "tput cols 2>/dev/null" in
···
88
84
(* Print each line of the hint in gray *)
89
85
String.split_on_char '\n' wrapped_hint
90
86
|> List.iter (fun line ->
91
-
Fmt.pr "%a@." (Fmt.styled `Faint Fmt.string) line)
87
+
Fmt.pr "%a@." (Fmt.styled `Faint Fmt.string) line)
92
88
| None -> ());
93
89
94
90
(* Print each issue with location and description *)
···
382
378
else Fmt.pr " %a@." Merlint.Rule_config.pp config.exclusions;
383
379
Stdlib.exit 0
384
380
385
-
let check_merlin_installed () =
386
-
if not (check_ocamlmerlin ()) then (
387
-
Log.err (fun m -> m "ocamlmerlin not found in PATH");
388
-
Log.err (fun m -> m "To fix this, run one of the following:");
389
-
Log.err (fun m -> m " 1. eval $(opam env) # If using opam");
390
-
Log.err (fun m ->
391
-
m " 2. opam install merlin # If merlin is not installed");
392
-
Stdlib.exit 1)
393
-
394
381
let parse_rule_filter rules_spec =
395
382
match rules_spec with
396
383
| None -> None
···
405
392
~show_config files =
406
393
setup_log ?style_renderer log_level;
407
394
if show_config then show_configuration files
408
-
else (
409
-
check_merlin_installed ();
395
+
else
410
396
let rule_filter = parse_rule_filter rules_spec in
411
-
analyze_files ~exclude_patterns ?rule_filter ~show_profile files)
397
+
analyze_files ~exclude_patterns ?rule_filter ~show_profile files
412
398
413
399
let cmd =
414
400
let doc = "Analyze OCaml code for style issues" in
-1
dune-project
-1
dune-project
+71
-60
lib/ast.ml
+71
-60
lib/ast.ml
···
129
129
depth_of 0 node
130
130
end
131
131
132
-
(** Convert ppxlib expression to our AST representation *)
133
-
let rec ppxlib_expr_to_ast (expr : Ppxlib.expression) : expr =
134
-
Log.debug (fun m ->
135
-
m "ppxlib_expr_to_ast: %s" (Ppxlib.Pprintast.string_of_expression expr));
132
+
(** Pretty-print expression for debugging *)
133
+
let expr_to_string (expr : Parsetree.expression) =
134
+
Format.asprintf "%a" Pprintast.expression expr
135
+
136
+
(** Convert Parsetree expression to our AST representation *)
137
+
let rec parsetree_expr_to_ast (expr : Parsetree.expression) : expr =
138
+
Log.debug (fun m -> m "parsetree_expr_to_ast: %s" (expr_to_string expr));
136
139
Log.debug (fun m ->
137
140
m "Expression type: %s"
138
-
(match expr.Ppxlib.pexp_desc with
139
-
| Ppxlib.Pexp_ifthenelse _ -> "Pexp_ifthenelse"
140
-
| Ppxlib.Pexp_match _ -> "Pexp_match"
141
-
| Ppxlib.Pexp_try _ -> "Pexp_try"
142
-
| Ppxlib.Pexp_function _ -> "Pexp_function"
143
-
| Ppxlib.Pexp_let _ -> "Pexp_let"
144
-
| Ppxlib.Pexp_sequence _ -> "Pexp_sequence"
141
+
(match expr.pexp_desc with
142
+
| Pexp_ifthenelse _ -> "Pexp_ifthenelse"
143
+
| Pexp_match _ -> "Pexp_match"
144
+
| Pexp_try _ -> "Pexp_try"
145
+
| Pexp_function _ -> "Pexp_function"
146
+
| Pexp_let _ -> "Pexp_let"
147
+
| Pexp_sequence _ -> "Pexp_sequence"
145
148
| _ -> "Other"));
146
-
match expr.Ppxlib.pexp_desc with
147
-
| Ppxlib.Pexp_ifthenelse (cond, then_expr, else_expr) ->
149
+
match expr.pexp_desc with
150
+
| Pexp_ifthenelse (cond, then_expr, else_expr) ->
148
151
If_then_else
149
152
{
150
-
cond = ppxlib_expr_to_ast cond;
151
-
then_expr = ppxlib_expr_to_ast then_expr;
152
-
else_expr = Option.map ppxlib_expr_to_ast else_expr;
153
+
cond = parsetree_expr_to_ast cond;
154
+
then_expr = parsetree_expr_to_ast then_expr;
155
+
else_expr = Option.map parsetree_expr_to_ast else_expr;
153
156
}
154
-
| Ppxlib.Pexp_match (expr, cases) ->
155
-
Match { expr = ppxlib_expr_to_ast expr; cases = List.length cases }
156
-
| Ppxlib.Pexp_try (expr, cases) ->
157
-
Try { expr = ppxlib_expr_to_ast expr; handlers = List.length cases }
158
-
| Ppxlib.Pexp_function (params, _, body) ->
157
+
| Pexp_match (expr, cases) ->
158
+
Match { expr = parsetree_expr_to_ast expr; cases = List.length cases }
159
+
| Pexp_try (expr, cases) ->
160
+
Try { expr = parsetree_expr_to_ast expr; handlers = List.length cases }
161
+
| Pexp_function (params, _, body) ->
159
162
(* In OCaml 5, multi-parameter functions have all params here *)
160
163
Log.debug (fun m -> m "Pexp_function: %d params" (List.length params));
161
164
162
165
let body_expr =
163
166
match body with
164
-
| Ppxlib.Pfunction_body expr ->
167
+
| Pfunction_body expr ->
165
168
Log.debug (fun m -> m "Found Pfunction_body");
166
-
ppxlib_expr_to_ast expr
167
-
| Ppxlib.Pfunction_cases (cases, _, _) ->
169
+
parsetree_expr_to_ast expr
170
+
| Pfunction_cases (cases, _, _) ->
168
171
Log.debug (fun m ->
169
172
m "Found Pfunction_cases with %d cases" (List.length cases));
170
173
(* This is a pattern matching function - treat it as a match expression *)
···
175
178
(* No parameters - this is just a pattern match *)
176
179
body_expr
177
180
else Function { params = List.length params; body = body_expr }
178
-
| Ppxlib.Pexp_let (_, bindings, body) ->
181
+
| Pexp_let (_, bindings, body) ->
179
182
let bindings =
180
183
List.map
181
-
(fun vb ->
182
-
match vb.Ppxlib.pvb_pat.Ppxlib.ppat_desc with
183
-
| Ppxlib.Ppat_var { txt; _ } ->
184
-
(txt, ppxlib_expr_to_ast vb.Ppxlib.pvb_expr)
185
-
| _ -> ("_", ppxlib_expr_to_ast vb.Ppxlib.pvb_expr))
184
+
(fun (vb : Parsetree.value_binding) ->
185
+
match vb.pvb_pat.ppat_desc with
186
+
| Ppat_var { txt; _ } -> (txt, parsetree_expr_to_ast vb.pvb_expr)
187
+
| _ -> ("_", parsetree_expr_to_ast vb.pvb_expr))
186
188
bindings
187
189
in
188
-
Let { bindings; body = ppxlib_expr_to_ast body }
189
-
| Ppxlib.Pexp_sequence (e1, e2) ->
190
-
Sequence [ ppxlib_expr_to_ast e1; ppxlib_expr_to_ast e2 ]
191
-
| Ppxlib.Pexp_construct ({ txt = Lident "[]"; _ }, None) ->
192
-
List (* Empty list *)
193
-
| Ppxlib.Pexp_construct ({ txt = Lident "::"; _ }, Some _) ->
194
-
List (* List cons *)
195
-
| Ppxlib.Pexp_array _ -> List (* Array literal *)
196
-
| Ppxlib.Pexp_record (fields, _) ->
190
+
Let { bindings; body = parsetree_expr_to_ast body }
191
+
| Pexp_sequence (e1, e2) ->
192
+
Sequence [ parsetree_expr_to_ast e1; parsetree_expr_to_ast e2 ]
193
+
| Pexp_construct ({ txt = Lident "[]"; _ }, None) -> List (* Empty list *)
194
+
| Pexp_construct ({ txt = Lident "::"; _ }, Some _) -> List (* List cons *)
195
+
| Pexp_array _ -> List (* Array literal *)
196
+
| Pexp_record (fields, _) ->
197
197
Record { fields = List.length fields } (* Record literal *)
198
-
| Ppxlib.Pexp_apply (func, args) ->
198
+
| Pexp_apply (func, args) ->
199
199
(* Parse function applications to find nested pattern matches *)
200
200
Log.debug (fun m -> m "Pexp_apply with %d args" (List.length args));
201
-
let func_ast = ppxlib_expr_to_ast func in
202
-
let args_asts = List.map (fun (_, arg) -> ppxlib_expr_to_ast arg) args in
201
+
let func_ast = parsetree_expr_to_ast func in
202
+
let args_asts =
203
+
List.map (fun (_, arg) -> parsetree_expr_to_ast arg) args
204
+
in
203
205
(* Treat the whole apply as a sequence containing func and all args *)
204
206
Sequence (func_ast :: args_asts)
205
207
| _ -> Other
206
208
207
209
(** Extract function definitions from structure items *)
208
-
let extract_functions_from_structure structure =
210
+
let extract_functions_from_structure (structure : Parsetree.structure) =
209
211
let functions = ref [] in
210
212
211
-
(* Use a visitor to find all value bindings *)
212
-
let visitor =
213
-
object
214
-
inherit Ppxlib.Ast_traverse.iter
215
-
216
-
method! value_binding vb =
217
-
match vb.Ppxlib.pvb_pat.Ppxlib.ppat_desc with
218
-
| Ppxlib.Ppat_var { txt = name; _ } ->
219
-
Log.debug (fun m -> m "Processing binding: %s" name);
220
-
let expr = ppxlib_expr_to_ast vb.pvb_expr in
221
-
Log.debug (fun m -> m "Converted %s to AST" name);
222
-
functions := (name, expr) :: !functions
223
-
| _ -> ()
224
-
end
213
+
let rec process_structure_item (item : Parsetree.structure_item) =
214
+
match item.pstr_desc with
215
+
| Pstr_value (_, bindings) ->
216
+
List.iter
217
+
(fun (vb : Parsetree.value_binding) ->
218
+
match vb.pvb_pat.ppat_desc with
219
+
| Ppat_var { txt = name; _ } ->
220
+
Log.debug (fun m -> m "Processing binding: %s" name);
221
+
let expr = parsetree_expr_to_ast vb.pvb_expr in
222
+
Log.debug (fun m -> m "Converted %s to AST" name);
223
+
functions := (name, expr) :: !functions
224
+
| _ -> ())
225
+
bindings
226
+
| Pstr_module { pmb_expr; _ } -> process_module_expr pmb_expr
227
+
| Pstr_recmodule mods ->
228
+
List.iter
229
+
(fun { Parsetree.pmb_expr; _ } -> process_module_expr pmb_expr)
230
+
mods
231
+
| _ -> ()
232
+
and process_module_expr (me : Parsetree.module_expr) =
233
+
match me.pmod_desc with
234
+
| Pmod_structure structure -> List.iter process_structure_item structure
235
+
| _ -> ()
225
236
in
226
237
227
-
visitor#structure structure;
238
+
List.iter process_structure_item structure;
228
239
List.rev !functions
229
240
230
-
(** Extract functions from a source file using ppxlib *)
241
+
(** Extract functions from a source file using compiler-libs *)
231
242
let extract_functions filename =
232
243
try
233
244
Log.debug (fun m -> m "Parsing file: %s" filename);
···
241
252
Log.debug (fun m -> m "Skipping interface file: %s" filename);
242
253
[])
243
254
else
244
-
let structure = Ppxlib.Parse.implementation lexbuf in
255
+
let structure = Parse.implementation lexbuf in
245
256
let functions = extract_functions_from_structure structure in
246
257
247
258
Log.debug (fun m ->
+16
-19
lib/context.ml
+16
-19
lib/context.ml
···
11
11
config : Config.t;
12
12
project_root : string;
13
13
ast : Ast.t Lazy.t;
14
-
dump : Dump.t Lazy.t;
14
+
dump : Merlin.Dump.t Lazy.t;
15
15
outline : Outline.t Lazy.t;
16
16
content : string Lazy.t;
17
17
functions : (string * Ast.expr) list Lazy.t;
···
35
35
ast = lazy { Ast.functions = Ast.extract_functions filename };
36
36
dump =
37
37
lazy
38
-
(match dump with
39
-
| Ok d -> d
40
-
| Error msg -> raise (Analysis_error msg));
38
+
(match dump with Ok d -> d | Error msg -> raise (Analysis_error msg));
41
39
outline =
42
40
lazy
43
41
(match outline with
···
99
97
let file_test_modules =
100
98
all_files
101
99
|> List.filter_map (fun f ->
102
-
if String.ends_with ~suffix:".ml" f then
103
-
let basename =
104
-
Filename.basename f |> Filename.remove_extension
105
-
in
106
-
if
107
-
String.starts_with ~prefix:"test_" basename
108
-
|| basename = "test"
109
-
then (
110
-
Log.debug (fun m ->
111
-
m "Context: Found test file %s -> module %s" f
112
-
basename);
113
-
Some basename)
114
-
else None
115
-
else None)
100
+
if String.ends_with ~suffix:".ml" f then
101
+
let basename =
102
+
Filename.basename f |> Filename.remove_extension
103
+
in
104
+
if
105
+
String.starts_with ~prefix:"test_" basename
106
+
|| basename = "test"
107
+
then (
108
+
Log.debug (fun m ->
109
+
m "Context: Found test file %s -> module %s" f basename);
110
+
Some basename)
111
+
else None
112
+
else None)
116
113
in
117
114
(* Combine and deduplicate *)
118
115
let all_test_modules =
···
137
134
let dump ctx =
138
135
let dump_data = Lazy.force ctx.dump in
139
136
(* Automatically fix all paths to use full path instead of basename *)
140
-
Dump.fix_all_paths ~full_path:ctx.filename dump_data
137
+
Merlin.Dump.fix_all_paths ~full_path:ctx.filename dump_data
141
138
142
139
let outline ctx = Lazy.force ctx.outline
143
140
let content ctx = Lazy.force ctx.content
+6
-4
lib/context.mli
+6
-4
lib/context.mli
···
2
2
*)
3
3
4
4
exception Analysis_error of string
5
-
(** Raised when analysis fails (e.g., Merlint_backend error, file read error). *)
5
+
(** Raised when analysis fails (e.g., Merlint_backend error, file read error).
6
+
*)
6
7
7
8
type file = {
8
9
filename : string; (** The current file being analyzed. *)
9
10
config : Config.t; (** The merlint configuration. *)
10
11
project_root : string; (** The project root directory. *)
11
12
ast : Ast.t Lazy.t; (** AST control flow from ppxlib (lazy). *)
12
-
dump : Dump.t Lazy.t; (** Names/identifiers from Merlint_backend dump (lazy). *)
13
+
dump : Merlin.Dump.t Lazy.t;
14
+
(** Names/identifiers from Merlint_backend dump (lazy). *)
13
15
outline : Outline.t Lazy.t; (** Outline from Merlint_backend (lazy). *)
14
16
content : string Lazy.t; (** File content (lazy). *)
15
17
functions : (string * Ast.expr) list Lazy.t;
···
32
34
config:Config.t ->
33
35
project_root:string ->
34
36
outline:(Outline.t, string) result ->
35
-
dump:(Dump.t, string) result ->
37
+
dump:(Merlin.Dump.t, string) result ->
36
38
file
37
39
(** [file ~filename ~config ~project_root ~outline ~dump] creates a file
38
40
context. *)
···
51
53
val ast : file -> Ast.t
52
54
(** [ast file] returns ast field. *)
53
55
54
-
val dump : file -> Dump.t
56
+
val dump : file -> Merlin.Dump.t
55
57
(** [dump file] returns dump field. *)
56
58
57
59
val outline : file -> Outline.t
+45
-38
lib/docs.ml
+45
-38
lib/docs.ml
···
162
162
Re.execp (Re.compile (Re.str "->")) signature
163
163
164
164
(** Extract the doc attribute from an attribute list *)
165
-
let doc_attribute attrs =
166
-
let open Ppxlib in
165
+
let doc_attribute (attrs : Parsetree.attributes) =
167
166
List.find_opt
168
-
(fun attr ->
167
+
(fun (attr : Parsetree.attribute) ->
169
168
match attr.attr_name.txt with "ocaml.doc" -> true | _ -> false)
170
169
attrs
171
-
|> Option.map (fun attr ->
172
-
match attr.attr_payload with
173
-
| PStr
174
-
[
175
-
{
176
-
pstr_desc =
177
-
Pstr_eval
178
-
( {
179
-
pexp_desc = Pexp_constant (Pconst_string (doc, _, _));
180
-
_;
181
-
},
182
-
_ );
183
-
_;
184
-
};
185
-
] ->
186
-
String.trim doc
187
-
| _ -> "")
170
+
|> Option.map (fun (attr : Parsetree.attribute) ->
171
+
match attr.attr_payload with
172
+
| PStr
173
+
[
174
+
{
175
+
pstr_desc =
176
+
Pstr_eval
177
+
( {
178
+
pexp_desc =
179
+
Pexp_constant
180
+
{ pconst_desc = Pconst_string (doc, _, _); _ };
181
+
_;
182
+
},
183
+
_ );
184
+
_;
185
+
};
186
+
] ->
187
+
String.trim doc
188
+
| _ -> "")
188
189
189
-
(** Extract the location info from a Ppxlib location *)
190
-
let extract_location (loc : Ppxlib.location) =
191
-
let start_line = loc.loc_start.pos_lnum in
192
-
let end_line = loc.loc_end.pos_lnum in
190
+
(** Extract the location info from a compiler-libs location *)
191
+
let extract_location_info loc_start loc_end =
192
+
(* Access Lexing.position fields directly *)
193
+
let start_line = loc_start.Lexing.pos_lnum in
194
+
let end_line = loc_end.Lexing.pos_lnum in
193
195
(start_line, end_line)
194
196
195
197
(** Get the string representation of a core type *)
196
-
let rec core_type_to_string (typ : Ppxlib.core_type) =
197
-
let open Ppxlib in
198
+
let rec core_type_to_string (typ : Parsetree.core_type) =
198
199
match typ.ptyp_desc with
199
200
| Ptyp_var name -> "'" ^ name
200
201
| Ptyp_constr ({ txt = Lident name; _ }, []) -> name
201
-
| Ptyp_constr ({ txt = Ldot (_, name); _ }, []) -> name
202
+
| Ptyp_constr ({ txt = Ldot (_, name); _ }, []) -> name.txt
202
203
| Ptyp_arrow (_, t1, t2) ->
203
204
let arg_str = core_type_to_string t1 in
204
205
let ret_str = core_type_to_string t2 in
205
206
arg_str ^ " -> " ^ ret_str
206
207
| Ptyp_tuple types ->
207
-
let type_strs = List.map core_type_to_string types in
208
+
let type_strs = List.map (fun (_, t) -> core_type_to_string t) types in
208
209
String.concat " * " type_strs
209
210
| _ -> "<complex type>"
210
211
···
230
231
!regular_comments
231
232
232
233
(** Process a value declaration and extract its documentation *)
233
-
let process_value_declaration vd ~regular_comments ~last_floating_doc =
234
-
let open Ppxlib in
234
+
let process_value_declaration (vd : Parsetree.value_description)
235
+
~regular_comments ~last_floating_doc =
235
236
let value_name = vd.pval_name.txt in
236
237
let signature = core_type_to_string vd.pval_type in
237
-
let val_line, _ = extract_location vd.pval_loc in
238
+
let val_line, _ =
239
+
extract_location_info vd.pval_loc.loc_start vd.pval_loc.loc_end
240
+
in
238
241
239
242
(* Check if this value has a regular comment *)
240
243
let has_regular_comment =
···
271
274
272
275
{ value_name; signature; doc; doc_line; val_line }
273
276
274
-
(** Extract documentation comments using ppxlib *)
277
+
(** Extract documentation comments using compiler-libs *)
275
278
let extract_doc_comments content =
276
279
try
277
-
let open Ppxlib in
278
280
(* Parse as a signature (interface file) *)
279
281
let lexbuf = Lexing.from_string content in
280
282
let signature = Parse.interface lexbuf in
281
283
282
284
(* We need to also check for regular comments in the original content
283
-
since ppxlib doesn't preserve them in the AST *)
285
+
since the parser doesn't preserve them in the AST *)
284
286
let lines = String.split_on_char '\n' content in
285
287
let regular_comments = regular_comments lines in
286
288
···
289
291
let last_floating_doc = ref None in
290
292
291
293
List.iter
292
-
(fun (sig_item : signature_item) ->
294
+
(fun (sig_item : Parsetree.signature_item) ->
293
295
match sig_item.psig_desc with
294
296
| Psig_attribute attr when attr.attr_name.txt = "ocaml.doc" -> (
295
297
(* Floating doc comment *)
···
300
302
pstr_desc =
301
303
Pstr_eval
302
304
( {
303
-
pexp_desc = Pexp_constant (Pconst_string (doc, _, _));
305
+
pexp_desc =
306
+
Pexp_constant
307
+
{ pconst_desc = Pconst_string (doc, _, _); _ };
304
308
_;
305
309
},
306
310
_ );
307
311
_;
308
312
};
309
313
] ->
310
-
let doc_line, _ = extract_location attr.attr_loc in
314
+
let doc_line, _ =
315
+
extract_location_info attr.attr_loc.loc_start
316
+
attr.attr_loc.loc_end
317
+
in
311
318
last_floating_doc := Some (doc, doc_line)
312
319
| _ -> ())
313
320
| Psig_value vd ->
···
322
329
323
330
List.rev !doc_comments
324
331
with Parsing.Parse_error | Failure _ ->
325
-
(* If ppxlib parsing fails, return empty list *)
332
+
(* If parsing fails, return empty list *)
326
333
[]
-648
lib/dump.ml
-648
lib/dump.ml
···
1
-
(** Dump module - handles all AST text dump parsing functionality *)
2
-
3
-
let src = Logs.Src.create "merlint.dump" ~doc:"AST dump parsing"
4
-
5
-
module Log = (val Logs.src_log src : Logs.LOG)
6
-
7
-
type name = { prefix : string list; base : string }
8
-
(** Structured name type *)
9
-
10
-
type elt = { name : name; location : Location.t option }
11
-
(** Common element type for all extracted items *)
12
-
13
-
type t = {
14
-
modules : elt list; (** Module names *)
15
-
types : elt list; (** Type declarations *)
16
-
exceptions : elt list; (** Exception declarations *)
17
-
variants : elt list; (** Variant constructors *)
18
-
identifiers : elt list; (** Value identifiers (usage) *)
19
-
patterns : elt list; (** Pattern variables *)
20
-
values : elt list; (** Value bindings (definitions) *)
21
-
}
22
-
(** Extracted names and identifiers from the AST dump *)
23
-
24
-
(** What kind of AST dump we're parsing *)
25
-
type what = Parsetree | Typedtree
26
-
27
-
exception Parse_error of string
28
-
(** Parse error exception *)
29
-
30
-
exception Type_error
31
-
(** Type error exception - raised when typedtree contains type errors *)
32
-
33
-
exception Wrong_ast_type
34
-
(** Wrong AST type exception - raised when parsing Typedtree but found Parsetree
35
-
nodes *)
36
-
37
-
(** Convert a structured name to a string *)
38
-
let name_to_string (n : name) =
39
-
match n.prefix with
40
-
| [] -> n.base
41
-
| prefix -> String.concat "." prefix ^ "." ^ n.base
42
-
43
-
(** Token kinds *)
44
-
type token_kind =
45
-
| Word of string
46
-
| Location of
47
-
Location.t (* Parsed location like (file.ml[1,0+0]..file.ml[1,0+31]) *)
48
-
| Module (* Tstr_module / Pstr_module *)
49
-
| Type (* Tstr_type / Pstr_type *)
50
-
| Type_declaration (* type_declaration *)
51
-
| Value (* Tstr_value / Pstr_value *)
52
-
| Exception (* Tstr_exception / Pstr_exception *)
53
-
| Variant (* Ttype_variant / Ptype_variant *)
54
-
| Ident (* Texp_ident / Pexp_ident *)
55
-
| Construct (* Texp_construct / Pexp_construct *)
56
-
| Pattern (* Tpat_var / Ppat_var *)
57
-
| Attribute (* Tstr_attribute / Pstr_attribute *)
58
-
| LParen
59
-
| RParen
60
-
| LBracket
61
-
| RBracket
62
-
63
-
type token = { kind : token_kind; loc : Location.t option }
64
-
(** Token representation *)
65
-
66
-
(** Empty accumulator for name extraction *)
67
-
let empty_acc =
68
-
{
69
-
modules = [];
70
-
types = [];
71
-
exceptions = [];
72
-
variants = [];
73
-
identifiers = [];
74
-
patterns = [];
75
-
values = [];
76
-
(* All value bindings including functions *)
77
-
}
78
-
79
-
(** Helper regex components for location parsing *)
80
-
let filename = Re.rep1 (Re.compl [ Re.char '[' ])
81
-
82
-
let number = Re.rep1 Re.digit
83
-
84
-
let location_part =
85
-
Re.seq
86
-
[
87
-
Re.str "[";
88
-
Re.group number;
89
-
Re.str ",";
90
-
number;
91
-
Re.str "+";
92
-
Re.group number;
93
-
Re.str "]";
94
-
]
95
-
96
-
let loc_regex =
97
-
Re.compile
98
-
(Re.seq
99
-
[
100
-
Re.str "(";
101
-
Re.group filename;
102
-
location_part;
103
-
Re.str "..";
104
-
filename;
105
-
location_part;
106
-
Re.str ")";
107
-
])
108
-
109
-
let parse_location str =
110
-
try
111
-
let m = Re.exec loc_regex str in
112
-
let file = Re.Group.get m 1 in
113
-
let start_line = int_of_string (Re.Group.get m 2) in
114
-
let start_col = int_of_string (Re.Group.get m 3) in
115
-
let end_line = int_of_string (Re.Group.get m 4) in
116
-
let end_col = int_of_string (Re.Group.get m 5) in
117
-
Some (Location.v ~file ~start_line ~start_col ~end_line ~end_col)
118
-
with Not_found -> None
119
-
120
-
(** Lookup table for AST node kinds *)
121
-
let ast_node_map =
122
-
[
123
-
(* Typedtree nodes *)
124
-
("Tstr_module", Module);
125
-
("Tstr_type", Type);
126
-
("Tstr_value", Value);
127
-
("Tstr_exception", Exception);
128
-
("Ttype_variant", Variant);
129
-
("Texp_ident", Ident);
130
-
("Texp_construct", Construct);
131
-
("Tpat_var", Pattern);
132
-
("Tstr_attribute", Attribute);
133
-
(* Parsetree nodes *)
134
-
("Pstr_module", Module);
135
-
("Pstr_type", Type);
136
-
("Pstr_value", Value);
137
-
("Pstr_exception", Exception);
138
-
("Ptype_variant", Variant);
139
-
("Pexp_ident", Ident);
140
-
("Pexp_construct", Construct);
141
-
("Ppat_var", Pattern);
142
-
("Pstr_attribute", Attribute);
143
-
(* Context-independent *)
144
-
("type_declaration", Type_declaration);
145
-
]
146
-
147
-
(** Get AST node token kind if word is a recognized AST node in the given
148
-
context *)
149
-
let ast_node_kind word =
150
-
(* Since we handle both Typedtree and Parsetree nodes in both contexts,
151
-
we can use a single lookup table *)
152
-
List.assoc_opt word ast_node_map
153
-
154
-
(** Classify a word as either an AST node or just a word *)
155
-
let classify_word word =
156
-
match ast_node_kind word with Some k -> k | None -> Word word
157
-
158
-
(** Check if we're at the start of a location pattern *)
159
-
let is_location_start text pos =
160
-
pos < String.length text
161
-
&& text.[pos] = '('
162
-
&&
163
-
try
164
-
(* Look for pattern like (file.ml[... *)
165
-
let rec check i =
166
-
if i >= String.length text then false
167
-
else if text.[i] = '[' then true
168
-
else if text.[i] = ' ' || text.[i] = '\n' then false
169
-
else check (i + 1)
170
-
in
171
-
check (pos + 1)
172
-
with Invalid_argument _ -> false
173
-
174
-
(** Parse a complete location token *)
175
-
let parse_location_token text start_pos =
176
-
let rec find_end pos paren_count =
177
-
if pos >= String.length text then pos
178
-
else
179
-
match text.[pos] with
180
-
| '(' -> find_end (pos + 1) (paren_count + 1)
181
-
| ')' ->
182
-
if paren_count = 1 then pos + 1
183
-
else find_end (pos + 1) (paren_count - 1)
184
-
| _ -> find_end (pos + 1) paren_count
185
-
in
186
-
let end_pos = find_end start_pos 0 in
187
-
let loc_str = String.sub text start_pos (end_pos - start_pos) in
188
-
(parse_location loc_str, end_pos)
189
-
190
-
(* Phase 1: Lexer - Convert raw text to tokens *)
191
-
192
-
(** Process end of text *)
193
-
let process_end_of_text acc current =
194
-
if current = "" then List.rev acc
195
-
else
196
-
let kind = classify_word current in
197
-
List.rev ({ kind; loc = None } :: acc)
198
-
199
-
(** Process location token *)
200
-
let process_location_token acc text pos what_context tokenize =
201
-
let loc_opt, new_pos = parse_location_token text pos in
202
-
match loc_opt with
203
-
| Some loc ->
204
-
tokenize
205
-
({ kind = Location loc; loc = None } :: acc)
206
-
"" new_pos what_context
207
-
| None ->
208
-
(* Failed to parse as location, treat as regular paren *)
209
-
tokenize ({ kind = LParen; loc = None } :: acc) "" (pos + 1) what_context
210
-
211
-
(** Process whitespace character *)
212
-
let process_whitespace acc current pos what_context tokenize =
213
-
if current = "" then tokenize acc current (pos + 1) what_context
214
-
else
215
-
let kind = classify_word current in
216
-
tokenize ({ kind; loc = None } :: acc) "" (pos + 1) what_context
217
-
218
-
(** Process bracket character *)
219
-
let process_bracket bracket acc current pos what_context tokenize =
220
-
let bracket_kind =
221
-
match bracket with
222
-
| '(' -> LParen
223
-
| ')' -> RParen
224
-
| '[' -> LBracket
225
-
| ']' -> RBracket
226
-
| _ -> assert false
227
-
in
228
-
let acc' =
229
-
if current = "" then acc
230
-
else
231
-
let kind = classify_word current in
232
-
{ kind; loc = None } :: acc
233
-
in
234
-
tokenize
235
-
({ kind = bracket_kind; loc = None } :: acc')
236
-
"" (pos + 1) what_context
237
-
238
-
let lex_text what text : token list =
239
-
(* Tokenizer that recognizes AST nodes based on current what context *)
240
-
let rec tokenize acc current pos what_context =
241
-
if pos >= String.length text then process_end_of_text acc current
242
-
else if current = "" && is_location_start text pos then
243
-
process_location_token acc text pos what_context tokenize
244
-
else
245
-
let ch = text.[pos] in
246
-
match ch with
247
-
| ' ' | '\n' | '\t' ->
248
-
process_whitespace acc current pos what_context tokenize
249
-
| ('(' | ')' | '[' | ']') as bracket ->
250
-
process_bracket bracket acc current pos what_context tokenize
251
-
| _ -> tokenize acc (current ^ String.make 1 ch) (pos + 1) what_context
252
-
in
253
-
tokenize [] "" 0 what
254
-
255
-
(** Parse structured name from string like "Str.regexp" or "Stdlib!.Obj.magic"
256
-
*)
257
-
let parse_name str =
258
-
(* Remove quotes if present *)
259
-
let str =
260
-
let len = String.length str in
261
-
if len >= 2 && str.[0] = '"' && str.[len - 1] = '"' then
262
-
String.sub str 1 (len - 2)
263
-
else str
264
-
in
265
-
(* Remove unique suffix like /123 if present *)
266
-
let str =
267
-
match String.index_opt str '/' with
268
-
| Some i -> String.sub str 0 i
269
-
| None -> str
270
-
in
271
-
(* Remove ! markers from stdlib names *)
272
-
let str = String.map (fun c -> if c = '!' then ' ' else c) str in
273
-
(* Split by . to get components, filtering out empty parts *)
274
-
let parts =
275
-
String.split_on_char '.' str
276
-
|> List.map String.trim
277
-
|> List.filter (fun s -> s <> "")
278
-
in
279
-
match List.rev parts with
280
-
| [] -> { prefix = []; base = "" }
281
-
| base :: rev_modules -> { prefix = List.rev rev_modules; base }
282
-
283
-
(* Phase 2: Parser - Convert tokens into structured data *)
284
-
285
-
(* Skip attribute contents - they can contain mixed AST nodes *)
286
-
let rec skip_attribute depth = function
287
-
| [] -> []
288
-
| { kind = LBracket; _ } :: rest -> skip_attribute (depth + 1) rest
289
-
| { kind = RBracket; _ } :: rest ->
290
-
if depth <= 1 then rest else skip_attribute (depth - 1) rest
291
-
| _ :: rest -> skip_attribute depth rest
292
-
293
-
(* Helper for parsing named items *)
294
-
let parse_named_item tokens =
295
-
match tokens with
296
-
| { kind = Word name_with_id; _ } :: rest
297
-
when String.contains name_with_id '/' ->
298
-
Some (parse_name name_with_id, rest)
299
-
| _ -> None
300
-
301
-
(* Parse variant list - can have multiple variants in sequence *)
302
-
let parse_variant_list acc location tokens continue_parse =
303
-
(* Helper to update variants accumulator *)
304
-
let add_variant acc' name current_loc =
305
-
{ acc' with variants = { name; location = current_loc } :: acc'.variants }
306
-
in
307
-
308
-
(* Parse multiple variants until we hit something else *)
309
-
let rec collect_variants acc' current_loc = function
310
-
| [] -> continue_parse acc' location []
311
-
| { kind; _ } :: rest -> (
312
-
match kind with
313
-
(* Update location if we see a location token *)
314
-
| Location loc -> collect_variants acc' (Some loc) rest
315
-
(* Variant name *)
316
-
| Word content when String.contains content '/' ->
317
-
let name = parse_name content in
318
-
let new_acc = add_variant acc' name current_loc in
319
-
collect_variants new_acc current_loc rest
320
-
(* Keep going through brackets and other tokens *)
321
-
| LBracket | RBracket | Word _ -> collect_variants acc' current_loc rest
322
-
(* Stop when we hit another AST node *)
323
-
| _ -> continue_parse acc' location ({ kind; loc = None } :: rest))
324
-
in
325
-
collect_variants acc location tokens
326
-
327
-
(** Parse token stream into structured AST *)
328
-
let parse_tokens tokens =
329
-
(* Helper to dispatch to specific parsers *)
330
-
let rec dispatch_parser acc location rest = function
331
-
| Module -> parse_module acc location rest
332
-
| Type -> parse_type acc location rest
333
-
| Type_declaration -> parse_type_declaration acc location rest
334
-
| Variant -> parse_variants acc location rest
335
-
| Ident -> parse_ident acc location rest
336
-
| Pattern -> parse_pattern acc location rest
337
-
| Value -> parse_value acc location rest
338
-
| Construct -> parse_construct acc location rest
339
-
| Attribute -> parse_attribute acc location rest
340
-
| _ -> parse acc location rest
341
-
and parse acc location = function
342
-
| [] -> acc
343
-
| { kind = Location loc; _ } :: rest ->
344
-
(* Direct location token *)
345
-
parse acc (Some loc) rest
346
-
| { kind = Word content; _ } :: rest
347
-
when String.ends_with ~suffix:"_item" content
348
-
|| content = "structure_item" ->
349
-
(* structure_item or similar - location already parsed if it was there *)
350
-
parse acc location rest
351
-
| { kind; _ } :: rest ->
352
-
(* Found an AST node token or other *)
353
-
dispatch_parser acc location rest kind
354
-
and parse_module acc location tokens =
355
-
match parse_named_item tokens with
356
-
| Some (name, rest) ->
357
-
let new_acc =
358
-
{ acc with modules = { name; location } :: acc.modules }
359
-
in
360
-
parse new_acc location rest
361
-
| None -> parse acc location tokens
362
-
and parse_type acc location rest =
363
-
(* Just continue parsing, types are handled by TypeDeclaration *)
364
-
parse acc location rest
365
-
and parse_type_declaration acc location tokens =
366
-
match parse_named_item tokens with
367
-
| Some (name, rest) ->
368
-
let new_acc = { acc with types = { name; location } :: acc.types } in
369
-
parse new_acc location rest
370
-
| None -> parse acc location tokens
371
-
and parse_variants acc location tokens =
372
-
parse_variant_list acc location tokens parse
373
-
and parse_ident acc location tokens =
374
-
match tokens with
375
-
| { kind = Word content; _ } :: rest ->
376
-
let name = parse_name content in
377
-
let new_acc =
378
-
{ acc with identifiers = { name; location } :: acc.identifiers }
379
-
in
380
-
parse new_acc location rest
381
-
| rest -> parse acc location rest
382
-
and parse_pattern acc location tokens =
383
-
match tokens with
384
-
| { kind = Word content; _ } :: rest ->
385
-
let name = parse_name content in
386
-
let new_acc =
387
-
{ acc with patterns = { name; location } :: acc.patterns }
388
-
in
389
-
parse new_acc location rest
390
-
| rest -> parse acc location rest
391
-
and parse_value acc location rest =
392
-
(* Just continue parsing, values might be handled differently *)
393
-
parse acc location rest
394
-
and parse_construct acc location tokens =
395
-
match tokens with
396
-
| { kind = Word content; _ } :: rest ->
397
-
let name = parse_name content in
398
-
let new_acc =
399
-
{ acc with variants = { name; location } :: acc.variants }
400
-
in
401
-
parse new_acc location rest
402
-
| rest -> parse acc location rest
403
-
and parse_attribute acc location tokens =
404
-
(* Attributes are typically followed by [ ... ] *)
405
-
match tokens with
406
-
| { kind = Word _; _ } :: { kind = LBracket; _ } :: rest ->
407
-
parse acc location (skip_attribute 1 rest)
408
-
| _ -> parse acc location tokens
409
-
in
410
-
411
-
parse empty_acc None tokens
412
-
413
-
(** Parse AST text with specific what *)
414
-
let text what input =
415
-
(* Phase 1: Lex the text into tokens *)
416
-
let tokens = lex_text what input in
417
-
(* Phase 2: Parse tokens into structured data *)
418
-
parse_tokens tokens
419
-
420
-
(** Parse parsetree text dump into AST structure *)
421
-
let parsetree input = text Parsetree input
422
-
423
-
(** Parse typedtree text dump into AST structure *)
424
-
let typedtree input =
425
-
(* Try Typedtree first, fall back to Parsetree if there are type errors *)
426
-
try
427
-
let result = text Typedtree input in
428
-
(* Check for type errors *)
429
-
let has_type_error =
430
-
List.exists (fun id -> id.name.base = "*type-error*") result.identifiers
431
-
in
432
-
if has_type_error then raise Type_error else result
433
-
with
434
-
| Type_error ->
435
-
(* Type errors in the code - try with Parsetree *)
436
-
Log.debug (fun m -> m "Type errors detected, falling back to Parsetree");
437
-
text Parsetree input
438
-
| Wrong_ast_type ->
439
-
(* Wrong AST type - Parsetree nodes in what should be Typedtree *)
440
-
Log.debug (fun m ->
441
-
m "Wrong AST type detected, falling back to Parsetree");
442
-
text Parsetree input
443
-
444
-
(** Utility functions for working with dump data *)
445
-
446
-
let iter_identifiers_with_location dump_data f =
447
-
List.iter
448
-
(fun (id : elt) ->
449
-
match id.location with Some loc -> f id loc | None -> ())
450
-
dump_data.identifiers
451
-
452
-
let location (elt : elt) = elt.location
453
-
454
-
(** Fix location to use full path instead of basename *)
455
-
let fix_location_path ~full_path loc =
456
-
Location.v ~file:full_path ~start_line:loc.Location.start_line
457
-
~start_col:loc.Location.start_col ~end_line:loc.Location.end_line
458
-
~end_col:loc.Location.end_col
459
-
460
-
(** Fix all locations in a dump structure to use full path *)
461
-
let fix_all_paths ~full_path dump =
462
-
let fix_elt (elt : elt) =
463
-
{
464
-
elt with
465
-
location =
466
-
(match elt.location with
467
-
| Some loc -> Some (fix_location_path ~full_path loc)
468
-
| None -> None);
469
-
}
470
-
in
471
-
{
472
-
modules = List.map fix_elt dump.modules;
473
-
types = List.map fix_elt dump.types;
474
-
exceptions = List.map fix_elt dump.exceptions;
475
-
variants = List.map fix_elt dump.variants;
476
-
identifiers = List.map fix_elt dump.identifiers;
477
-
patterns = List.map fix_elt dump.patterns;
478
-
values = List.map fix_elt dump.values;
479
-
}
480
-
481
-
let check_identifier_pattern ~full_path identifiers pattern_match
482
-
issue_constructor =
483
-
List.filter_map
484
-
(fun (id : elt) ->
485
-
match id.location with
486
-
| Some loc ->
487
-
let name = id.name in
488
-
if pattern_match name then
489
-
let loc = fix_location_path ~full_path loc in
490
-
Some (issue_constructor ~loc)
491
-
else None
492
-
| None -> None)
493
-
identifiers
494
-
495
-
let check_module_usage ~full_path identifiers module_name issue_constructor =
496
-
check_identifier_pattern ~full_path identifiers
497
-
(fun name ->
498
-
match name.prefix with
499
-
| [ "Stdlib"; m ] when m = module_name -> true
500
-
| [ m ] when m = module_name -> true
501
-
| _ -> false)
502
-
issue_constructor
503
-
504
-
let check_function_usage ~full_path identifiers module_name function_name
505
-
issue_constructor =
506
-
check_identifier_pattern ~full_path identifiers
507
-
(fun name ->
508
-
match (name.prefix, name.base) with
509
-
| [ "Stdlib"; m ], base when m = module_name && base = function_name ->
510
-
true
511
-
| [ m ], base when m = module_name && base = function_name -> true
512
-
| _ -> false)
513
-
issue_constructor
514
-
515
-
let check_function_call_pattern content function_name arg_pattern
516
-
issue_constructor _filename =
517
-
let lines = String.split_on_char '\n' content in
518
-
let issues = ref [] in
519
-
520
-
(* Create patterns for both qualified and unqualified calls, avoiding comments *)
521
-
let qualified_pattern =
522
-
Re.compile
523
-
(Re.seq
524
-
[
525
-
Re.str "Alcotest.";
526
-
Re.str function_name;
527
-
Re.rep Re.space;
528
-
Re.str "(";
529
-
Re.rep Re.space;
530
-
Re.str arg_pattern;
531
-
])
532
-
in
533
-
534
-
let unqualified_pattern =
535
-
Re.compile
536
-
(Re.seq
537
-
[
538
-
Re.bow;
539
-
Re.str function_name;
540
-
Re.rep Re.space;
541
-
Re.str "(";
542
-
Re.rep Re.space;
543
-
Re.str arg_pattern;
544
-
])
545
-
in
546
-
547
-
(* Pattern to detect if we're inside a comment *)
548
-
let comment_pattern =
549
-
Re.compile (Re.seq [ Re.str "(*"; Re.rep Re.any; Re.str "*)" ])
550
-
in
551
-
552
-
List.iteri
553
-
(fun line_idx line ->
554
-
let line_num = line_idx + 1 in
555
-
556
-
(* Skip lines that are entirely comments *)
557
-
if not (Re.execp comment_pattern line) then
558
-
if
559
-
(* Check for qualified call first (e.g., Alcotest.fail) *)
560
-
Re.execp qualified_pattern line
561
-
then issues := issue_constructor (line, line_num, true) :: !issues
562
-
(* Only check for unqualified call if qualified didn't match *)
563
-
else if Re.execp unqualified_pattern line then
564
-
issues := issue_constructor (line, line_num, false) :: !issues)
565
-
lines;
566
-
567
-
!issues
568
-
569
-
let check_elements ~full_path elements check_fn create_issue_fn =
570
-
List.filter_map
571
-
(fun (elt : elt) ->
572
-
let name_str = name_to_string elt.name in
573
-
match (check_fn name_str, elt.location) with
574
-
| Some result, Some loc ->
575
-
let loc = fix_location_path ~full_path loc in
576
-
Some (create_issue_fn name_str loc result)
577
-
| _ -> None)
578
-
elements
579
-
580
-
(** Standard functions for type t *)
581
-
582
-
let equal_name n1 n2 = n1.prefix = n2.prefix && n1.base = n2.base
583
-
let equal_elt e1 e2 = equal_name e1.name e2.name && e1.location = e2.location
584
-
585
-
let equal t1 t2 =
586
-
List.equal equal_elt t1.modules t2.modules
587
-
&& List.equal equal_elt t1.types t2.types
588
-
&& List.equal equal_elt t1.exceptions t2.exceptions
589
-
&& List.equal equal_elt t1.variants t2.variants
590
-
&& List.equal equal_elt t1.identifiers t2.identifiers
591
-
&& List.equal equal_elt t1.patterns t2.patterns
592
-
&& List.equal equal_elt t1.values t2.values
593
-
594
-
let compare_name n1 n2 =
595
-
match compare n1.prefix n2.prefix with 0 -> compare n1.base n2.base | n -> n
596
-
597
-
let compare_elt e1 e2 =
598
-
match compare_name e1.name e2.name with
599
-
| 0 -> compare e1.location e2.location
600
-
| n -> n
601
-
602
-
let compare t1 t2 =
603
-
match List.compare compare_elt t1.modules t2.modules with
604
-
| 0 -> (
605
-
match List.compare compare_elt t1.types t2.types with
606
-
| 0 -> (
607
-
match List.compare compare_elt t1.exceptions t2.exceptions with
608
-
| 0 -> (
609
-
match List.compare compare_elt t1.variants t2.variants with
610
-
| 0 -> (
611
-
match
612
-
List.compare compare_elt t1.identifiers t2.identifiers
613
-
with
614
-
| 0 -> (
615
-
match
616
-
List.compare compare_elt t1.patterns t2.patterns
617
-
with
618
-
| 0 -> List.compare compare_elt t1.values t2.values
619
-
| n -> n)
620
-
| n -> n)
621
-
| n -> n)
622
-
| n -> n)
623
-
| n -> n)
624
-
| n -> n
625
-
626
-
let pp_name ppf name = Fmt.pf ppf "%s" (name_to_string name)
627
-
628
-
let pp_elt ppf elt =
629
-
match elt.location with
630
-
| Some loc -> Fmt.pf ppf "%a at %a" pp_name elt.name Location.pp loc
631
-
| None -> pp_name ppf elt.name
632
-
633
-
let pp_elt_list name ppf elts =
634
-
if elts <> [] then
635
-
Fmt.pf ppf "@[<v2>%s (%d):@,%a@]@." name (List.length elts)
636
-
(Fmt.list ~sep:Fmt.cut pp_elt)
637
-
elts
638
-
639
-
let pp ppf t =
640
-
Fmt.pf ppf "@[<v>";
641
-
pp_elt_list "Modules" ppf t.modules;
642
-
pp_elt_list "Types" ppf t.types;
643
-
pp_elt_list "Exceptions" ppf t.exceptions;
644
-
pp_elt_list "Variants" ppf t.variants;
645
-
pp_elt_list "Identifiers" ppf t.identifiers;
646
-
pp_elt_list "Patterns" ppf t.patterns;
647
-
pp_elt_list "Values" ppf t.values;
648
-
Fmt.pf ppf "@]"
-97
lib/dump.mli
-97
lib/dump.mli
···
1
-
(** Dump module - extracts names and identifiers from AST text dumps.
2
-
3
-
This module parses the textual representation of OCaml AST dumps (from
4
-
Merlin) to extract names of functions, modules, types, etc. It does NOT
5
-
analyze control flow or expression structure - use the Ast module for that.
6
-
*)
7
-
8
-
type name = { prefix : string list; base : string }
9
-
(** Structured name type. *)
10
-
11
-
type elt = { name : name; location : Location.t option }
12
-
(** Common element type for all extracted items. *)
13
-
14
-
type t = {
15
-
modules : elt list; (** Module names. *)
16
-
types : elt list; (** Type declarations. *)
17
-
exceptions : elt list; (** Exception declarations. *)
18
-
variants : elt list; (** Variant constructors. *)
19
-
identifiers : elt list; (** Value identifiers (usage). *)
20
-
patterns : elt list; (** Pattern variables. *)
21
-
values : elt list; (** Value bindings (definitions). *)
22
-
}
23
-
24
-
val equal : t -> t -> bool
25
-
(** [equal a b] returns true if [a] and [b] are structurally equal. *)
26
-
27
-
val compare : t -> t -> int
28
-
(** [compare a b] returns a comparison result between [a] and [b]. *)
29
-
30
-
val pp : t Fmt.t
31
-
(** [pp] is a pretty-printer for the dump data. *)
32
-
33
-
exception Parse_error of string
34
-
(** Parse error exception. *)
35
-
36
-
exception Type_error
37
-
(** Type error exception - raised when typedtree contains type errors. *)
38
-
39
-
exception Wrong_ast_type
40
-
41
-
val name_to_string : name -> string
42
-
(** [name_to_string name] converts a structured name to a string. *)
43
-
44
-
val parsetree : string -> t
45
-
(** [parsetree text] parses parsetree text dump into AST structure. *)
46
-
47
-
val typedtree : string -> t
48
-
(** [typedtree text] parses typedtree text dump into AST structure. *)
49
-
50
-
(** {2 Utility functions for working with dump data.} *)
51
-
52
-
val iter_identifiers_with_location : t -> (elt -> Location.t -> unit) -> unit
53
-
(** [iter_identifiers_with_location dump_data f] applies f to each identifier
54
-
with location. *)
55
-
56
-
val location : elt -> Location.t option
57
-
(** [location elt] extracts location from element. *)
58
-
59
-
val check_module_usage :
60
-
full_path:string -> elt list -> string -> (loc:Location.t -> 'a) -> 'a list
61
-
(** [check_module_usage ~full_path identifiers module_name issue_constructor]
62
-
checks for specific module usage. Automatically fixes location paths to use
63
-
full_path instead of basename. *)
64
-
65
-
val check_function_usage :
66
-
full_path:string ->
67
-
elt list ->
68
-
string ->
69
-
string ->
70
-
(loc:Location.t -> 'a) ->
71
-
'a list
72
-
(** [check_function_usage ~full_path identifiers module_name function_name
73
-
issue_constructor] checks for specific function usage. Automatically fixes
74
-
location paths to use full_path instead of basename. *)
75
-
76
-
val check_function_call_pattern :
77
-
string -> string -> string -> (string * int * bool -> 'a) -> string -> 'a list
78
-
(** [check_function_call_pattern content function_name arg_pattern
79
-
issue_constructor filename] checks for function calls with specific
80
-
argument patterns. For example, to find 'fail (Fmt.str' patterns, use:
81
-
check_function_call_pattern content "fail" "Fmt.str" issue_constructor
82
-
filename. *)
83
-
84
-
val check_elements :
85
-
full_path:string ->
86
-
elt list ->
87
-
(string -> 'a option) ->
88
-
(string -> Location.t -> 'a -> 'b) ->
89
-
'b list
90
-
(** [check_elements ~full_path elements check_fn create_issue_fn] generic
91
-
element checking. Automatically fixes location paths to use full_path
92
-
instead of basename. *)
93
-
94
-
val fix_all_paths : full_path:string -> t -> t
95
-
(** [fix_all_paths ~full_path dump] fixes all locations in dump structure to use
96
-
full_path instead of basename. This is automatically called by Context.dump,
97
-
so rules don't need to call it directly. *)
+1
-1
lib/dune
+1
-1
lib/dune
+39
-39
lib/dune.ml
+39
-39
lib/dune.ml
···
64
64
in
65
65
Array.to_list entries
66
66
|> List.concat_map (fun entry ->
67
-
let path = Fpath.(dir_path / entry) in
68
-
let path_str = Fpath.to_string path in
69
-
if
70
-
entry = "dune" && Sys.file_exists path_str
71
-
&& not (Sys.is_directory path_str)
72
-
then [ path ]
73
-
else if
74
-
Sys.is_directory path_str && entry <> "_build" && entry <> ".git"
75
-
&& entry <> "_opam"
76
-
then files path
77
-
else [])
67
+
let path = Fpath.(dir_path / entry) in
68
+
let path_str = Fpath.to_string path in
69
+
if
70
+
entry = "dune" && Sys.file_exists path_str
71
+
&& not (Sys.is_directory path_str)
72
+
then [ path ]
73
+
else if
74
+
Sys.is_directory path_str && entry <> "_build" && entry <> ".git"
75
+
&& entry <> "_opam"
76
+
then files path
77
+
else [])
78
78
79
79
(** Parse a dune file and extract module information *)
80
80
let parse_dune_file filename =
···
299
299
let executable_modules dune_describe =
300
300
dune_describe.executables |> List.concat_map snd
301
301
|> List.filter_map (fun file ->
302
-
let file_str = Fpath.to_string file in
303
-
if String.ends_with ~suffix:".ml" file_str then
304
-
Some (String.capitalize_ascii Fpath.(file |> rem_ext |> basename))
305
-
else None)
302
+
let file_str = Fpath.to_string file in
303
+
if String.ends_with ~suffix:".ml" file_str then
304
+
Some (String.capitalize_ascii Fpath.(file |> rem_ext |> basename))
305
+
else None)
306
306
|> List.sort_uniq String.compare
307
307
308
308
(** Get library modules from describe *)
···
310
310
dune_describe.libraries
311
311
|> List.concat_map (fun (lib_info : library_info) -> lib_info.files)
312
312
|> List.filter_map (fun file ->
313
-
let file_str = Fpath.to_string file in
314
-
if String.ends_with ~suffix:".ml" file_str then
315
-
Some Fpath.(file |> rem_ext |> basename)
316
-
else None)
313
+
let file_str = Fpath.to_string file in
314
+
if String.ends_with ~suffix:".ml" file_str then
315
+
Some Fpath.(file |> rem_ext |> basename)
316
+
else None)
317
317
|> List.sort_uniq String.compare
318
318
319
319
(** Get test modules from describe *)
···
321
321
dune_describe.tests
322
322
|> List.concat_map (fun (t : test_info) -> t.files)
323
323
|> List.filter_map (fun file ->
324
-
let file_str = Fpath.to_string file in
325
-
if String.ends_with ~suffix:".ml" file_str then
326
-
Some Fpath.(file |> rem_ext |> basename)
327
-
else None)
324
+
let file_str = Fpath.to_string file in
325
+
if String.ends_with ~suffix:".ml" file_str then
326
+
Some Fpath.(file |> rem_ext |> basename)
327
+
else None)
328
328
|> List.sort_uniq String.compare
329
329
330
330
(** Get project structure from dune files *)
···
406
406
let libraries =
407
407
structure
408
408
|> List.filter_map (function
409
-
| Library { name; public_name; dir; modules } ->
410
-
let files =
411
-
item_files (Library { name; public_name; dir; modules })
412
-
in
413
-
Some ({ name; public_name; files } : library_info)
414
-
| _ -> None)
409
+
| Library { name; public_name; dir; modules } ->
410
+
let files =
411
+
item_files (Library { name; public_name; dir; modules })
412
+
in
413
+
Some ({ name; public_name; files } : library_info)
414
+
| _ -> None)
415
415
in
416
416
let executables =
417
417
structure
418
418
|> List.filter_map (function
419
-
| Executable { names; dir; modules } -> (
420
-
let files = item_files (Executable { names; dir; modules }) in
421
-
match names with [] -> None | main :: _ -> Some (main, files))
422
-
| _ -> None)
419
+
| Executable { names; dir; modules } -> (
420
+
let files = item_files (Executable { names; dir; modules }) in
421
+
match names with [] -> None | main :: _ -> Some (main, files))
422
+
| _ -> None)
423
423
in
424
424
let tests =
425
425
structure
426
426
|> List.filter_map (function
427
-
| Test { names; dir; modules; libraries } -> (
428
-
let files = item_files (Test { names; dir; modules; libraries }) in
429
-
match names with
430
-
| [] -> None
431
-
| main :: _ -> Some { name = main; files; libraries })
432
-
| _ -> None)
427
+
| Test { names; dir; modules; libraries } -> (
428
+
let files = item_files (Test { names; dir; modules; libraries }) in
429
+
match names with
430
+
| [] -> None
431
+
| main :: _ -> Some { name = main; files; libraries })
432
+
| _ -> None)
433
433
in
434
434
{ libraries; executables; tests }
435
435
+21
-23
lib/engine.ml
+21
-23
lib/engine.ml
···
62
62
let enabled_rules =
63
63
Data.all_rules
64
64
|> List.filter (fun rule ->
65
-
Filter.is_enabled_by_code filter (Rule.code rule))
65
+
Filter.is_enabled_by_code filter (Rule.code rule))
66
66
in
67
67
(config, files_to_analyze, project_ctx, enabled_rules)
68
68
···
72
72
enabled_rules
73
73
|> List.filter Rule.is_project_scoped
74
74
|> List.concat_map (fun rule ->
75
-
let code = Rule.code rule in
76
-
let issues = run_project_rule ?profiling project_ctx rule in
77
-
(* Filter out issues for files that are excluded from this rule *)
78
-
List.filter
79
-
(fun result ->
80
-
match Rule.Run.location result with
81
-
| Some loc ->
82
-
let file = loc.Location.file in
83
-
let excluded =
84
-
Rule_config.should_exclude config.exclusions ~rule:code ~file
85
-
in
86
-
if excluded then
87
-
Log.debug (fun m ->
88
-
m "Excluding %s issue for file %s" code file);
89
-
not excluded
90
-
| None ->
91
-
(* Issues without locations can't be excluded by file *)
92
-
true)
93
-
issues)
75
+
let code = Rule.code rule in
76
+
let issues = run_project_rule ?profiling project_ctx rule in
77
+
(* Filter out issues for files that are excluded from this rule *)
78
+
List.filter
79
+
(fun result ->
80
+
match Rule.Run.location result with
81
+
| Some loc ->
82
+
let file = loc.Location.file in
83
+
let excluded =
84
+
Rule_config.should_exclude config.exclusions ~rule:code ~file
85
+
in
86
+
if excluded then
87
+
Log.debug (fun m ->
88
+
m "Excluding %s issue for file %s" code file);
89
+
not excluded
90
+
| None ->
91
+
(* Issues without locations can't be excluded by file *)
92
+
true)
93
+
issues)
94
94
95
95
(** Analyze a single file with applicable rules *)
96
96
let analyze_single_file ?profiling ~config ~project_root ~file_rules filepath =
97
97
let filename = Fpath.to_string filepath in
98
98
try
99
99
let merlin_start = Unix.gettimeofday () in
100
-
(* Use ocaml-merlin library for outline *)
101
100
let backend = Merlin.create () in
102
101
let outline = Merlin.outline backend ~file:filename in
102
+
let dump = Merlin.dump_ast backend ~file:filename in
103
103
Merlin.close backend;
104
-
(* Use merlint-specific dump functionality *)
105
-
let dump = Merlin_dump.dump filename in
106
104
let merlin_duration = Unix.gettimeofday () -. merlin_start in
107
105
(match profiling with
108
106
| Some prof ->
+1
-1
lib/filter.ml
+1
-1
lib/filter.ml
···
92
92
(* Last token, add to enabled by default *)
93
93
parse_rule_spec spec
94
94
|> Result.map (fun codes ->
95
-
{ enabled = Some (codes @ enabled); disabled })
95
+
{ enabled = Some (codes @ enabled); disabled })
96
96
| spec :: "+" :: rest -> (
97
97
match parse_rule_spec spec with
98
98
| Ok codes -> process_tokens (codes @ enabled) disabled rest
+2
-22
lib/location.ml
+2
-22
lib/location.ml
···
1
-
(** Shared location types and utilities *)
2
-
3
-
type t = {
4
-
file : string;
5
-
start_line : int;
6
-
start_col : int;
7
-
end_line : int;
8
-
end_col : int;
9
-
}
10
-
11
-
let v ~file ~start_line ~start_col ~end_line ~end_col =
12
-
{ file; start_line; start_col; end_line; end_col }
13
-
14
-
let pp ppf loc = Fmt.pf ppf "%s:%d:%d" loc.file loc.start_line loc.start_col
15
-
16
-
let compare l1 l2 =
17
-
let fc = String.compare l1.file l2.file in
18
-
if fc <> 0 then fc
19
-
else
20
-
let line_c = compare l1.start_line l2.start_line in
21
-
if line_c <> 0 then line_c else compare l1.start_col l2.start_col
1
+
include Merlin.Location
22
2
23
-
let equal a b = compare a b = 0
3
+
let pp ppf loc = Fmt.pf ppf "%s:%d:%d" loc.file loc.start.line loc.start.col
+1
-28
lib/location.mli
+1
-28
lib/location.mli
···
1
-
(** Shared location types and utilities. *)
2
-
3
-
type t = {
4
-
file : string;
5
-
start_line : int;
6
-
start_col : int;
7
-
end_line : int;
8
-
end_col : int;
9
-
}
10
-
(** Location with range in a file. *)
11
-
12
-
val v :
13
-
file:string ->
14
-
start_line:int ->
15
-
start_col:int ->
16
-
end_line:int ->
17
-
end_col:int ->
18
-
t
19
-
(** [v ~file ~start_line ~start_col ~end_line ~end_col] creates a location. *)
20
-
21
-
val pp : t Fmt.t
22
-
(** [pp] is a pretty-printer for location. *)
23
-
24
-
val compare : t -> t -> int
25
-
(** [compare a b] compares two locations. *)
26
-
27
-
val equal : t -> t -> bool
28
-
(** [equal a b] returns true if [a] and [b] represent the same location. *)
1
+
include module type of Merlin.Location
-51
lib/merlin_dump.ml
-51
lib/merlin_dump.ml
···
1
-
(** Merlin dump commands for merlint.
2
-
3
-
This module provides the dump functionality (typedtree/parsetree) that's
4
-
specific to merlint's code analysis needs. *)
5
-
6
-
let src = Logs.Src.create "merlint.merlin_dump" ~doc:"Merlin dump interface"
7
-
8
-
module Log = (val Logs.src_log src : Logs.LOG)
9
-
10
-
(* JSON schema for dump responses using jsont *)
11
-
type raw_dump_response = { dump_class : string option; dump_value : string }
12
-
13
-
let raw_dump_response_jsont =
14
-
Jsont.Object.map ~kind:"dump_response" (fun dump_class dump_value ->
15
-
{ dump_class; dump_value })
16
-
|> Jsont.Object.opt_mem "class" Jsont.string ~enc:(fun r -> r.dump_class)
17
-
|> Jsont.Object.mem "value" Jsont.string ~enc:(fun r -> r.dump_value)
18
-
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
19
-
20
-
let run_merlin_dump_raw format file =
21
-
let cmd =
22
-
Fmt.str "ocamlmerlin single dump -what %s -filename %s < %s" format
23
-
(Filename.quote file) (Filename.quote file)
24
-
in
25
-
Log.info (fun m -> m "Running merlin dump command: %s" cmd);
26
-
match Command.run cmd with
27
-
| Error msg ->
28
-
Log.err (fun m -> m "Merlin dump command failed: %s" msg);
29
-
Error msg
30
-
| Ok json_str -> (
31
-
Log.debug (fun m ->
32
-
m "Merlin dump successful for %s, JSON length: %d" file
33
-
(String.length json_str));
34
-
match Jsont_bytesrw.decode_string raw_dump_response_jsont json_str with
35
-
| Ok response -> Ok response.dump_value
36
-
| Error msg ->
37
-
Log.err (fun m -> m "Failed to parse Merlin JSON for %s: %s" file msg);
38
-
Error ("Failed to parse Merlin JSON: " ^ msg))
39
-
40
-
let dump file =
41
-
match run_merlin_dump_raw "typedtree" file with
42
-
| Ok text -> Ok (Dump.typedtree text)
43
-
| Error msg -> (
44
-
(* Typedtree failed, try parsetree instead *)
45
-
Log.info (fun m ->
46
-
m "Typedtree failed for %s, trying parsetree: %s" file msg);
47
-
match run_merlin_dump_raw "parsetree" file with
48
-
| Ok text -> Ok (Dump.parsetree text)
49
-
| Error msg2 ->
50
-
Error
51
-
("Both typedtree and parsetree failed: " ^ msg ^ ", " ^ msg2))
+2
-1
lib/outline.ml
+2
-1
lib/outline.ml
+2
-1
lib/outline.mli
+2
-1
lib/outline.mli
+1
-3
lib/rules/e005.ml
+1
-3
lib/rules/e005.ml
···
107
107
in
108
108
109
109
(* Apply additional allowance for pattern matching (2 lines per case) *)
110
-
let threshold =
111
-
config.max_function_length + (match_cases * 2)
112
-
in
110
+
let threshold = config.max_function_length + (match_cases * 2) in
113
111
114
112
if length > threshold then
115
113
let issue_loc =
+2
-2
lib/rules/e100.ml
+2
-2
lib/rules/e100.ml
···
5
5
let filename = ctx.filename in
6
6
7
7
(* Check identifiers for Obj.magic usage *)
8
-
Dump.check_function_usage ~full_path:filename dump_data.identifiers "Obj"
9
-
"magic" (fun ~loc -> Issue.v ~loc ())
8
+
Merlin.Dump.check_function_usage ~full_path:filename dump_data.identifiers
9
+
"Obj" "magic" (fun ~loc -> Issue.v ~loc ())
10
10
11
11
let pp ppf () =
12
12
Fmt.pf ppf "Usage of Obj.magic detected - this is extremely unsafe"
+1
-1
lib/rules/e200.ml
+1
-1
lib/rules/e200.ml
···
7
7
(* Check identifiers for Str module usage *)
8
8
(* In typedtree, we get ["Stdlib"; "Str"] or ["Str"]
9
9
In parsetree, we get ["Str"] for Str.function_name *)
10
-
Dump.check_module_usage ~full_path:filename dump_data.identifiers "Str"
10
+
Merlin.Dump.check_module_usage ~full_path:filename dump_data.identifiers "Str"
11
11
(fun ~loc -> Issue.v ~loc ())
12
12
13
13
let pp ppf () =
+1
-1
lib/rules/e205.ml
+1
-1
lib/rules/e205.ml
···
12
12
let issues = ref [] in
13
13
14
14
(* Check identifiers for Printf/Format module usage *)
15
-
Dump.iter_identifiers_with_location (Context.dump ctx) (fun id loc ->
15
+
Merlin.Dump.iter_identifiers_with_location (Context.dump ctx) (fun id loc ->
16
16
let name = id.name in
17
17
let prefix = name.prefix in
18
18
let base = name.base in
+1
-1
lib/rules/e300.ml
+1
-1
lib/rules/e300.ml
···
4
4
5
5
let check (ctx : Context.file) =
6
6
let filename = ctx.filename in
7
-
Dump.check_elements ~full_path:filename (Context.dump ctx).variants
7
+
Merlin.Dump.check_elements ~full_path:filename (Context.dump ctx).variants
8
8
(fun name ->
9
9
(* For qualified names, only check the basename *)
10
10
let name_to_check =
+3
-3
lib/rules/e305.ml
+3
-3
lib/rules/e305.ml
···
21
21
22
22
(* Check modules for naming convention *)
23
23
List.filter_map
24
-
(fun (module_elt : Dump.elt) ->
25
-
let module_name = Dump.name_to_string module_elt.name in
24
+
(fun (module_elt : Merlin.Dump.elt) ->
25
+
let module_name = Merlin.Dump.name_to_string module_elt.name in
26
26
if not (is_snake_case_module module_name) then
27
27
let expected = Naming.to_capitalized_snake_case module_name in
28
28
(* Only report if the conversion actually changes the name *)
29
29
if expected <> module_name then
30
-
match Dump.location module_elt with
30
+
match Merlin.Dump.location module_elt with
31
31
| Some loc -> Some (Issue.v ~loc { module_name; expected })
32
32
| None -> None
33
33
else None
+1
-1
lib/rules/e310.ml
+1
-1
lib/rules/e310.ml
···
11
11
let check (ctx : Context.file) =
12
12
let filename = ctx.filename in
13
13
(* Check value names *)
14
-
Dump.check_elements ~full_path:filename (Context.dump ctx).patterns
14
+
Merlin.Dump.check_elements ~full_path:filename (Context.dump ctx).patterns
15
15
check_value_name (fun name_str loc expected ->
16
16
Issue.v ~loc { value_name = name_str; expected })
17
17
+2
-2
lib/rules/e315.ml
+2
-2
lib/rules/e315.ml
···
7
7
(* Check type names *)
8
8
let ast = Context.dump ctx in
9
9
List.filter_map
10
-
(fun (type_elt : Dump.elt) ->
10
+
(fun (type_elt : Merlin.Dump.elt) ->
11
11
let name_str = type_elt.name.base in
12
12
if name_str <> Naming.to_lowercase_snake_case name_str then
13
-
match Dump.location type_elt with
13
+
match Merlin.Dump.location type_elt with
14
14
| Some loc ->
15
15
Some
16
16
(Issue.v ~loc
+3
-3
lib/rules/e320.ml
+3
-3
lib/rules/e320.ml
···
12
12
@ ast.variants
13
13
in
14
14
List.filter_map
15
-
(fun (elt : Dump.elt) ->
15
+
(fun (elt : Merlin.Dump.elt) ->
16
16
(* Only check the base name, not the full qualified name *)
17
17
let base_name = elt.name.base in
18
18
let underscore_count =
···
21
21
0 base_name
22
22
in
23
23
if underscore_count > max_underscores && String.length base_name > 5 then
24
-
match Dump.location elt with
24
+
match Merlin.Dump.location elt with
25
25
| Some loc ->
26
26
(* Use full name for display but count underscores only in base *)
27
-
let full_name = Dump.name_to_string elt.name in
27
+
let full_name = Merlin.Dump.name_to_string elt.name in
28
28
Some
29
29
(Issue.v ~loc
30
30
{
+6
-6
lib/rules/e335.ml
+6
-6
lib/rules/e335.ml
···
7
7
(* First, collect all underscore-prefixed pattern bindings *)
8
8
let underscore_bindings =
9
9
List.filter_map
10
-
(fun (elt : Dump.elt) ->
11
-
let name = Dump.name_to_string elt.name in
10
+
(fun (elt : Merlin.Dump.elt) ->
11
+
let name = Merlin.Dump.name_to_string elt.name in
12
12
if
13
13
String.length name > 0
14
14
&& name.[0] = '_'
15
15
&& not (String.starts_with ~prefix:"__" name)
16
16
(* Ignore PPX-generated code *)
17
17
then
18
-
match Dump.location elt with
18
+
match Merlin.Dump.location elt with
19
19
| Some loc -> Some (name, loc)
20
20
| None -> None
21
21
else None)
···
28
28
(* Find all usages of this binding *)
29
29
let usage_locations =
30
30
List.filter_map
31
-
(fun (elt : Dump.elt) ->
32
-
let ident_name = Dump.name_to_string elt.name in
33
-
if ident_name = binding_name then Dump.location elt else None)
31
+
(fun (elt : Merlin.Dump.elt) ->
32
+
let ident_name = Merlin.Dump.name_to_string elt.name in
33
+
if ident_name = binding_name then Merlin.Dump.location elt else None)
34
34
(Context.dump ctx).identifiers
35
35
in
36
36
+4
-4
lib/rules/e340.ml
+4
-4
lib/rules/e340.ml
···
42
42
let error_helpers =
43
43
Outline.values outline
44
44
|> List.filter_map (fun (item : Outline.item) ->
45
-
if String.starts_with ~prefix:"err_" item.name then
46
-
Some (item.name, item.location)
47
-
else None)
45
+
if String.starts_with ~prefix:"err_" item.name then
46
+
Some (item.name, item.location)
47
+
else None)
48
48
in
49
49
50
50
(* Check if a line number is inside any error helper function *)
···
59
59
File.process_lines_with_location filename content
60
60
(fun line_idx line location ->
61
61
ignore line_idx;
62
-
let line_num = location.Location.start_line in
62
+
let line_num = Location.start_line location in
63
63
64
64
(* Only flag if we're not inside an error helper *)
65
65
if not (is_inside_error_helper line_num) then
+4
-4
lib/rules/e510.ml
+4
-4
lib/rules/e510.ml
···
6
6
try
7
7
let dump_data = Context.dump ctx in
8
8
(* Get all identifiers from the typedtree *)
9
-
let identifiers = dump_data.Dump.identifiers in
9
+
let identifiers = dump_data.Merlin.Dump.identifiers in
10
10
11
11
(* Check if any logging functions are used *)
12
12
let log_functions =
···
29
29
(fun (module_name, func_name) ->
30
30
List.exists
31
31
(fun ident ->
32
-
match ident.Dump.name.prefix with
32
+
match ident.Merlin.Dump.name.prefix with
33
33
| prefix_mod :: _ when prefix_mod = module_name ->
34
34
ident.name.base = func_name
35
35
| _ -> false)
···
41
41
let has_log_source =
42
42
List.exists
43
43
(fun ident ->
44
-
match (ident.Dump.name.prefix, ident.name.base) with
44
+
match (ident.Merlin.Dump.name.prefix, ident.name.base) with
45
45
| [ "Logs"; "Src" ], "create" -> true
46
46
| [ "Logs" ], "src_log" -> true
47
47
| _, ("log_src" | "src") ->
48
48
(* Check if it's a value definition for log source *)
49
49
List.exists
50
-
(fun value -> value.Dump.name.base = ident.name.base)
50
+
(fun value -> value.Merlin.Dump.name.base = ident.name.base)
51
51
dump_data.values
52
52
| _ -> false)
53
53
identifiers
+4
-4
lib/rules/e605.ml
+4
-4
lib/rules/e605.ml
···
75
75
let test_files_in_list =
76
76
files
77
77
|> List.filter (fun f ->
78
-
String.ends_with ~suffix:".ml" f
79
-
&&
80
-
let basename = Filename.basename f |> Filename.remove_extension in
81
-
String.starts_with ~prefix:"test_" basename || basename = "test")
78
+
String.ends_with ~suffix:".ml" f
79
+
&&
80
+
let basename = Filename.basename f |> Filename.remove_extension in
81
+
String.starts_with ~prefix:"test_" basename || basename = "test")
82
82
in
83
83
Logs.debug (fun m ->
84
84
m "E605: Test .ml files in analyzed files: %d"
+1
-1
lib/rules/e616.ml
+1
-1
lib/rules/e616.ml
···
15
15
let content = Lazy.force ctx.content in
16
16
17
17
(* Use the new dump function to find fail (Fmt.str patterns *)
18
-
Dump.check_function_call_pattern content "fail" "Fmt.str"
18
+
Merlin.Dump.check_function_call_pattern content "fail" "Fmt.str"
19
19
(fun (line, line_num, is_qualified) ->
20
20
let loc =
21
21
Location.v ~file:filename ~start_line:line_num ~start_col:0
+13
-8
lib/rules/e618.ml
+13
-8
lib/rules/e618.ml
···
33
33
in
34
34
35
35
List.iter
36
-
(fun (elt : Dump.elt) ->
36
+
(fun (elt : Merlin.Dump.elt) ->
37
37
(* Look for patterns like Module__Submodule *)
38
-
let name = Dump.name_to_string elt.Dump.name in
38
+
let name = Merlin.Dump.name_to_string elt.Merlin.Dump.name in
39
39
if String.contains name '_' then
40
40
(* Skip autogenerated Dune__exe prefixes and OCaml special identifiers *)
41
41
if
···
52
52
(* For the suggestion, remove the library prefix to make it cleaner *)
53
53
let clean_original =
54
54
if String.contains name '.' then
55
-
(* Extract just the problematic part after the library prefix *)
55
+
(* Strip known stdlib prefix if present *)
56
56
let parts = String.split_on_char '.' name in
57
57
match parts with
58
-
| _lib :: rest -> String.concat "." rest
58
+
| lib :: rest
59
+
when (not (Re.execp bad_pattern lib)) && List.length rest > 0
60
+
->
61
+
String.concat "." rest
59
62
| _ -> name
60
63
else name
61
64
in
···
64
67
(Re.compile (Re.str "__"))
65
68
~by:"." clean_original
66
69
in
67
-
match Dump.location elt with
70
+
match Merlin.Dump.location elt with
68
71
| Some loc ->
69
72
(* Ensure the location includes the correct filename *)
70
73
let loc_with_file =
71
-
Location.v ~file:filename ~start_line:loc.start_line
72
-
~start_col:loc.start_col ~end_line:loc.end_line
73
-
~end_col:loc.end_col
74
+
Location.v ~file:filename
75
+
~start_line:(Location.start_line loc)
76
+
~start_col:(Location.start_col loc)
77
+
~end_line:(Location.end_line loc)
78
+
~end_col:(Location.end_col loc)
74
79
in
75
80
issues :=
76
81
Issue.v ~loc:loc_with_file
+1
-1
lib/rules/e619.ml
+1
-1
lib/rules/e619.ml
···
5
5
let content = Lazy.force ctx.content in
6
6
7
7
(* Use the dump function to find failwith (Fmt.str patterns *)
8
-
Dump.check_function_call_pattern content "failwith" "Fmt.str"
8
+
Merlin.Dump.check_function_call_pattern content "failwith" "Fmt.str"
9
9
(fun (line, line_num, _is_qualified) ->
10
10
let loc =
11
11
Location.v ~file:filename ~start_line:line_num ~start_col:0
+3
-1
lib/sexp.ml
+3
-1
lib/sexp.ml
-1
merlint.opam
-1
merlint.opam
+1
-1
test/test_dump.ml
+1
-1
test/test_dump.ml
+2
-2
test/test_issue.ml
+2
-2
test/test_issue.ml
···
12
12
(* Check location retrieval *)
13
13
(match Issue.location issue_with_loc with
14
14
| Some loc ->
15
-
Alcotest.(check string) "location file" "test.ml" loc.Location.file;
16
-
Alcotest.(check int) "location start line" 1 loc.Location.start_line
15
+
Alcotest.(check string) "location file" "test.ml" (Location.file loc);
16
+
Alcotest.(check int) "location start line" 1 (Location.start_line loc)
17
17
| None -> Alcotest.fail "Expected location");
18
18
19
19
match Issue.location issue_without_loc with
+8
-8
test/test_location.ml
+8
-8
test/test_location.ml
···
9
9
Location.v ~file:"test.ml" ~start_line:10 ~start_col:5 ~end_line:10
10
10
~end_col:5
11
11
in
12
-
Alcotest.(check string) "file" "test.ml" loc.file;
13
-
Alcotest.(check int) "line" 10 loc.start_line;
14
-
Alcotest.(check int) "col" 5 loc.start_col
12
+
Alcotest.(check string) "file" "test.ml" (Location.file loc);
13
+
Alcotest.(check int) "line" 10 (Location.start_line loc);
14
+
Alcotest.(check int) "col" 5 (Location.start_col loc)
15
15
16
16
let test_pp () =
17
17
let loc =
···
46
46
Location.v ~file:"test.ml" ~start_line:10 ~start_col:5 ~end_line:15
47
47
~end_col:20
48
48
in
49
-
Alcotest.(check string) "file" "test.ml" ext.file;
50
-
Alcotest.(check int) "start_line" 10 ext.start_line;
51
-
Alcotest.(check int) "start_col" 5 ext.start_col;
52
-
Alcotest.(check int) "end_line" 15 ext.end_line;
53
-
Alcotest.(check int) "end_col" 20 ext.end_col
49
+
Alcotest.(check string) "file" "test.ml" (Location.file ext);
50
+
Alcotest.(check int) "start_line" 10 (Location.start_line ext);
51
+
Alcotest.(check int) "start_col" 5 (Location.start_col ext);
52
+
Alcotest.(check int) "end_line" 15 (Location.end_line ext);
53
+
Alcotest.(check int) "end_col" 20 (Location.end_col ext)
54
54
55
55
let suite =
56
56
( "location",
+3
-5
test/test_merlin.ml
+3
-5
test/test_merlin.ml
···
2
2
3
3
These tests verify that the Merlin_dump module works correctly. *)
4
4
5
-
open Merlint
5
+
module Dump = Merlin.Dump
6
6
7
7
(* Test the dump result handling *)
8
8
let test_dump_result_handling () =
9
9
let mock_dump = Error "Mock error" in
10
-
Alcotest.(check bool)
11
-
"dump error is Error" true
12
-
(Result.is_error mock_dump)
10
+
Alcotest.(check bool) "dump error is Error" true (Result.is_error mock_dump)
13
11
14
12
let test_dump_ok_handling () =
15
-
let mock_dump = Ok (Dump.typedtree "test content") in
13
+
let mock_dump = Ok (Merlin.Dump.typedtree "test content") in
16
14
Alcotest.(check bool) "dump ok is Ok" true (Result.is_ok mock_dump)
17
15
18
16
let suite =
+6
-8
test/test_outline.ml
+6
-8
test/test_outline.ml
···
25
25
26
26
let test_flatten_simple () =
27
27
let items =
28
-
[ make_item ~name:"foo" ~kind:Value (); make_item ~name:"bar" ~kind:Type () ]
28
+
[
29
+
make_item ~name:"foo" ~kind:Value (); make_item ~name:"bar" ~kind:Type ();
30
+
]
29
31
in
30
32
let result = flatten items in
31
33
Alcotest.(check int) "two items" 2 (List.length result)
···
91
93
List.iter
92
94
(fun (kind, name) ->
93
95
let item = make_item ~name ~kind () in
94
-
Alcotest.(check string)
95
-
(Fmt.str "%s kind" name)
96
-
name item.name)
96
+
Alcotest.(check string) (Fmt.str "%s kind" name) name item.name)
97
97
kinds
98
98
99
99
let test_is_function_type () =
···
110
110
Alcotest.(check string)
111
111
"multi-arg return" "bool"
112
112
(extract_return_type "int -> string -> bool");
113
-
Alcotest.(check string)
114
-
"no arrow" "int" (extract_return_type "int")
113
+
Alcotest.(check string) "no arrow" "int" (extract_return_type "int")
115
114
116
115
let test_count_parameters () =
117
-
Alcotest.(check int)
118
-
"one int" 1 (count_parameters "int -> string" "int");
116
+
Alcotest.(check int) "one int" 1 (count_parameters "int -> string" "int");
119
117
Alcotest.(check int)
120
118
"two ints" 2
121
119
(count_parameters "int -> int -> string" "int");