Opinionated OCaml linter with Merlin integration for code quality, naming conventions, and style checks
irmin: Implement Store.diff for tree comparison
Implements the previously stubbed diff function that compares two trees
and yields a sequence of changes (Add, Remove, Change).
The algorithm recursively traverses both trees and:
- Emits Remove for entries only in old tree
- Emits Add for entries only in new tree
- Emits Change for modified contents
- Handles subtree transitions (contents ↔ node)
+437
-522
+2
-1
dune-project
+2
-1
dune-project
+4
-4
lib/context.ml
+4
-4
lib/context.ml
···
27
27
test_modules : string list Lazy.t;
28
28
}
29
29
30
-
let file ~filename ~config ~project_root ~merlin_result =
30
+
let file ~filename ~config ~project_root ~outline ~dump =
31
31
{
32
32
filename;
33
33
config;
···
35
35
ast = lazy { Ast.functions = Ast.extract_functions filename };
36
36
dump =
37
37
lazy
38
-
(match merlin_result.Merlin.dump with
39
-
| Ok dump -> dump
38
+
(match dump with
39
+
| Ok d -> d
40
40
| Error msg -> raise (Analysis_error msg));
41
41
outline =
42
42
lazy
43
-
(match merlin_result.Merlin.outline with
43
+
(match outline with
44
44
| Ok o -> o
45
45
| Error msg -> raise (Analysis_error msg));
46
46
content =
+6
-5
lib/context.mli
+6
-5
lib/context.mli
···
2
2
*)
3
3
4
4
exception Analysis_error of string
5
-
(** Raised when analysis fails (e.g., Merlin error, file read error). *)
5
+
(** Raised when analysis fails (e.g., Merlint_backend error, file read error). *)
6
6
7
7
type file = {
8
8
filename : string; (** The current file being analyzed. *)
9
9
config : Config.t; (** The merlint configuration. *)
10
10
project_root : string; (** The project root directory. *)
11
11
ast : Ast.t Lazy.t; (** AST control flow from ppxlib (lazy). *)
12
-
dump : Dump.t Lazy.t; (** Names/identifiers from Merlin dump (lazy). *)
13
-
outline : Outline.t Lazy.t; (** Outline from Merlin (lazy). *)
12
+
dump : Dump.t Lazy.t; (** Names/identifiers from Merlint_backend dump (lazy). *)
13
+
outline : Outline.t Lazy.t; (** Outline from Merlint_backend (lazy). *)
14
14
content : string Lazy.t; (** File content (lazy). *)
15
15
functions : (string * Ast.expr) list Lazy.t;
16
16
(** Functions extracted with ppxlib (lazy). *)
···
31
31
filename:string ->
32
32
config:Config.t ->
33
33
project_root:string ->
34
-
merlin_result:Merlin.t ->
34
+
outline:(Outline.t, string) result ->
35
+
dump:(Dump.t, string) result ->
35
36
file
36
-
(** [file ~filename ~config ~project_root ~merlin_result] creates a file
37
+
(** [file ~filename ~config ~project_root ~outline ~dump] creates a file
37
38
context. *)
38
39
39
40
val project :
+13
-1
lib/dune
+13
-1
lib/dune
···
3
3
(library
4
4
(public_name merlint)
5
5
(name merlint)
6
-
(libraries yojson unix re logs fmt astring fpath sexplib0 parsexp ppxlib))
6
+
(libraries
7
+
ocaml-merlin
8
+
eio
9
+
re
10
+
logs
11
+
fmt
12
+
astring
13
+
fpath
14
+
vlog
15
+
tty
16
+
ppxlib
17
+
jsont
18
+
jsont.bytesrw))
7
19
8
20
(rule
9
21
(target examples.ml)
+1
-4
lib/dune.ml
+1
-4
lib/dune.ml
···
3
3
let src = Logs.Src.create "merlint.dune" ~doc:"Dune interface"
4
4
5
5
module Log = (val Logs.src_log src : Logs.LOG)
6
-
open Sexplib0
7
6
8
7
(* Error helper function *)
9
8
let err_build_failed msg = Error (Fmt.str "Failed to build project: %s" msg)
···
85
84
close_in ic;
86
85
87
86
(* Parse all S-expressions in the file *)
88
-
let stanzas =
89
-
Parsexp.Many.parse_string content |> Result.value ~default:[]
90
-
in
87
+
let stanzas = Sexp.parse_string content in
91
88
Log.debug (fun m ->
92
89
m "Parsed dune file %a: found %d stanzas" Fpath.pp filename
93
90
(List.length stanzas));
+7
-2
lib/engine.ml
+7
-2
lib/engine.ml
···
97
97
let filename = Fpath.to_string filepath in
98
98
try
99
99
let merlin_start = Unix.gettimeofday () in
100
-
let merlin_result = Merlin.analyze_file filename in
100
+
(* Use ocaml-merlin library for outline *)
101
+
let backend = Merlin.create () in
102
+
let outline = Merlin.outline backend ~file:filename in
103
+
Merlin.close backend;
104
+
(* Use merlint-specific dump functionality *)
105
+
let dump = Merlin_dump.dump filename in
101
106
let merlin_duration = Unix.gettimeofday () -. merlin_start in
102
107
(match profiling with
103
108
| Some prof ->
···
105
110
{ operation = Profiling.Merlin filename; duration = merlin_duration }
106
111
| None -> ());
107
112
let file_ctx =
108
-
Context.file ~filename ~config ~project_root ~merlin_result
113
+
Context.file ~filename ~config ~project_root ~outline ~dump
109
114
in
110
115
let applicable_rules =
111
116
List.filter
-120
lib/merlin.ml
-120
lib/merlin.ml
···
1
-
(** Wrapper for OCaml Merlin commands *)
2
-
3
-
let src = Logs.Src.create "merlint.merlin" ~doc:"Merlin interface"
4
-
5
-
module Log = (val Logs.src_log src : Logs.LOG)
6
-
7
-
(* Error helper functions *)
8
-
let err_file_not_found file = Error ("File not found: " ^ file)
9
-
let err_json_parse msg = Error ("Failed to parse Merlin JSON: " ^ msg)
10
-
11
-
let err_both_failed msg1 msg2 =
12
-
Error ("Both typedtree and parsetree failed: " ^ msg1 ^ ", " ^ msg2)
13
-
14
-
type t = {
15
-
outline : (Outline.t, string) result;
16
-
dump : (Dump.t, string) result;
17
-
}
18
-
19
-
(** Standard functions using polymorphic equality and comparison *)
20
-
let equal = ( = )
21
-
22
-
let compare = compare
23
-
24
-
let pp ppf t =
25
-
let pp_result pp_ok ppf = function
26
-
| Ok v -> pp_ok ppf v
27
-
| Error e -> Fmt.pf ppf "Error: %s" e
28
-
in
29
-
Fmt.pf ppf "@[<v>Merlin result:@, outline: %a@, dump: %a@]"
30
-
(pp_result Outline.pp) t.outline (pp_result Dump.pp) t.dump
31
-
32
-
let outline file =
33
-
(* Ensure file exists before trying to analyze it *)
34
-
if not (Sys.file_exists file) then err_file_not_found file
35
-
else
36
-
let cmd =
37
-
Fmt.str "ocamlmerlin single outline -filename %s < %s"
38
-
(Filename.quote file) (Filename.quote file)
39
-
in
40
-
Log.info (fun m -> m "Running merlin outline command: %s" cmd);
41
-
match Command.run cmd with
42
-
| Error msg ->
43
-
Log.err (fun m -> m "Merlin outline command failed: %s" msg);
44
-
Error msg
45
-
| Ok content -> (
46
-
Log.debug (fun m ->
47
-
m "Merlin outline result length: %d chars" (String.length content));
48
-
try
49
-
match Yojson.Safe.from_string content with
50
-
| `Assoc fields -> (
51
-
match List.assoc_opt "value" fields with
52
-
| Some outline ->
53
-
Log.debug (fun m ->
54
-
m "Successfully extracted outline for %s" file);
55
-
Ok (Outline.of_json outline)
56
-
| None ->
57
-
Log.warn (fun m ->
58
-
m "No value in outline response for %s" file);
59
-
Error "No value in outline response")
60
-
| _ ->
61
-
Log.warn (fun m ->
62
-
m "Invalid outline response format for %s" file);
63
-
Error "Invalid outline response format"
64
-
with exn ->
65
-
Log.err (fun m ->
66
-
m "Exception parsing outline for %s: %s" file
67
-
(Printexc.to_string exn));
68
-
Error (Printexc.to_string exn))
69
-
70
-
let run_merlin_dump_raw format file =
71
-
let cmd =
72
-
Fmt.str "ocamlmerlin single dump -what %s -filename %s < %s" format
73
-
(Filename.quote file) (Filename.quote file)
74
-
in
75
-
Log.info (fun m -> m "Running merlin dump command: %s" cmd);
76
-
match Command.run cmd with
77
-
| Error msg ->
78
-
Log.err (fun m -> m "Merlin dump command failed: %s" msg);
79
-
Error msg
80
-
| Ok json_str -> (
81
-
Log.debug (fun m ->
82
-
m "Merlin dump successful for %s, JSON length: %d" file
83
-
(String.length json_str));
84
-
try Ok (Yojson.Safe.from_string json_str)
85
-
with Yojson.Json_error msg ->
86
-
Log.err (fun m -> m "Failed to parse Merlin JSON for %s: %s" file msg);
87
-
err_json_parse msg)
88
-
89
-
let dump_value format file =
90
-
match run_merlin_dump_raw format file with
91
-
| Ok json -> (
92
-
match json with
93
-
| `Assoc fields -> (
94
-
match List.assoc_opt "value" fields with
95
-
| Some value -> Ok value
96
-
| None -> Error "Failed to extract value from Merlin output")
97
-
| _ -> Error "Invalid Merlin JSON format")
98
-
| Error msg -> Error msg
99
-
100
-
let dump file =
101
-
match dump_value "typedtree" file with
102
-
| Ok json -> (
103
-
match json with
104
-
| `String text -> Ok (Dump.typedtree text)
105
-
| _ -> Error "Invalid typedtree format")
106
-
| Error msg -> (
107
-
(* Typedtree failed, try parsetree instead *)
108
-
Log.info (fun m ->
109
-
m "Typedtree failed for %s, trying parsetree: %s" file msg);
110
-
match dump_value "parsetree" file with
111
-
| Ok json -> (
112
-
match json with
113
-
| `String text -> Ok (Dump.parsetree text)
114
-
| _ -> Error "Invalid parsetree format")
115
-
| Error msg2 -> err_both_failed msg msg2)
116
-
117
-
let analyze_file file =
118
-
(* Run merlin commands for the file *)
119
-
Log.info (fun m -> m "Analyzing file %s with merlin" file);
120
-
{ outline = outline file; dump = dump file }
-19
lib/merlin.mli
-19
lib/merlin.mli
···
1
-
(** Wrapper for OCaml Merlin commands. *)
2
-
3
-
type t = {
4
-
outline : (Outline.t, string) result;
5
-
dump : (Dump.t, string) result;
6
-
}
7
-
(** Result of merlin analyses for a single file. *)
8
-
9
-
val equal : t -> t -> bool
10
-
(** [equal a b] returns true if [a] and [b] have equal results. *)
11
-
12
-
val compare : t -> t -> int
13
-
(** [compare a b] returns a comparison result between [a] and [b]. *)
14
-
15
-
val pp : t Fmt.t
16
-
(** [pp] is a pretty-printer for the merlin result. *)
17
-
18
-
val analyze_file : string -> t
19
-
(** [analyze_file filename] analyzes a file with merlin commands. *)
+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))
+28
-165
lib/outline.ml
+28
-165
lib/outline.ml
···
1
-
(** OCamlmerlin outline output - structured representation *)
1
+
(** OCamlmerlin outline output - structured representation.
2
+
3
+
This module re-exports types from ocaml-merlin with merlint-specific helpers. *)
4
+
5
+
(* {2 Re-exported types from Merlin} *)
2
6
3
-
type kind =
7
+
type kind = Merlin.symbol_kind =
4
8
| Value
5
9
| Type
6
10
| Module
11
+
| Module_type
7
12
| Class
8
-
| Exception
13
+
| Class_type
9
14
| Constructor
15
+
| Exception
10
16
| Field
11
17
| Method
12
-
| Other of string
18
+
| Label
13
19
14
-
type position = { line : int; col : int }
15
-
type range = { start : position; end_ : position }
20
+
type position = Merlin.position = { line : int; col : int }
21
+
type item = Merlin.outline_item
22
+
type t = Merlin.outline
16
23
17
-
type item = {
18
-
name : string;
19
-
kind : kind;
20
-
type_sig : string option; (* Type signature for values *)
21
-
range : range option;
22
-
}
23
-
24
-
type t = item list
24
+
(* {2 Re-exported functions from Merlin} *)
25
25
26
-
let empty () = []
26
+
let flatten = Merlin.flatten_outline
27
+
let values = Merlin.values
28
+
let by_name = Merlin.by_name
29
+
let is_function_type = Merlin.is_function_type
30
+
let extract_return_type = Merlin.extract_return_type
31
+
let count_parameters = Merlin.count_parameters
27
32
28
-
(** Standard functions using polymorphic equality and comparison *)
29
-
let equal = ( = )
33
+
(* {2 Merlint-specific helpers} *)
30
34
31
-
let compare = compare
35
+
let pp = Merlin.pp_outline
36
+
let pp_item = Merlin.pp_outline_item
37
+
let pp_kind = Merlin.pp_symbol_kind
32
38
33
-
(** Parse kind from string *)
34
-
let parse_kind = function
35
-
| "Value" -> Value
36
-
| "Type" -> Type
37
-
| "Module" -> Module
38
-
| "Class" -> Class
39
-
| "Exn" | "Exception" -> Exception (* Merlin outputs "Exn" *)
40
-
| "Constructor" -> Constructor
41
-
| "Field" -> Field
42
-
| "Method" -> Method
43
-
| s -> Other s
44
-
45
-
(** Parse position from JSON *)
46
-
let parse_position json =
47
-
match json with
48
-
| `Assoc items ->
49
-
let line =
50
-
match List.assoc_opt "line" items with Some (`Int l) -> l | _ -> 0
51
-
in
52
-
let col =
53
-
match List.assoc_opt "col" items with Some (`Int c) -> c | _ -> 0
54
-
in
55
-
{ line; col }
56
-
| _ -> { line = 0; col = 0 }
57
-
58
-
(** Parse range from JSON *)
59
-
let parse_range json =
60
-
match json with
61
-
| `Assoc items ->
62
-
let start =
63
-
match List.assoc_opt "start" items with
64
-
| Some pos -> parse_position pos
65
-
| None -> { line = 0; col = 0 }
66
-
in
67
-
let end_ =
68
-
match List.assoc_opt "end" items with
69
-
| Some pos -> parse_position pos
70
-
| None -> { line = 0; col = 0 }
71
-
in
72
-
Some { start; end_ }
73
-
| _ -> None
74
-
75
-
(** Parse item from JSON *)
76
-
let parse_item json =
77
-
match json with
78
-
| `Assoc items ->
79
-
let name =
80
-
match List.assoc_opt "name" items with Some (`String n) -> n | _ -> ""
81
-
in
82
-
let kind =
83
-
match List.assoc_opt "kind" items with
84
-
| Some (`String k) -> parse_kind k
85
-
| _ -> Other "unknown"
86
-
in
87
-
let type_sig =
88
-
match List.assoc_opt "type" items with
89
-
| Some (`String t) -> Some t
90
-
| _ -> None
91
-
in
92
-
let range =
93
-
(* Merlin provides start and end directly, not under location *)
94
-
parse_range json
95
-
in
96
-
Some { name; kind; type_sig; range }
97
-
| _ -> None
98
-
99
-
(** Parse outline from JSON *)
100
-
let of_json json =
101
-
match json with `List items -> List.filter_map parse_item items | _ -> []
102
-
103
-
(** Get all values from outline *)
104
-
let values outline = List.filter (fun item -> item.kind = Value) outline
105
-
106
-
(** Find item by name *)
107
-
let by_name name outline = List.find_opt (fun item -> item.name = name) outline
108
-
109
-
(** Pretty print kind *)
110
-
let pp_kind ppf = function
111
-
| Value -> Fmt.pf ppf "value"
112
-
| Type -> Fmt.pf ppf "type"
113
-
| Module -> Fmt.pf ppf "module"
114
-
| Class -> Fmt.pf ppf "class"
115
-
| Exception -> Fmt.pf ppf "exception"
116
-
| Constructor -> Fmt.pf ppf "constructor"
117
-
| Field -> Fmt.pf ppf "field"
118
-
| Method -> Fmt.pf ppf "method"
119
-
| Other s -> Fmt.pf ppf "other(%s)" s
120
-
121
-
(** Pretty print position *)
122
-
let pp_position ppf pos = Fmt.pf ppf "%d:%d" pos.line pos.col
123
-
124
-
(** Pretty print range *)
125
-
let pp_range ppf range =
126
-
Fmt.pf ppf "%a-%a" pp_position range.start pp_position range.end_
127
-
128
-
(** Pretty print item *)
129
-
let pp_item ppf item =
130
-
let type_str =
131
-
match item.type_sig with Some t -> Fmt.str ": %s" t | None -> ""
132
-
in
133
-
match item.range with
134
-
| Some range ->
135
-
Fmt.pf ppf "%s (%a)%s at %a" item.name pp_kind item.kind type_str pp_range
136
-
range
137
-
| None -> Fmt.pf ppf "%s (%a)%s" item.name pp_kind item.kind type_str
138
-
139
-
(** Pretty print outline *)
140
-
let pp ppf outline =
141
-
Fmt.pf ppf "@[<v>%a@]" (Fmt.list ~sep:Fmt.cut pp_item) outline
142
-
143
-
(** Extract location from outline item *)
144
39
let location filename (item : item) =
145
-
match item.range with
146
-
| Some range ->
147
-
Some
148
-
(Location.v ~file:filename ~start_line:range.start.line
149
-
~start_col:range.start.col ~end_line:range.end_.line
150
-
~end_col:range.end_.col)
151
-
| None -> None
152
-
153
-
(** Type signature analysis utilities *)
154
-
155
-
let is_function_type signature =
156
-
String.contains signature '-' && String.contains signature '>'
157
-
158
-
let extract_return_type signature =
159
-
(* Extract the rightmost part after -> *)
160
-
match String.rindex_opt signature '>' with
161
-
| Some idx when idx > 0 && signature.[idx - 1] = '-' ->
162
-
let return_part =
163
-
String.sub signature (idx + 1) (String.length signature - idx - 1)
164
-
in
165
-
String.trim return_part
166
-
| _ -> signature
167
-
168
-
let count_parameters signature param_type =
169
-
(* Count occurrences of param_type in function signature *)
170
-
let rec count_matches str pattern acc start =
171
-
match String.index_from_opt str start pattern.[0] with
172
-
| None -> acc
173
-
| Some idx ->
174
-
if
175
-
String.length str >= idx + String.length pattern
176
-
&& String.sub str idx (String.length pattern) = pattern
177
-
then count_matches str pattern (acc + 1) (idx + String.length pattern)
178
-
else count_matches str pattern acc (idx + 1)
179
-
in
180
-
count_matches signature param_type 0 0
40
+
let loc = item.location in
41
+
Some
42
+
(Location.v ~file:filename ~start_line:loc.start.line
43
+
~start_col:loc.start.col ~end_line:loc.end_.line ~end_col:loc.end_.col)
+36
-41
lib/outline.mli
+36
-41
lib/outline.mli
···
1
-
(** OCamlmerlin outline output - structured representation. *)
1
+
(** OCamlmerlin outline output - structured representation.
2
2
3
-
(** Outline item kinds we care about *)
4
-
type kind =
3
+
This module re-exports types from ocaml-merlin with merlint-specific helpers. *)
4
+
5
+
(** {2 Re-exported types from Merlin} *)
6
+
7
+
type kind = Merlin.symbol_kind =
5
8
| Value
6
9
| Type
7
10
| Module
11
+
| Module_type
8
12
| Class
13
+
| Class_type
14
+
| Constructor
9
15
| Exception
10
-
| Constructor
11
16
| Field
12
17
| Method
13
-
| Other of string
18
+
| Label
14
19
15
-
type position = { line : int; col : int }
20
+
type position = Merlin.position = { line : int; col : int }
16
21
(** Position in file. *)
17
22
18
-
type range = { start : position; end_ : position }
19
-
(** Range in file. *)
20
-
21
-
type item = {
22
-
name : string;
23
-
kind : kind;
24
-
type_sig : string option; (* Type signature for values *)
25
-
range : range option;
26
-
}
23
+
type item = Merlin.outline_item
27
24
(** Outline item. *)
28
25
29
-
type t = item list
26
+
type t = Merlin.outline
30
27
(** Outline result. *)
31
28
32
-
val equal : t -> t -> bool
33
-
(** [equal a b] returns true if [a] and [b] are equal. Uses polymorphic
34
-
equality. *)
29
+
(** {2 Re-exported functions from Merlin} *)
30
+
31
+
val flatten : t -> item list
32
+
(** [flatten outline] returns all items including nested children, flattened. *)
33
+
34
+
val values : t -> item list
35
+
(** [values outline] returns all items with kind [Value]. *)
35
36
36
-
val compare : t -> t -> int
37
-
(** [compare a b] returns a comparison result between [a] and [b]. Uses
38
-
polymorphic comparison. *)
37
+
val by_name : string -> t -> item option
38
+
(** [by_name name outline] finds the first item with the given name. *)
39
39
40
-
val empty : unit -> t
41
-
(** [empty] creates empty outline. *)
40
+
val is_function_type : string -> bool
41
+
(** [is_function_type signature] returns true if the signature contains [->]. *)
42
42
43
-
val of_json : Yojson.Safe.t -> t
44
-
(** [of_json json] parses outline. *)
43
+
val extract_return_type : string -> string
44
+
(** [extract_return_type signature] extracts the rightmost type after [->]. *)
45
45
46
-
val values : t -> item list
47
-
(** [values outline] returns all values. *)
46
+
val count_parameters : string -> string -> int
47
+
(** [count_parameters signature param_type] counts occurrences of [param_type]
48
+
in the [signature]. *)
48
49
49
-
val by_name : string -> t -> item option
50
-
(** [by_name name outline] finds item. *)
50
+
(** {2 Merlint-specific helpers} *)
51
51
52
52
val pp : t Fmt.t
53
53
(** [pp] is a pretty-printer for outline. *)
54
54
55
-
val location : string -> item -> Location.t option
56
-
(** [location filename item] extracts location. *)
55
+
val pp_item : item Fmt.t
56
+
(** [pp_item] is a pretty-printer for outline item. *)
57
57
58
-
(** {2 Type signature analysis} *)
58
+
val pp_kind : kind Fmt.t
59
+
(** [pp_kind] is a pretty-printer for symbol kind. *)
59
60
60
-
val is_function_type : string -> bool
61
-
(** [is_function_type signature] checks if function type. *)
62
-
63
-
val extract_return_type : string -> string
64
-
(** [extract_return_type signature] extracts return type. *)
65
-
66
-
val count_parameters : string -> string -> int
67
-
(** [count_parameters signature param_type] counts parameters. *)
61
+
val location : string -> item -> Location.t option
62
+
(** [location filename item] extracts location for merlint's Location.t. *)
+44
-46
lib/rules/e005.ml
+44
-46
lib/rules/e005.ml
···
76
76
List.filter_map
77
77
(fun (item : Outline.item) ->
78
78
match item.kind with
79
-
| Value -> (
79
+
| Value ->
80
80
(* Calculate function length from outline location *)
81
-
match item.range with
82
-
| Some range ->
83
-
let length = range.end_.line - range.start.line + 1 in
81
+
let loc = item.location in
82
+
let length = loc.end_.line - loc.start.line + 1 in
84
83
85
-
(* Check if this is a pure data structure *)
86
-
let is_data_def =
87
-
List.exists
88
-
(fun (name, expr) ->
89
-
name = item.name && is_pure_data_structure expr)
90
-
ast.functions
91
-
in
84
+
(* Check if this is a pure data structure *)
85
+
let is_data_def =
86
+
List.exists
87
+
(fun (name, expr) ->
88
+
name = item.name && is_pure_data_structure expr)
89
+
ast.functions
90
+
in
92
91
93
-
(* Skip length check for pure data structures *)
94
-
if is_data_def then (
95
-
Logs.debug (fun m ->
96
-
m "Skipping pure data structure: %s" item.name);
97
-
None)
98
-
else
99
-
(* Find the function's AST to count match cases *)
100
-
let match_cases =
101
-
match
102
-
List.find_opt
103
-
(fun (name, _) -> name = item.name)
104
-
ast.functions
105
-
with
106
-
| Some (_, expr) -> count_match_cases expr
107
-
| None -> 0
108
-
in
92
+
(* Skip length check for pure data structures *)
93
+
if is_data_def then (
94
+
Logs.debug (fun m ->
95
+
m "Skipping pure data structure: %s" item.name);
96
+
None)
97
+
else
98
+
(* Find the function's AST to count match cases *)
99
+
let match_cases =
100
+
match
101
+
List.find_opt
102
+
(fun (name, _) -> name = item.name)
103
+
ast.functions
104
+
with
105
+
| Some (_, expr) -> count_match_cases expr
106
+
| None -> 0
107
+
in
109
108
110
-
(* Apply additional allowance for pattern matching (2 lines per case) *)
111
-
let threshold =
112
-
config.max_function_length + (match_cases * 2)
113
-
in
109
+
(* Apply additional allowance for pattern matching (2 lines per case) *)
110
+
let threshold =
111
+
config.max_function_length + (match_cases * 2)
112
+
in
114
113
115
-
if length > threshold then
116
-
let loc =
117
-
Location.v ~file:ctx.filename ~start_line:range.start.line
118
-
~start_col:range.start.col ~end_line:range.end_.line
119
-
~end_col:range.end_.col
120
-
in
121
-
(* Severity = how much the function exceeds the threshold *)
122
-
let severity = length - threshold in
123
-
Some
124
-
(Issue.v ~loc ~severity
125
-
{ name = item.name; length; threshold })
126
-
else None
127
-
| None -> None)
128
-
| Type | Module | Class | Exception | Constructor | Field | Method
129
-
| Other _ ->
114
+
if length > threshold then
115
+
let issue_loc =
116
+
Location.v ~file:ctx.filename ~start_line:loc.start.line
117
+
~start_col:loc.start.col ~end_line:loc.end_.line
118
+
~end_col:loc.end_.col
119
+
in
120
+
(* Severity = how much the function exceeds the threshold *)
121
+
let severity = length - threshold in
122
+
Some
123
+
(Issue.v ~loc:issue_loc ~severity
124
+
{ name = item.name; length; threshold })
125
+
else None
126
+
| Type | Module | Module_type | Class | Class_type | Exception
127
+
| Constructor | Field | Method | Label ->
130
128
None)
131
129
outline
132
130
+3
-1
lib/rules/e325.ml
+3
-1
lib/rules/e325.ml
···
8
8
| Outline.Value -> "Value"
9
9
| Outline.Type -> "Type"
10
10
| Outline.Module -> "Module"
11
+
| Outline.Module_type -> "Module_type"
11
12
| Outline.Class -> "Class"
13
+
| Outline.Class_type -> "Class_type"
12
14
| Outline.Exception -> "Exception"
13
15
| Outline.Constructor -> "Constructor"
14
16
| Outline.Field -> "Field"
15
17
| Outline.Method -> "Method"
16
-
| Outline.Other s -> s
18
+
| Outline.Label -> "Label"
17
19
18
20
(** Check if a return type is an option type *)
19
21
let returns_option return_type =
+3
-1
lib/rules/e330.ml
+3
-1
lib/rules/e330.ml
···
8
8
| Outline.Value -> "Value"
9
9
| Outline.Type -> "Type"
10
10
| Outline.Module -> "Module"
11
+
| Outline.Module_type -> "Module_type"
11
12
| Outline.Class -> "Class"
13
+
| Outline.Class_type -> "Class_type"
12
14
| Outline.Exception -> "Exception"
13
15
| Outline.Constructor -> "Constructor"
14
16
| Outline.Field -> "Field"
15
17
| Outline.Method -> "Method"
16
-
| Outline.Other s -> s
18
+
| Outline.Label -> "Label"
17
19
18
20
(** Check if an item name has redundant module prefix *)
19
21
let has_redundant_prefix item_name_lower module_name filename =
+3
-5
lib/rules/e340.ml
+3
-5
lib/rules/e340.ml
···
43
43
Outline.values outline
44
44
|> List.filter_map (fun (item : Outline.item) ->
45
45
if String.starts_with ~prefix:"err_" item.name then
46
-
match item.range with
47
-
| Some range -> Some (item.name, range)
48
-
| None -> None
46
+
Some (item.name, item.location)
49
47
else None)
50
48
in
51
49
52
50
(* Check if a line number is inside any error helper function *)
53
51
let is_inside_error_helper line_num =
54
52
List.exists
55
-
(fun (_name, (range : Outline.range)) ->
56
-
line_num >= range.start.line && line_num <= range.end_.line)
53
+
(fun (_name, (loc : Merlin.location)) ->
54
+
line_num >= loc.start.line && line_num <= loc.end_.line)
57
55
error_helpers
58
56
in
59
57
+2
-2
lib/rules/e351.ml
+2
-2
lib/rules/e351.ml
···
23
23
(** Check outline for global mutable state *)
24
24
let check_global_mutable_state ~filename outline =
25
25
List.filter_map
26
-
(fun item ->
27
-
match item.Outline.kind with
26
+
(fun (item : Outline.item) ->
27
+
match item.kind with
28
28
| Outline.Value -> (
29
29
match (item.type_sig, Outline.location filename item) with
30
30
| Some type_sig, Some location when is_mutable_type type_sig ->
+16
-18
lib/rules/e405.ml
+16
-18
lib/rules/e405.ml
···
54
54
55
55
(* Check all public values in the outline *)
56
56
List.filter_map
57
-
(fun item ->
58
-
match item.Outline.kind with
59
-
| Outline.Value -> (
60
-
match item.range with
61
-
| Some range ->
62
-
let has_doc_before = has_doc_comment content range.start.line in
63
-
let has_doc_after =
64
-
has_doc_comment_after content range.end_.line
65
-
in
66
-
if (not has_doc_before) && not has_doc_after then
67
-
let loc =
68
-
Location.v ~file:ctx.filename ~start_line:range.start.line
69
-
~start_col:range.start.col ~end_line:range.end_.line
70
-
~end_col:range.end_.col
71
-
in
72
-
Some (Issue.v ~loc { value_name = item.name; location = loc })
73
-
else None
74
-
| None -> None)
57
+
(fun (item : Outline.item) ->
58
+
match item.kind with
59
+
| Outline.Value ->
60
+
let item_loc = item.location in
61
+
let has_doc_before = has_doc_comment content item_loc.start.line in
62
+
let has_doc_after =
63
+
has_doc_comment_after content item_loc.end_.line
64
+
in
65
+
if (not has_doc_before) && not has_doc_after then
66
+
let loc =
67
+
Location.v ~file:ctx.filename ~start_line:item_loc.start.line
68
+
~start_col:item_loc.start.col ~end_line:item_loc.end_.line
69
+
~end_col:item_loc.end_.col
70
+
in
71
+
Some (Issue.v ~loc { value_name = item.name; location = loc })
72
+
else None
75
73
| _ -> None)
76
74
(Outline.values outline)
77
75
+1
-3
lib/rules/e415.ml
+1
-3
lib/rules/e415.ml
···
72
72
| None -> [] (* No type t, nothing to check *)
73
73
| Some t_item ->
74
74
(* Get line number for the type *)
75
-
let line_num =
76
-
match t_item.range with Some r -> r.start.line | None -> 1
77
-
in
75
+
let line_num = t_item.location.start.line in
78
76
79
77
(* Check if pp function exists in the outline *)
80
78
let has_pp =
+99
lib/sexp.ml
+99
lib/sexp.ml
···
1
+
(** Simple S-expression parser for dune files *)
2
+
3
+
type t = Atom of string | List of t list
4
+
5
+
(** Parse s-expressions from a string *)
6
+
let parse_string content =
7
+
let len = String.length content in
8
+
let pos = ref 0 in
9
+
10
+
let skip_whitespace () =
11
+
while !pos < len && String.contains " \t\n\r" content.[!pos] do
12
+
incr pos
13
+
done
14
+
in
15
+
16
+
let skip_line_comment () =
17
+
while !pos < len && content.[!pos] <> '\n' do
18
+
incr pos
19
+
done;
20
+
if !pos < len then incr pos
21
+
in
22
+
23
+
let rec skip_whitespace_and_comments () =
24
+
skip_whitespace ();
25
+
if !pos < len && content.[!pos] = ';' then (
26
+
skip_line_comment ();
27
+
skip_whitespace_and_comments ())
28
+
in
29
+
30
+
let is_atom_char c =
31
+
match c with
32
+
| 'a' .. 'z'
33
+
| 'A' .. 'Z'
34
+
| '0' .. '9'
35
+
| '_' | '-' | '.' | '/' | ':' | '+' | '=' | '<' | '>' | '*' | '?' | '!' ->
36
+
true
37
+
| _ -> false
38
+
in
39
+
40
+
let parse_quoted_string () =
41
+
incr pos;
42
+
(* skip opening quote *)
43
+
let buf = Buffer.create 64 in
44
+
while !pos < len && content.[!pos] <> '"' do
45
+
if content.[!pos] = '\\' && !pos + 1 < len then (
46
+
incr pos;
47
+
let c =
48
+
match content.[!pos] with
49
+
| 'n' -> '\n'
50
+
| 't' -> '\t'
51
+
| 'r' -> '\r'
52
+
| c -> c
53
+
in
54
+
Buffer.add_char buf c)
55
+
else Buffer.add_char buf content.[!pos];
56
+
incr pos
57
+
done;
58
+
if !pos < len then incr pos;
59
+
(* skip closing quote *)
60
+
Atom (Buffer.contents buf)
61
+
in
62
+
63
+
let parse_atom () =
64
+
let start = !pos in
65
+
while !pos < len && is_atom_char content.[!pos] do
66
+
incr pos
67
+
done;
68
+
Atom (String.sub content start (!pos - start))
69
+
in
70
+
71
+
let rec parse_sexp () =
72
+
skip_whitespace_and_comments ();
73
+
if !pos >= len then None
74
+
else
75
+
match content.[!pos] with
76
+
| '(' ->
77
+
incr pos;
78
+
let items = ref [] in
79
+
skip_whitespace_and_comments ();
80
+
while !pos < len && content.[!pos] <> ')' do
81
+
(match parse_sexp () with
82
+
| Some sexp -> items := sexp :: !items
83
+
| None -> ());
84
+
skip_whitespace_and_comments ()
85
+
done;
86
+
if !pos < len then incr pos;
87
+
(* skip closing paren *)
88
+
Some (List (List.rev !items))
89
+
| '"' -> Some (parse_quoted_string ())
90
+
| c when is_atom_char c -> Some (parse_atom ())
91
+
| _ ->
92
+
incr pos;
93
+
parse_sexp ()
94
+
in
95
+
96
+
let rec parse_all acc =
97
+
match parse_sexp () with Some sexp -> parse_all (sexp :: acc) | None -> acc
98
+
in
99
+
List.rev (parse_all [])
+2
-1
merlint.opam
+2
-1
merlint.opam
+17
-12
test/test_merlin.ml
+17
-12
test/test_merlin.ml
···
1
+
(** Tests for merlint's Merlin integration.
2
+
3
+
These tests verify that the Merlin_dump module works correctly. *)
4
+
1
5
open Merlint
2
6
3
-
(* Test the data structure creation without I/O *)
4
-
let test_result_structure () =
7
+
(* Test the dump result handling *)
8
+
let test_dump_result_handling () =
5
9
let mock_dump = Error "Mock error" in
6
-
let mock_outline = Ok (Outline.empty ()) in
10
+
Alcotest.(check bool)
11
+
"dump error is Error" true
12
+
(Result.is_error mock_dump)
7
13
8
-
let result = Merlin.{ dump = mock_dump; outline = mock_outline } in
9
-
10
-
(* Test the result structure *)
11
-
Alcotest.(check bool) "dump should fail" true (Result.is_error result.dump);
12
-
Alcotest.(check bool)
13
-
"outline should succeed" true
14
-
(Result.is_ok result.outline)
14
+
let test_dump_ok_handling () =
15
+
let mock_dump = Ok (Dump.typedtree "test content") in
16
+
Alcotest.(check bool) "dump ok is Ok" true (Result.is_ok mock_dump)
15
17
16
18
let suite =
17
-
( "merlin",
18
-
[ Alcotest.test_case "result structure" `Quick test_result_structure ] )
19
+
( "merlin_dump",
20
+
[
21
+
Alcotest.test_case "dump result handling" `Quick test_dump_result_handling;
22
+
Alcotest.test_case "dump ok handling" `Quick test_dump_ok_handling;
23
+
] )
+98
-70
test/test_outline.ml
+98
-70
test/test_outline.ml
···
2
2
3
3
open Merlint.Outline
4
4
5
-
let test_parse_empty () =
6
-
let json = `List [] in
7
-
let result = of_json json in
5
+
(* Helper to create test items *)
6
+
let make_item ?(type_sig = None) ?(deprecated = false) ?(children = []) ~name
7
+
~kind () =
8
+
{
9
+
Merlin.name;
10
+
kind;
11
+
type_sig;
12
+
deprecated;
13
+
location =
14
+
{
15
+
file = "test.ml";
16
+
start = { line = 1; col = 0 };
17
+
end_ = { line = 1; col = 10 };
18
+
};
19
+
children;
20
+
}
21
+
22
+
let test_flatten_empty () =
23
+
let result = flatten [] in
8
24
Alcotest.(check int) "empty outline" 0 (List.length result)
9
25
10
-
let test_parse_simple () =
11
-
let json =
12
-
`List
13
-
[
14
-
`Assoc
15
-
[
16
-
("name", `String "foo");
17
-
("kind", `String "Value");
18
-
("type", `String "int -> int");
19
-
( "location",
20
-
`Assoc
21
-
[
22
-
("start", `Assoc [ ("line", `Int 1); ("col", `Int 0) ]);
23
-
("end", `Assoc [ ("line", `Int 1); ("col", `Int 10) ]);
24
-
] );
25
-
];
26
-
`Assoc [ ("name", `String "Bar"); ("kind", `String "Type") ];
27
-
]
26
+
let test_flatten_simple () =
27
+
let items =
28
+
[ make_item ~name:"foo" ~kind:Value (); make_item ~name:"bar" ~kind:Type () ]
28
29
in
30
+
let result = flatten items in
31
+
Alcotest.(check int) "two items" 2 (List.length result)
29
32
30
-
let result = of_json json in
31
-
Alcotest.(check int) "two items" 2 (List.length result);
32
-
33
-
let first = List.hd result in
34
-
Alcotest.(check string) "first name" "foo" first.name;
35
-
Alcotest.(check bool) "first is value" true (first.kind = Value);
36
-
Alcotest.(check (option string))
37
-
"first type" (Some "int -> int") first.type_sig;
38
-
Alcotest.(check bool) "first has range" true (first.range <> None);
39
-
40
-
let second = List.nth result 1 in
41
-
Alcotest.(check string) "second name" "Bar" second.name;
42
-
Alcotest.(check bool) "second is type" true (second.kind = Type);
43
-
Alcotest.(check (option string)) "second no type" None second.type_sig
33
+
let test_flatten_with_children () =
34
+
let child = make_item ~name:"inner" ~kind:Value () in
35
+
let parent = make_item ~name:"Outer" ~kind:Module ~children:[ child ] () in
36
+
let result = flatten [ parent ] in
37
+
Alcotest.(check int) "parent and child" 2 (List.length result)
44
38
45
39
let test_get_values () =
46
40
let items =
47
41
[
48
-
{ name = "foo"; kind = Value; type_sig = Some "int"; range = None };
49
-
{ name = "Bar"; kind = Type; type_sig = None; range = None };
50
-
{ name = "baz"; kind = Value; type_sig = Some "string"; range = None };
42
+
make_item ~name:"foo" ~kind:Value ~type_sig:(Some "int") ();
43
+
make_item ~name:"Bar" ~kind:Type ();
44
+
make_item ~name:"baz" ~kind:Value ~type_sig:(Some "string") ();
51
45
]
52
46
in
53
47
54
-
let values = values items in
55
-
Alcotest.(check int) "two values" 2 (List.length values);
56
-
Alcotest.(check string) "first value" "foo" (List.hd values).name;
57
-
Alcotest.(check string) "second value" "baz" (List.nth values 1).name
48
+
let result = values items in
49
+
Alcotest.(check int) "two values" 2 (List.length result);
50
+
Alcotest.(check string) "first value" "foo" (List.hd result).name;
51
+
Alcotest.(check string) "second value" "baz" (List.nth result 1).name
58
52
59
53
let test_find_by_name () =
60
54
let items =
61
55
[
62
-
{ name = "foo"; kind = Value; type_sig = Some "int"; range = None };
63
-
{ name = "Bar"; kind = Type; type_sig = None; range = None };
56
+
make_item ~name:"foo" ~kind:Value ~type_sig:(Some "int") ();
57
+
make_item ~name:"Bar" ~kind:Type ();
64
58
]
65
59
in
66
60
···
71
65
let not_found = by_name "baz" items in
72
66
Alcotest.(check bool) "not found baz" true (not_found = None)
73
67
74
-
let test_parse_kinds () =
75
-
let json =
76
-
`List
77
-
[
78
-
`Assoc [ ("name", `String "m"); ("kind", `String "Module") ];
79
-
`Assoc [ ("name", `String "c"); ("kind", `String "Class") ];
80
-
`Assoc [ ("name", `String "e"); ("kind", `String "Exn") ];
81
-
`Assoc [ ("name", `String "C"); ("kind", `String "Constructor") ];
82
-
`Assoc [ ("name", `String "f"); ("kind", `String "Field") ];
83
-
`Assoc [ ("name", `String "meth"); ("kind", `String "Method") ];
84
-
`Assoc [ ("name", `String "x"); ("kind", `String "Unknown") ];
85
-
]
86
-
in
68
+
let test_find_nested () =
69
+
let child = make_item ~name:"nested" ~kind:Value () in
70
+
let parent = make_item ~name:"M" ~kind:Module ~children:[ child ] () in
71
+
let found = by_name "nested" [ parent ] in
72
+
Alcotest.(check bool) "found nested" true (found <> None);
73
+
Alcotest.(check string) "correct name" "nested" (Option.get found).name
87
74
88
-
let items = of_json json in
89
-
let kinds = List.map (fun item -> item.kind) items in
75
+
let test_all_kinds () =
76
+
let kinds =
77
+
[
78
+
(Value, "value");
79
+
(Type, "type");
80
+
(Module, "module");
81
+
(Module_type, "module_type");
82
+
(Class, "class");
83
+
(Class_type, "class_type");
84
+
(Constructor, "constructor");
85
+
(Exception, "exception");
86
+
(Field, "field");
87
+
(Method, "method");
88
+
(Label, "label");
89
+
]
90
+
in
91
+
List.iter
92
+
(fun (kind, name) ->
93
+
let item = make_item ~name ~kind () in
94
+
Alcotest.(check string)
95
+
(Fmt.str "%s kind" name)
96
+
name item.name)
97
+
kinds
90
98
91
-
Alcotest.(check bool) "has module" true (List.mem Module kinds);
92
-
Alcotest.(check bool) "has class" true (List.mem Class kinds);
93
-
Alcotest.(check bool) "has exception" true (List.mem Exception kinds);
94
-
Alcotest.(check bool) "has constructor" true (List.mem Constructor kinds);
95
-
Alcotest.(check bool) "has field" true (List.mem Field kinds);
96
-
Alcotest.(check bool) "has method" true (List.mem Method kinds);
99
+
let test_is_function_type () =
100
+
Alcotest.(check bool) "arrow is function" true (is_function_type "int -> int");
101
+
Alcotest.(check bool) "simple not function" false (is_function_type "int");
97
102
Alcotest.(check bool)
98
-
"has other" true
99
-
(List.exists (function Other _ -> true | _ -> false) kinds)
103
+
"multi arrow is function" true
104
+
(is_function_type "int -> int -> int")
105
+
106
+
let test_extract_return_type () =
107
+
Alcotest.(check string)
108
+
"simple return" "string"
109
+
(extract_return_type "int -> string");
110
+
Alcotest.(check string)
111
+
"multi-arg return" "bool"
112
+
(extract_return_type "int -> string -> bool");
113
+
Alcotest.(check string)
114
+
"no arrow" "int" (extract_return_type "int")
115
+
116
+
let test_count_parameters () =
117
+
Alcotest.(check int)
118
+
"one int" 1 (count_parameters "int -> string" "int");
119
+
Alcotest.(check int)
120
+
"two ints" 2
121
+
(count_parameters "int -> int -> string" "int");
122
+
Alcotest.(check int) "no match" 0 (count_parameters "int -> string" "bool")
100
123
101
124
let tests =
102
125
[
103
-
Alcotest.test_case "parse_empty" `Quick test_parse_empty;
104
-
Alcotest.test_case "parse_simple" `Quick test_parse_simple;
126
+
Alcotest.test_case "flatten_empty" `Quick test_flatten_empty;
127
+
Alcotest.test_case "flatten_simple" `Quick test_flatten_simple;
128
+
Alcotest.test_case "flatten_with_children" `Quick test_flatten_with_children;
105
129
Alcotest.test_case "get_values" `Quick test_get_values;
106
130
Alcotest.test_case "find_by_name" `Quick test_find_by_name;
107
-
Alcotest.test_case "parse_kinds" `Quick test_parse_kinds;
131
+
Alcotest.test_case "find_nested" `Quick test_find_nested;
132
+
Alcotest.test_case "all_kinds" `Quick test_all_kinds;
133
+
Alcotest.test_case "is_function_type" `Quick test_is_function_type;
134
+
Alcotest.test_case "extract_return_type" `Quick test_extract_return_type;
135
+
Alcotest.test_case "count_parameters" `Quick test_count_parameters;
108
136
]
109
137
110
138
let suite = ("outline", tests)