qsp_parser/bin/qsp_parser.ml

open StdLabels
module Report = Qsp_syntax.Report

(** Filter the results given by the analysis *)
let filter_report : Args.filters -> Report.t list -> Report.t -> Report.t list =
 fun filters reports r ->
  let is_ok =
    match filters.level with
    | None -> true
    | Some level -> Report.level_to_enum level >= Report.level_to_enum r.level
  in

  match is_ok with true -> r :: reports | _ -> reports

type ctx = { error_nb : int; warn_nb : int; debug_nb : int; fatal_error : bool }

(*
    List all the controls to apply 
 *)
let available_checks =
  [
    snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Type_of);
    snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Dead_end);
    snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Nested_strings);
    snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Locations);
    snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Dup_test);
  ]

let pp_module formatter (module A : Qsp_syntax.S.Analyzer) =
  Format.fprintf formatter "%s" A.identifier;
  Format.pp_print_tab formatter ();
  (match !A.active with
  | true -> Format.fprintf formatter "*"
  | false -> Format.fprintf formatter " ");
  Format.pp_print_tab formatter ();
  Format.fprintf formatter "%s" A.description;
  ()

(** Print all the available modules *)
let pp_modules formatter =
  let max_length =
    List.fold_left available_checks ~init:0 ~f:(fun l v ->
        let (module A : Qsp_syntax.S.Analyzer) =
          Qsp_syntax.Check.get_module v
        in
        max l (String.length A.identifier))
  in

  Format.pp_open_tbox formatter ();

  (* Print the name, left justified, with enought spaces for the all the
     identifiers *)
  Format.fprintf formatter "%-*s" (succ max_length) "Name";
  (* Tab delimiter *)
  Format.pp_set_tab formatter ();
  Format.fprintf formatter "Active ";
  Format.pp_set_tab formatter ();
  Format.fprintf formatter "Description@\n";

  Format.fprintf formatter "%a"
    (Format.pp_print_list
       (fun f v ->
         let m = Qsp_syntax.Check.get_module v in
         pp_module f m)
       ~pp_sep:(fun f () -> Format.pp_force_newline f ()))
    available_checks;
  Format.pp_close_tbox formatter ();
  Format.pp_print_break formatter 0 0

(** Get all the tests to apply.

   The expression is declared lazy in order to be sure to apply the filters
   from the command line before. *)
let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t =
  lazy
    (let module Check = Qsp_syntax.Check.Make (struct
       let t =
         List.filter available_checks ~f:(fun v ->
             let (module A : Qsp_syntax.S.Analyzer) =
               Qsp_syntax.Check.get_module v
             in
             !A.active)
         |> Array.of_list
     end) in
    (module Check))

(** Read the source file until getting a report (the whole location has been
    read properly), or until the first syntax error.

    The function update the context (list of errors) passed in arguments. *)
let parse_location :
    type context.
    ctx:ctx ref ->
    (module Qsp_syntax.S.Analyzer with type context = context) ->
    context ->
    Qparser.Lexbuf.t ->
    Args.filters ->
    unit =
 fun ~ctx (module Check) context lexbuf filters ->
  let result =
    Qparser.Analyzer.parse (module Check) lexbuf context
    |> Result.map (fun f ->
           List.fold_left f.Qparser.Analyzer.report ~init:[]
             ~f:(filter_report filters)
           |> List.sort ~cmp:Report.compare)
  in
  match result with
  | Ok [] -> ()
  | Ok report ->
      (* Display the result *)
      let start_position, _ = Qparser.Lexbuf.positions lexbuf in
      Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@."
        start_position.Lexing.pos_fname Report.pp_result report;

      List.iter report ~f:(fun report ->
          match report.Report.level with
          | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb }
          | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb }
          | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb })
  | Error e ->
      (* Syntax error, we haven’t been able to run the test *)
      let start_position, _ = Qparser.Lexbuf.positions lexbuf in
      Format.fprintf Format.std_formatter "Location@ %s@;@[%a]@."
        start_position.Lexing.pos_fname Report.pp e;
      ctx := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true }

let () =
  let file_names, parameters =
    Args.parse ~modules:available_checks ~list_tests:pp_modules
  in
  let file_name = List.hd file_names in

  let ic = Stdlib.open_in_bin file_name in

  (*let lexer = Lexing.from_channel ~with_positions:true ic in*)
  let lexer, parameters =
    match Filename.extension file_name with
    | ".qsrc" ->
        (* Deactivate the tests which only applies to a global file *)
        List.iter available_checks ~f:(fun t ->
            let (module C : Qsp_syntax.S.Analyzer) =
              Qsp_syntax.Check.get_module t
            in
            if C.is_global then C.active := false);
        (* The source file are in UTF-8, and we can use the file line number as
           we have only a single location. *)
        ( Sedlexing.Utf8.from_channel ic,
          { parameters with reset_line = parameters.Args.reset_line || false }
        )
    | ".txt" ->
        (Sedlexing.Utf16.from_channel ic (Some Little_endian), parameters)
    | _ -> raise (Failure "unknown extension")
  in
  let lexer =
    Qparser.Lexbuf.from_lexbuf ~reset_line:parameters.reset_line lexer
  in

  (* Initialize all the checkers before parsing the source *)
  let (module Check) = Lazy.force checkers in
  let check_context = Check.initialize () in
  let ctx =
    ref { error_nb = 0; warn_nb = 0; debug_nb = 0; fatal_error = false }
  in

  let () =
    try
      while true do
        parse_location ~ctx
          (module Check)
          check_context lexer parameters.filters
      done
    with Qparser.Lexer.EOF -> ()
  in

  (match !ctx.fatal_error with
  | true ->
      Format.fprintf Format.std_formatter
        "(Ignoring global checkers because of the previous syntax errors)@."
  | false ->
      (* If the parsing was global and we didn’t got parsing error, extract the
         result for the whole test *)
      let global_report = Check.finalize check_context in
      List.iter global_report ~f:(fun (f_name, report) ->
          Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@." f_name
            Report.pp report;

          match report.Report.level with
          | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb }
          | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb }
          | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb }));

  match (!ctx.error_nb, !ctx.warn_nb) with
  | 0, 0 -> (
      print_endline "No errors found";
      match !ctx.debug_nb with 0 -> exit 0 | _ -> exit 1)
  | _ ->
      Printf.printf "Found %d error(s), %d warning(s)\n" !ctx.error_nb
        !ctx.warn_nb;
      exit 1