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
|
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);
]
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.
*)
let parse_location : ctx:ctx -> Qparser.Lexbuf.t -> Args.filters -> ctx =
fun ~ctx lexbuf filters ->
let (module Check) = Lazy.force checkers in
let result =
Qparser.Analyzer.parse (module Check) lexbuf
|> Result.map (fun (_, f) ->
List.fold_left f ~init:[] ~f:(filter_report filters)
|> List.sort ~cmp:Report.compare)
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 Report.pp_result report;
List.fold_left report ~init:ctx ~f:(fun ctx report ->
match report.Report.level with
| Error -> { ctx with error_nb = succ ctx.error_nb }
| Warn -> { ctx with warn_nb = succ ctx.warn_nb }
| Debug -> { ctx with debug_nb = succ ctx.debug_nb }))
| 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 = succ ctx.error_nb }
let default_ctx = { error_nb = 0; warn_nb = 0; debug_nb = 0 }
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" ->
(* 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
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
|
