Merge pull request #1008 from ocsigen/more-raise-less-fail

More raise less fail

Author: smorimoto

src/core/lwt_pool.ml

@@ -108,7 +108,7 @@ let validate_and_return p c =
             resolver is waiting. *)
          dispose p c >>= fun () ->
          replace_disposed p;
-         Lwt.fail e)
+         Lwt.reraise e)
 
 (* Acquire a pool member. *)
 let acquire p =

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.Exception_filter.run exc -> Lwt.fail exc
+  | exception exc when Lwt.Exception_filter.run exc -> Lwt.reraise exc
 
 let rec unfold_lwt f u () =
   let* x = f u in
@@ -299,7 +299,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.Exception_filter.run exn -> Lwt.fail exn
+  | exception exn when Lwt.Exception_filter.run exn -> Lwt.reraise exn
 
 let rec of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () ->
     match seq () with
@@ -315,4 +315,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.Exception_filter.run exc -> Lwt.fail exc
+    | exception exc when Lwt.Exception_filter.run exc -> Lwt.reraise exc

src/core/lwt_stream.ml

@@ -279,9 +279,9 @@ class ['a] bounded_push_impl (info : 'a push_bounded) wakener_cell last close =
              let waiter, wakener = Lwt.task () in
              info.pushb_push_waiter <- waiter;
              info.pushb_push_wakener <- wakener;
-             Lwt.fail exn
+             Lwt.reraise exn
            | _ ->
-             Lwt.fail exn)
+             Lwt.reraise exn)
     end else begin
       (* Push the element at the end of the queue. *)
       enqueue' (Some x) last;
@@ -367,11 +367,18 @@ let feed s =
     else begin
       (* Otherwise request a new element. *)
       let thread =
-        from.from_create () >>= fun x ->
-        (* Push the element to the end of the queue. *)
-        enqueue x s;
-        if x = None then Lwt.wakeup s.close ();
-        Lwt.return_unit
+        (* The function [from_create] can raise an exception (with
+           [raise], rather than returning a failed promise with
+           [Lwt.fail]). In this case, we have to catch the exception
+           and turn it into a safe failed promise. *)
+        Lwt.catch
+          (fun () ->
+            from.from_create () >>= fun x ->
+            (* Push the element to the end of the queue. *)
+            enqueue x s;
+            if x = None then Lwt.wakeup s.close ();
+            Lwt.return_unit)
+          Lwt.reraise
       in
       (* Allow other threads to access this thread. *)
       from.from_thread <- thread;
@@ -1070,7 +1077,7 @@ let parse s f =
     (fun () -> f s)
     (fun exn ->
        s.node <- node;
-       Lwt.fail exn)
+       Lwt.reraise exn)
 
 let hexdump stream =
   let buf = Buffer.create 80 and num = ref 0 in

src/ppx/ppx_lwt.ml

@@ -23,7 +23,7 @@ let add_wildcard_case cases =
   if not has_wildcard
   then cases
        @ (let loc = Location.none in
-          [case ~lhs:[%pat? exn] ~guard:None ~rhs:[%expr Lwt.fail exn]])
+          [case ~lhs:[%pat? exn] ~guard:None ~rhs:[%expr Lwt.reraise exn]])
   else cases
 
 (** {3 Internal names} *)
@@ -154,11 +154,11 @@ let lwt_expression mapper exp attributes ext_loc =
     Some (mapper#expression { new_exp with pexp_attributes })
 
   (* [assert%lwt $e$] ≡
-     [try Lwt.return (assert $e$) with exn -> Lwt.fail exn] *)
+     [try Lwt.return (assert $e$) with exn -> Lwt.reraise exn] *)
   | Pexp_assert e ->
     let new_exp =
       let loc = !default_loc in
-      [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.fail exn]
+      [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.reraise exn]
     in
     Some (mapper#expression { new_exp with pexp_attributes })
 

src/ppx/ppx_lwt.mli

@@ -80,10 +80,10 @@ catch (fun () -> f x)
         prerr_endline msg;
         return ()
     | exn ->
-        Lwt.fail exn)
+        Lwt.reraise exn)
    ]}
 
-   Note that the [exn -> Lwt.fail exn] branch is automatically added
+   Note that the [exn -> Lwt.reraise exn] branch is automatically added
    when needed.
 
    - finalizer:

src/unix/lwt_io.ml

@@ -231,7 +231,7 @@ let perform_io : type mode. mode _channel -> int Lwt.t = fun ch ->
             (function
               | Unix.Unix_error (Unix.EPIPE, _, _) ->
                 Lwt.return 0
-              | exn -> Lwt.fail exn) [@ocaml.warning "-4"]
+              | exn -> Lwt.reraise exn) [@ocaml.warning "-4"]
         else
           perform ch.buffer ptr len
       in
@@ -525,7 +525,7 @@ let make :
     max = (match mode with
       | Input -> 0
       | Output -> size);
-    close = lazy(Lwt.catch close Lwt.fail);
+    close = lazy(Lwt.catch close Lwt.reraise);
     abort_waiter = abort_waiter;
     abort_wakener = abort_wakener;
     main = wrapper;
@@ -537,7 +537,7 @@ let make :
         perform_io,
         fun pos cmd ->
           try seek pos cmd
-          with e when Lwt.Exception_filter.run e -> Lwt.fail e
+          with e when Lwt.Exception_filter.run e -> Lwt.reraise e
     );
   } and wrapper = {
     state = Idle;
@@ -678,7 +678,7 @@ struct
     let ptr = ic.ptr in
     if ptr = ic.max then
       refill ic >>= function
-      | 0 -> Lwt.fail End_of_file
+      | 0 -> raise End_of_file
       | _ -> read_char ic
     else begin
       ic.ptr <- ptr + 1;
@@ -690,7 +690,7 @@ struct
       (fun () -> read_char ic >|= fun ch -> Some ch)
       (function
         | End_of_file -> Lwt.return_none
-        | exn -> Lwt.fail exn)
+        | exn -> Lwt.reraise exn)
 
   let read_line ic =
     let buf = Buffer.create 128 in
@@ -711,7 +711,7 @@ struct
             if cr_read then Buffer.add_char buf '\r';
             Lwt.return(Buffer.contents buf)
           | exn ->
-            Lwt.fail exn)
+            Lwt.reraise exn)
     in
     read_char ic >>= function
     | '\r' -> loop true
@@ -723,7 +723,7 @@ struct
       (fun () -> read_line ic >|= fun ch -> Some ch)
       (function
         | End_of_file -> Lwt.return_none
-        | exn -> Lwt.fail exn)
+        | exn -> Lwt.reraise exn)
 
   let unsafe_read_into' ic blit buf ofs len =
     let avail = ic.max - ic.ptr in
@@ -771,7 +771,7 @@ struct
     let rec loop ic buf ofs len =
       read_into ic buf ofs len >>= function
       | 0 ->
-          Lwt.fail End_of_file
+          raise End_of_file
       | n ->
           let len = len - n in
           if len = 0 then
@@ -985,7 +985,7 @@ struct
     if ic.max - ic.ptr < size then
       refill ic >>= function
       | 0 ->
-        Lwt.fail End_of_file
+        raise End_of_file
       | _ ->
         read_block_unsafe ic size f
     else begin
@@ -1440,7 +1440,7 @@ let open_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?(suffix = "") () =
         Lwt.return (fname, chan))
       (function
         | Unix.Unix_error _ when n < 1000 -> attempt (n + 1)
-        | exn -> Lwt.fail exn)
+        | exn -> Lwt.reraise exn)
   in
   attempt 0
 
@@ -1468,7 +1468,7 @@ let create_temp_dir
         Lwt.return name)
       (function
       | Unix.Unix_error (Unix.EEXIST, _, _) when n < 1000 -> attempt (n + 1)
-      | exn -> Lwt.fail exn)
+      | exn -> Lwt.reraise exn)
   in
   attempt 0
 
@@ -1489,10 +1489,10 @@ let win32_unlink fn =
                 (* If everything succeeded but the final removal still failed,
                    restore original permissions *)
                 Lwt_unix.chmod fn st_perm >>= fun () ->
-                Lwt.fail exn)
+                Lwt.reraise exn)
          )
-         (fun _ -> Lwt.fail exn)
-     | exn -> Lwt.fail exn)
+         (fun _ -> Lwt.reraise exn)
+     | exn -> Lwt.reraise exn)
 
 let unlink =
   if Sys.win32 then
@@ -1549,7 +1549,7 @@ let close_socket fd =
          (function
            (* Occurs if the peer closes the connection first. *)
            | Unix.Unix_error (Unix.ENOTCONN, _, _) -> Lwt.return_unit
-           | exn -> Lwt.fail exn) [@ocaml.warning "-4"])
+           | exn -> Lwt.reraise exn) [@ocaml.warning "-4"])
     (fun () ->
        Lwt_unix.close fd)
 
@@ -1574,7 +1574,7 @@ let open_connection ?fd ?in_buffer ?out_buffer sockaddr =
                      ~mode:output (Lwt_bytes.write fd)))
     (fun exn ->
        Lwt_unix.close fd >>= fun () ->
-       Lwt.fail exn)
+       Lwt.reraise exn)
 
 let with_close_connection f (ic, oc) =
   (* If the user already tried to close the socket and got an exception, we
@@ -1639,7 +1639,7 @@ let establish_server_generic
         (function
           | Unix.Unix_error (Unix.ECONNABORTED, _, _) ->
             Lwt.return `Try_again
-          | e -> Lwt.fail e)
+          | e -> Lwt.reraise e)
     in
 
     Lwt.pick [try_to_accept; should_stop] >>= function

src/unix/lwt_process.cppo.ml

@@ -378,7 +378,7 @@ let read_opt read ic =
     (function
       | Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file ->
         Lwt.return_none
-      | exn -> Lwt.fail exn) [@ocaml.warning "-4"]
+      | exn -> Lwt.reraise exn) [@ocaml.warning "-4"]
 
 let recv_chars pr =
   let ic = pr#stdout in
@@ -512,8 +512,8 @@ let pmap ?timeout ?env ?cwd ?stderr cmd text =
       | Lwt.Canceled as exn ->
         (* Cancel the getter if the sender was canceled. *)
         Lwt.cancel getter;
-        Lwt.fail exn
-      | exn -> Lwt.fail exn)
+        Lwt.reraise exn
+      | exn -> Lwt.reraise exn)
 
 let pmap_chars ?timeout ?env ?cwd ?stderr cmd chars =
   let pr = open_process ?timeout ?env ?cwd ?stderr cmd in
@@ -534,8 +534,8 @@ let pmap_line ?timeout ?env ?cwd ?stderr cmd line =
       | Lwt.Canceled as exn ->
         (* Cancel the getter if the sender was canceled. *)
         Lwt.cancel getter;
-        Lwt.fail exn
-      | exn -> Lwt.fail exn)
+        Lwt.reraise exn
+      | exn -> Lwt.reraise exn)
 
 let pmap_lines ?timeout ?env ?cwd ?stderr cmd lines =
   let pr = open_process ?timeout ?env ?cwd ?stderr cmd in

src/unix/lwt_unix.cppo.ml

@@ -147,7 +147,7 @@ let auto_pause timeout =
 
 exception Timeout
 
-let timeout d = sleep d >>= fun () -> Lwt.fail Timeout
+let timeout d = sleep d >>= fun () -> raise Timeout
 
 let with_timeout d f = Lwt.pick [timeout d; Lwt.apply f ()]
 
@@ -582,7 +582,7 @@ let wrap_syscall event ch action =
   | Retry_write ->
     register_action Write ch action
   | e when Lwt.Exception_filter.run e ->
-    Lwt.fail e
+    Lwt.reraise e
 
 (* +-----------------------------------------------------------------+
    | Basic file input/output                                         |
@@ -636,7 +636,7 @@ let wait_read ch =
          Lwt.return_unit
        else
          register_action Read ch ignore)
-    Lwt.fail
+    Lwt.reraise
 
 external stub_read : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_read"
 external read_job : Unix.file_descr -> Bytes.t -> int -> int -> int job = "lwt_unix_read_job"
@@ -694,7 +694,7 @@ let wait_write ch =
          Lwt.return_unit
        else
          register_action Write ch ignore)
-    Lwt.fail
+    Lwt.reraise
 
 external stub_write : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_write"
 external write_job : Unix.file_descr -> Bytes.t -> int -> int -> int job = "lwt_unix_write_job"
@@ -1034,7 +1034,7 @@ let file_exists name =
     (fun e ->
        match e with
        | Unix.Unix_error _ -> Lwt.return_false
-       | _ -> Lwt.fail e) [@ocaml.warning "-4"]
+       | _ -> Lwt.reraise e) [@ocaml.warning "-4"]
 
 external utimes_job : string -> float -> float -> unit job =
   "lwt_unix_utimes_job"
@@ -1140,7 +1140,7 @@ struct
       (fun e ->
          match e with
          | Unix.Unix_error _ -> Lwt.return_false
-         | _ -> Lwt.fail e) [@ocaml.warning "-4"]
+         | _ -> Lwt.reraise e) [@ocaml.warning "-4"]
 
 end
 
@@ -1408,7 +1408,7 @@ let files_of_directory path =
               (fun () -> readdir_n handle chunk_size)
               (fun exn ->
                  closedir handle >>= fun () ->
-                 Lwt.fail exn) >>= fun entries ->
+                 Lwt.reraise exn) >>= fun entries ->
             if Array.length entries < chunk_size then begin
               state := LDS_done;
               closedir handle >>= fun () ->
@@ -1423,7 +1423,7 @@ let files_of_directory path =
               (fun () -> readdir_n handle chunk_size)
               (fun exn ->
                  closedir handle >>= fun () ->
-                 Lwt.fail exn) >>= fun entries ->
+                 Lwt.reraise exn) >>= fun entries ->
             if Array.length entries < chunk_size then begin
               state := LDS_done;
               closedir handle >>= fun () ->
@@ -2395,7 +2395,7 @@ let () =
 let _waitpid flags pid =
   Lwt.catch
     (fun () -> Lwt.return (Unix.waitpid flags pid))
-    Lwt.fail
+    Lwt.reraise
 
 let waitpid =
   if Sys.win32 then