OCaml 5.4 syntax support (#2720)

* Basic OCaml 5.4 support

- update vendored parsers to mirror upstream at 5.4:
  * introduce locations for Longident.t components
  * distinguish (module M:S) and ((module M):(module S)) for expressions
- support for new syntaxes:
  * bivariance
  * labelled tuples

* Add test for labeled tuples

* review: lax rule for variance annotation

* review: test comments inside tuple types

* review: track labels locations in tuple types

* Locations for labels

* Concrete node for tuple element punning

Author: Octachron

CHANGES.md

@@ -6,9 +6,12 @@ profile. This started with version 0.26.0.
 
 ## unreleased
 
-### Added 
+### Added
 
-- Support for OCaml 5.4 (#2717, @Julow)
+- Support for OCaml 5.4 (#2717, #2720, @Julow, @Octachron)
+  OCamlformat now supports OCaml 5.4 syntax.
+  Module packing of the form `((module M) : (module S))` are no longer
+  rewritten to `(module M : S)` because these are now two different syntaxes.
 
 - Added option `module-indent` option (#2711, @HPRIOR) to control the indentation
   of items within modules. This affects modules and signatures. For example, 

lib/Ast.ml

@@ -61,8 +61,8 @@ let longident_is_simple c x =
   let rec length x =
     match x with
     | Longident.Lident x -> String.length x
-    | Ldot (x, y) -> length x + 1 + String.length y
-    | Lapply (x, y) -> length x + length y + 3
+    | Ldot (x, y) -> length x.txt + 1 + String.length y.txt
+    | Lapply (x, y) -> length x.txt + length y.txt + 3
   in
   longident_fit_margin c (length x)
 
@@ -977,14 +977,16 @@ end = struct
       | Ptyp_alias (t1, _) | Ptyp_poly (_, t1) -> assert (typ == t1)
       | Ptyp_arrow (t, t2) ->
           assert (List.exists t ~f:(fun x -> typ == x.pap_type) || typ == t2)
-      | Ptyp_tuple t1N | Ptyp_constr (_, t1N) -> assert (List.exists t1N ~f)
+      | Ptyp_tuple t1N ->
+          assert (List.exists t1N ~f:(fun x -> x.lte_elt == typ))
+      | Ptyp_constr (_, t1N) -> assert (List.exists t1N ~f)
       | Ptyp_variant (r1N, _, _) ->
           assert (
             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_package ptyp -> assert (List.exists ptyp.ppt_cstrs ~f:snd_f)
       | Ptyp_object (fields, _) ->
           assert (
             List.exists fields ~f:(function
@@ -1017,15 +1019,20 @@ end = struct
       match ctx.ppat_desc with
       | Ppat_constraint (_, t1) -> assert (typ == t1)
       | Ppat_extension (_, PTyp t) -> assert (typ == t)
-      | Ppat_unpack (_, Some (_, l, _)) ->
-          assert (List.exists l ~f:(fun (_, t) -> typ == t))
+      | Ppat_unpack (_, Some ptyp) ->
+          assert (List.exists ptyp.ppt_cstrs ~f:(fun (_, t) -> typ == t))
       | Ppat_record (l, _) ->
           assert (List.exists l ~f:(fun (_, t, _) -> Option.exists t ~f))
+      | Ppat_tuple (l, _) ->
+          assert (
+            List.exists l ~f:(function
+              | Lte_constrained_pun x -> x.type_constraint == typ
+              | _ -> false ) )
       | _ -> assert false )
     | Exp ctx -> (
       match ctx.pexp_desc with
-      | Pexp_pack (_, Some (_, it1N, _), _) ->
-          assert (List.exists it1N ~f:snd_f)
+      | Pexp_pack (_, Some ptyp, _) ->
+          assert (List.exists ptyp.ppt_cstrs ~f:snd_f)
       | Pexp_constraint (_, t1)
        |Pexp_coerce (_, None, t1)
        |Pexp_extension (_, PTyp t1) ->
@@ -1039,6 +1046,16 @@ end = struct
                 Option.exists c ~f:check_type_constraint ) )
       | Pexp_let (lbs, _, _) -> assert (check_let_bindings lbs)
       | Pexp_function (_, Some t1, _, _) -> assert (check_type_constraint t1)
+      | Pexp_tuple l ->
+          assert (
+            List.exists l ~f:(function
+              | Lte_constrained_pun
+                  {type_constraint= Pconstraint t | Pcoerce (None, t); _} ->
+                  t == typ
+              | Lte_constrained_pun
+                  {type_constraint= Pcoerce (Some bty, ty); _} ->
+                  typ == bty || typ == ty
+              | _ -> false ) )
       | _ -> assert false )
     | Fpe _ | Fpc _ -> assert false
     | Vc c -> assert (check_value_constraint c)
@@ -1063,7 +1080,7 @@ end = struct
     | Mod ctx -> (
       match ctx.pmod_desc with
       | Pmod_unpack (_, ty1, ty2) ->
-          let f (_, cstrs, _) = List.exists cstrs ~f:(fun (_, x) -> f x) in
+          let f ptyp = List.exists ptyp.ppt_cstrs ~f:snd_f in
           assert (Option.exists ty1 ~f || Option.exists ty2 ~f)
       | _ -> assert false )
     | Sig ctx -> (
@@ -1255,7 +1272,12 @@ end = struct
     | Pat ctx -> (
         let f pI = pI == pat in
         match ctx.ppat_desc with
-        | Ppat_array p1N | Ppat_list p1N | Ppat_tuple p1N | Ppat_cons p1N ->
+        | Ppat_tuple (p1N, _) ->
+            assert (
+              List.exists p1N ~f:(function
+                | Lte_simple s -> f s.lte_elt
+                | _ -> false ) )
+        | Ppat_array p1N | Ppat_list p1N | Ppat_cons p1N ->
             assert (List.exists p1N ~f)
         | Ppat_record (p1N, _) ->
             assert (List.exists p1N ~f:(fun (_, _, x) -> Option.exists x ~f))
@@ -1423,7 +1445,12 @@ end = struct
         | Pexp_apply (e0, e1N) ->
             (* FAIL *)
             assert (e0 == exp || List.exists e1N ~f:snd_f)
-        | Pexp_tuple e1N | Pexp_array e1N | Pexp_list e1N | Pexp_cons e1N ->
+        | Pexp_tuple e1N ->
+            assert (
+              List.exists e1N ~f:(function
+                | Lte_simple te -> te.lte_elt == exp
+                | _ -> false ) )
+        | Pexp_array e1N | Pexp_list e1N | Pexp_cons e1N ->
             assert (List.exists e1N ~f)
         | Pexp_construct (_, e) | Pexp_variant (_, e) ->
             assert (Option.exists e ~f)
@@ -1529,7 +1556,13 @@ end = struct
         && fit_margin c (width xexp)
     | Pexp_construct (_, Some e0) | Pexp_variant (_, Some e0) ->
         Exp.is_trivial e0
-    | Pexp_array e1N | Pexp_list e1N | Pexp_tuple e1N ->
+    | Pexp_tuple e1N ->
+        List.for_all e1N ~f:(function
+          | Lte_pun _ -> true
+          | Lte_constrained_pun _ -> false
+          | Lte_simple lte -> Exp.is_trivial lte.lte_elt )
+        && fit_margin c (width xexp)
+    | Pexp_array e1N | Pexp_list e1N ->
         List.for_all e1N ~f:Exp.is_trivial && fit_margin c (width xexp)
     | Pexp_record (e1N, e0) ->
         Option.for_all e0 ~f:Exp.is_trivial
@@ -1631,8 +1664,9 @@ end = struct
     | {ast= Typ _; _} -> None
     | {ctx= Exp {pexp_desc; _}; ast= Exp exp} -> (
       match pexp_desc with
-      | Pexp_tuple (e0 :: _) ->
+      | Pexp_tuple (Lte_simple {lte_elt= e0; _} :: _) ->
           Some (Comma, if exp == e0 then Left else Right)
+      | Pexp_tuple (_ :: _) -> Some (Comma, Right)
       | Pexp_cons l ->
           Some (ColonColon, if exp == List.last_exn l then Right else Left)
       | Pexp_construct
@@ -1848,6 +1882,9 @@ end = struct
           ( Str {pstr_desc= Pstr_exception _; _}
           | Sig {psig_desc= Psig_exception _; _} ) } ->
         true
+    | { ast= {ptyp_desc= Ptyp_tuple ({lte_label= Some _; _} :: _); _}
+      ; ctx= Typ {ptyp_desc= Ptyp_arrow _; _} } ->
+        true
     | _ -> (
       match ambig_prec (sub_ast ~ctx (Typ typ)) with
       | `Ambiguous -> true
@@ -2039,6 +2076,9 @@ end = struct
     register_reset (fun () -> Hashtbl.clear memo) ;
     memo
 
+  let last_tuple_and_simple f l =
+    match List.last_exn l with Lte_simple l -> f l.lte_elt | _ -> false
+
   (** [exposed cls exp] holds if there is a right-most subexpression of [exp]
       which satisfies [Exp.mem_cls cls] and is not parenthesized. *)
   let rec exposed_right_exp =
@@ -2087,7 +2127,7 @@ end = struct
          |Pexp_try (_, cases, _) ->
             continue (List.last_exn cases).pc_rhs
         | Pexp_apply (_, args) -> continue (snd (List.last_exn args))
-        | Pexp_tuple es -> continue (List.last_exn es)
+        | Pexp_tuple es -> last_tuple_and_simple continue es
         | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
          |Pexp_constraint _
          |Pexp_construct (_, None)
@@ -2168,7 +2208,7 @@ end = struct
       | Pexp_indexop_access {pia_rhs= rhs; _} -> (
         match rhs with Some e -> continue e | None -> false )
       | Pexp_apply (_, args) -> continue (snd (List.last_exn args))
-      | Pexp_tuple es -> continue (List.last_exn es)
+      | Pexp_tuple es -> last_tuple_and_simple continue es
       | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
        |Pexp_constraint _
        |Pexp_construct (_, None)
@@ -2220,7 +2260,7 @@ end = struct
                && Option.value_map ~default:false (prec_ast ctx) ~f:(fun p ->
                    Prec.compare p Apply < 0 ) ->
             true
-        | Pexp_tuple e1N -> List.last_exn e1N == xexp.ast
+        | Pexp_tuple e1N -> last_tuple_and_simple (( == ) xexp.ast) e1N
         | _ -> false
       in
       match ambig_prec (sub_ast ~ctx (Exp exp)) with

lib/Exposed.ml

@@ -15,7 +15,7 @@ module Left = struct
   let rec core_type typ =
     match typ.ptyp_desc with
     | Ptyp_arrow (t :: _, _) -> core_type t.pap_type
-    | Ptyp_tuple l -> core_type (List.hd_exn l)
+    | Ptyp_tuple l -> core_type (List.hd_exn l).lte_elt
     | Ptyp_object _ -> true
     | Ptyp_alias (typ, _) -> core_type typ
     | _ -> false
@@ -29,7 +29,7 @@ module Right = struct
     | {ptyp_desc; _} -> (
       match ptyp_desc with
       | Ptyp_arrow (_, t) -> core_type t
-      | Ptyp_tuple l -> core_type (List.last_exn l)
+      | Ptyp_tuple l -> core_type (List.last_exn l).lte_elt
       | Ptyp_object _ -> true
       | _ -> false )
 

lib/Extended_ast.ml

@@ -154,6 +154,81 @@ module Parse = struct
           (f, Some t, None)
       | _ -> (f, t, Option.map ~f:(m.pat m) v)
     in
+    let map_labeled_tuple_element m f = function
+      | Lte_simple lte -> f m lte
+      | (Lte_constrained_pun _ | Lte_pun _) as x -> x
+    in
+    let pat_tuple_elt m te =
+      match (te.lte_label, te.lte_elt) with
+      (* [ ~x:x ] -> [ ~x ] *)
+      | ( Some lbl
+        , {ppat_desc= Ppat_var {txt= v_txt; _}; ppat_attributes= []; _} )
+        when String.equal lbl.txt v_txt ->
+          Lte_pun lbl
+      (* [~x:(x : t)] -> [ ~(x : t)] *)
+      | ( Some lbl
+        , { ppat_desc=
+              Ppat_constraint
+                ( { ppat_desc= Ppat_var {txt= v_txt; _}
+                  ; ppat_attributes= []
+                  ; _ }
+                , t )
+          ; ppat_attributes= []
+          ; ppat_loc
+          ; _ } )
+        when String.equal lbl.txt v_txt ->
+          Lte_constrained_pun
+            { loc= {lbl.loc with loc_end= ppat_loc.loc_end}
+            ; label= lbl
+            ; type_constraint= t }
+      | lte_label, pat -> Lte_simple {lte_label; lte_elt= m.pat m pat}
+    in
+    let pat_tuple_elt m lte =
+      map_labeled_tuple_element m pat_tuple_elt lte
+    in
+    let exp_tuple_elt m te =
+      match (te.lte_label, te.lte_elt) with
+      (* [ ~x:x ] -> [ ~x ] *)
+      | ( Some lbl
+        , { pexp_desc= Pexp_ident {txt= Lident v_txt; _}
+          ; pexp_attributes= []
+          ; _ } )
+        when String.equal lbl.txt v_txt ->
+          Lte_pun lbl
+      (* [~x:(x : t)] -> [ ~(x : t)] *)
+      | ( Some lbl
+        , { pexp_desc=
+              Pexp_constraint
+                ( { pexp_desc= Pexp_ident {txt= Lident v_txt; _}
+                  ; pexp_attributes= []
+                  ; _ }
+                , t )
+          ; pexp_attributes= []
+          ; pexp_loc
+          ; _ } )
+        when String.equal lbl.txt v_txt ->
+          Lte_constrained_pun
+            { loc= {lbl.loc with loc_end= pexp_loc.loc_end}
+            ; label= lbl
+            ; type_constraint= Pconstraint t }
+      (* [~x:(x : t1 :> t2)] -> [ ~(x : t1 :> t2)] *)
+      | ( Some lbl
+        , { pexp_desc=
+              Pexp_coerce
+                ({pexp_desc= Pexp_ident {txt= Lident v_txt; _}; _}, bty, tty)
+          ; pexp_attributes= []
+          ; pexp_loc
+          ; _ } )
+        when String.equal lbl.txt v_txt ->
+          Lte_constrained_pun
+            { loc= {lbl.loc with loc_end= pexp_loc.loc_end}
+            ; label= lbl
+            ; type_constraint= Pcoerce (bty, tty) }
+      | lte_label, exp -> Lte_simple {lte_label; lte_elt= m.expr m exp}
+    in
+    let exp_tuple_elt m lte =
+      map_labeled_tuple_element m exp_tuple_elt lte
+    in
     let binding_op (m : Ast_mapper.mapper) b =
       let b' =
         let loc_start = b.pbop_op.loc.loc_start in
@@ -184,6 +259,9 @@ module Parse = struct
               , {ptyp_desc= Ptyp_package pt; ptyp_attributes= []; _} )
         ; _ } as p ->
           {p with ppat_desc= Ppat_unpack (name, Some pt)}
+      | {ppat_desc= Ppat_tuple (l, oc); _} as p ->
+          let l = List.map ~f:(pat_tuple_elt m) l in
+          {p with ppat_desc= Ppat_tuple (l, oc)}
       | p -> Ast_mapper.default_mapper.pat m p
     in
     let expr (m : Ast_mapper.mapper) = function
@@ -222,26 +300,9 @@ module Parse = struct
              && not (Std_longident.is_monadic_binding longident) ->
           let label_loc = {txt= op; loc= loc_op} in
           {e with pexp_desc= Pexp_infix (label_loc, m.expr m l, m.expr m r)}
-      (* [(module M) : (module T)] -> [(module M : T)] *)
-      | { pexp_desc=
-            Pexp_constraint
-              ( { pexp_desc=
-                    Pexp_pack (name, None, {infix_ext= None; infix_attrs= []})
-                ; pexp_attributes= []
-                ; pexp_loc
-                ; _ }
-              , {ptyp_desc= Ptyp_package pt; ptyp_attributes= []; ptyp_loc; _}
-              )
-        ; _ } as p
-        when Migrate_ast.Location.compare_start ptyp_loc pexp_loc > 0 ->
-          (* Match locations to differentiate between the two position for
-             the constraint, we want to shorten the second: - [let _ :
-             (module S) = (module M)] - [let _ = ((module M) : (module
-             S))] *)
-          { p with
-            pexp_desc=
-              Pexp_pack (name, Some pt, {infix_ext= None; infix_attrs= []})
-          }
+      | {pexp_desc= Pexp_tuple l; _} as p ->
+          let l = List.map ~f:(exp_tuple_elt m) l in
+          {p with pexp_desc= Pexp_tuple l}
       | e -> Ast_mapper.default_mapper.expr m e
     in
     Ast_mapper.{default_mapper with expr; pat; binding_op}