jon.recoil.org
this repo has no description
1open Odoc_model
2
3type context = { c_loc : Location_.span option; c_context : string list }
4(** Context added by {!with_location} and {!with_context}. *)
5
6let context_acc = ref { c_loc = None; c_context = [] }
7
8let acc = ref []
9
10let with_ref r x f =
11 let saved = !r in
12 r := x;
13 let v = f () in
14 let x = !r in
15 r := saved;
16 (v, x)
17
18let add f = acc := f :: !acc
19
20(** Raise a single message for root errors. *)
21let raise_root_errors ~filename failures =
22 let roots =
23 List.fold_left
24 (fun acc -> function `Root name -> name :: acc | `Warning _ -> acc)
25 [] failures
26 |> List.sort_uniq String.compare
27 in
28 match roots with
29 | [] -> ()
30 | _ :: _ ->
31 Error.raise_warning ~non_fatal:true
32 (Error.filename_only "Couldn't find the following modules:@;<1 2>@[%a@]"
33 Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string)
34 roots filename)
35
36(** Raise the other warnings. *)
37let raise_warnings ~filename failures =
38 List.iter
39 (function
40 | `Root _ -> ()
41 | `Warning (msg, context, non_fatal) ->
42 let rec pp_context fmt = function
43 | hd :: tl ->
44 pp_context fmt tl;
45 Format.fprintf fmt "%s@\n" hd
46 | [] -> ()
47 in
48 let pp_failure fmt () =
49 Format.fprintf fmt "%a%s" pp_context context.c_context msg
50 in
51 let err =
52 match context.c_loc with
53 | Some loc -> Error.make "%a" pp_failure () loc
54 | None -> Error.filename_only "%a" pp_failure () filename
55 in
56 Error.raise_warning ~non_fatal err)
57 failures
58
59let catch_failures ~filename f =
60 let r, failures = with_ref acc [] f in
61 Error.catch_warnings (fun () ->
62 if !Error.enable_missing_root_warning then
63 raise_root_errors ~filename failures;
64 raise_warnings ~filename failures;
65 r)
66
67let kasprintf k fmt =
68 Format.(kfprintf (fun _ -> k (flush_str_formatter ())) str_formatter fmt)
69
70let report ~non_fatal fmt =
71 kasprintf (fun msg -> add (`Warning (msg, !context_acc, non_fatal))) fmt
72
73let report_internal fmt = report ~non_fatal:true fmt
74
75let report_root ~name = add (`Root name)
76
77let report_warning fmt = report ~non_fatal:false fmt
78
79let with_location loc f =
80 fst (with_ref context_acc { !context_acc with c_loc = Some loc } f)
81
82let with_context fmt =
83 kasprintf
84 (fun msg f ->
85 let c = !context_acc in
86 fst (with_ref context_acc { c with c_context = msg :: c.c_context } f))
87 fmt