path: root/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 }

module type T = sig
  include module type of Qsp_checks.Dynamics
end

(** Witness used to extract the values in the module Qsp_checks.Dynamics during
    the parsing. *)
let dynamic_context_id : Qsp_checks.Dynamics.context Type.Id.t = Type.Id.make ()

(*
    List all the controls to apply 
 *)
let available_checks =
  [
    Qsp_syntax.Catalog.build ~context_id:dynamic_context_id
      (module Qsp_checks.Dynamics);
    Qsp_syntax.Catalog.build (module Qsp_checks.Type_of);
    Qsp_syntax.Catalog.build (module Qsp_checks.Dead_end);
    Qsp_syntax.Catalog.build (module Qsp_checks.Nested_strings);
    Qsp_syntax.Catalog.build (module Qsp_checks.Locations);
    Qsp_syntax.Catalog.build (module Qsp_checks.Dup_test);
    Qsp_syntax.Catalog.build (module Qsp_checks.Write_only);
  ]

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_checks.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_checks.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
       with type context = Qsp_checks.Check.result array)
    Lazy.t =
  lazy
    (let module Check = Qsp_checks.Check.Make (struct
       let t =
         List.filter available_checks ~f:(fun v ->
             let (module A : Qsp_syntax.S.Analyzer) =
               Qsp_checks.Check.get_module v
             in
             !A.active)
         |> Array.of_list
     end) in
    (module Check))

let display_result :
    ctx:ctx ref ->
    Qparser.Lexbuf.t ->
    Args.filters ->
    (Report.t list, Report.t) result ->
    unit =
 fun ~ctx lexbuf filters result ->
  match result with
  | 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 }
  | Ok report -> (
      let report =
        List.fold_left report ~init:[] ~f:(filter_report filters)
        |> List.sort ~cmp:Report.compare
      in
      match report with
      | [] -> ()
      | _ ->
          (* 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 }))

(** 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 :
    ctx:ctx ref ->
    (module Qsp_syntax.S.Analyzer
       with type context = Qsp_checks.Check.result array) ->
    Qsp_checks.Check.result array ->
    Qparser.Lexbuf.t ->
    Args.filters ->
    unit =
 fun ~ctx (module Check) context lexbuf filters ->
  let result =
    Qparser.Analyzer.parse
      (module Check)
      Qparser.Analyzer.Location lexbuf context
  in

  (* Also analyse eache dynamic string identified in the module *)
  let result_with_dynamics =
    Result.map
      (fun r ->
        match Qsp_checks.Check.get dynamic_context_id (Array.get context 0) with
        | None -> r.Qparser.Analyzer.report
        | Some dyn_context ->
            let seq : Qsp_checks.Dynamics.text Seq.t =
              Qsp_checks.Dynamics.dynamics_string dyn_context
            in
            Seq.fold_left
              (fun r content ->
                let text = content.Qsp_checks.Dynamics.content ^ "\n" in

                let lexing =
                  Sedlexing.Latin1.from_string text
                  |> Qparser.Lexbuf.from_lexbuf
                       ~position:(fst content.Qsp_checks.Dynamics.position)
                in

                let dyn_report =
                  Qparser.Analyzer.parse
                    (module Check)
                    Qparser.Analyzer.Dynamic lexing context
                in
                match dyn_report with
                | Error e ->
                    (* Syntax error are not blocking here, but are transformed
                       into check error *)
                    e :: r
                | Ok dyn_ok_reports ->
                    dyn_ok_reports.Qparser.Analyzer.report @ r)
              r.Qparser.Analyzer.report seq)
      result
  in
  display_result ~ctx lexbuf filters result_with_dynamics

let () =
  let file_names, parameters =
    Args.parse ~modules:available_checks ~list_tests:pp_modules
  in
  let file_name =
    List.filter ~f:(fun name -> name.[0] != '+') file_names |> List.hd
  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_checks.Check.get_module t
            in
            if C.is_global && !C.active then C.active := false);

        Qsp_checks.Dynamics.active := true;

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