Source file warnings.ml
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
(** This module implements a warning management module *)
type warning =
| Config of config_warning
| Term_parsing of term_parsing_warning
and term_parsing_warning =
| Var_and_const of (string * string * (Lexing.position * Lexing.position))
and config_warning =
| Missing_key of (string * string list * string)
| Missing_name of (string * string list * string * string)
| Missing_engine of (string * string list * string * string)
| Default_engines
| Default_colors
| Bad_group of
(string * string list * string * Yojson.Basic.t * string * string)
| Json_error of string
let grp_preamble file path =
match path with
| [] -> Printf.sprintf "In file \"%s\"" file
| path ->
Printf.sprintf "In file \"%s\", under the path \"%s\"" file
(Utils.string_of_list " -> " (fun x -> x) path)
let issue_warning = function
| Config (Missing_key (file, path, key)) ->
Logs.warn (fun m ->
m "%s, key \"%s\" is missing" (grp_preamble file path) key)
| Config (Missing_name (file, path, key, msg)) ->
Logs.warn (fun m ->
m
"%s, key \"%s\" is missing in association with signature engine \
\"%s\""
(grp_preamble file path) key msg)
| Config (Missing_engine (file, path, key, msg)) ->
Logs.warn (fun m ->
m
"%s, key \"%s\" is missing in association with signature name \
\"%s\""
(grp_preamble file path) key msg)
| Config Default_engines ->
Logs.warn (fun m -> m "Using default signature to engine mapping")
| Config Default_colors ->
Logs.warn (fun m -> m "Using default bacground and node colors")
| Config (Bad_group (file, path, yojson_msg, json, msg, msg')) ->
let () =
Logs.warn (fun m -> m "%s, %s" (grp_preamble file path) yojson_msg)
in
let () =
Logs.warn (fun m ->
m "%s, but got: \"%s\"" msg
(Yojson.Basic.pretty_to_string ~std:true json))
in
Logs.warn (fun m -> m "%s" msg')
| Config (Json_error msg) ->
let () = Logs.warn (fun m -> m "Json error: %s" msg) in
Logs.warn (fun m -> m "Using default configuration")
| Term_parsing (Var_and_const (id, sg_name, (pos1, pos2))) ->
if pos1 = Lexing.dummy_pos || pos2 = Lexing.dummy_pos then
Logs.warn
(fun m ->
m
"@[%a@ is@ both@ a@ variable@ and@ a@ constant@ of@ \
the@ signature@ %a.@ Used@ here@ as@ a@ variable.@]"
PPUtils.term_pp
id
PPUtils.sig_pp
sg_name)
else
let () = if pos1.Lexing.pos_fname = "" && pos2.Lexing.pos_fname = "" then Error.underline_error id (pos1, pos2) else () in
let loc_string = Error.compute_comment_for_location (pos1, pos2) in
Logs.warn
(fun m ->
m
"@[@[%a:@]@;@[%a@ is@ both@ a@ variable@ and@ a@ \
constant@ of@ the@ signature@ %a.@ Used@ here@ as@ \
a@ variable.@]@]"
Error.pp_text
loc_string
PPUtils.term_pp
id
PPUtils.sig_pp
sg_name)