Source file error.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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
open Result

type full_location_payload = Odoc_parser.Warning.t = {
  location : Location_.span;
  message : string;
}

type filename_only_payload = { file : string; message : string }

type t =
  [ `With_full_location of Odoc_parser.Warning.t
  | `With_filename_only of filename_only_payload ]

let kasprintf k fmt =
  Format.(kfprintf (fun _ -> k (flush_str_formatter ())) str_formatter fmt)

let kmake k ?suggestion format =
  format
  |> kasprintf (fun message ->
         match suggestion with
         | None -> k message
         | Some suggestion -> k (message ^ "\nSuggestion: " ^ suggestion))

let make ?suggestion format =
  let k message location = `With_full_location { location; message } in
  kmake k ?suggestion format

let filename_only ?suggestion format =
  let k message file = `With_filename_only { file; message } in
  kmake k ?suggestion format

let _to_string =
  let pp_prefix ppf = function
    | Some p -> Format.fprintf ppf "%s: " p
    | None -> ()
  in
  fun ?prefix -> function
    | `With_full_location { location; message } ->
        if String.compare location.file "" != 0 then
          Format.asprintf "%a:@\n%a%s" Location_.pp location pp_prefix prefix
            message
        else Format.asprintf "%a%s" pp_prefix prefix message
    | `With_filename_only { file; message } ->
        Format.asprintf "File \"%s\":@\n%a%s" file pp_prefix prefix message

let to_string e = _to_string e

exception Conveyed_by_exception of t

let raise_exception error = raise (Conveyed_by_exception error)

let catch f = try Ok (f ()) with Conveyed_by_exception error -> Error error

type warning = {
  w : t;
  non_fatal : bool;
      (** If [true], the warning won't be made fatal in [warn_error] mode. *)
}

type 'a with_warnings = { value : 'a; warnings : warning list }

let with_ref r f =
  let saved = !r in
  try
    let v = f () in
    r := saved;
    v
  with e ->
    r := saved;
    raise e

let raised_warnings = ref []

let raise_warnings' warnings =
  raised_warnings := List.rev_append warnings !raised_warnings

let raise_warning ?(non_fatal = false) w =
  raised_warnings := { w; non_fatal } :: !raised_warnings

let raise_warnings with_warnings =
  raise_warnings' with_warnings.warnings;
  with_warnings.value

let catch_warnings f =
  with_ref raised_warnings (fun () ->
      raised_warnings := [];
      let value = f () in
      let warnings = List.rev !raised_warnings in
      { value; warnings })

type 'a with_errors_and_warnings = ('a, t) Result.result with_warnings

let raise_errors_and_warnings we =
  match raise_warnings we with Ok x -> x | Error e -> raise_exception e

let catch_errors_and_warnings f = catch_warnings (fun () -> catch f)

let print_error ?prefix t = prerr_endline (_to_string ?prefix t)

let print_errors = List.iter print_error

type warnings_options = { warn_error : bool; print_warnings : bool }

let print_warnings ~warnings_options warnings =
  if warnings_options.print_warnings then
    List.iter
      (fun w ->
        let prefix =
          if warnings_options.warn_error && not w.non_fatal then "Error"
          else "Warning"
        in
        print_error ~prefix w.w)
      warnings

(* When there is warnings. *)
let handle_warn_error ~warnings_options warnings ok =
  print_warnings ~warnings_options warnings;
  let maybe_fatal = List.exists (fun w -> not w.non_fatal) warnings in
  if maybe_fatal && warnings_options.warn_error then
    Error (`Msg "Warnings have been generated.")
  else Ok ok

let handle_warnings ~warnings_options ww =
  handle_warn_error ~warnings_options ww.warnings ww.value

let handle_errors_and_warnings ~warnings_options = function
  | { value = Error e; warnings } ->
      print_warnings ~warnings_options warnings;
      Error (`Msg (to_string e))
  | { value = Ok ok; warnings } ->
      handle_warn_error ~warnings_options warnings ok

let unpack_warnings ww = (ww.value, List.map (fun w -> w.w) ww.warnings)

let t_of_parser_t : Odoc_parser.Warning.t -> t =
 fun x -> (`With_full_location x :> t)

let raise_parser_warnings v =
  (* Parsing errors may be fatal. *)
  let warnings = Odoc_parser.warnings v in
  let non_fatal = false in
  raise_warnings'
    (List.map (fun p -> { w = t_of_parser_t p; non_fatal }) warnings);
  Odoc_parser.ast v