Skip to content

Commit 27df7d1

Browse files
mbarbinmbarbin
authored
Merge pull request #77 from mbarbin/cli-linter-tweak
Cli linter tweak
2 parents 7ca7c47 + a4bffdb commit 27df7d1

File tree

7 files changed

+193
-145
lines changed

7 files changed

+193
-145
lines changed

‎lib/dunolint_cli/src/cmd__lint.ml‎

Lines changed: 7 additions & 112 deletions
Original file line numberDiff line numberDiff line change
@@ -19,126 +19,18 @@
1919
(* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively. *)
2020
(*********************************************************************************)
2121

22-
let maybe_autoformat_file ~previous_contents ~new_contents =
23-
(* For the time being we are using here a heuristic to drive whether to
24-
autoformat linted files. This is motivated by pragmatic reasoning and lower
25-
friction for onboarding in various situation where formatting may or may
26-
not be used in projects. *)
27-
if String.equal previous_contents new_contents
28-
then new_contents
29-
else (
30-
let was_originally_well_formatted =
31-
try
32-
let formatted =
33-
Dunolint_engine.format_dune_file ~new_contents:previous_contents
34-
in
35-
String.equal formatted previous_contents
36-
with
37-
| _ -> false
38-
in
39-
if was_originally_well_formatted
40-
then Dunolint_engine.format_dune_file ~new_contents
41-
else new_contents)
42-
;;
43-
44-
module Visitor_decision = struct
45-
(* A subtype of [Dunolint_engine.Visitor_decision] used by [Lint_file]. *)
46-
type t =
47-
| Continue
48-
| Skip_subtree
49-
end
50-
51-
module Lint_file (Linter : Dunolinter.S) = struct
52-
exception Skip_subtree
53-
54-
let lint_stanza ~rules ~stanza =
55-
let loc =
56-
Sexps_rewriter.loc
57-
(Dunolinter.sexps_rewriter stanza)
58-
(Dunolinter.original_sexp stanza)
59-
in
60-
Dunolinter.Handler.emit_error_and_resume () ~loc ~f:(fun () ->
61-
match Dunolinter.linter stanza with
62-
| Unhandled -> ()
63-
| T { eval; enforce } ->
64-
List.iter rules ~f:(fun rule ->
65-
match Dunolint.Rule.eval rule ~f:eval with
66-
| `return -> ()
67-
| `enforce condition -> enforce condition
68-
| `skip_subtree -> raise Skip_subtree))
69-
;;
70-
71-
let lint_file ~dunolint_engine ~rules ~(path : Relative_path.t) =
72-
let previous_contents_ref = ref "" in
73-
let visitor_decision = ref Visitor_decision.Continue in
74-
Dunolint_engine.lint_file
75-
dunolint_engine
76-
~path
77-
?create_file:None
78-
~rewrite_file:(fun ~previous_contents ->
79-
previous_contents_ref := previous_contents;
80-
match Linter.create ~path ~original_contents:previous_contents with
81-
| Error { loc; message } ->
82-
Err.error ~loc [ Pp.textf "%s" message ];
83-
previous_contents
84-
| Ok linter ->
85-
let () =
86-
try Linter.visit linter ~f:(fun stanza -> lint_stanza ~rules ~stanza) with
87-
| Skip_subtree -> visitor_decision := Skip_subtree
88-
in
89-
Linter.contents linter)
90-
~autoformat_file:(fun ~new_contents ->
91-
let previous_contents = !previous_contents_ref in
92-
maybe_autoformat_file ~previous_contents ~new_contents);
93-
!visitor_decision
94-
;;
95-
end
96-
97-
module Dune_lint = Lint_file (Dune_linter)
98-
module Dune_project_lint = Lint_file (Dune_project_linter)
99-
100-
let visit_directory ~dunolint_engine ~config ~parent_dir ~files =
101-
match
102-
match Dunolint.Config.skip_subtree config with
103-
| None -> `return
104-
| Some condition ->
105-
Dunolint.Rule.eval condition ~f:(fun (`path condition) ->
106-
Dunolinter.eval_path ~path:parent_dir ~condition)
107-
with
108-
| `enforce nothing -> Nothing.unreachable_code nothing [@coverage off]
109-
| `skip_subtree -> Dunolint_engine.Visitor_decision.Skip_subtree
110-
| `return ->
111-
let rules = Dunolint.Config.rules config in
112-
let rec loop = function
113-
| [] -> Dunolint_engine.Visitor_decision.Continue
114-
| file :: files ->
115-
let path = Relative_path.extend parent_dir (Fsegment.v file) in
116-
(match
117-
match Dunolint.Linted_file_kind.of_string file with
118-
| Error (`Msg _) -> Visitor_decision.Continue
119-
| Ok linted_file_kind ->
120-
(match linted_file_kind with
121-
| `dune -> Dune_lint.lint_file ~dunolint_engine ~rules ~path
122-
| `dune_project -> Dune_project_lint.lint_file ~dunolint_engine ~rules ~path)
123-
with
124-
| Continue -> loop files
125-
| Skip_subtree -> Dunolint_engine.Visitor_decision.Skip_subtree)
126-
in
127-
loop files
128-
;;
129-
13022
let main =
13123
Command.make
13224
~summary:"lint project"
13325
(let%map_open.Command dunolint_engine_config = Dunolint_engine.Config.arg
13426
and () = Log_cli.set_config ()
13527
and config =
13628
Arg.named_opt [ "config" ] Param.file ~doc:"Path to dunolint config file"
137-
and below = Common.below ~doc:"Lint only below this path"
29+
and below = Common_helpers.below ~doc:"Lint only below this path"
13830
and enforce =
13931
Arg.named_multi
14032
[ "enforce" ]
141-
(Common.sexpable_param (module Dunolint.Condition))
33+
(Common_helpers.sexpable_param (module Dunolint.Condition))
14234
~docv:"COND"
14335
~doc:"Add condition to enforce"
14436
>>| List.map ~f:(fun condition -> `enforce condition)
@@ -149,7 +41,10 @@ let main =
14941
let contents = In_channel.read_all config in
15042
Parsexp.Conv_single.parse_string_exn contents Dunolint.Config.t_of_sexp
15143
| None ->
152-
Dunolint.Config.create ~skip_subtree:(Common.skip_subtree ~globs:[]) ~rules:[] ()
44+
Dunolint.Config.create
45+
~skip_subtree:(Common_helpers.skip_subtree ~globs:[])
46+
~rules:[]
47+
()
15348
in
15449
let config =
15550
Dunolint.Config.create
@@ -163,5 +58,5 @@ let main =
16358
dunolint_engine
16459
?below
16560
~f:(fun ~parent_dir ~subdirectories:_ ~files ->
166-
visit_directory ~dunolint_engine ~config ~parent_dir ~files))
61+
Linter.visit_directory ~dunolint_engine ~config ~parent_dir ~files))
16762
;;

‎lib/dunolint_cli/src/cmd__lint.mli‎

Lines changed: 0 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -19,11 +19,4 @@
1919
(*_ <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively. *)
2020
(*_********************************************************************************)
2121

22-
val visit_directory
23-
: dunolint_engine:Dunolint_engine.t
24-
-> config:Dunolint.Config.t
25-
-> parent_dir:Relative_path.t
26-
-> files:string list
27-
-> Dunolint_engine.Visitor_decision.t
28-
2922
val main : unit Command.t

‎lib/dunolint_cli/src/cmd__tools__lint_file.ml‎

Lines changed: 17 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -65,34 +65,22 @@ let skip_subtree ~config ~path =
6565
| (`return | `skip_subtree) as result -> result)
6666
;;
6767

68-
exception Skip_subtree
69-
70-
let lint_stanza ~rules ~stanza =
71-
let loc =
72-
Sexps_rewriter.loc
73-
(Dunolinter.sexps_rewriter stanza)
74-
(Dunolinter.original_sexp stanza)
75-
in
76-
Dunolinter.Handler.emit_error_and_resume () ~loc ~f:(fun () ->
77-
match Dunolinter.linter stanza with
78-
| Unhandled -> ()
79-
| T { eval; enforce } ->
80-
List.iter rules ~f:(fun rule ->
81-
match Dunolint.Rule.eval rule ~f:eval with
82-
| `return -> ()
83-
| `enforce condition -> enforce condition
84-
| `skip_subtree -> raise Skip_subtree))
85-
;;
86-
87-
let lint_file (module Linter : Dunolinter.S) ~format_file ~rules ~path ~original_contents =
88-
match Linter.create ~path ~original_contents with
68+
let lint_file
69+
(module File_linter : Dunolinter.S)
70+
~format_file
71+
~rules
72+
~path
73+
~original_contents
74+
=
75+
match File_linter.create ~path ~original_contents with
8976
| Error { loc; message } -> Err.raise ~loc [ Pp.textf "%s" message ]
9077
| Ok linter ->
9178
let () =
92-
try Linter.visit linter ~f:(fun stanza -> lint_stanza ~rules ~stanza) with
93-
| Skip_subtree -> ()
79+
With_return.with_return (fun return ->
80+
File_linter.visit linter ~f:(fun stanza ->
81+
Linter.lint_stanza ~rules ~stanza ~return))
9482
in
95-
let new_contents = Linter.contents linter in
83+
let new_contents = File_linter.contents linter in
9684
if format_file then Dunolint_engine.format_dune_file ~new_contents else new_contents
9785
;;
9886

@@ -199,7 +187,7 @@ When the contents of the file is read from stdin, or if the file given does not
199187
and enforce =
200188
Arg.named_multi
201189
[ "enforce" ]
202-
(Common.sexpable_param (module Dunolint.Condition))
190+
(Common_helpers.sexpable_param (module Dunolint.Condition))
203191
~docv:"COND"
204192
~doc:"Add condition to enforce."
205193
>>| List.map ~f:(fun condition -> `enforce condition)
@@ -212,7 +200,10 @@ When the contents of the file is read from stdin, or if the file given does not
212200
let contents = In_channel.read_all config in
213201
Parsexp.Conv_single.parse_string_exn contents Dunolint.Config.t_of_sexp
214202
| None ->
215-
Dunolint.Config.create ~skip_subtree:(Common.skip_subtree ~globs:[]) ~rules:[] ()
203+
Dunolint.Config.create
204+
~skip_subtree:(Common_helpers.skip_subtree ~globs:[])
205+
~rules:[]
206+
()
216207
in
217208
let config =
218209
Dunolint.Config.create

‎lib/dunolint_cli/src/common.ml‎ renamed to ‎lib/dunolint_cli/src/common_helpers.ml‎

File renamed without changes.

‎lib/dunolint_cli/src/common.mli‎ renamed to ‎lib/dunolint_cli/src/common_helpers.mli‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,8 @@
1919
(*_ <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively. *)
2020
(*_********************************************************************************)
2121

22+
(** For use in the rest of the files in this directory. *)
23+
2224
val sexpable_param : (module Sexpable.S with type t = 'a) -> 'a Command.Param.t
2325

2426
(** Restrict the scope of a command to a subdirectory only. "Below this path". *)

‎lib/dunolint_cli/src/linter.ml‎

Lines changed: 126 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,126 @@
1+
(*********************************************************************************)
2+
(* Dunolint - A tool to lint and help manage files in dune projects *)
3+
(* Copyright (C) 2024-2025 Mathieu Barbin <mathieu.barbin@gmail.com> *)
4+
(* *)
5+
(* This file is part of Dunolint. *)
6+
(* *)
7+
(* Dunolint is free software; you can redistribute it and/or modify it *)
8+
(* under the terms of the GNU Lesser General Public License as published by *)
9+
(* the Free Software Foundation either version 3 of the License, or any later *)
10+
(* version, with the LGPL-3.0 Linking Exception. *)
11+
(* *)
12+
(* Dunolint is distributed in the hope that it will be useful, but WITHOUT *)
13+
(* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or *)
14+
(* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License *)
15+
(* and the file `NOTICE.md` at the root of this repository for more details. *)
16+
(* *)
17+
(* You should have received a copy of the GNU Lesser General Public License *)
18+
(* and the LGPL-3.0 Linking Exception along with this library. If not, see *)
19+
(* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively. *)
20+
(*********************************************************************************)
21+
22+
let maybe_autoformat_file ~previous_contents ~new_contents =
23+
(* For the time being we are using here a heuristic to drive whether to
24+
autoformat linted files. This is motivated by pragmatic reasoning and lower
25+
friction for onboarding in various situation where formatting may or may
26+
not be used in projects. *)
27+
if String.equal previous_contents new_contents
28+
then new_contents
29+
else (
30+
let was_originally_well_formatted =
31+
try
32+
let formatted =
33+
Dunolint_engine.format_dune_file ~new_contents:previous_contents
34+
in
35+
String.equal formatted previous_contents
36+
with
37+
| _ -> false
38+
in
39+
if was_originally_well_formatted
40+
then Dunolint_engine.format_dune_file ~new_contents
41+
else new_contents)
42+
;;
43+
44+
module Visitor_decision = struct
45+
(* A subtype of [Dunolint_engine.Visitor_decision] used by [Lint_file]. *)
46+
type t =
47+
| Continue
48+
| Skip_subtree
49+
end
50+
51+
let lint_stanza ~rules ~stanza ~(return : _ With_return.return) =
52+
let loc =
53+
Sexps_rewriter.loc
54+
(Dunolinter.sexps_rewriter stanza)
55+
(Dunolinter.original_sexp stanza)
56+
in
57+
Dunolinter.Handler.emit_error_and_resume () ~loc ~f:(fun () ->
58+
match Dunolinter.linter stanza with
59+
| Unhandled -> ()
60+
| T { eval; enforce } ->
61+
List.iter rules ~f:(fun rule ->
62+
match Dunolint.Rule.eval rule ~f:eval with
63+
| `return -> ()
64+
| `enforce condition -> enforce condition
65+
| `skip_subtree -> return.return ()))
66+
;;
67+
68+
module Lint_file (Linter : Dunolinter.S) = struct
69+
let lint_file ~dunolint_engine ~rules ~(path : Relative_path.t) =
70+
let previous_contents_ref = ref "" in
71+
let visitor_decision = ref Visitor_decision.Continue in
72+
Dunolint_engine.lint_file
73+
dunolint_engine
74+
~path
75+
?create_file:None
76+
~rewrite_file:(fun ~previous_contents ->
77+
previous_contents_ref := previous_contents;
78+
match Linter.create ~path ~original_contents:previous_contents with
79+
| Error { loc; message } ->
80+
Err.error ~loc [ Pp.textf "%s" message ];
81+
previous_contents
82+
| Ok linter ->
83+
let () =
84+
With_return.with_return (fun return ->
85+
Linter.visit linter ~f:(fun stanza -> lint_stanza ~rules ~stanza ~return))
86+
in
87+
Linter.contents linter)
88+
~autoformat_file:(fun ~new_contents ->
89+
let previous_contents = !previous_contents_ref in
90+
maybe_autoformat_file ~previous_contents ~new_contents);
91+
!visitor_decision
92+
;;
93+
end
94+
95+
module Dune_lint = Lint_file (Dune_linter)
96+
module Dune_project_lint = Lint_file (Dune_project_linter)
97+
98+
let visit_directory ~dunolint_engine ~config ~parent_dir ~files =
99+
match
100+
match Dunolint.Config.skip_subtree config with
101+
| None -> `return
102+
| Some condition ->
103+
Dunolint.Rule.eval condition ~f:(fun (`path condition) ->
104+
Dunolinter.eval_path ~path:parent_dir ~condition)
105+
with
106+
| `enforce nothing -> Nothing.unreachable_code nothing [@coverage off]
107+
| `skip_subtree -> Dunolint_engine.Visitor_decision.Skip_subtree
108+
| `return ->
109+
let rules = Dunolint.Config.rules config in
110+
let rec loop = function
111+
| [] -> Dunolint_engine.Visitor_decision.Continue
112+
| file :: files ->
113+
let path = Relative_path.extend parent_dir (Fsegment.v file) in
114+
(match
115+
match Dunolint.Linted_file_kind.of_string file with
116+
| Error (`Msg _) -> Visitor_decision.Continue
117+
| Ok linted_file_kind ->
118+
(match linted_file_kind with
119+
| `dune -> Dune_lint.lint_file ~dunolint_engine ~rules ~path
120+
| `dune_project -> Dune_project_lint.lint_file ~dunolint_engine ~rules ~path)
121+
with
122+
| Continue -> loop files
123+
| Skip_subtree -> Dunolint_engine.Visitor_decision.Skip_subtree)
124+
in
125+
loop files
126+
;;

0 commit comments

Comments
 (0)