1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
let eval_path ~path ~predicate =
match (predicate : Dunolint.Predicate.t) with
| `dune _ | `dune_project _ -> Dunolint.Trilang.Undefined
| `path condition ->
Blang.eval condition (function
| `equals value -> Relative_path.equal path value
| `glob glob -> Dunolint.Glob.test glob (Relative_path.to_string path))
|> Dunolint.Trilang.const
;;
let maybe_autoformat_file ~dunolint_engine ~previous_contents ~new_contents =
if String.equal previous_contents new_contents
then new_contents
else (
let was_originally_well_formatted =
try
let formatted =
Dunolint_engine.format_dune_file dunolint_engine ~new_contents:previous_contents
in
String.equal formatted previous_contents
with
| _ -> false
in
if was_originally_well_formatted
then Dunolint_engine.format_dune_file dunolint_engine ~new_contents
else new_contents)
;;
module Lint_file (Linter : Dunolinter.S) = struct
exception Skip_subtree
let lint_file ~dunolint_engine ~(path : Relative_path.t) ~f =
let previous_contents_ref = ref "" in
let visitor_decision = ref Dunolint_engine.Visitor_decision.Continue in
Dunolint_engine.lint_file
dunolint_engine
~path
?create_file:None
~rewrite_file:(fun ~previous_contents ->
previous_contents_ref := previous_contents;
match Linter.create ~path ~original_contents:previous_contents with
| Error { loc; message } ->
Err.error ~loc [ Pp.textf "%s" message ];
previous_contents
| Ok linter ->
let () =
try Linter.visit linter ~f with
| Skip_subtree -> visitor_decision := Skip_subtree
in
Linter.contents linter)
~autoformat_file:(fun ~new_contents ->
let previous_contents = !previous_contents_ref in
maybe_autoformat_file ~dunolint_engine ~previous_contents ~new_contents);
!visitor_decision
;;
let visit_file ~dunolint_engine ~rules ~path =
lint_file ~dunolint_engine ~path ~f:(fun stanza ->
let loc =
Sexps_rewriter.loc
(Dunolinter.sexps_rewriter stanza)
(Dunolinter.original_sexp stanza)
in
Dunolinter.Handler.emit_error_and_resume () ~loc ~f:(fun () ->
match Dunolinter.linter stanza with
| Unhandled -> ()
| T { eval; enforce } ->
List.iter rules ~f:(fun rule ->
match Dunolint.Rule.eval rule ~f:eval with
| `return -> ()
| `enforce condition -> enforce condition
| `skip_subtree -> raise Skip_subtree)))
;;
end
module Dune_lint = Lint_file (Dune_linter)
module Dune_project_lint = Lint_file (Dune_project_linter)
let visit_directory ~dunolint_engine ~config ~parent_dir ~files =
Log.debug (fun () ->
Pp.O.
[ Pp.text "Dunolint visit_directory "
++ Pp_tty.path (module Relative_path) parent_dir
]);
match
match Dunolint.Config.skip_subtree config with
| None -> `return
| Some condition ->
Dunolint.Rule.eval condition ~f:(fun predicate ->
eval_path ~path:parent_dir ~predicate:(predicate :> Dunolint.Predicate.t))
with
| `enforce nothing -> Nothing.unreachable_code nothing
| `skip_subtree ->
Log.debug (fun () ->
Pp.O.
[ Pp.text "Skipping directory " ++ Pp_tty.path (module Relative_path) parent_dir ]);
Dunolint_engine.Visitor_decision.Skip_subtree
| `return ->
let rules = Dunolint.Config.rules config in
let rec loop = function
| [] -> Dunolint_engine.Visitor_decision.Continue
| file :: files ->
let path = Relative_path.extend parent_dir (Fsegment.v file) in
(match
match file with
| "dune" -> Dune_lint.visit_file ~dunolint_engine ~rules ~path
| "dune-project" -> Dune_project_lint.visit_file ~dunolint_engine ~rules ~path
| _ -> Dunolint_engine.Visitor_decision.Continue
with
| Dunolint_engine.Visitor_decision.Continue -> loop files
| (Break | Skip_subtree) as visitor_decision -> visitor_decision)
in
loop files
;;
let main =
Command.make
~summary:"lint project"
(let%map_open.Command dunolint_engine_config = Dunolint_engine.Config.arg
and () = Log_cli.set_config ()
and config =
Arg.named_opt [ "config" ] Param.file ~doc:"Path to dunolint config file"
and below = Common.below ~doc:"Lint only below this path"
and enforce =
Arg.named_multi
[ "enforce" ]
(Common.sexpable_param (module Dunolint.Condition))
~docv:"COND"
~doc:"Add condition to enforce"
>>| List.map ~f:(fun condition -> `enforce condition)
in
let config =
match config with
| Some config ->
let contents = In_channel.read_all config in
Parsexp.Conv_single.parse_string_exn contents Dunolint.Config.t_of_sexp
| None ->
Dunolint.Config.create ~skip_subtree:(Common.skip_subtree ~globs:[]) ~rules:[] ()
in
let config =
Dunolint.Config.create
?skip_subtree:(Dunolint.Config.skip_subtree config)
~rules:(Dunolint.Config.rules config @ enforce)
()
in
Dunolint_engine.run ~config:dunolint_engine_config
@@ fun dunolint_engine ->
Dunolint_engine.visit
dunolint_engine
?below
~f:(fun ~parent_dir ~subdirectories:_ ~files ->
visit_directory ~dunolint_engine ~config ~parent_dir ~files))
;;