1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
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)
module Check = Qsp_syntax.Check.Make (struct
let t = [| e1 |]
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
()
|
