5.5 support: Modular explicits (#2781)

Backport modular explicits syntax.
The test code is taken from the compiler's testsuite.

* Factorize the formatting of package types

This removes code with seamingly no regressions.

Author: Julow

CHANGES.md

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

lib/Ast.ml

@@ -966,6 +966,7 @@ end = struct
       | Pconstraint t -> f t
       | Pcoerce (t1, t2) -> Option.exists t1 ~f || f t2
     in
+    let check_package_type ptyp = List.exists ptyp.ppt_cstrs ~f:snd_f in
     match ctx with
     | Pld (PTyp t1) -> assert (typ == t1)
     | Pld _ -> assert false
@@ -985,13 +986,15 @@ end = struct
               | {prf_desc= Rtag (_, _, t1N); _} -> List.exists t1N ~f
               | {prf_desc= Rinherit t1; _} -> typ == t1 ) )
       | Ptyp_open (_, t1) -> assert (t1 == typ)
-      | Ptyp_package ptyp -> assert (List.exists ptyp.ppt_cstrs ~f:snd_f)
+      | Ptyp_package ptyp -> assert (check_package_type ptyp)
       | Ptyp_object (fields, _) ->
           assert (
             List.exists fields ~f:(function
               | {pof_desc= Otag (_, t1); _} -> typ == t1
               | {pof_desc= Oinherit t1; _} -> typ == t1 ) )
-      | Ptyp_class (_, l) -> assert (List.exists l ~f) )
+      | Ptyp_class (_, l) -> assert (List.exists l ~f)
+      | Ptyp_functor (_, _, ptyp, rhs) ->
+          assert (rhs == typ || check_package_type ptyp) )
     | Td {ptype_params; ptype_cstrs; ptype_kind; ptype_manifest; _} ->
         assert (
           List.exists ptype_params ~f:fst_f
@@ -1018,8 +1021,7 @@ end = struct
       match ctx.ppat_desc with
       | Ppat_constraint (_, t1) -> assert (typ == t1)
       | Ppat_extension (_, PTyp t) -> assert (typ == t)
-      | Ppat_unpack (_, Some ptyp) ->
-          assert (List.exists ptyp.ppt_cstrs ~f:(fun (_, t) -> typ == t))
+      | Ppat_unpack (_, Some ptyp) -> assert (check_package_type ptyp)
       | Ppat_record (l, _) ->
           assert (List.exists l ~f:(fun (_, t, _) -> Option.exists t ~f))
       | Ppat_tuple (l, _) ->
@@ -1030,8 +1032,7 @@ end = struct
       | _ -> assert false )
     | Exp ctx -> (
       match ctx.pexp_desc with
-      | Pexp_pack (_, Some ptyp, _) ->
-          assert (List.exists ptyp.ppt_cstrs ~f:snd_f)
+      | Pexp_pack (_, Some ptyp, _) -> assert (check_package_type ptyp)
       | Pexp_constraint (_, t1)
        |Pexp_coerce (_, None, t1)
        |Pexp_extension (_, PTyp t1) ->
@@ -1079,8 +1080,9 @@ end = struct
     | Mod ctx -> (
       match ctx.pmod_desc with
       | Pmod_unpack (_, ty1, ty2) ->
-          let f ptyp = List.exists ptyp.ppt_cstrs ~f:snd_f in
-          assert (Option.exists ty1 ~f || Option.exists ty2 ~f)
+          assert (
+            Option.exists ty1 ~f:check_package_type
+            || Option.exists ty2 ~f:check_package_type )
       | _ -> assert false )
     | Sig ctx -> (
       match ctx.psig_desc with
@@ -1583,16 +1585,18 @@ end = struct
       | _ -> false
     in
     let constructor_cxt_prec_of_inner = function
-      | {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _; _} -> Some (Apply, Non)
+      | {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _ | Ptyp_functor _; _} ->
+          Some (Apply, Non)
       | {ptyp_desc= Ptyp_tuple _; _} -> Some (InfixOp3, Non)
       | _ -> None
     in
     match ctx with
     | { ctx= Td {ptype_kind= Ptype_variant v; _}
       ; ast=
           Typ
-            ({ptyp_desc= Ptyp_arrow _ | Ptyp_poly _ | Ptyp_tuple _; _} as typ)
-      }
+            ( { ptyp_desc=
+                  Ptyp_arrow _ | Ptyp_poly _ | Ptyp_functor _ | Ptyp_tuple _
+              ; _ } as typ ) }
       when List.exists v ~f:(is_tuple_lvl1_in_constructor typ) ->
         constructor_cxt_prec_of_inner typ
     | { ctx=
@@ -1601,7 +1605,9 @@ end = struct
           | Sig {psig_desc= Psig_typext {ptyext_constructors= l; _}; _} )
       ; ast=
           Typ
-            ({ptyp_desc= Ptyp_arrow _ | Ptyp_poly _ | Ptyp_tuple _; _} as typ)
+            ( { ptyp_desc=
+                  Ptyp_arrow _ | Ptyp_poly _ | Ptyp_functor _ | Ptyp_tuple _
+              ; _ } as typ )
       ; _ }
       when List.exists l ~f:(is_tuple_lvl1_in_ext_constructor typ) ->
         constructor_cxt_prec_of_inner typ
@@ -1621,8 +1627,9 @@ end = struct
               ; _ } )
       ; ast=
           Typ
-            ({ptyp_desc= Ptyp_tuple _ | Ptyp_arrow _ | Ptyp_poly _; _} as typ)
-      }
+            ( { ptyp_desc=
+                  Ptyp_tuple _ | Ptyp_arrow _ | Ptyp_poly _ | Ptyp_functor _
+              ; _ } as typ ) }
       when is_tuple_lvl1_in_ext_constructor typ constr ->
         constructor_cxt_prec_of_inner typ
     | {ctx= Str _ | Str_exp _; ast= Typ _; _} -> None
@@ -1634,7 +1641,7 @@ end = struct
             else Right
           in
           Some (MinusGreater, assoc)
-      | Ptyp_poly _ -> Some (MinusGreater, Right)
+      | Ptyp_poly _ | Ptyp_functor _ -> Some (MinusGreater, Right)
       | Ptyp_tuple _ -> Some (InfixOp3, Non)
       | Ptyp_alias _ -> Some (As, Non)
       | Ptyp_constr (_, _ :: _ :: _) -> Some (Comma, Non)
@@ -1770,7 +1777,7 @@ end = struct
     | Typ {ptyp_desc; _} -> (
       match ptyp_desc with
       | Ptyp_package _ -> Some Low
-      | Ptyp_arrow _ | Ptyp_poly _ -> Some MinusGreater
+      | Ptyp_arrow _ | Ptyp_poly _ | Ptyp_functor _ -> Some MinusGreater
       | Ptyp_tuple _ -> Some InfixOp3
       | Ptyp_alias _ -> Some As
       | Ptyp_any | Ptyp_var _ | Ptyp_constr _ | Ptyp_object _
@@ -1869,7 +1876,10 @@ end = struct
     match xtyp with
     | {ast= {ptyp_desc= Ptyp_package _; _}; _} -> true
     | {ast= {ptyp_desc= Ptyp_alias _; _}; ctx= Typ _} -> true
-    | { ast= {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _ | Ptyp_tuple _; _}
+    | { ast=
+          { ptyp_desc=
+              Ptyp_arrow _ | Ptyp_poly _ | Ptyp_functor _ | Ptyp_tuple _
+          ; _ }
       ; ctx= Typ {ptyp_desc= Ptyp_class _; _} } ->
         true
     | { ast= {ptyp_desc= Ptyp_alias _; _}
@@ -1887,15 +1897,17 @@ end = struct
         true
     | { ast=
           { ptyp_desc=
-              Ptyp_alias _ | Ptyp_arrow _ | Ptyp_poly _ | Ptyp_tuple _
+              ( Ptyp_alias _ | Ptyp_arrow _ | Ptyp_poly _ | Ptyp_functor _
+              | Ptyp_tuple _ )
           ; _ }
       ; ctx=
           ( Str {pstr_desc= Pstr_exception _; _}
           | Str_exp {pstr_desc= Pstr_exception _; _}
           | Sig {psig_desc= Psig_exception _; _} ) } ->
         true
     | { ast= {ptyp_desc= Ptyp_tuple ({lte_label= Some _; _} :: _); _}
-      ; ctx= Typ {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _; _} } ->
+      ; ctx= Typ {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _ | Ptyp_functor _; _}
+      } ->
         true
     | _ -> (
       match ambig_prec (sub_ast ~ctx (Typ typ)) with

lib/Fmt_ast.ml

@@ -547,7 +547,7 @@ let fmt_extension_suffix ?epi c ext =
   opt ext (fun name -> str "%" $ fmt_str_loc c name $ fmt_opt epi)
 
 let is_arrow_or_poly = function
-  | {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _; _} -> true
+  | {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _ | Ptyp_functor _; _} -> true
   | _ -> false
 
 let fmt_assign_arrow c =
@@ -938,13 +938,9 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
         $ space_break $ fmt_longident_loc c lid )
   | Ptyp_extension ext ->
       hvbox c.conf.fmt_opts.extension_indent.v (fmt_extension c ctx ext)
-  | Ptyp_package {ppt_path= id; ppt_cstrs= cnstrs; ppt_attrs= attrs; ppt_loc}
-    ->
-      Cmts.fmt c ppt_loc
-      @@ hvbox 2
-           ( hovbox 0 (str "module" $ space_break $ fmt_longident_loc c id)
-           $ fmt_package_type c ctx cnstrs
-           $ fmt_attributes c attrs )
+  | Ptyp_package ptyp ->
+      let pro = str "module" $ space_break in
+      fmt_package_type c ctx ~parens:false ~pro ptyp
   | Ptyp_open (lid, typ) ->
       hvbox 2
         ( hvbox 0 (fmt_longident_loc c lid $ str ".(")
@@ -1074,8 +1070,25 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
            (sub_typ ~ctx >> fmt_core_type c) )
       $ space_break
       $ fmt_longident_loc c ~pre:"#" lid
+  | Ptyp_functor (lbl, lid, ptyp, rhs) ->
+      let fmt_lbl =
+        match lbl with
+        | Nolabel -> noop
+        | Labelled l -> fmt_str_loc c l $ str ":" $ cut_break
+        | Optional _ -> assert false (* Not produced by the parser *)
+      in
+      hovbox_if box 0
+        ( (let pro =
+             hvbox 2
+               ( fmt_lbl $ str "(" $ str "module" $ space_break
+               $ fmt_str_loc c lid $ str " :" )
+             $ break 1 2
+           in
+           fmt_package_type c ctx ~parens:false ~pro ptyp $ str ")" )
+        $ arrow_sep c ~parens
+        $ fmt_core_type c ~pro_space:false (sub_typ ~ctx rhs) )
 
-and fmt_package_type c ctx cnstrs =
+and fmt_package_type_cnstrs c ctx cnstrs =
   let fmt_cstr ~first ~last:_ (lid, typ) =
     fmt_or first (break 1 0) (break 1 1)
     $ hvbox 2
@@ -1085,6 +1098,15 @@ and fmt_package_type c ctx cnstrs =
   in
   list_fl cnstrs fmt_cstr
 
+and fmt_package_type c ctx ~parens ~pro ptyp =
+  let {ppt_path; ppt_cstrs; ppt_attrs; ppt_loc} = ptyp in
+  Cmts.fmt c ppt_loc
+    (hvbox 2
+       (Params.parens_if parens c.conf
+          ( hovbox 0 (pro $ fmt_longident_loc c ppt_path)
+          $ fmt_package_type_cnstrs c ctx ppt_cstrs
+          $ fmt_attributes c ppt_attrs ) ) )
+
 and fmt_row_field c ctx {prf_desc; prf_attributes; prf_loc} =
   let c = update_config c prf_attributes in
   let row =
@@ -1354,17 +1376,9 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
   | Ppat_unpack (name, pt) ->
       let fmt_constraint_opt pt k =
         match pt with
-        | Some {ppt_path= id; ppt_cstrs= cnstrs; ppt_attrs= attrs; ppt_loc}
-          ->
-            Cmts.fmt c ppt_loc
-            @@ hovbox 0
-                 (Params.parens_if parens c.conf
-                    (hvbox 1
-                       ( hovbox 0
-                           ( k $ space_break $ str ": "
-                           $ fmt_longident_loc c id )
-                       $ fmt_package_type c ctx cnstrs
-                       $ fmt_attributes c attrs ) ) )
+        | Some pt ->
+            let pro = k $ space_break $ str ": " in
+            fmt_package_type c ctx ~parens ~pro pt
         | None -> wrap_fits_breaks_if ~space:false c.conf parens "(" ")" k
       in
       fmt_constraint_opt pt
@@ -2725,14 +2739,9 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
       and epi = cls_paren in
       let fmt_mod m =
         match pt with
-        | Some {ppt_path= id; ppt_cstrs= cnstrs; ppt_attrs= attrs; ppt_loc}
-          ->
-            Cmts.fmt c ppt_loc
-            @@ hvbox 2
-                 ( hovbox 0
-                     (m $ space_break $ str ": " $ fmt_longident_loc c id)
-                 $ fmt_package_type c ctx cnstrs
-                 $ fmt_attributes c attrs )
+        | Some pt ->
+            let pro = m $ space_break $ str ": " in
+            fmt_package_type c ctx ~parens:false ~pro pt
         | None -> m
       in
       outer_pro
@@ -4541,12 +4550,13 @@ and fmt_module_expr ?(dock_struct = true) c ({ast= m; ctx= ctx0} as xmod) =
   | Pmod_unpack (e, ty1, ty2) ->
       let package_type sep
           {ppt_path= lid; ppt_cstrs= cstrs; ppt_attrs= attrs; ppt_loc} =
+        (* TODO: Use [fmt_package_type]. *)
         break 1 (Params.Indent.mod_unpack_annot c.conf)
         $ hovbox 0
             ( hovbox 0
                 ( str sep $ Cmts.fmt_before c ppt_loc
                 $ fmt_longident_loc c lid )
-            $ fmt_package_type c ctx cstrs
+            $ fmt_package_type_cnstrs c ctx cstrs
             $ fmt_attributes c attrs $ Cmts.fmt_after c ppt_loc )
       in
       { empty with

test/passing/gen/dune.inc

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

test/passing/refs.ahrefs/break_colon-before.ml.err

@@ -0,0 +1 @@
+Warning: break_colon-before.ml:116 exceeds the margin

test/passing/refs.ahrefs/break_colon-before.ml.ref

@@ -92,3 +92,28 @@ let to_clambda_function (id, (function_decl : Flambda.function_declaration))
      closed set of closures, is the substitutions for variables bound to the
      various closures in the set. Such closures will always be ... *)
   x
+
+let f
+  : (module M : S
+      with type foo = foooooooooooooooooooooooooooooooooooooo
+       and type foo = foooooooooooooooooooooooooooooooooooooo) -> fooo =
+  f
+
+let f
+  : fooooooooooooooooooooooooooooooooooooo ->
+  (module M : S
+    with type foo = foooooooooooooooooooooooooooooooooooooo
+     and type foo = foooooooooooooooooooooooooooooooooooooo) -> fooo =
+  f
+
+let f
+  : fooooooooooooooooooooooooooooooooooooo ->
+  (module Foooooooooooooooooooooooooooooooooooooo :
+    Foooooooooooooooooooooooooooooooooooooo) -> fooo =
+  f
+
+let f
+  : (module
+      Foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo :
+      S) -> fooo =
+  f

test/passing/refs.ahrefs/break_colon.ml.err

@@ -0,0 +1 @@
+Warning: break_colon.ml:116 exceeds the margin

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

@@ -92,3 +92,28 @@ let to_clambda_function (id, (function_decl : Flambda.function_declaration)) :
      closed set of closures, is the substitutions for variables bound to the
      various closures in the set. Such closures will always be ... *)
   x
+
+let f :
+  (module M : S
+    with type foo = foooooooooooooooooooooooooooooooooooooo
+     and type foo = foooooooooooooooooooooooooooooooooooooo) -> fooo =
+  f
+
+let f :
+  fooooooooooooooooooooooooooooooooooooo ->
+  (module M : S
+    with type foo = foooooooooooooooooooooooooooooooooooooo
+     and type foo = foooooooooooooooooooooooooooooooooooooo) -> fooo =
+  f
+
+let f :
+  fooooooooooooooooooooooooooooooooooooo ->
+  (module Foooooooooooooooooooooooooooooooooooooo :
+    Foooooooooooooooooooooooooooooooooooooo) -> fooo =
+  f
+
+let f :
+  (module
+    Foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo :
+    S) -> fooo =
+  f

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

@@ -135,3 +135,21 @@ let _ =
   let module MS = struct module type S = sig end end in
   (fun _ -> ()) (fun (module M1 : MS.S) ((module M2) : (module MS.S)) ->
     ((module M1) : (module MS.S)), ((module M2) : (module MS.S)))
+
+let f :
+  (* a *)
+  (module (* a *) M (* a *) : (* a *) S) ->
+  (* a *)
+  (* a *)
+  fooo =
+  f
+
+let f :
+  (* a *)
+  (module (* a *) Foooooooooooooooooooooooooooooooooooooo (* a *) :
+    (* a *)
+  Foooooooooooooooooooooooooooooooooooooo) ->
+  (* a *)
+  (* a *)
+  fooo =
+  f

test/passing/refs.ahrefs/modular_explicits.ml.err

@@ -0,0 +1 @@
+Warning: modular_explicits.ml:753 exceeds the margin