qsp_parser/bin/args.ml

open StdLabels
module Report = Qsp_syntax.Report

let input_files = ref []

let usage =
  Printf.sprintf "%s input_file" (Filename.basename Sys.executable_name)

let anon_fun filename = input_files := filename :: !input_files
let level_value = ref None
let reset_line = ref false
let interractive () = ()

type filters = { level : Report.level option }

type t = { reset_line : bool; filters : filters }
(** All the arguments given from the command line *)

let level : string -> unit =
 fun str_level ->
  match Report.level_of_string str_level with
  | Ok level_ -> level_value := Some level_
  | Error e ->
      print_endline e;
      exit 1

let disable_module modules identifier =
  let identifier =
    String.sub identifier ~pos:1 ~len:(String.length identifier - 1)
  in
  List.iter modules ~f:(fun t ->
      let (module C : Qsp_syntax.S.Analyzer) = Qsp_syntax.Check.get_module t in
      if String.equal C.identifier identifier then C.active := false)

let enable_module modules identifier =
  let identifier =
    String.sub identifier ~pos:1 ~len:(String.length identifier - 1)
  in
  List.iter modules ~f:(fun t ->
      let (module C : Qsp_syntax.S.Analyzer) = Qsp_syntax.Check.get_module t in
      if String.equal C.identifier identifier then C.active := true)

let speclist printer =
  let common_arguments =
    [
      ( "--version",
        Arg.Unit
          (fun () ->
            Printf.printf "Version %s\n" Tools.Git_hash.revision;
            exit 0),
        "\tDisplay the version of the application and exit" );
      ( "--list-tests",
        Arg.Unit
          (fun () ->
            printer Format.std_formatter;
            exit 0),
        "\tPrint all the available tests then exit" );
      ( "--level",
        Arg.String level,
        "\tFilter with this message level [debug, warn, error]" );
      ( "--global",
        Arg.Set reset_line,
        "\tEach line is refered from the begining of the file and not the \
         location" );
      ("-<test>", Arg.Unit (fun () -> ()), "\tDisable this test");
      ("+<test>", Arg.Unit (fun () -> ()), "\tEnable this test");
    ]
  and windows_arguments =
    match Sys.os_type with
    | "Win32" ->
        [ ("--no-prompt", Arg.Unit interractive, "\tDeprecated. Does nothing") ]
    | _ -> []
  in
  common_arguments @ windows_arguments

let parse :
    modules:Qsp_syntax.Check.t list ->
    list_tests:(Format.formatter -> unit) ->
    string list * t =
 fun ~modules ~list_tests ->
  let speclist = speclist list_tests in
  let speclist =
    let r = ref speclist in
    for i = 1 to pred (Array.length Sys.argv) do
      let s = Sys.argv.(i) in
      if
        s.[0] = '-'
        && String.length s > 1
        && s.[1] != '-'
        && (not (String.equal s "--help"))
        && (not (String.equal s "-help"))
        && not (List.exists !r ~f:(fun (s', _, _) -> String.equal s s'))
      then
        r :=
          ( s,
            Arg.Unit (fun () -> disable_module modules s),
            "\tDisable this test" )
          :: !r
      else if s.[0] = '+' then enable_module modules s
    done;
    !r
  in
  let () = Arg.parse (Arg.align speclist) anon_fun usage in

  match !input_files with
  | [] ->
      Arg.usage (Arg.align speclist) usage;
      prerr_endline "";
      prerr_endline "Error, you should provide at least one file to parse.";

      exit 1
  | _ ->
      let filters = { level = !level_value } in
      (!input_files, { reset_line = !reset_line; filters })