Better naming for exception filters

Author: raphael-proust

src/core/lwt.ml

@@ -711,17 +711,19 @@ end
 open Basic_helpers
 
 (* Small helpers to avoid catching ocaml-runtime exceptions *)
-type exception_filter = exn -> bool
-let catch_filter__all = fun _ -> true
-let catch_filter__all_except_runtime = function
-  | Out_of_memory -> false
-  | Stack_overflow -> false
-  | _ -> true
-let exception_filter =
-  (* Default value: the legacy behaviour to avoid breaking programs *)
-  ref catch_filter__all
-let set_exception_filter f = exception_filter := f
-let filter_exception e = !exception_filter e
+module Exception_filter = struct
+  type t = exn -> bool
+  let handle_all = fun _ -> true
+  let handle_all_except_runtime = function
+    | Out_of_memory -> false
+    | Stack_overflow -> false
+    | _ -> true
+  let v =
+    (* Default value: the legacy behaviour to avoid breaking programs *)
+    ref handle_all
+  let set f = v := f
+  let run e = !v e
+end
 
 module Sequence_associated_storage :
 sig
@@ -802,7 +804,7 @@ struct
       let result = f () in
       current_storage := saved_storage;
       result
-    with exn when !exception_filter exn ->
+    with exn when Exception_filter.run exn ->
       current_storage := saved_storage;
       raise exn
 end
@@ -1140,7 +1142,7 @@ struct
        be reject later, it is not the responsibility of this function to pass
        the exception to [!async_exception_hook]. *)
     try f v
-    with exn when !exception_filter exn ->
+    with exn when Exception_filter.run exn ->
       !async_exception_hook exn
 
 
@@ -1840,7 +1842,7 @@ struct
 
           let p' =
             try f v with exn
-            when !exception_filter exn -> fail exn
+            when Exception_filter.run exn -> fail exn
           in
           let Internal p' = to_internal_promise p' in
           (* Run the user's function [f]. *)
@@ -1906,7 +1908,7 @@ struct
 
           let p' =
             try f v
-            with exn when !exception_filter exn ->
+            with exn when Exception_filter.run exn ->
               fail (add_loc exn) in
           let Internal p' = to_internal_promise p' in
 
@@ -1963,7 +1965,7 @@ struct
 
           let p''_result =
             try Fulfilled (f v) with exn
-            when !exception_filter exn -> Rejected exn
+            when Exception_filter.run exn -> Rejected exn
           in
 
           let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in
@@ -1993,7 +1995,7 @@ struct
           to_public_promise
             {state =
               try Fulfilled (f v)
-              with exn when !exception_filter exn -> Rejected exn})
+              with exn when Exception_filter.run exn -> Rejected exn})
         ~if_deferred:(fun () ->
           let (p'', callback) =
             create_result_promise_and_callback_if_deferred () in
@@ -2012,7 +2014,7 @@ struct
   let catch f h =
     let p =
       try f ()
-      with exn when !exception_filter exn -> fail exn
+      with exn when Exception_filter.run exn -> fail exn
     in
     let Internal p = to_internal_promise p in
     let p = underlying p in
@@ -2037,7 +2039,7 @@ struct
 
           let p' =
             try h exn
-            with exn when !exception_filter exn -> fail exn
+            with exn when Exception_filter.run exn -> fail exn
           in
           let Internal p' = to_internal_promise p' in
 
@@ -2073,7 +2075,7 @@ struct
   let backtrace_catch add_loc f h =
     let p =
       try f ()
-      with exn when !exception_filter exn -> fail exn
+      with exn when Exception_filter.run exn -> fail exn
     in
     let Internal p = to_internal_promise p in
     let p = underlying p in
@@ -2098,7 +2100,7 @@ struct
 
           let p' =
             try h exn
-            with exn when !exception_filter exn ->
+            with exn when Exception_filter.run exn ->
               fail (add_loc exn)
           in
           let Internal p' = to_internal_promise p' in
@@ -2135,7 +2137,7 @@ struct
   let try_bind f f' h =
     let p =
       try f ()
-      with exn when !exception_filter exn -> fail exn
+      with exn when Exception_filter.run exn -> fail exn
     in
     let Internal p = to_internal_promise p in
     let p = underlying p in
@@ -2152,7 +2154,7 @@ struct
 
           let p' =
             try f' v
-            with exn when !exception_filter exn -> fail exn
+            with exn when Exception_filter.run exn -> fail exn
           in
           let Internal p' = to_internal_promise p' in
 
@@ -2168,7 +2170,7 @@ struct
 
           let p' =
             try h exn
-            with exn when !exception_filter exn -> fail exn
+            with exn when Exception_filter.run exn -> fail exn
           in
           let Internal p' = to_internal_promise p' in
 
@@ -2210,7 +2212,7 @@ struct
   let backtrace_try_bind add_loc f f' h =
     let p =
       try f ()
-      with exn when !exception_filter exn -> fail exn
+      with exn when Exception_filter.run exn -> fail exn
     in
     let Internal p = to_internal_promise p in
     let p = underlying p in
@@ -2227,7 +2229,7 @@ struct
 
           let p' =
             try f' v
-            with exn when !exception_filter exn ->
+            with exn when Exception_filter.run exn ->
               fail (add_loc exn)
           in
           let Internal p' = to_internal_promise p' in
@@ -2244,7 +2246,7 @@ struct
 
           let p' =
             try h exn
-            with exn when !exception_filter exn ->
+            with exn when Exception_filter.run exn ->
               fail (add_loc exn)
           in
           let Internal p' = to_internal_promise p' in
@@ -2499,7 +2501,7 @@ struct
   let dont_wait f h =
     let p =
       try f ()
-      with exn when !exception_filter exn -> fail exn
+      with exn when Exception_filter.run exn -> fail exn
     in
     let Internal p = to_internal_promise p in
 
@@ -2522,7 +2524,7 @@ struct
   let async f =
     let p =
       try f ()
-      with exn when !exception_filter exn -> fail exn
+      with exn when Exception_filter.run exn -> fail exn
     in
     let Internal p = to_internal_promise p in
 
@@ -3125,39 +3127,39 @@ struct
 
 
   let apply f x =
-    try f x with exn when !exception_filter exn -> fail exn
+    try f x with exn when Exception_filter.run exn -> fail exn
 
   let wrap f =
     try return (f ())
-    with exn when !exception_filter exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap1 f x1 =
     try return (f x1)
-    with exn when !exception_filter exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap2 f x1 x2 =
     try return (f x1 x2)
-    with exn when !exception_filter exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap3 f x1 x2 x3 =
     try return (f x1 x2 x3)
-    with exn when !exception_filter exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap4 f x1 x2 x3 x4 =
     try return (f x1 x2 x3 x4)
-    with exn when !exception_filter exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap5 f x1 x2 x3 x4 x5 =
     try return (f x1 x2 x3 x4 x5)
-    with exn when !exception_filter exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap6 f x1 x2 x3 x4 x5 x6 =
     try return (f x1 x2 x3 x4 x5 x6)
-    with exn when !exception_filter exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
   let wrap7 f x1 x2 x3 x4 x5 x6 x7 =
     try return (f x1 x2 x3 x4 x5 x6 x7)
-    with exn when !exception_filter exn -> fail exn
+    with exn when Exception_filter.run exn -> fail exn
 
 
 

src/core/lwt.mli

@@ -2011,24 +2011,30 @@ val ignore_result : _ t -> unit
     The helpers below allow you to change the way that Lwt handles the two OCaml
     runtime exceptions [Out_of_memory] and [Stack_overflow]. *)
 
-(** An [exception_filter] is a value which indicates to Lwt what exceptions to
-    catch and what exceptions to let bubble up all the way out of the main loop
-    immediately. *)
-type exception_filter
+module Exception_filter: sig
 
-(** [catch_filter__all] is the default filter. With it the all the exceptions
-    (including [Out_of_memory] and [Stack_overflow]) are caught and transformed
-    into rejected promises. *)
-val catch_filter__all : exception_filter
+  (** An [Exception_filter.t] is a value which indicates to Lwt what exceptions to
+      catch and what exceptions to let bubble up all the way out of the main loop
+      immediately. *)
+  type t
 
-(** [catch_filter__all_except_runtime] is a filter which lets the OCaml runtime
-    exceptions ([Out_of_memory] and [Stack_overflow]) go through all the Lwt
-    abstractions and bubble all the way out of the call to [Lwt_main.run]. *)
-val catch_filter__all_except_runtime : exception_filter
+  (** [handle_all] is the default filter. With it the all the exceptions
+      (including [Out_of_memory] and [Stack_overflow]) can be handled: caught
+      and transformed into rejected promises. *)
+  val handle_all : t
 
-(** [set_exception_filter] sets the given exception filter globally. *)
-val set_exception_filter : exception_filter -> unit
+  (** [handle_all_except_runtime] is a filter which lets the OCaml runtime
+      exceptions ([Out_of_memory] and [Stack_overflow]) go through all the Lwt
+      abstractions and bubble all the way out of the call to [Lwt_main.run]. *)
+  val handle_all_except_runtime : t
 
+  (** [set] sets the given exception filter globally. *)
+  val set : t -> unit
+
+  (**/**)
+  val run : exn -> bool
+
+end
 
 
 (**/**)
@@ -2048,5 +2054,3 @@ val backtrace_try_bind :
 val abandon_wakeups : unit -> unit
 
 val debug_state_is : 'a state -> 'a t -> bool t
-
-val filter_exception : exn -> bool

src/core/lwt_seq.ml

@@ -270,7 +270,7 @@ let rec unfold f u () =
   match f u with
   | None -> return_nil
   | Some (x, u') -> Lwt.return (Cons (x, unfold f u'))
-  | exception exc when Lwt.filter_exception exc -> Lwt.fail exc
+  | exception exc when Lwt.Exception_filter.run exc -> Lwt.fail exc
 
 let rec unfold_lwt f u () =
   let* x = f u in
@@ -305,7 +305,7 @@ let rec of_seq seq () =
   | Seq.Nil -> return_nil
   | Seq.Cons (x, next) ->
     Lwt.return (Cons (x, (of_seq next)))
-  | exception exn when Lwt.filter_exception exn -> Lwt.fail exn
+  | exception exn when Lwt.Exception_filter.run exn -> Lwt.fail exn
 
 let rec of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () ->
     match seq () with
@@ -321,4 +321,4 @@ let of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () ->
        let+ x = x in
        let next = of_seq_lwt next in
        Cons (x, next)
-    | exception exc when Lwt.filter_exception exc -> Lwt.fail exc
+    | exception exc when Lwt.Exception_filter.run exc -> Lwt.fail exc

src/react/lwt_react.ml

@@ -98,7 +98,7 @@ module E = struct
       Lwt_stream.iter
         (fun v ->
           try push v
-          with exn when Lwt.filter_exception exn ->
+          with exn when Lwt.Exception_filter.run exn ->
             !Lwt.async_exception_hook exn)
         stream in
     with_finaliser (cancel_thread t) event

src/unix/lwt_io.ml

@@ -537,7 +537,7 @@ let make :
         perform_io,
         fun pos cmd ->
           try seek pos cmd
-          with e when Lwt.filter_exception e -> Lwt.fail e
+          with e when Lwt.Exception_filter.run e -> Lwt.fail e
     );
   } and wrapper = {
     state = Idle;

src/unix/lwt_main.ml

@@ -107,7 +107,7 @@ let run p =
   | result ->
     finished ();
     result
-  | exception exn when Lwt.filter_exception exn ->
+  | exception exn when Lwt.Exception_filter.run exn ->
     finished ();
     raise exn
 

src/unix/lwt_main.mli

@@ -41,10 +41,10 @@ let () = Lwt_main.run (main ())
 
       In addition, note that if you have set the exception filter to let runtime
       exceptions bubble up (via
-      [Lwt.set_exception_filter catch_filter__all_except_runtime]) then Lwt does
-      not attempt to catch exceptions thrown by the OCaml runtime. Specifically,
-      in this case, Lwt lets [Out_of_memory] and [Stack_overflow] exceptions
-      traverse all of its functions and bubble up to the caller of
+      [Lwt.Exception_filter.(set handle_all_except_runtime)])
+      then Lwt does not attempt to catch exceptions thrown by the OCaml runtime.
+      Specifically, in this case, Lwt lets [Out_of_memory] and [Stack_overflow]
+      exceptions traverse all of its functions and bubble up to the caller of
       [Lwt_main.run]. Moreover because these exceptions are left to traverse the
       call stack, they leave the internal data-structures in an inconsistent
       state. For this reason, calling [Lwt_main.run] again after such an

src/unix/lwt_preemptive.ml

@@ -182,7 +182,7 @@ let detach f args =
   let task () =
     try
       result := Result.Ok (f args)
-    with exn when Lwt.filter_exception exn ->
+    with exn when Lwt.Exception_filter.run exn ->
       result := Result.Error exn
   in
   get_worker () >>= fun worker ->

src/unix/lwt_timeout.ml

@@ -72,7 +72,7 @@ let rec loop () =
       (*XXX Should probably report any exception *)
       try
         x.action ()
-      with e when Lwt.filter_exception e ->
+      with e when Lwt.Exception_filter.run e ->
         !handle_exn e
     done;
     curr := (!curr + 1) mod (Array.length !buckets);