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
188
189
190
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 Relative_path.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
| `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 default_dune_lang_version = lazy (Dune_project.Dune_lang_version.create (2, 0))
let enclosing_dune_lang_version ~context ~(path : Relative_path.t) =
match Dunolint_engine.Context.enclosing_dune_lang_version context with
| None -> Some (Lazy.force default_dune_lang_version)
| Some (Ok version_or_missing) -> version_or_missing
| Some (Error Invalid_dune_project) ->
Err.debug
~loc:(Loc.of_file ~path:(path :> Fpath.t))
(lazy
Pp.O.
[ Pp.text "Formatting file "
++ Pp_tty.path (module Relative_path) path
++ Pp.text " was disabled due to existing errors in enclosing "
++ Pp_tty.path (module String) "dune-project"
++ Pp.text " file."
]);
None
;;
let autoformat_dune_file ~context ~path ~previous_contents ~new_contents =
if String.equal previous_contents new_contents
then new_contents
else (
match enclosing_dune_lang_version ~context ~path with
| None -> new_contents
| Some dune_lang_version ->
let was_originally_well_formatted =
try
let formatted =
Dunolint_engine.format_dune_file
~dune_lang_version
~new_contents:previous_contents
in
String.equal formatted previous_contents
with
| exn ->
Err.debug
~loc:(Loc.of_file ~path:(path :> Fpath.t))
(lazy
[ Pp.text "Exception raised when formatting original file contents:"
; Err.exn exn
]
[@coverage off]);
false
in
if was_originally_well_formatted
then Dunolint_engine.format_dune_file ~dune_lang_version ~new_contents
else new_contents)
;;
let lint_stanza ~path ~context ~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 (Dunolint_engine.Context.configs context) ~f:(fun { config; location } ->
match Relative_path.chop_prefix path ~prefix:location with
| None -> raise_config_not_applicable_err ~path ~location [@coverage off]
| Some path ->
List.iter
(match Dunolint.Config.Private.view config with
| `v1 v1 -> Dunolint.Config.V1.rules v1)
~f:(fun rule ->
match
Dunolint.Rule.eval rule ~f:(fun predicate -> eval ~path ~predicate)
with
| `return -> ()
| `enforce condition -> enforce ~path ~condition)))
;;
let lint_file
(module Linter : Dunolinter.S)
~dunolint_engine
~context
~(path : Relative_path.t)
=
let previous_contents_ref = ref "" 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 ->
Linter.visit linter ~f:(fun stanza -> lint_stanza ~path ~context ~stanza);
Linter.contents linter)
~autoformat_file:(fun ~new_contents ->
let previous_contents = !previous_contents_ref in
autoformat_dune_file ~context ~path ~previous_contents ~new_contents)
;;
let should_skip_file ~context ~path =
List.exists (Dunolint_engine.Context.configs context) ~f:(fun { config; location } ->
match Relative_path.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
| `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 ->
List.iter files ~f:(fun file ->
match Dunolint.Linted_file_kind.of_string file with
| Error (`Msg _) -> ()
| Ok linted_file_kind ->
let path = Relative_path.extend parent_dir (Fsegment.v file) in
if not (should_skip_file ~context ~path)
then (
let lint_file m = lint_file m ~dunolint_engine ~context ~path in
match linted_file_kind with
| `dune -> lint_file (module Dune_linter)
| `dune_project -> lint_file (module Dune_project_linter)
| `dune_workspace -> lint_file (module Dune_workspace_linter)
| `dunolint -> lint_file (module Dunolint_linter)));
Dunolint_engine.Visitor_decision.Continue
;;