Fix invalid syntax generated for let type a = A in ... (#2783)

* Add more tests for let-struct-items

Taken from the compiler's testsuite.

Author: Julow

CHANGES.md

@@ -9,7 +9,7 @@ profile. This started with version 0.26.0.
 ### Highlight
 
 - \* Support OCaml 5.5 syntax
-  (#2772, #2774, #2775, #2777, #2780, #2781, #2782, @Julow)
+  (#2772, #2774, #2775, #2777, #2780, #2781, #2782, #2783, @Julow)
   The update brings several tiny changes, they are listed below.
 
 - \* Update Odoc's parser to 3.0 (#2757, @Julow)

lib/Fmt_ast.ml

@@ -3472,8 +3472,8 @@ and fmt_class_params c ctx params =
        ( wrap_fits_breaks c.conf "[" "]" (list_fl params fmt_param)
        $ space_break ) )
 
-and fmt_type_declaration c ?(kw = "") ?(nonrec_kw = "") ?name ?(eq = "=")
-    {ast= decl; _} =
+and fmt_type_declaration c ?(pro = noop) ?(kw = "") ?(nonrec_kw = "") ?name
+    ?(eq = "=") {ast= decl; _} =
   protect c (Td decl)
   @@
   let { ptype_name= {txt; loc}
@@ -3513,7 +3513,7 @@ and fmt_type_declaration c ?(kw = "") ?(nonrec_kw = "") ?name ?(eq = "=")
   in
   let box_manifest k =
     hvbox c.conf.fmt_opts.type_decl_indent.v
-      ( str kw
+      ( pro $ str kw
       $ fmt_extension_suffix c ext
       $ fmt_attributes c attrs_before
       $ str nonrec_kw $ str " "
@@ -3901,9 +3901,9 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; ctx= ctx0} as xmty) =
   | Pmty_with _ ->
       let wcs, mt = Sugar.mod_with (sub_mty ~ctx mty) in
       let fmt_cstr ~first ~last:_ wc =
-        let pre = if first then "with" else " and" in
+        let pro = if first then str "with" else str " and" in
         fmt_or first space_break cut_break
-        $ fmt_with_constraint c ctx ~pre wc
+        $ fmt_with_constraint c ctx ~pro wc
       in
       let fmt_cstrs ~first:_ ~last:_ (wcs_and, loc, attr) =
         Cmts.fmt c loc
@@ -4336,28 +4336,28 @@ and fmt_module_statement c ~attributes ?(epi = noop) ?keyword mod_expr =
   $ fmt_item_attributes c ~pre:Blank attrs_after
   $ epi $ doc_after
 
-and fmt_with_constraint c ctx ~pre = function
+and fmt_with_constraint c ctx ~pro = function
   | Pwith_type (lid, td) ->
-      fmt_type_declaration ~kw:(pre ^ " type") c ~name:lid (sub_td ~ctx td)
+      fmt_type_declaration ~pro ~kw:" type" c ~name:lid (sub_td ~ctx td)
   | Pwith_module (m1, m2) ->
-      str pre $ str " module " $ fmt_longident_loc c m1 $ str " = "
+      pro $ str " module " $ fmt_longident_loc c m1 $ str " = "
       $ fmt_longident_loc c m2
   | Pwith_typesubst (lid, td) ->
-      fmt_type_declaration ~kw:(pre ^ " type") c ~eq:":=" ~name:lid
+      fmt_type_declaration ~pro ~kw:" type" c ~eq:":=" ~name:lid
         (sub_td ~ctx td)
   | Pwith_modsubst (m1, m2) ->
-      str pre $ str " module " $ fmt_longident_loc c m1 $ str " := "
+      pro $ str " module " $ fmt_longident_loc c m1 $ str " := "
       $ fmt_longident_loc c m2
   | Pwith_modtype (m1, m2) ->
       let m1 = {m1 with txt= Some (str_longident c m1.txt)} in
       let m2 = Some (sub_mty ~ctx m2) in
-      str pre $ break 1 2
+      pro $ break 1 2
       $ fmt_module c ctx (str "module type") m1 [] None ~rec_flag:false m2
           ~attrs:Ast_helper.Attr.empty_ext_attrs
   | Pwith_modtypesubst (m1, m2) ->
       let m1 = {m1 with txt= Some (str_longident c m1.txt)} in
       let m2 = Some (sub_mty ~ctx m2) in
-      str pre $ break 1 2
+      pro $ break 1 2
       $ fmt_module c ctx ~eqty:":=" (str "module type") m1 [] None
           ~rec_flag:false m2 ~attrs:Ast_helper.Attr.empty_ext_attrs
 
@@ -4624,17 +4624,19 @@ and fmt_structure c ctx itms =
   let ast (x, _) = Str x in
   fmt_item_list c ctx update_config ast fmt_item itms
 
-and fmt_type c ?eq rec_flag decls ctx =
+and fmt_type c ?pro ?(epi = noop) ?eq rec_flag decls ctx =
   let update_config c td = update_config_attrs c td.ptype_attributes in
   let is_rec = Asttypes.is_recursive rec_flag in
-  let fmt_decl c ctx ~prev ~next:_ decl =
-    let first = Option.is_none prev in
+  let fmt_decl c ctx ~prev ~next decl =
+    let first = Option.is_none prev and last = Option.is_none next in
     let kw, nonrec_kw =
       if first then
         if is_rec then ("type", None) else ("type", Some " nonrec")
       else ("and", None)
     in
-    fmt_type_declaration c ~kw ?nonrec_kw ?eq (sub_td ~ctx decl)
+    let pro = if first then pro else None in
+    fmt_type_declaration c ?pro ~kw ?nonrec_kw ?eq (sub_td ~ctx decl)
+    $ fmt_if last epi
   in
   let ast x = Td x in
   fmt_item_list c ctx update_config ast fmt_decl decls
@@ -4700,7 +4702,7 @@ and fmt_structure_item' ~ctx0 c ~last:last_item ~semisemi ~pro ?epi ~ctx si =
       fmt_recmodule c ctx mbs fmt_module_binding ~pro ?epi
         (fun x -> Mb (ctx, x))
         sub_mb
-  | Pstr_type (rec_flag, decls) -> fmt_type c rec_flag decls ctx
+  | Pstr_type (rec_flag, decls) -> fmt_type c ~pro ?epi rec_flag decls ctx
   | Pstr_typext te -> fmt_type_extension c ctx ~pro ?epi te
   | Pstr_value {pvbs_rec= rec_flag; pvbs_bindings= bindings} ->
       let update_config c i =

test/passing/gen/dune.inc

@@ -3779,6 +3779,24 @@
  (package ocamlformat)
  (action (diff let_punning.ml.err let_punning.ml.stderr)))
 
+(rule
+ (deps .ocamlformat)
+ (package ocamlformat)
+ (action
+  (with-stdout-to let_struct_item.ml.stdout
+   (with-stderr-to let_struct_item.ml.stderr
+     (run %{bin:ocamlformat} --name let_struct_item.ml --margin-check %{dep:../tests/let_struct_item.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff let_struct_item.ml.ref let_struct_item.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff let_struct_item.ml.err let_struct_item.ml.stderr)))
+
 (rule
  (deps .ocamlformat)
  (package ocamlformat)

test/passing/refs.ahrefs/let_struct_item.ml.ref

@@ -0,0 +1,109 @@
+let () =
+  ()
+  |> let type u = A in
+     f ~y:0
+
+let _ =
+  let type t = A in
+  A
+
+let _ =
+  let type t = .. in
+  let type t += A in
+  A
+
+type u = ..
+
+let _ =
+  let type u += A in
+  A
+
+let _ =
+  let class c =
+    object
+      method f = 12
+    end in
+  new c
+
+let _ =
+  let external f : 'a -> 'a = "%identity" in
+  f
+
+let _ =
+  let type t =
+    | A of int
+    | B
+  in
+  let _ = [ A 42; B ] in
+  let type t = .. in
+  let type t += A of string in
+  let _ = A "hello" in
+  let class c =
+    object
+      method f = 42
+    end in
+  let class type ct = object
+    method f : int
+  end in
+  let class d : ct =
+    object (self)
+      inherit c
+      initializer print_int self#f
+    end in
+  let external f : 'a -> 'a = "%identity" in
+  let [@@@warning "-unused-var"] in
+  let v = 42, 12 in
+  assert (f v == v);
+  "OK"
+
+(* PR#14554, a regression reported by Antonio Monteiro.
+   (The regressions or fixes are after 5.4, which is the last release
+   without the generic [Pexp_struct_item] typing rules of #13839).
+
+   In each example below, we expect the inferred type
+   {[
+     val dog : < bark : 'this -> unit > t as 'this
+   ]}
+   where the ['this] variable has been generalized,
+   it is not a weak variable like ['_this].
+*)
+
+type 'a t
+
+(* This was correct in OCaml 5.4,
+   and was temporarily broken by #13839. *)
+let dog : 'this =
+  let module Dog = struct
+    external make : bark:('self -> unit) -> < bark : 'self -> unit > t
+      = "%identity"
+  end in
+  Dog.make ~bark:(fun (o : 'this) -> ())
+
+(* This variant from Samuel Vivien would also
+   suffer from the same regression. *)
+let dog : 'this =
+  let external make : bark:('self -> unit) -> < bark : 'self -> unit > t
+        = "%identity"
+  in
+  make ~bark:(fun (o : 'this) -> ())
+
+(* This variant from Gabriel Scherer was already wrong in OCaml 5.4,
+   and has been fixed at the same time as the other two. *)
+let dog : 'this =
+  let open struct
+    external make : bark:('self -> unit) -> < bark : 'self -> unit > t
+      = "%identity"
+  end in
+  make ~bark:(fun (o : 'this) -> ())
+
+(* </end of #14554> *)
+
+let _ =
+  let type t =
+    | Foooooooooooooooooooooooooooooooooooooooooooooooooo
+    | Baaaaaaaaaaaaaaaaaaaaaaaar
+  in
+  let module rec Foooooooooooooooooooooooooooooooooooooooooooooooooooooooo =
+  struct end
+  in
+  ()

test/passing/refs.default/let_struct_item.ml.ref

@@ -0,0 +1,106 @@
+let () =
+  ()
+  |> let type u = A in
+     f ~y:0
+
+let _ =
+  let type t = A in
+  A
+
+let _ =
+  let type t = .. in
+  let type t += A in
+  A
+
+type u = ..
+
+let _ =
+  let type u += A in
+  A
+
+let _ =
+  let class c =
+    object
+      method f = 12
+    end in
+  new c
+
+let _ =
+  let external f : 'a -> 'a = "%identity" in
+  f
+
+let _ =
+  let type t = A of int | B in
+  let _ = [ A 42; B ] in
+  let type t = .. in
+  let type t += A of string in
+  let _ = A "hello" in
+  let class c =
+    object
+      method f = 42
+    end in
+  let class type ct = object
+    method f : int
+  end in
+  let class d : ct =
+    object (self)
+      inherit c
+      initializer print_int self#f
+    end in
+  let external f : 'a -> 'a = "%identity" in
+  let [@@@warning "-unused-var"] in
+  let v = (42, 12) in
+  assert (f v == v);
+  "OK"
+
+(* PR#14554, a regression reported by Antonio Monteiro.
+   (The regressions or fixes are after 5.4, which is the last release
+   without the generic [Pexp_struct_item] typing rules of #13839).
+
+   In each example below, we expect the inferred type
+   {[
+     val dog : < bark : 'this -> unit > t as 'this
+   ]}
+   where the ['this] variable has been generalized,
+   it is not a weak variable like ['_this].
+*)
+
+type 'a t
+
+(* This was correct in OCaml 5.4,
+   and was temporarily broken by #13839. *)
+let dog : 'this =
+  let module Dog = struct
+    external make : bark:('self -> unit) -> < bark : 'self -> unit > t
+      = "%identity"
+  end in
+  Dog.make ~bark:(fun (o : 'this) -> ())
+
+(* This variant from Samuel Vivien would also
+   suffer from the same regression. *)
+let dog : 'this =
+  let external make : bark:('self -> unit) -> < bark : 'self -> unit > t
+        = "%identity"
+  in
+  make ~bark:(fun (o : 'this) -> ())
+
+(* This variant from Gabriel Scherer was already wrong in OCaml 5.4,
+   and has been fixed at the same time as the other two. *)
+let dog : 'this =
+  let open struct
+    external make : bark:('self -> unit) -> < bark : 'self -> unit > t
+      = "%identity"
+  end in
+  make ~bark:(fun (o : 'this) -> ())
+
+(* </end of #14554> *)
+
+let _ =
+  let type t =
+    | Foooooooooooooooooooooooooooooooooooooooooooooooooo
+    | Baaaaaaaaaaaaaaaaaaaaaaaar
+  in
+  let module rec Foooooooooooooooooooooooooooooooooooooooooooooooooooooooo =
+  struct end
+  in
+  ()