Merge pull request #1091 from ocsigen/ppx-type-wrong-1085

raphael-proust · web-flow · commit 2e8e9686511e · 2026-01-23T12:18:08.000+01:00
ppx: add test for #1085, add standalone ppx executable
diff --git a/examples/ppx_lwt_standalone/dune b/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))
+
diff --git a/examples/ppx_lwt_standalone/ppx_lwt_standalone.ml b/examples/ppx_lwt_standalone/ppx_lwt_standalone.ml
@@ -0,0 +1 @@
+let () = Ppxlib.Driver.standalone ()
diff --git a/src/ppx/dune b/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
diff --git a/src/ppx/ppx_lwt.ml b/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
@@ -382,6 +389,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
 
diff --git a/test/ppx/main.ml b/test/ppx/main.ml
@@ -7,7 +7,7 @@ open Lwt
    an outer call to Lwt_main.run, and nested calls to Lwt_main.run are not
    allowed. *)
 [@@@ocaml.warning "-22"]
-let%lwt structure_let_result = Lwt.return_true
+let%lwt structure_let_result : bool = Lwt.return_true
 [@@@ocaml.warning "+22"]
 
 let __trace_ctxt = "test" (* TODO: figure out how to make this implicit *)
@@ -164,6 +164,23 @@ let suite = suite "ppx" [
     (fun () ->
        Lwt.return structure_let_result
     ) ;
+
+  (* as reported in https://github.com/ocsigen/lwt/issues/1085 *)
+  test "1085-int"
+    (fun () ->
+      let%lwt (_ : int) = Lwt.return 0 in
+      Lwt.return_true
+    ) ;
+  test "1085-int-again"
+    (fun () ->
+      let%lwt _ : int = Lwt.return 0 in
+      Lwt.return_true
+    ) ;
+  test "1085-any"
+    (fun () ->
+      let%lwt _ : _ = Lwt.return 0 in
+      Lwt.return_true
+    ) ;
 ]
 
 let _ = Test.run "ppx" [ suite ]
