qsp_parser/bin/qsp_parser.ml

open StdLabels
module Report = Qsp_syntax.Report

type result = Report.t list [@@deriving show]

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

(*
    List all the controls to apply 
 *)
let _, _, _, e1 = Qsp_syntax.Check.build (module Qsp_syntax.Type_of)
let _, _, _, e2 = Qsp_syntax.Check.build (module Qsp_syntax.Dead_end)

module Check = Qsp_syntax.Check.Make (struct
  let t = [| e1; e2 |]
end)

(** Read the source file until getting a report (the whole location has been
    read properly), or until the first syntax error. 
    *)
let parse_location : ctx:ctx -> Qparser.Lexbuf.t -> Args.filters -> ctx =
 fun ~ctx lexbuf filters ->
  let result =
    Qparser.Analyzer.parse (module Check) lexbuf
    |> Result.map (fun (_, f) ->
           List.fold_left f ~init:[] ~f:(filter_report filters))
  in
  match result with
  | Ok report -> (
      (* Display the result *)
      match report with
      | [] -> ctx
      | _ ->
          let start_position, _ = Qparser.Lexbuf.positions lexbuf in
          Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@."
            start_position.Lexing.pos_fname pp_result report;

          List.fold_left report ~init:ctx ~f:(fun ctx report ->
              match report.Report.level with
              | Error -> { ctx with error_nb = ctx.error_nb + 1 }
              | Warn -> { ctx with warn_nb = ctx.warn_nb + 1 }
              | Debug -> { ctx with debug_nb = ctx.debug_nb + 1 }))
  | Error e ->
      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 with error_nb = ctx.error_nb + 1 }

let default_ctx = { error_nb = 0; warn_nb = 0; debug_nb = 0 }

let () =
  let file_names, parameters = Args.parse () 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" ->
        (* 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 = 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

  let ctx = ref default_ctx in
  let () =
    try
      while true do
        ctx := parse_location ~ctx:!ctx lexer parameters.filters
      done
    with Qparser.Lexer.EOF -> ()
  in

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

  let () =
    match parameters.interractive with
    | true ->
        print_endline "Press <Enter> to terminate";
        ignore @@ read_line ()
    | _ -> ()
  in
  ()