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
|
open StdLabels
module Report = Qsp_syntax.Report
type result = Report.t list [@@deriving show]
type filters = { level : Report.level option }
module Args = struct
let input_files = ref []
let usage = "qsp_parser input_file"
let anon_fun filename = input_files := filename :: !input_files
let level_value = ref None
let level : string -> unit =
fun str_level ->
match Report.level_of_string str_level with
| Ok level_ -> level_value := Some level_
| Error e ->
print_endline e;
exit 1
let speclist =
[ ("--level", Arg.String level, "Message level [debug, warn, error]") ]
let parse () =
let () = Arg.parse speclist anon_fun usage in
let filters = { level = !level_value } in
(!input_files, filters)
end
(** Filter the results given by the analysis *)
let filter_report : 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
(** Read the source file until getting a report (the whole location has been
read properly), or until the first syntax error.
*)
let parse_location :
(module Qparser.Lexer.Encoding) -> Sedlexing.lexbuf -> filters -> unit =
fun encoding lexbuf filters ->
let result =
Qparser.Analyzer.parse (module Qsp_syntax.Type_of) encoding lexbuf
in
let result =
Result.map
(fun f -> List.fold_left (f []) ~init:[] ~f:(filter_report filters))
result
in
match result with
| Ok report -> (
(* Display the result *)
match report with
| [] -> ()
| _ ->
let start_position, _ = Sedlexing.lexing_positions lexbuf in
Format.fprintf Format.std_formatter "Location %s@;@[%a@]@."
start_position.Lexing.pos_fname pp_result report;
let () =
match Sys.os_type with "Win32" -> ignore @@ read_line () | _ -> ()
in
())
| Error e ->
let start_position, _ = Sedlexing.lexing_positions lexbuf in
Format.fprintf Format.std_formatter "Location %s@;@[%a]@."
start_position.Lexing.pos_fname Report.pp e
let () =
let file_names, filters = Args.parse () in
let file_name = List.hd file_names in
let ic = Stdlib.open_in file_name in
(*let lexer = Lexing.from_channel ~with_positions:true ic in*)
let lexer, mod_ =
match Filename.extension file_name with
| ".qsrc" ->
( Sedlexing.Utf8.from_channel ic,
(module Sedlexing.Utf8 : Qparser.Lexer.Encoding) )
| ".txt" ->
( Sedlexing.Utf16.from_channel ic (Some Little_endian),
(module struct
let lexeme lexbuf = Sedlexing.Utf8.lexeme lexbuf
end : Qparser.Lexer.Encoding) )
| _ -> raise (Failure "unknown extension")
in
let () =
try
while true do
parse_location mod_ lexer filters
done
with Qparser.Lexer.EOF -> ()
in
let () =
match Sys.os_type with "Win32" -> ignore @@ read_line () | _ -> ()
in
()
|
