123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107 |
- 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
- ()
|