jon.recoil.org
this repo has no description
1let enable_missing_root_warning = ref false
2
3type full_location_payload = Odoc_parser.Warning.t = {
4 location : Location_.span;
5 message : string;
6}
7
8type filename_only_payload = { file : string; message : string }
9
10type t =
11 [ `With_full_location of Odoc_parser.Warning.t
12 | `With_filename_only of filename_only_payload ]
13
14let kasprintf k fmt =
15 Format.(kfprintf (fun _ -> k (flush_str_formatter ())) str_formatter fmt)
16
17let kmake k ?suggestion format =
18 format
19 |> kasprintf (fun message ->
20 match suggestion with
21 | None -> k message
22 | Some suggestion -> k (message ^ "\nSuggestion: " ^ suggestion))
23
24let make ?suggestion format =
25 let k message location = `With_full_location { location; message } in
26 kmake k ?suggestion format
27
28let filename_only ?suggestion format =
29 let k message file = `With_filename_only { file; message } in
30 kmake k ?suggestion format
31
32let _to_string =
33 let pp_prefix ppf = function
34 | Some p -> Format.fprintf ppf "%s: " p
35 | None -> ()
36 in
37 fun ?prefix -> function
38 | `With_full_location { location; message } ->
39 if String.compare location.file "" != 0 then
40 Format.asprintf "%a:@\n%a%s" Location_.pp location pp_prefix prefix
41 message
42 else Format.asprintf "%a%s" pp_prefix prefix message
43 | `With_filename_only { file; message } ->
44 Format.asprintf "File \"%s\":@\n%a%s" file pp_prefix prefix message
45
46let to_string e = _to_string e
47
48exception Conveyed_by_exception of t
49
50let raise_exception error = raise (Conveyed_by_exception error)
51
52let catch f = try Ok (f ()) with Conveyed_by_exception error -> Error error
53
54type warning = {
55 w : t;
56 non_fatal : bool;
57 (** If [true], the warning won't be made fatal in [warn_error] mode. *)
58}
59
60type 'a with_warnings = { value : 'a; warnings : warning list }
61
62let with_ref r f =
63 let saved = !r in
64 try
65 let v = f () in
66 r := saved;
67 v
68 with e ->
69 r := saved;
70 raise e
71
72let raised_warnings = ref []
73
74let raise_warnings' warnings =
75 raised_warnings := List.rev_append warnings !raised_warnings
76
77let raise_warning ?(non_fatal = false) w =
78 raised_warnings := { w; non_fatal } :: !raised_warnings
79
80let raise_warnings with_warnings =
81 raise_warnings' with_warnings.warnings;
82 with_warnings.value
83
84let catch_warnings f =
85 with_ref raised_warnings (fun () ->
86 raised_warnings := [];
87 let value = f () in
88 let warnings = List.rev !raised_warnings in
89 { value; warnings })
90
91type 'a with_errors_and_warnings = ('a, t) result with_warnings
92
93let raise_errors_and_warnings we =
94 match raise_warnings we with Ok x -> x | Error e -> raise_exception e
95
96let catch_errors_and_warnings f = catch_warnings (fun () -> catch f)
97
98let print_error ?prefix t = prerr_endline (_to_string ?prefix t)
99
100let print_errors = List.iter print_error
101
102type warnings_options = {
103 warn_error : bool;
104 print_warnings : bool;
105 warnings_tag : string option;
106}
107
108let print_warnings ~warnings_options warnings =
109 if warnings_options.print_warnings then
110 List.iter
111 (fun w ->
112 let prefix =
113 if warnings_options.warn_error && not w.non_fatal then "Error"
114 else "Warning"
115 in
116 print_error ~prefix w.w)
117 warnings
118
119(* When there is warnings. *)
120let handle_warn_error ~warnings_options warnings ok =
121 print_warnings ~warnings_options warnings;
122 let maybe_fatal = List.exists (fun w -> not w.non_fatal) warnings in
123 if maybe_fatal && warnings_options.warn_error then
124 Error (`Msg "Warnings have been generated.")
125 else Ok ok
126
127let handle_warnings ~warnings_options ww =
128 handle_warn_error ~warnings_options ww.warnings ww.value
129
130let handle_errors_and_warnings ~warnings_options = function
131 | { value = Error e; warnings } ->
132 print_warnings ~warnings_options warnings;
133 Error (`Msg (to_string e))
134 | { value = Ok ok; warnings } ->
135 handle_warn_error ~warnings_options warnings ok
136
137let unpack_warnings ww = (ww.value, List.map (fun w -> w.w) ww.warnings)
138
139let t_of_parser_t : Odoc_parser.Warning.t -> t =
140 fun x -> (`With_full_location x :> t)
141
142let raise_parser_warnings v =
143 (* Parsing errors may be fatal. *)
144 let warnings = Odoc_parser.warnings v in
145 let non_fatal = false in
146 raise_warnings'
147 (List.map (fun p -> { w = t_of_parser_t p; non_fatal }) warnings);
148 Odoc_parser.ast v