Source file dunolint_engine.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.         *)
(*********************************************************************************)

module Prompt = Dunolint_vendor_prompt.Prompt
module Unix = UnixLabels

let src = Logs.Src.create "dunolint" ~doc:"dunolint"

module File_kind = File_kind
module Running_mode = Running_mode
module Config_cache = Config_cache
module Context = Context

module Edited_file = struct
  (* Edited files are indexed by their path relative to the workspace root that
     is assumed to be located at the [cwd] active during creation and use of the
     engine [t]. *)
  type t =
    { path : Relative_path.t
    ; original_contents : string (* Empty if the file is new *)
    ; mutable new_contents : string
    }
end

type t =
  { running_mode : Running_mode.t
  ; config_cache : Config_cache.t
  ; edited_files : Edited_file.t Hashtbl.M(Relative_path).t
  ; root_configs : Dunolint.Config.t list
  }

let create ?(root_configs = []) ~running_mode () =
  { running_mode
  ; config_cache = Config_cache.create ()
  ; edited_files = Hashtbl.create (module Relative_path)
  ; root_configs
  }
;;

let file_exists ~path =
  match (Unix.stat (Relative_path.to_string path)).st_kind with
  | exception Unix.Unix_error (ENOENT, _, _) -> false
  | S_REG -> true
  | file_kind ->
    let () =
      (* This construct is the same as featuring all values in the match case
         but we cannot disable individual coverage in or patterns with
         bisect_ppx atm. Left for future work. *)
      match[@coverage off] file_kind with
      | S_REG -> assert false
      | S_DIR | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK -> ()
    in
    Err.raise
      Pp.O.
        [ Pp.text "Linted file "
          ++ Pp_tty.path (module Relative_path) path
          ++ Pp.text " is expected to be a regular file."
        ; Pp.text "Actual file kind is "
          ++ Pp_tty.id (module File_kind) file_kind
          ++ Pp.text "."
        ]
;;

let lint_file ?autoformat_file ?create_file ?rewrite_file t ~path =
  Log.info ~src (fun () ->
    Pp.O.[ Pp.text "Linting file " ++ Pp_tty.path (module Relative_path) path ]);
  let edited_file = Hashtbl.find t.edited_files path in
  let file_exists = file_exists ~path in
  match
    if file_exists || Option.is_some edited_file
    then (
      let previous_contents =
        match edited_file with
        | Some edited_file -> edited_file.new_contents
        | None -> In_channel.read_all (path |> Relative_path.to_string)
      in
      let new_contents =
        match rewrite_file with
        | None -> previous_contents
        | Some rewrite_file -> rewrite_file ~previous_contents
      in
      Some (previous_contents, new_contents))
    else (
      match create_file with
      | Some create_file ->
        let new_contents = create_file () in
        Some ("", new_contents)
      | None -> None)
  with
  | None -> ()
  | Some (previous_contents, new_contents) ->
    let new_contents =
      match autoformat_file with
      | None -> new_contents
      | Some fmt -> fmt ~new_contents
    in
    if (not file_exists) || not (String.equal previous_contents new_contents)
    then (
      match edited_file with
      | Some edited_file -> edited_file.new_contents <- new_contents
      | None ->
        Hashtbl.set
          t.edited_files
          ~key:path
          ~data:{ Edited_file.path; original_contents = previous_contents; new_contents })
;;

module Process_status = struct
  [@@@coverage off]

  type t = Unix.process_status =
    | WEXITED of int
    | WSIGNALED of int
    | WSTOPPED of int

  let pp = function
    | WEXITED i -> Pp.verbatimf "Exited %d" i
    | WSIGNALED i -> Pp.verbatimf "Signaled %d" i
    | WSTOPPED i -> Pp.verbatimf "Stopped %d" i
  ;;
end

let format_dune_file_internal ~new_contents =
  let ((in_ch, out_ch, err_ch) as process) =
    Unix.open_process_full "dune format-dune-file" ~env:(Unix.environment ())
  in
  Out_channel.output_string out_ch new_contents;
  Out_channel.close out_ch;
  let output = In_channel.input_all in_ch in
  let err_output = In_channel.input_all err_ch in
  match Unix.close_process_full process with
  | WEXITED 0 -> Ok output
  | process_status ->
    let () =
      match[@coverage off] process_status with
      | WEXITED _ | WSIGNALED _ | WSTOPPED _ -> ()
    in
    Error
      [ Pp.text "Failed to format dune file:"
      ; Pp.text
          (if Err.am_running_test ()
           then "<REDACTED IN TEST>"
           else String.strip err_output [@coverage off])
      ; Process_status.pp process_status
      ]
;;

let format_dune_file ~new_contents =
  match format_dune_file_internal ~new_contents with
  | Ok output -> output
  | Error text -> Err.raise text
;;

let format_dune_file_or_continue ~loc ~new_contents =
  match format_dune_file_internal ~new_contents with
  | Ok output -> output
  | Error text ->
    Err.error ~loc text;
    new_contents
;;

let lint_dune_file ?with_linter t ~(path : Relative_path.t) ~f =
  lint_file
    t
    ~path
    ?create_file:None
    ~rewrite_file:(fun ~previous_contents ->
      match Dune_linter.create ~path ~original_contents:previous_contents with
      | Error { loc; message } ->
        Err.error ~loc [ Pp.textf "%s" message ];
        previous_contents
      | Ok linter ->
        Dune_linter.visit linter ~f;
        Option.iter with_linter ~f:(fun f -> f linter);
        Dune_linter.contents linter)
    ~autoformat_file:(fun ~new_contents ->
      format_dune_file_or_continue
        ~loc:(Loc.of_file ~path:(path :> Fpath.t))
        ~new_contents)
;;

let lint_dune_project_file ?with_linter t ~(path : Relative_path.t) ~f =
  lint_file
    t
    ~path
    ?create_file:None
    ~rewrite_file:(fun ~previous_contents ->
      match Dune_project_linter.create ~path ~original_contents:previous_contents with
      | Error { loc; message } ->
        Err.error ~loc [ Pp.textf "%s" message ];
        previous_contents
      | Ok linter ->
        Dune_project_linter.visit linter ~f;
        Option.iter with_linter ~f:(fun f -> f linter);
        Dune_project_linter.contents linter)
    ~autoformat_file:(fun ~new_contents ->
      format_dune_file_or_continue
        ~loc:(Loc.of_file ~path:(path :> Fpath.t))
        ~new_contents)
;;

let is_directory ~path =
  let path = Relative_path.rem_empty_seg path in
  match (Unix.stat (Relative_path.to_string path)).st_kind with
  | exception Unix.Unix_error (ENOENT, _, _) -> `Absent
  | S_DIR -> `Yes
  | file_kind ->
    let () =
      match[@coverage off] file_kind with
      | S_DIR -> assert false
      | S_REG | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK -> ()
    in
    `No file_kind
;;

let is_directory_exn ~path =
  match is_directory ~path with
  | (`Absent | `Yes) as result -> result
  | `No file_kind ->
    Err.raise
      Pp.O.
        [ Pp.text "Parent path "
          ++ Pp_tty.path (module Relative_path) path
          ++ Pp.text " is expected to be a directory."
        ; Pp.text "Actual file kind is "
          ++ Pp_tty.id (module File_kind) file_kind
          ++ Pp.text "."
        ]
;;

let rec mkdirs path =
  match is_directory_exn ~path with
  | `Yes -> ()
  | `Absent ->
    (match Path_in_workspace.parent path with
     | None -> () [@coverage off]
     | Some path -> mkdirs path);
    Unix.mkdir (Relative_path.to_string path) ~perm:0o755
;;

let materialize t =
  let running_mode = t.running_mode in
  let edited_files =
    Hashtbl.to_alist t.edited_files
    |> List.sort ~compare:(fun (p1, _) (p2, _) -> Relative_path.compare p1 p2)
    |> List.map ~f:snd
  in
  let exception Quit in
  try
    List.iteri edited_files ~f:(fun i { path; original_contents; new_contents } ->
      if i > 0 then print_endline "";
      let should_mkdir =
        match Path_in_workspace.parent path with
        | None -> None [@coverage off]
        | Some parent_dir as some ->
          (match is_directory_exn ~path:parent_dir with
           | `Absent -> some
           | `Yes -> None)
      in
      let with_flow ~should_enable_color flow =
        Option.iter should_mkdir ~f:(fun parent_dir ->
          Out_channel.fprintf
            flow
            "%s `mkdir -p %s`\n"
            (match[@coverage off] running_mode with
             | Dry_run -> "dry-run: Would run"
             | Check -> "check: Would run"
             | Interactive -> "Would run"
             | Force_yes -> "Running")
            (Relative_path.to_string parent_dir));
        Out_channel.fprintf
          flow
          "%s file %S:\n"
          (match running_mode with
           | Dry_run -> "dry-run: Would edit"
           | Check -> "check: Would edit"
           | Interactive -> "Would edit"
           | Force_yes -> "Editing")
          (Relative_path.to_string path);
        Out_channel.output_line
          flow
          (if Err.am_running_test ()
           then Expect_test_patdiff.patdiff original_contents new_contents ~context:3
           else (
             let name = Relative_path.to_string path in
             let rules =
               if should_enable_color
               then None
               else Some Patdiff.Format.Rules.(strip_styles default)
             in
             Patdiff.Patdiff_core.patdiff
               ?rules
               ~context:6
               ~prev:{ name; text = original_contents }
               ~next:{ name; text = new_contents }
               ()));
        Out_channel.flush flow
      in
      let () =
        match running_mode with
        | Dry_run | Check | Force_yes ->
          let should_enable_color =
            match Err.color_mode () with
            | `Auto -> Unix.isatty Unix.stdout
            | `Always -> true
            | `Never -> false
          in
          with_flow ~should_enable_color stdout
        | Interactive ->
          Git_pager.run ~f:(fun pager ->
            with_flow
              ~should_enable_color:(Git_pager.should_enable_color pager)
              (Git_pager.write_end pager))
      in
      let do_it =
        match running_mode with
        | Dry_run | Check -> false
        | Force_yes -> true
        | Interactive ->
          print_endline "";
          (match
             Prompt.ask
               ~prompt:"Accept diff"
               ~choices:
                 [ Prompt.Choice.create
                     'N'
                     `No
                     ~help:"No - skip diff and go to the next one (default)."
                 ; Prompt.Choice.create 'y' `Yes ~help:"Yes - save diff and continue."
                 ; Prompt.Choice.create
                     'q'
                     `Quit
                     ~help:"Quit - do not accept diff and exit."
                 ]
           with
           | `Yes -> true
           | `No -> false
           | (exception End_of_file) | `Quit -> raise Quit)
      in
      if do_it
      then (
        Option.iter should_mkdir ~f:mkdirs;
        Out_channel.write_all (Relative_path.to_string path) ~data:new_contents))
  with
  | Quit -> ()
;;

module Visitor_decision = struct
  type t =
    | Break
    | Continue
    | Skip_subtree
end

let build_context (t : t) ~path =
  (* Build context by first adding root_configs (base defaults), then
     auto-discovered configs from ancestors. In rule processing order:
     root_configs, then ancestor configs, then subtree configs (each taking
     precedence over the previous). *)
  let initial_context =
    List.fold t.root_configs ~init:Context.empty ~f:(fun context config ->
      Context.add_config context ~config ~location:Relative_path.empty)
  in
  List.fold
    (Path_in_workspace.ancestors_autoloading_dirs ~path)
    ~init:initial_context
    ~f:(fun context dir ->
      match Config_cache.load_config_in_dir t.config_cache ~dir with
      | Absent -> context
      | Present config -> Context.add_config context ~config ~location:dir
      | Error e -> raise (Err.E e))
;;

module Directory_entries = struct
  type t =
    { subdirectories : string list
    ; files : string list
    }

  let readdir ~parent_dir =
    let entries =
      Stdlib.Sys.readdir (Relative_path.to_string parent_dir)
      |> Array.to_list
      |> List.sort ~compare:String.compare
    in
    let subdirectories, files, _ =
      entries
      |> List.partition3_map ~f:(fun entry ->
        match
          (Unix.lstat (Stdlib.Filename.concat (Relative_path.to_string parent_dir) entry))
            .st_kind
        with
        | S_DIR -> `Fst entry
        | S_REG -> `Snd entry
        | s_kind ->
          let () =
            match[@coverage off] s_kind with
            | S_DIR | S_REG -> assert false
            | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK -> ()
          in
          `Trd ()
        | exception Unix.Unix_error (EACCES, _, _) ->
          (Err.warning
             Pp.O.
               [ Pp.text "Permission denied - skipping "
                 ++ Pp_tty.path (module Relative_path) parent_dir
                 ++ Pp.text "."
               ];
           `Trd ())
          [@coverage off])
    in
    { subdirectories; files }
  ;;
end

let visit ?(autoload_config = true) ?below (t : t) ~f =
  let root_path =
    match below with
    | None -> Relative_path.empty
    | Some below -> Relative_path.to_dir_path below
  in
  let initial_context =
    if autoload_config
    then build_context t ~path:root_path
    else
      (* When autoload is disabled, only use root_configs. *)
      List.fold t.root_configs ~init:Context.empty ~f:(fun context config ->
        Context.add_config context ~config ~location:Relative_path.empty)
  in
  let rec visit = function
    | [] -> ()
    | (_, []) :: tl -> visit tl
    | (context, parent_dir :: tl) :: rest ->
      Log.debug ~src (fun () ->
        Pp.O.
          [ Pp.text "Visiting directory " ++ Pp_tty.path (module Relative_path) parent_dir
          ]);
      let subtree_context, skip_directory =
        if autoload_config
        then (
          match Config_cache.load_config_in_dir t.config_cache ~dir:parent_dir with
          | Absent -> context, false
          | Present config ->
            Context.add_config context ~config ~location:parent_dir, false
          | Error e ->
            Err.emit e ~level:Error;
            Log.info ~src (fun () ->
              Pp.O.
                [ Pp.text "Skipping directory due to invalid config: "
                  ++ Pp_tty.path (module Relative_path) parent_dir
                ]);
            context, true)
        else context, false
      in
      if skip_directory
      then visit ((context, tl) :: rest)
      else (
        let { Directory_entries.subdirectories; files } =
          Directory_entries.readdir ~parent_dir
        in
        match
          (f ~context:subtree_context ~parent_dir ~subdirectories ~files
           : Visitor_decision.t)
        with
        | Break -> () [@coverage off]
        | Continue ->
          visit
            (( subtree_context
             , List.map subdirectories ~f:(fun subdirectory ->
                 Relative_path.extend parent_dir (Fsegment.v subdirectory)
                 |> Relative_path.to_dir_path) )
             :: (context, tl)
             :: rest)
        | Skip_subtree ->
          Log.info ~src (fun () ->
            Pp.O.
              [ Pp.text "Skipping directory "
                ++ Pp_tty.path (module Relative_path) parent_dir
              ]);
          visit ((context, tl) :: rest))
  in
  visit [ initial_context, [ root_path ] ]
;;

let run ?root_configs ~running_mode f =
  let t = create ?root_configs ~running_mode () in
  let result = f t in
  materialize t;
  let () =
    match running_mode with
    | Dry_run | Force_yes | Interactive -> ()
    | Check ->
      if not (Hashtbl.is_empty t.edited_files)
      then
        Err.error
          [ Pp.text "Linting check failed: Exiting with unaddressed linting errors." ]
  in
  result
;;

module Private = struct
  let mkdirs = mkdirs

  module Path_in_workspace = Path_in_workspace
end