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
180
181
182
183
184
185
186
187
open! Import
let raise_config_not_applicable_err ~(path : Relative_path.t) ~location =
Err.raise
~loc:(Loc.of_file ~path:(path :> Fpath.t))
~exit_code:Err.Exit_code.internal_error
[ Pp.text "Path is not within config location."
; Err.sexp [%sexp { path : Relative_path.t; location : Relative_path.t }]
] [@coverage off]
;;
let should_skip_subtree ~context ~(path : Relative_path.t) =
List.exists (Dunolint_engine.Context.configs context) ~f:(fun { config; location } ->
match Path_in_workspace.chop_prefix path ~prefix:location with
| None -> raise_config_not_applicable_err ~path ~location [@coverage off]
| Some path ->
(match Dunolint.Config.Private.view config with
| `v0 v0 ->
(match Dunolint.Config.V0.skip_subtree v0 with
| None -> false
| Some condition ->
Path_in_workspace.paths_to_check_for_skip_predicates ~path
|> List.exists ~f:(fun path ->
match
Dunolint.Rule.eval condition ~f:(fun (`path condition) ->
Dunolinter.eval_path ~path ~condition)
with
| `enforce _ -> .
| `return -> false
| `skip_subtree -> true))
| `v1 v1 ->
let skip_paths = Dunolint.Config.V1.skip_paths v1 |> List.concat in
Path_in_workspace.paths_to_check_for_skip_predicates ~path
|> List.exists ~f:(fun path ->
let path = Relative_path.to_string path in
List.exists skip_paths ~f:(fun glob -> Dunolint.Glob.test glob path))))
;;
let maybe_autoformat_file ~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 ~new_contents:previous_contents
in
String.equal formatted previous_contents
with
| _ -> false
in
if was_originally_well_formatted
then Dunolint_engine.format_dune_file ~new_contents
else new_contents)
;;
module Visitor_decision = struct
type t =
| Continue
| Skip_subtree
end
let lint_stanza ~path ~context ~stanza ~(return : _ With_return.return) =
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 (Dunolint_engine.Context.configs context) ~f:(fun { config; location } ->
match Path_in_workspace.chop_prefix path ~prefix:location with
| None -> raise_config_not_applicable_err ~path ~location [@coverage off]
| Some path ->
List.iter (Dunolint.Config.rules config) ~f:(fun rule ->
match Dunolint.Rule.eval rule ~f:(fun predicate -> eval ~path ~predicate) with
| `return -> ()
| `enforce condition -> enforce ~path ~condition
| `skip_subtree -> return.return `skip_subtree)))
;;
module Lint_file (Linter : Dunolinter.S) = struct
let lint_file ~dunolint_engine ~context ~(path : Relative_path.t) =
let previous_contents_ref = ref "" in
let visitor_decision = ref 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 result =
With_return.with_return (fun return ->
Linter.visit linter ~f:(fun stanza ->
lint_stanza ~path ~context ~stanza ~return);
`continue)
in
let () =
match result with
| `continue -> ()
| `skip_subtree -> visitor_decision := Visitor_decision.Skip_subtree
in
Linter.contents linter)
~autoformat_file:(fun ~new_contents ->
let previous_contents = !previous_contents_ref in
maybe_autoformat_file ~previous_contents ~new_contents);
!visitor_decision
;;
end
module Dune_lint = Lint_file (Dune_linter)
module Dune_project_lint = Lint_file (Dune_project_linter)
let should_skip_file ~context ~path =
List.exists (Dunolint_engine.Context.configs context) ~f:(fun { config; location } ->
match Path_in_workspace.chop_prefix path ~prefix:location with
| None -> raise_config_not_applicable_err ~path ~location [@coverage off]
| Some path ->
(match Dunolint.Config.Private.view config with
| `v0 _ -> false
| `v1 v1 ->
let filename = Relative_path.to_string path in
let skip_files = Dunolint.Config.V1.skip_paths v1 |> List.concat in
List.exists skip_files ~f:(fun glob -> Dunolint.Glob.test glob filename)))
;;
let visit_directory ~dunolint_engine ~context ~parent_dir ~files =
match should_skip_subtree ~context ~path:parent_dir with
| true -> Dunolint_engine.Visitor_decision.Skip_subtree
| false ->
let rec loop = function
| [] -> Dunolint_engine.Visitor_decision.Continue
| file :: files ->
(match
match Dunolint.Linted_file_kind.of_string file with
| Error (`Msg _) -> Visitor_decision.Continue
| Ok linted_file_kind ->
let path = Relative_path.extend parent_dir (Fsegment.v file) in
if should_skip_file ~context ~path
then Visitor_decision.Continue
else (
match linted_file_kind with
| `dune -> Dune_lint.lint_file ~dunolint_engine ~context ~path
| `dune_project ->
Dune_project_lint.lint_file ~dunolint_engine ~context ~path)
with
| Continue -> loop files
| Skip_subtree -> Dunolint_engine.Visitor_decision.Skip_subtree)
in
loop files
;;