Prepare 5 9 4

CHANGES

@@ -1,3 +1,35 @@
+===== 5.9.4 =====
+
+====== Additions ======
+
+  * Lwt_engine.id: an unused type definition for better 6+ compatibility
+
+  * Lwt_unix.notification=int: a type alias for better 6+ compatibility
+
+===== 5.9.3 =====
+
+====== Fixes ======
+
+  * lwt_ppx: correctly carry type annotations again (broken since in 5.9.2). (Pierre Villemot, #1091)
+
+===== 5.9.2 =====
+
+====== Packaging ======
+
+  * lwt_ppx is compatible with newer versions of ppxlib. (Patrick Ferris, Kate Deplaix, Sora Morimoto, #1033)
+
+====== Other ======
+
+  * Misc repository maintenance. (Sora Morimoto)
+
+  * Misc typo. (Kaustubh Maske Patil, #1056)
+
+===== 5.9.1 =====
+
+====== Fixes ======
+
+  * META files now carry version information. (Hugo Heuzard, #1042, #1053)
+
 ===== 5.9.0 =====
 
 ====== Additions ======
@@ -14,6 +46,12 @@
 
   * Misc repository maintenance. (Sora Morimoto, Shon Feder, #1037, #1035)
 
+===== 5.8.1 =====
+
+====== Fixes ======
+
+  * META files now carry version information. (Hugo Heuzard, #1042, #1053)
+
 ===== 5.8.0 =====
 
 ====== Improvements ======

dune

@@ -0,0 +1 @@
+(data_only_dirs examples)

dune-project

@@ -25,6 +25,8 @@
 
 (package
  (name lwt_ppx)
+ (version 5.9.3)
+ (authors "Gabriel Radanne")
  (synopsis "PPX syntax for Lwt, providing something similar to async/await from JavaScript")
  (depends
   (ocaml (>= 4.08))
@@ -51,6 +53,7 @@
 
 (package
  (name lwt)
+ (version 5.9.2)
  (synopsis "Promises and event-driven I/O")
  (description "A promise is a value that may become determined in the future.
 

examples/ppx_lwt_standalone/dune

@@ -0,0 +1,10 @@
+; causes build errors when in src/ppx (when building other packages but not this one)
+; can't use (package lwt_ppx) because dune complains it'd be useless without a public_name
+; so this lives in examples/
+(executable
+ (name ppx_lwt_standalone)
+ (modules ppx_lwt_standalone)
+ (libraries
+  lwt_ppx
+  ppxlib))
+

examples/ppx_lwt_standalone/ppx_lwt_standalone.ml

@@ -0,0 +1 @@
+let () = Ppxlib.Driver.standalone ()

lwt.opam

@@ -1,5 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
+version: "5.9.2"
 synopsis: "Promises and event-driven I/O"
 description: """
 A promise is a value that may become determined in the future.

lwt_ppx.opam

@@ -1,11 +1,12 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
+version: "5.9.3"
 synopsis:
   "PPX syntax for Lwt, providing something similar to async/await from JavaScript"
 maintainer: [
   "Raphaël Proust <[email protected]>" "Anton Bachin <[email protected]>"
 ]
-authors: ["Jérôme Vouillon" "Jérémie Dimino"]
+authors: ["Gabriel Radanne"]
 license: "MIT"
 homepage: "https://github.com/ocsigen/lwt"
 doc: "https://ocsigen.org/lwt"

src/ppx/dune

@@ -2,6 +2,7 @@
  (public_name lwt_ppx)
  (synopsis "Lwt PPX syntax extension")
  (libraries ppxlib)
+ (modules ppx_lwt)
  (ppx_runtime_libraries lwt)
  (kind ppx_rewriter)
  (preprocess

src/ppx/ppx_lwt.ml

@@ -56,7 +56,8 @@ let gen_name i = lwt_prefix ^ string_of_int i
 let gen_bindings l =
   let aux i binding =
     { binding with
-      pvb_pat = pvar ~loc:binding.pvb_expr.pexp_loc (gen_name i)
+      pvb_pat = pvar ~loc:binding.pvb_expr.pexp_loc (gen_name i);
+      pvb_constraint = None;
     }
   in
   List.mapi aux l
@@ -72,7 +73,13 @@ let gen_binds e_loc l e =
       in
       let fun_ =
         let loc = e_loc in
-        [%expr (fun [%p binding.pvb_pat] -> [%e aux (i+1) t])]
+        match binding.pvb_constraint with
+        | None -> [%expr (fun [%p binding.pvb_pat] -> [%e aux (i+1) t])]
+        | Some (Pvc_constraint { locally_abstract_univars = []; typ }) ->
+            [%expr (fun ([%p binding.pvb_pat] : [%t typ]) -> [%e aux (i+1) t])]
+        | _ ->
+            (* no support for more advanced type annotations *)
+            Location.Error.(raise (make ~loc "unsupported value binding constraint" ~sub:[]))
       in
       let new_exp =
           let loc = e_loc in
@@ -339,6 +346,18 @@ class mapper = object (self)
             (Lwt_main.run [@ocaml.ppwarning [%e warning]])
               [%e super#expression exp]]
 
+      | [%stri let%lwt [%p? var] : [%t? typ] = [%e? exp]] ->
+        let warning =
+          estring ~loc:!default_loc
+            ("let%lwt should not be used at the module item level.\n" ^
+             "Replace let%lwt x = e by let x = Lwt_main.run (e)")
+        in
+        let loc = !default_loc in
+        [%stri
+          let [%p var] : [%t typ] =
+            (Lwt_main.run [@ocaml.ppwarning [%e warning]])
+              [%e super#expression exp]]
+
       | x -> super#structure_item x);
 end
 

src/unix/lwt_engine.ml

@@ -37,11 +37,15 @@ let _fake_event = {
 
 let fake_event = ref _fake_event
 
+type engine_id = ..
+type engine_id += Engine_id__other
+
 (* +-----------------------------------------------------------------+
    | Engines                                                         |
    +-----------------------------------------------------------------+ *)
 
 class virtual abstract = object(self)
+  method id = Engine_id__other
   method virtual iter : bool -> unit
   method virtual private cleanup : unit
   method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
@@ -172,9 +176,12 @@ external ev_io_stop : ev_loop -> ev_io -> unit = "lwt_libev_io_stop"
 external ev_timer_init : ev_loop -> float -> bool -> (unit -> unit) -> ev_timer = "lwt_libev_timer_init"
 external ev_timer_stop : ev_loop -> ev_timer -> unit  = "lwt_libev_timer_stop"
 
+type engine_id += Engine_id__libev of Ev_backend.t
 class libev ?(backend=Ev_backend.default) () = object
   inherit abstract
 
+  method! id = Engine_id__libev backend
+
   val loop = ev_init backend
   method loop = loop
 
@@ -330,9 +337,12 @@ class virtual select_or_poll_based = object
          if Lwt_sequence.is_empty actions then wait_writable <- Fd_map.remove fd wait_writable)
 end
 
+type engine_id += Engine_id__select
 class virtual select_based = object(self)
   inherit select_or_poll_based
 
+  method! id = Engine_id__select
+
   method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list
 
   method iter block =
@@ -365,9 +375,12 @@ class virtual select_based = object(self)
     List.iter (fun fd -> invoke_actions fd wait_writable) fds_w
 end
 
+type engine_id += Engine_id__poll
 class virtual poll_based = object(self)
   inherit select_or_poll_based
 
+  method! id = Engine_id__select
+
   method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list
 
   method iter block =
@@ -429,6 +442,7 @@ let set ?(transfer=true) ?(destroy=true) engine =
   if destroy then !current#destroy;
   current := (engine : #t :> t)
 
+let id () = !current#id
 let iter block = !current#iter block
 let on_readable fd f = !current#on_readable fd f
 let on_writable fd f = !current#on_writable fd f

src/unix/lwt_engine.mli

@@ -65,8 +65,13 @@ val forwards_signal : int -> bool
 (** An engine represents a set of functions used to register different
     kinds of callbacks for different kinds of events. *)
 
+type engine_id = ..
+
+val id : unit -> engine_id
+
 (** Abstract class for engines. *)
 class virtual abstract : object
+  method id : engine_id
   method destroy : unit
     (** Destroy the engine, remove all its events and free its
         associated resources. *)
@@ -142,6 +147,8 @@ end
 
   (** Type of libev loops. *)
 
+type engine_id += Engine_id__libev of Ev_backend.t
+
 (** Engine based on libev. If not compiled with libev support, the
     creation of the class will raise {!Lwt_sys.Not_available}. *)
 class libev : ?backend:Ev_backend.t -> unit -> object
@@ -158,6 +165,8 @@ class libev : ?backend:Ev_backend.t -> unit -> object
 end
 
 (** Engine based on {!Unix.select}. *)
+type engine_id += Engine_id__select
+type engine_id += Engine_id__poll
 class select : t
 
 (** Abstract class for engines based on a select-like function. *)

src/unix/lwt_io.ml

@@ -1553,18 +1553,14 @@ let close_socket fd =
     (fun () ->
        Lwt_unix.close fd)
 
-let open_connection ?fd ?(set_tcp_nodelay=true) ?(prepare_fd=ignore) ?in_buffer ?out_buffer sockaddr =
+let open_connection ?fd ?in_buffer ?out_buffer sockaddr =
   let fd =
     match fd with
     | None ->
       Lwt_unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0
     | Some fd ->
       fd
   in
-
-  if set_tcp_nodelay then Lwt_unix.setsockopt fd Unix.TCP_NODELAY true;
-  prepare_fd fd;
-
   let close = lazy (close_socket fd) in
   Lwt.catch
     (fun () ->
@@ -1590,8 +1586,8 @@ let with_close_connection f (ic, oc) =
     (fun () -> f (ic, oc))
     (fun () -> close_if_not_closed ic <&> close_if_not_closed oc)
 
-let with_connection ?fd ?set_tcp_nodelay ?prepare_fd ?in_buffer ?out_buffer sockaddr f =
-  open_connection ?fd ?set_tcp_nodelay ?prepare_fd ?in_buffer ?out_buffer sockaddr >>= fun channels ->
+let with_connection ?fd ?in_buffer ?out_buffer sockaddr f =
+  open_connection ?fd ?in_buffer ?out_buffer sockaddr >>= fun channels ->
   with_close_connection f channels
 
 type server = {
@@ -1609,9 +1605,6 @@ let shutdown_server_deprecated server =
 let establish_server_generic
     bind_function
     ?fd:preexisting_socket_for_listening
-    ?(set_tcp_nodelay=true)
-    ?(prepare_listening_fd=ignore)
-    ?(prepare_client_fd=ignore)
     ?(backlog = Lwt_unix.somaxconn () [@ocaml.warning "-3"])
     listening_address
     connection_handler_callback =
@@ -1625,7 +1618,6 @@ let establish_server_generic
       socket
   in
   Lwt_unix.setsockopt listening_socket Unix.SO_REUSEADDR true;
-  prepare_listening_fd listening_socket;
 
   (* This promise gets resolved with `Should_stop when the user calls
      Lwt_io.shutdown_server. This begins the shutdown procedure. *)
@@ -1653,13 +1645,10 @@ let establish_server_generic
     Lwt.pick [try_to_accept; should_stop] >>= function
     | `Accepted (client_socket, client_address) ->
       begin
-        try
-          Lwt_unix.set_close_on_exec client_socket
+        try Lwt_unix.set_close_on_exec client_socket
         with Invalid_argument _ -> ()
       end;
 
-      if set_tcp_nodelay then Lwt_unix.setsockopt client_socket Unix.TCP_NODELAY true;
-      prepare_client_fd client_socket;
       connection_handler_callback client_address client_socket;
 
       accept_loop ()
@@ -1701,9 +1690,7 @@ let establish_server_generic
   server, server_has_started
 
 let establish_server_with_client_socket
-    ?server_fd ?backlog ?(no_close = false)
-    ?set_tcp_nodelay ?prepare_listening_fd ?prepare_client_fd
-    sockaddr f =
+    ?server_fd ?backlog ?(no_close = false) sockaddr f =
   let handler client_address client_socket =
     Lwt.async begin fun () ->
       (* Not using Lwt.finalize here, to make sure that exceptions from [f]
@@ -1731,9 +1718,7 @@ let establish_server_with_client_socket
 
   let server, server_started =
     establish_server_generic
-      Lwt_unix.bind ?fd:server_fd ?backlog
-        ?set_tcp_nodelay ?prepare_listening_fd ?prepare_client_fd
-        sockaddr handler
+      Lwt_unix.bind ?fd:server_fd ?backlog sockaddr handler
   in
   server_started >>= fun () ->
   Lwt.return server
@@ -1744,7 +1729,6 @@ let establish_server_with_client_address_generic
     ?(buffer_size = !default_buffer_size)
     ?backlog
     ?(no_close = false)
-    ?set_tcp_nodelay ?prepare_listening_fd ?prepare_client_fd
     sockaddr
     handler =
 
@@ -1800,19 +1784,13 @@ let establish_server_with_client_address_generic
         best_effort_close output_channel)
   in
 
-  establish_server_generic bind_function ?fd ?backlog
-    ?set_tcp_nodelay ?prepare_listening_fd ?prepare_client_fd
-    sockaddr handler
+  establish_server_generic bind_function ?fd ?backlog sockaddr handler
 
 let establish_server_with_client_address
-    ?fd ?buffer_size ?backlog ?no_close
-    ?set_tcp_nodelay ?prepare_listening_fd ?prepare_client_fd
-    sockaddr handler =
+    ?fd ?buffer_size ?backlog ?no_close sockaddr handler =
   let server, server_started =
     establish_server_with_client_address_generic
-      Lwt_unix.bind ?fd ?buffer_size ?backlog ?no_close
-      ?set_tcp_nodelay ?prepare_listening_fd ?prepare_client_fd
-      sockaddr handler
+      Lwt_unix.bind ?fd ?buffer_size ?backlog ?no_close sockaddr handler
   in
   server_started >>= fun () ->
   Lwt.return server