Source file exn.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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
open! Import

type t = exn [@@deriving_inline sexp_of]

let sexp_of_t = (sexp_of_exn : t -> Sexplib0.Sexp.t)

[@@@end]

let exit = Caml.exit

exception Finally of t * t [@@deriving_inline sexp]

let () =
  Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Finally] (function
    | Finally (arg0__001_, arg1__002_) ->
      let res0__003_ = sexp_of_t arg0__001_
      and res1__004_ = sexp_of_t arg1__002_ in
      Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "exn.ml.Finally"; res0__003_; res1__004_ ]
    | _ -> assert false)
;;

[@@@end]

exception Reraised of string * t [@@deriving_inline sexp]

let () =
  Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Reraised] (function
    | Reraised (arg0__005_, arg1__006_) ->
      let res0__007_ = sexp_of_string arg0__005_
      and res1__008_ = sexp_of_t arg1__006_ in
      Sexplib0.Sexp.List
        [ Sexplib0.Sexp.Atom "exn.ml.Reraised"; res0__007_; res1__008_ ]
    | _ -> assert false)
;;

[@@@end]

exception Sexp of Sexp.t

(* We install a custom exn-converter rather than use:

   {[
     exception Sexp of Sexp.t [@@deriving_inline sexp]
     (* ... *)
     [@@@end]
   ]}

   to eliminate the extra wrapping of [(Sexp ...)]. *)
let () =
  Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Sexp] (function
    | Sexp t -> t
    | _ ->
      (* Reaching this branch indicates a bug in sexplib. *)
      assert false)
;;

let create_s sexp = Sexp sexp

let raise_with_original_backtrace t backtrace =
  Caml.Printexc.raise_with_backtrace t backtrace
;;

external is_phys_equal_most_recent : t -> bool = "Base_caml_exn_is_most_recent_exn"

let reraise exn str =
  let exn' = Reraised (str, exn) in
  if is_phys_equal_most_recent exn
  then (
    let bt = Caml.Printexc.get_raw_backtrace () in
    raise_with_original_backtrace exn' bt)
  else raise exn'
;;

let reraisef exc format = Printf.ksprintf (fun str () -> reraise exc str) format
let to_string exc = Sexp.to_string_hum ~indent:2 (sexp_of_exn exc)
let to_string_mach exc = Sexp.to_string_mach (sexp_of_exn exc)
let sexp_of_t = sexp_of_exn

let protectx ~f x ~(finally : _ -> unit) =
  match f x with
  | res ->
    finally x;
    res
  | exception exn ->
    let bt = Caml.Printexc.get_raw_backtrace () in
    (match finally x with
     | () -> raise_with_original_backtrace exn bt
     | exception final_exn ->
       (* Unfortunately, the backtrace of the [final_exn] is discarded here. *)
       raise_with_original_backtrace (Finally (exn, final_exn)) bt)
;;

let protect ~f ~finally = protectx ~f () ~finally

let does_raise (type a) (f : unit -> a) =
  try
    ignore (f () : a);
    false
  with
  | _ -> true
;;

include Pretty_printer.Register_pp (struct
    type t = exn

    let pp ppf t =
      match sexp_of_exn_opt t with
      | Some sexp -> Sexp.pp_hum ppf sexp
      | None -> Caml.Format.pp_print_string ppf (Caml.Printexc.to_string t)
    ;;

    let module_name = "Base.Exn"
  end)

let print_with_backtrace exc raw_backtrace =
  Caml.Format.eprintf "@[<2>Uncaught exception:@\n@\n@[%a@]@]@\n@." pp exc;
  if Caml.Printexc.backtrace_status ()
  then Caml.Printexc.print_raw_backtrace Caml.stderr raw_backtrace;
  Caml.flush Caml.stderr
;;

let set_uncaught_exception_handler () =
  Caml.Printexc.set_uncaught_exception_handler print_with_backtrace
;;

let handle_uncaught_aux ~do_at_exit ~exit f =
  try f () with
  | exc ->
    let raw_backtrace = Caml.Printexc.get_raw_backtrace () in
    (* One reason to run [do_at_exit] handlers before printing out the error message is
       that it helps curses applications bring the terminal in a good state, otherwise the
       error message might get corrupted.  Also, the OCaml top-level uncaught exception
       handler does the same. *)
    if do_at_exit
    then (
      try Caml.do_at_exit () with
      | _ -> ());
    (try print_with_backtrace exc raw_backtrace with
     | _ ->
       (try
          Caml.Printf.eprintf "Exn.handle_uncaught could not print; exiting anyway\n%!"
        with
        | _ -> ()));
    exit 1
;;

let handle_uncaught_and_exit f = handle_uncaught_aux f ~exit ~do_at_exit:true

let handle_uncaught ~exit:must_exit f =
  handle_uncaught_aux f ~exit:(if must_exit then exit else ignore) ~do_at_exit:must_exit
;;

let reraise_uncaught str func =
  try func () with
  | exn ->
    let bt = Caml.Printexc.get_raw_backtrace () in
    raise_with_original_backtrace (Reraised (str, exn)) bt
;;

external clear_backtrace : unit -> unit = "Base_clear_caml_backtrace_pos" [@@noalloc]

let raise_without_backtrace e =
  (* We clear the backtrace to reduce confusion, so that people don't think whatever
     is stored corresponds to this raise. *)
  clear_backtrace ();
  Caml.raise_notrace e
;;

let initialize_module () = set_uncaught_exception_handler ()

module Private = struct
  let clear_backtrace = clear_backtrace
end