Source file Config.ml

[@@@ocaml.text "/*"]

(** Copyright 2021-2026, Kakadu. *)

(** SPDX-License-Identifier: LGPL-3.0-or-later *)

[@@@ocaml.text "/*"]

type mode =
  | Unspecified
  | Dump_json of string
  | Dump_text
  | File of string
  | Dir of string
  | Fix of string
  | UnusedDecls of string

type t =
  { mutable outfile : string option
  ; mutable outgolint : string option
  ; mutable out_sarif : string option
  ; mutable out_rdjsonl : string option
    (* Spec: https://github.com/reviewdog/reviewdog/tree/master/proto/rdf#rdjson *)
  ; mutable mode : mode
    (* Below options to manage file paths. Not sure are they really required *)
  ; mutable prefix_to_cut : string option
  ; mutable prefix_to_add : string option
  ; mutable extra_includes : string list
  ; mutable verbose : bool
  ; mutable gen_replacements : bool
  ; enabled_lints : string Base.Hash_set.t
  ; all_lints : string Base.Hash_set.t
  ; mutable skip_level_allow : bool
  ; mutable check_filesystem : bool
  ; mutable plugin_name_suffix : string option
  ; mutable build_info: string
  }

let opts =
  { outfile = None
  ; outgolint = None
  ; out_sarif = None
  ; out_rdjsonl = None
  ; mode = Unspecified
  ; prefix_to_cut = Some "_build/default/"
  ; prefix_to_add = None
  ; extra_includes = []
  ; verbose = false
  ; gen_replacements = false
  ; enabled_lints = Base.Hash_set.create (module Base.String)
  ; all_lints = Base.Hash_set.create (module Base.String)
  ; skip_level_allow = true
  ; check_filesystem = true
  ; plugin_name_suffix = None
  ; build_info = "No loaded yet"
  }
;;

(** Modes *)

let mode () = opts.mode
let set_mode m = opts.mode <- m
let set_dump_file s = set_mode (Dump_json s)
let set_dump_text () = set_mode Dump_text
let set_in_file s = set_mode (File s)
let set_in_dir s = set_mode (Dir s)
let set_in_unused_decls s = set_mode (UnusedDecls s)

(** Other switches *)
let set_fix s = set_mode (Fix s)

let add_include s = opts.extra_includes <- s :: opts.extra_includes
let set_out_file s = opts.outfile <- Some s
let set_out_golint s = opts.outgolint <- Some s
let set_out_rdjsonl s = opts.out_rdjsonl <- Some s
let set_out_sarif s = opts.out_sarif <- Some s
let set_prefix_to_cut s = opts.prefix_to_cut <- Some s
let set_prefix_to_add s = opts.prefix_to_add <- Some s
let includes () = opts.extra_includes
let prefix_to_cut () = opts.prefix_to_cut
let prefix_to_add () = opts.prefix_to_add
let is_check_filesystem () = opts.check_filesystem
let enabled_lints () = opts.enabled_lints
let all_lints () = opts.all_lints
let outfile () = opts.outfile
let out_golint () = opts.outgolint
let out_rdjsonl () = opts.out_rdjsonl
let out_sarif () = opts.out_sarif
let unset_check_filesystem () = opts.check_filesystem <- false
let verbose () = opts.verbose
let gen_replacements () = opts.gen_replacements
let set_verbose () = opts.verbose <- true
let set_skip_level_allow b = opts.skip_level_allow <- b
let set_plugin_name_suffix s = opts.plugin_name_suffix <- Some s
let plugin_name_suffix () = opts.plugin_name_suffix

let recover_filepath filepath =
  let filepath =
    match prefix_to_cut () with
    | Some prefix when String.starts_with filepath ~prefix ->
      Base.String.drop_prefix filepath (String.length prefix)
    | Some prefix when verbose () ->
      Format.eprintf "Can't cut prefix '%s' from '%s'\n%!" prefix filepath;
      filepath
    | Some _ | None -> filepath
  in
  let filepath =
    match prefix_to_add () with
    | Some s -> Printf.sprintf "%s%s" s filepath
    | None -> filepath
  in
  filepath
;;

(** Is lint enabled globally, don't take to account local decorations *)
let is_enabled () =
  let hash = enabled_lints () in
  fun (module M : LINT.GENERAL) ->
    match M.level with
    | LINT.Allow when opts.skip_level_allow -> false
    | _ -> Base.Hash_set.mem hash M.lint_id
;;

let parse_args () =
  let standard_args =
    [ "-o", Arg.String set_out_file, "[FILE] Set Markdown output file"
    ; "-dump", Arg.Unit set_dump_text, "Dump info about available lints to terminal"
    ; ( "-dump-lints"
      , Arg.String set_dump_file
      , "[FILE] Dump information about available lints to JSON" )
    ; "-dir", Arg.String set_in_dir, "[FILE] Set root directory of dune project"
    ; ( "-unused-decls"
      , Arg.String set_in_unused_decls
      , "[FILE] Look for unused definitions" )
    ; "-ogolint", Arg.String set_out_golint, "Set output file in golint format"
    ; "-ordjsonl", Arg.String set_out_rdjsonl, "Set output file in rdjsonl format"
    ; "-osarif", Arg.String set_out_sarif, "Set output file in SARIF format"
    ; ( "-del-prefix"
      , Arg.String set_prefix_to_cut
      , "Set prefix to cut from pathes in OUTPUT file" )
    ; ( "-add-prefix"
      , Arg.String set_prefix_to_add
      , "Set prefix to prepend to pathes in OUTPUT file" )
    ; "-I", Arg.String add_include, "Add extra include path for type checking"
    ; ( "-skip-level-allow"
      , Arg.Bool set_skip_level_allow
      , "[bool] Skip lints with level = Allow" )
    ; ( "-with-plugins"
      , Arg.String set_plugin_name_suffix
      , "PREFIX Try to load plugins whos name ends with PREFIX" )
    ; "-v", Arg.Unit set_verbose, "More verbose output"
    ; ( "-version"
      , Arg.Unit
          (fun () ->
            Printf.printf
              "version: %s\n" opts.build_info
            )
      , " Print version" )
    ; ( "-diffs-with-fixes"
      , Arg.Unit (fun () -> opts.gen_replacements <- true)
      , " Do generate DIFFs with replacements" )
    ; "-fix", Arg.String set_fix, "Apply all found lints available for correction"
    ]
  in
  let extra_args =
    Base.Hash_set.fold
      ~init:
        [ ( "-no-check-filesystem"
          , Arg.Unit unset_check_filesystem
          , " Disable checking structure of a project" )
        ]
      ~f:(fun acc x ->
        assert (x <> "");
        ( Printf.sprintf "-no-%s" x
        , Arg.Unit (fun () -> Base.Hash_set.remove opts.enabled_lints x)
        , " Disable checking for this lint" )
        :: ( Printf.sprintf "-with-%s" x
           , Arg.Unit (fun () -> Base.Hash_set.add opts.enabled_lints x)
           , " Enable checking for this lint" )
        :: acc)
      opts.all_lints
    |> List.sort (fun (a, _, _) (b, _, _) -> String.compare a b)
  in
  Arg.parse
    (standard_args @ extra_args)
    set_in_file
    "Use -dir [PATH] to check dune-based project"
;;

include (
struct
  let hash : (string, unit) Hashtbl.t = Hashtbl.create 24

  let enable s =
    (* Format.printf "enabling lint '%s'\n%!" s; *)
    Hashtbl.remove hash s
  ;;

  let disable s =
    (* Format.printf "disabling lint '%s'\n%!" s; *)
    Hashtbl.add hash s ()
  ;;

  let is_lint_enabled s =
    match Hashtbl.find hash s with
    | exception Not_found -> true
    | _ -> false
  ;;
end :
sig
  val is_lint_enabled : string -> bool
  val enable : string -> unit
  val disable : string -> unit
end)