blob: 0c839fecef43cf0d612fb7d9d13bb1dfa8635e7d (
plain)
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
|
(** Report built over the differents analysis in the file *)
type level = Error | Warn | Debug
[@@deriving show { with_path = false }, enum, eq]
type pos = Lexing.position * Lexing.position
let level_of_string : string -> (level, string) result =
fun level ->
match String.lowercase_ascii level with
| "error" -> Ok Error
| "warn" -> Ok Warn
| "debug" -> Ok Debug
| _ ->
Error
(Format.sprintf
"Unknown report level '%s'. Accepted values are error, warn, debug"
level)
let pp_pos : Format.formatter -> pos -> unit =
fun f (start_pos, end_pos) ->
let start_c = start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol
and end_c = end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol
and start_line = start_pos.Lexing.pos_lnum
and end_line = end_pos.Lexing.pos_lnum in
if start_line != end_line then
Format.fprintf f "Lines %d-%d" start_line end_line
else Format.fprintf f "Line %d %d:%d" start_line start_c end_c
let pp_line : Format.formatter -> pos -> unit =
fun f (start_pos, end_pos) ->
(* Only care about the first line *)
ignore end_pos;
let start_line = start_pos.Lexing.pos_lnum in
Format.fprintf f "%d" start_line
type t = { level : level; loc : pos; message : string }
[@@deriving show { with_path = false }]
(** Compare two positions *)
let compare_pos : pos -> pos -> int =
fun (pos1_start, pos1_end) (pos2_start, pos2_end) ->
(* first compare the position *)
match compare pos1_start.pos_cnum pos2_start.pos_cnum with
| 0 ->
(* Then the ending position *)
compare pos1_end.pos_cnum pos2_end.pos_cnum
| other -> other
let compare : t -> t -> int =
fun t1 t2 ->
(* first compare the position *)
match compare_pos t1.loc t2.loc with
| 0 -> (
(* And the level *)
match compare (level_to_enum t1.level) (level_to_enum t2.level) with
| 0 -> String.compare t1.message t2.message
| other -> other)
| other -> other
let debug : pos -> string -> t =
fun loc message -> { level = Debug; loc; message }
let warn : pos -> string -> t =
fun loc message -> { level = Warn; loc; message }
let error : pos -> string -> t =
fun loc message -> { level = Error; loc; message }
let message level loc message = { level; loc; message }
type result = t list [@@deriving show]
|
