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
|
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_print_module formatter (module A : Qsp_syntax.S.Analyzer) =
Format.fprintf formatter "%s" A.identifier;
Format.pp_print_tab formatter ();
Format.fprintf formatter "%s" A.description;
()
let pp_print_modules formatter =
let max_length =
Array.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
let ll = Array.to_list available_checks in
Format.pp_open_tbox formatter ();
(* Print the name, left justified, with enougth spaces for the identifier *)
Format.fprintf formatter "%-*s" (max_length + 1) "Name";
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_print_module f m)
~pp_sep:(fun f () -> Format.pp_force_newline f ()))
ll;
Format.pp_close_tbox formatter ();
Format.pp_print_break formatter 0 0
module Check = Qsp_syntax.Check.Make (struct
let t = available_checks
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)
|> 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 = 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 ~list_tests:pp_print_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
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
()
|
