package dunolint

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file cmd__tools__lint_file.ml

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
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
(*********************************************************************************)
(*  Dunolint - A tool to lint and help manage files in dune projects             *)
(*  Copyright (C) 2024-2025 Mathieu Barbin <mathieu.barbin@gmail.com>            *)
(*                                                                               *)
(*  This file is part of Dunolint.                                               *)
(*                                                                               *)
(*  Dunolint is free software; you can redistribute it and/or modify it          *)
(*  under the terms of the GNU Lesser General Public License as published by     *)
(*  the Free Software Foundation either version 3 of the License, or any later   *)
(*  version, with the LGPL-3.0 Linking Exception.                                *)
(*                                                                               *)
(*  Dunolint is distributed in the hope that it will be useful, but WITHOUT      *)
(*  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or        *)
(*  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License  *)
(*  and the file `NOTICE.md` at the root of this repository for more details.    *)
(*                                                                               *)
(*  You should have received a copy of the GNU Lesser General Public License     *)
(*  and the LGPL-3.0 Linking Exception along with this library. If not, see      *)
(*  <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.         *)
(*********************************************************************************)

open! Import
module Unix = UnixLabels

module Save_in_place = struct
  type t =
    { file : Fpath.t
    ; perm : int
    }

  let invalid_file_kind ~file ~file_kind =
    Err.raise
      Pp.O.
        [ Pp.text "Linted file "
          ++ Pp_tty.path (module Fpath) file
          ++ Pp.text " is expected to be a regular file."
        ; Pp.text "Actual file kind is "
          ++ Pp_tty.id (module Dunolint_engine.File_kind) file_kind
          ++ Pp.text "."
        ]
  ;;

  let of_file ~file =
    match Unix.lstat (Fpath.to_string file) with
    | exception Unix.Unix_error (ENOENT, _, _) ->
      Err.raise
        Pp.O.[ Pp.text "No such file " ++ Pp_tty.path (module Fpath) file ++ Pp.text "." ]
    | stat ->
      (match stat.st_kind with
       | S_REG -> { file; perm = stat.st_perm }
       | (S_DIR | S_LNK) as file_kind -> invalid_file_kind ~file ~file_kind
       | (S_CHR | S_BLK | S_FIFO | S_SOCK) as file_kind ->
         invalid_file_kind ~file ~file_kind [@coverage off])
  ;;
end

let lint_file
      (module File_linter : Dunolinter.S)
      ~format_file
      ~context
      ~path
      ~original_contents
  =
  match File_linter.create ~path ~original_contents with
  | Error { loc; message } -> Err.raise ~loc [ Pp.textf "%s" message ]
  | Ok linter ->
    let (_ : [ `continue | `skip_subtree ]) =
      With_return.with_return (fun return ->
        File_linter.visit linter ~f:(fun stanza ->
          Linter.lint_stanza ~path ~context ~stanza ~return);
        `continue)
    in
    let new_contents = File_linter.contents linter in
    if format_file then Dunolint_engine.format_dune_file ~new_contents else new_contents
;;

let select_linter ~path =
  let filename = Fpath.filename path in
  match Dunolint.Linted_file_kind.of_string filename with
  | Ok linted_file_kind ->
    (match linted_file_kind with
     | `dune -> (module Dune_linter : Dunolinter.S)
     | `dune_project -> (module Dune_project_linter : Dunolinter.S))
  | Error (`Msg _msg) ->
    Err.raise
      Pp.O.
        [ Pp.text "Cannot infer the file kind from the filename "
          ++ Pp_tty.path (module String) filename
          ++ Pp.verbatim "."
        ]
      ~hints:
        Pp.O.
          [ Pp.text "You may override the filename with the flag "
            ++ Pp_tty.kwd (module String) "--filename"
            ++ Pp.verbatim "."
          ]
;;

let main =
  let in_place_switch = "in-place" in
  let save_in_place ~in_place ~file =
    match in_place, file with
    | false, (None | Some _) -> None
    | true, Some file -> Some (Save_in_place.of_file ~file)
    | true, None ->
      Err.raise
        ~exit_code:Err.Exit_code.cli_error
        Pp.O.
          [ Pp.text "The flag "
            ++ Pp_tty.kwd (module String) in_place_switch
            ++ Pp.text " may only be used when the input is read from a regular file."
          ]
  in
  Command.make
    ~summary:"Lint a single file."
    ~readme:(fun () ->
      "This command is meant to ease the integration with editors in workflows that \
       enable linting on save.\n\n\
       This will read the contents of a build file either from $(b,disk) or from \
       $(b,stdin) and print its linted result on $(b,stdout).\n\n\
       By default, the contents will be read from $(b,stdin). You may supply the path to \
       a file instead.\n\n\
       Dunolint will locate the workspace root by searching for $(b,dune-workspace) or \
       $(b,dune-project) files in the current directory and its ancestors. If no \
       workspace is found, the current working directory is used as the default \
       workspace root (useful for editor integration with standalone files). Once the \
       workspace root is determined, dunolint will auto-discover and load $(b,dunolint) \
       config files from parent directories up to that root. The workspace root can be \
       overridden using the $(b,--root) flag.\n\n\
       When reading from stdin, the $(b,--filename) flag should be used to specify the \
       logical path of the file being linted. This path is used to: (1) infer the file \
       kind (e.g. dune vs dune-project), (2) discover which config files to load based \
       on the file's location in the directory hierarchy, and (3) evaluate skip_paths \
       rules.")
    (let open Command.Std in
     let+ () = Log_cli.set_config ()
     and+ file =
       Arg.pos_opt
         ~pos:0
         (Param.validated_string (module Fpath))
         ~docv:"FILE"
         ~doc:"Path to file to lint (by default reads from stdin)."
     and+ filename =
       Arg.named_opt
         [ "filename" ]
         (Param.validated_string (module Fpath))
         ~docv:"path/to/file"
         ~doc:
           "Logical path of the file being linted. Used to infer the file kind from its \
            basename, discover config files from parent directories, and evaluate \
            skip_paths rules. This flag is particularly useful when reading from \
            $(b,stdin) to specify where the file logically resides in the project \
            hierarchy."
     and+ in_place =
       Arg.flag
         [ in_place_switch ]
         ~doc:
           "When the input is a regular file, you may use this option to save the linted \
            result in the file directly, instead of printing it to $(b,stdout). \
            Supplying this flag results in failure when the input is read from \
            $(b,stdin)."
     and+ config =
       Arg.named_opt
         [ "config" ]
         Param.file
         ~doc:
           "Path to dunolint config file. When specified, disables auto-discovery of \
            config files from parent directories."
     and+ format_file =
       Arg.named_with_default
         [ "format-file" ]
         Param.bool
         ~default:true
         ~doc:"Format file with after linting, using [dune format-dune-file]."
     and+ root = Common_helpers.root in
     let save_in_place = save_in_place ~in_place ~file in
     let cwd = Unix.getcwd () |> Absolute_path.v in
     let workspace_root =
       Workspace_root.find_exn ~default_is_cwd:true ~specified_by_user:root
     in
     let filename =
       Option.map filename ~f:(fun filename ->
         Common_helpers.relativize ~workspace_root ~cwd ~path:filename)
     in
     let file =
       Option.map file ~f:(fun file ->
         Common_helpers.relativize ~workspace_root ~cwd ~path:file)
     in
     let config =
       Option.map config ~f:(fun config ->
         Common_helpers.relativize ~workspace_root ~cwd ~path:(Fpath.v config)
         |> Relative_path.to_string)
     in
     Workspace_root.chdir workspace_root ~level:Debug;
     let path =
       match Option.first_some filename file with
       | Some file -> file
       | None -> Relative_path.v "stdin"
     in
     let autoload_config = Option.is_none config in
     let root_configs =
       List.concat
         [ [ Common_helpers.default_skip_paths_config () ]
         ; (match config with
            | None -> []
            | Some config_path ->
              [ Dunolinter.Config_handler.load_config_exn ~filename:config_path ])
         ]
     in
     let context =
       if autoload_config
       then (
         (* [root_configs] are added to discovered configs by [build_context]. *)
         let engine = Dunolint_engine.create ~root_configs ~running_mode:Dry_run () in
         Dunolint_engine.build_context engine ~path)
       else
         (* When autoload is disabled, we still need the [root_configs]. Since
            build_context won't be called, manually create the context. *)
         List.fold
           root_configs
           ~init:Dunolint_engine.Context.empty
           ~f:(fun context config ->
             Dunolint_engine.Context.add_config
               context
               ~config
               ~location:Relative_path.empty)
     in
     let linter = select_linter ~path:(path :> Fpath.t) in
     let original_contents =
       match file with
       | Some file -> In_channel.read_all (file |> Relative_path.to_string)
       | None -> In_channel.input_all In_channel.stdin
     in
     let output =
       if Linter.should_skip_subtree ~context ~path
       then original_contents
       else lint_file linter ~format_file ~context ~path ~original_contents
     in
     let () =
       match save_in_place with
       | None ->
         Out_channel.flush Out_channel.stdout;
         Out_channel.set_binary_mode Out_channel.stdout true;
         Out_channel.output_string Out_channel.stdout output;
         Out_channel.flush Out_channel.stdout;
         Out_channel.set_binary_mode Out_channel.stdout false
       | Some { file; perm } ->
         if not (String.equal original_contents output)
         then
           Out_channel.with_file ~perm (Fpath.to_string file) ~f:(fun oc ->
             Out_channel.output_string oc output)
     in
     ())
;;