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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
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 }
(*
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);
]
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 ~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 }
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 } in
let () =
try
while true do
parse_location ~ctx
(module Check)
check_context lexer parameters.filters
done
with Qparser.Lexer.EOF -> ()
in
(* If the parsing was global, 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
|
