Source file cmd__tools__lint_file.ml

(*********************************************************************************)
(*  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
     ())
;;