Support Ptyp_open from OCaml 5.2 (#2519)

* Backport Ptyp_open to parser-extended

* Backport Ptyp_open to parser-standard

CHANGES.md

@@ -6,6 +6,12 @@ profile. This started with version 0.26.0.
 
 ## unreleased
 
+### Added
+
+- Support OCaml 5.2 syntax (#2519, @Julow)
+  This includes:
+  + Local open in types.
+
 ### Changed
 
 - Added `let-binding-deindent-fun` flag (#2521, @henrytill)

lib/Ast.ml

@@ -960,6 +960,7 @@ end = struct
             List.exists r1N ~f:(function
               | {prf_desc= Rtag (_, _, t1N); _} -> List.exists t1N ~f
               | {prf_desc= Rinherit t1; _} -> typ == t1 ) )
+      | Ptyp_open (_, t1) -> assert (t1 == typ)
       | Ptyp_package (_, it1N) -> assert (List.exists it1N ~f:snd_f)
       | Ptyp_object (fields, _) ->
           assert (
@@ -1604,7 +1605,8 @@ end = struct
       | Ptyp_constr (_, _ :: _ :: _) -> Some (Comma, Non)
       | Ptyp_constr _ -> Some (Apply, Non)
       | Ptyp_any | Ptyp_var _ | Ptyp_object _ | Ptyp_class _
-       |Ptyp_variant _ | Ptyp_poly _ | Ptyp_package _ | Ptyp_extension _ ->
+       |Ptyp_variant _ | Ptyp_poly _ | Ptyp_package _ | Ptyp_extension _
+       |Ptyp_open _ ->
           None )
     | {ctx= Cty {pcty_desc; _}; ast= Typ typ; _} -> (
       match pcty_desc with
@@ -1726,7 +1728,8 @@ end = struct
       | Ptyp_tuple _ -> Some InfixOp3
       | Ptyp_alias _ -> Some As
       | Ptyp_any | Ptyp_var _ | Ptyp_constr _ | Ptyp_object _
-       |Ptyp_class _ | Ptyp_variant _ | Ptyp_poly _ | Ptyp_extension _ ->
+       |Ptyp_class _ | Ptyp_variant _ | Ptyp_poly _ | Ptyp_extension _
+       |Ptyp_open _ ->
           None )
     | Td _ -> None
     | Cty {pcty_desc; _} -> (

lib/Fmt_ast.ml

@@ -864,6 +864,12 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
       hvbox 2
         ( hovbox 0 (fmt "module@ " $ fmt_longident_loc c id)
         $ fmt_package_type c ctx cnstrs )
+  | Ptyp_open (lid, typ) ->
+      hvbox 2
+        ( hvbox 0 (fmt_longident_loc c lid $ fmt ".(")
+        $ fmt "@;<0 0>"
+        $ fmt_core_type c (sub_typ ~ctx typ)
+        $ fmt ")" )
   | Ptyp_poly ([], _) ->
       impossible "produced by the parser, handled elsewhere"
   | Ptyp_poly (a1N, t) ->

test/passing/tests/open-closing-on-separate-line.ml.ref

@@ -357,3 +357,34 @@ let _ =
         match path uri with "" -> with_path uri "/" | _ -> uri
       )
     )
+
+(* Ptyp_open *)
+
+let _ : M.(foo * M.(bar)) = ()
+
+let _ : M.(foo) * M.(bar) = ()
+
+let _ : M.([`Foo of foo]) = ()
+
+let _ : M.N.(foo) = ()
+
+let _ :
+    M.(
+      foooooooooooooooooooooooooooooooooooooooo
+      * foooooooooooooooooooooooooooooooooooooooo) =
+  ()
+
+let _ :
+    M.(
+      [ `Foo of
+        foooooooooooooooooooooooooooooooooooooooo
+        * foooooooooooooooooooooooooooooooooooooooo ]) =
+  ()
+
+let _ : M.((foo[@attr])) = ()
+
+let _ : (M.(foo)[@attr]) = ()
+
+let _ : M.((foo[@attr] [@attr])) = ()
+
+let _ : (M.((foo[@attr]))[@attr]) = ()

test/passing/tests/open.ml

@@ -281,3 +281,17 @@ let _ =
       (* we have an absoluteURI *)
       Uri.(
         match path uri with "" -> with_path uri "/" | _ -> uri))
+
+(* Ptyp_open *)
+
+let _ : M.(foo * M.(bar)) = ()
+let _ : M.(foo) * M.(bar) = ()
+let _ : M.([ `Foo of foo ]) = ()
+let _ : M.N.(foo) = ()
+let _ : M.(foooooooooooooooooooooooooooooooooooooooo * foooooooooooooooooooooooooooooooooooooooo) = ()
+let _ : M.([ `Foo of foooooooooooooooooooooooooooooooooooooooo * foooooooooooooooooooooooooooooooooooooooo]) = ()
+
+let _ : M.(foo [@attr]) = ()
+let _ : M.(foo)[@attr] = ()
+let _ : M.(foo [@attr] [@attr]) = ()
+let _ : M.(foo [@attr])[@attr] = ()

test/passing/tests/open.ml.ref

@@ -344,3 +344,34 @@ let _ =
       (* we have an absoluteURI *)
       Uri.(
         match path uri with "" -> with_path uri "/" | _ -> uri ) )
+
+(* Ptyp_open *)
+
+let _ : M.(foo * M.(bar)) = ()
+
+let _ : M.(foo) * M.(bar) = ()
+
+let _ : M.([`Foo of foo]) = ()
+
+let _ : M.N.(foo) = ()
+
+let _ :
+    M.(
+      foooooooooooooooooooooooooooooooooooooooo
+      * foooooooooooooooooooooooooooooooooooooooo) =
+  ()
+
+let _ :
+    M.(
+      [ `Foo of
+        foooooooooooooooooooooooooooooooooooooooo
+        * foooooooooooooooooooooooooooooooooooooooo ]) =
+  ()
+
+let _ : M.((foo[@attr])) = ()
+
+let _ : (M.(foo)[@attr]) = ()
+
+let _ : M.((foo[@attr] [@attr])) = ()
+
+let _ : (M.((foo[@attr]))[@attr]) = ()

vendor/parser-extended/ast_helper.ml

@@ -79,6 +79,7 @@ module Typ = struct
   let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
   let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
+  let open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t))
 end
 
 module Pat = struct

vendor/parser-extended/ast_mapper.ml

@@ -242,6 +242,8 @@ module T = struct
     | Ptyp_package pt ->
         let lid, l = map_package_type sub pt in
         package ~loc ~attrs lid l
+    | Ptyp_open (mod_ident, t) ->
+        open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t)
     | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
 
   let map_type_declaration sub

vendor/parser-extended/parser.mly

@@ -3378,44 +3378,100 @@ tuple_type:
    - applications of type constructors:   int, int list, int option list
    - variant types:                       [`A]
  *)
+
+
+(*
+  Delimited types:
+    - parenthesised type          (type)
+    - first-class module types    (module S)
+    - object types                < x: t; ... >
+    - variant types               [ `A ]
+    - extension                   [%foo ...]
+
+  We support local opens on the following classes of types:
+    - parenthesised
+    - first-class module types
+    - variant types
+
+  Object types are not support for local opens due to a potential
+  conflict with MetaOCaml syntax:
+    M.< x: t, y: t >
+  and quoted expressions:
+    .< e >.
+
+  Extension types are not support for local opens merely as a precaution.
+*)
+delimited_type_supporting_local_open:
+  | LPAREN type_ = core_type RPAREN
+      { type_ }
+  | LPAREN MODULE attrs = ext_attributes package_type = package_core_type RPAREN
+      { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc package_type) attrs }
+  | mktyp(
+      LBRACKET field = tag_field RBRACKET
+        { Ptyp_variant([ field ], Closed, None) }
+    | LBRACKET BAR fields = row_field_list RBRACKET
+        { Ptyp_variant(fields, Closed, None) }
+    | LBRACKET field = row_field BAR fields = row_field_list RBRACKET
+        { Ptyp_variant(field :: fields, Closed, None) }
+    | LBRACKETGREATER BAR? fields = row_field_list RBRACKET
+        { Ptyp_variant(fields, Open, None) }
+    | LBRACKETGREATER RBRACKET
+        { Ptyp_variant([], Open, None) }
+    | LBRACKETLESS BAR? fields = row_field_list RBRACKET
+        { Ptyp_variant(fields, Closed, Some []) }
+    | LBRACKETLESS BAR? fields = row_field_list
+      GREATER
+      tags = name_tag_list
+      RBRACKET
+        { Ptyp_variant(fields, Closed, Some tags) }
+  )
+  { $1 }
+;
+
+object_type:
+  | mktyp(
+      LESS meth_list = meth_list GREATER
+        { let (f, c) = meth_list in Ptyp_object (f, c) }
+    | LESS GREATER
+        { Ptyp_object ([], OClosed) }
+  )
+  { $1 }
+;
+
+extension_type:
+  | mktyp (
+      ext = extension
+        { Ptyp_extension ext }
+  )
+  { $1 }
+;
+
+delimited_type:
+  | object_type
+  | extension_type
+  | delimited_type_supporting_local_open
+    { $1 }
+;
+
 atomic_type:
-  | LPAREN core_type RPAREN
-      { $2 }
-  | LPAREN MODULE ext_attributes package_core_type RPAREN
-      { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc $4) $3 }
+  | type_ = delimited_type
+      { type_ }
   | mktyp( /* begin mktyp group */
-      QUOTE ident
-        { Ptyp_var $2 }
-    | UNDERSCORE
-        { Ptyp_any }
-    | tys = actual_type_parameters
+      tys = actual_type_parameters
       tid = mkrhs(type_longident)
-        { Ptyp_constr(tid, tys) }
-    | LESS meth_list GREATER
-        { let (f, c) = $2 in Ptyp_object (f, c) }
-    | LESS GREATER
-        { Ptyp_object ([], OClosed) }
+        { Ptyp_constr (tid, tys) }
     | tys = actual_type_parameters
       HASH
       cid = mkrhs(clty_longident)
-        { Ptyp_class(cid, tys) }
-    | LBRACKET tag_field RBRACKET
-        (* not row_field; see CONFLICTS *)
-        { Ptyp_variant([$2], Closed, None) }
-    | LBRACKET BAR row_field_list RBRACKET
-        { Ptyp_variant($3, Closed, None) }
-    | LBRACKET row_field BAR row_field_list RBRACKET
-        { Ptyp_variant($2 :: $4, Closed, None) }
-    | LBRACKETGREATER BAR? row_field_list RBRACKET
-        { Ptyp_variant($3, Open, None) }
-    | LBRACKETGREATER RBRACKET
-        { Ptyp_variant([], Open, None) }
-    | LBRACKETLESS BAR? row_field_list RBRACKET
-        { Ptyp_variant($3, Closed, Some []) }
-    | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET
-        { Ptyp_variant($3, Closed, Some $5) }
-    | extension
-        { Ptyp_extension $1 }
+        { Ptyp_class (cid, tys) }
+    | mod_ident = mkrhs(mod_ext_longident)
+      DOT
+      type_ = delimited_type_supporting_local_open
+        { Ptyp_open (mod_ident, type_) }
+    | QUOTE ident = ident
+        { Ptyp_var ident }
+    | UNDERSCORE
+        { Ptyp_any }
   )
   { $1 } /* end mktyp group */
 ;

vendor/parser-extended/parsetree.mli

@@ -187,6 +187,7 @@ and core_type_desc =
            {!value_description}.
          *)
   | Ptyp_package of package_type  (** [(module S)]. *)
+  | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *)
   | Ptyp_extension of extension  (** [[%id]]. *)
 
 and package_type = Longident.t loc * (Longident.t loc * core_type) list

vendor/parser-extended/printast.ml

@@ -231,6 +231,9 @@ let rec core_type i ppf x =
   | Ptyp_package pt ->
       line i ppf "Ptyp_package\n";
       package_type i ppf pt
+  | Ptyp_open (mod_ident, t) ->
+      line i ppf "Ptyp_open \"%a\"\n" fmt_longident_loc mod_ident;
+      core_type i ppf t
   | Ptyp_extension (s, arg) ->
       line i ppf "Ptyp_extension %a\n" fmt_string_loc s;
       payload i ppf arg

vendor/parser-standard/ast_helper.ml

@@ -72,6 +72,7 @@ module Typ = struct
   let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
   let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
+  let open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t))
 
   let force_poly t =
     match t.ptyp_desc with
@@ -114,6 +115,8 @@ module Typ = struct
             Ptyp_poly(string_lst, loop core_type)
         | Ptyp_package(longident,lst) ->
             Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+        | Ptyp_open (mod_ident, core_type) ->
+            Ptyp_open (mod_ident, loop core_type)
         | Ptyp_extension (s, arg) ->
             Ptyp_extension (s, arg)
       in

vendor/parser-standard/ast_mapper.ml

@@ -155,6 +155,8 @@ module T = struct
     | Ptyp_package (lid, l) ->
         package ~loc ~attrs (map_loc sub lid)
           (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
+    | Ptyp_open (mod_ident, t) ->
+        open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t)
     | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
 
   let map_type_declaration sub