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

Author: Octachron

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,15 @@ 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:snd_f)
+      | 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 +1018,15 @@ 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))
       | _ -> 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) ->
@@ -1063,7 +1064,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 +1256,9 @@ 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:(fun (_, x) -> f x))
+        | 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 +1426,8 @@ 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:snd_f)
+        | 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 +1533,10 @@ 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:(snd >> Exp.is_trivial)
+        && 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,7 +1638,7 @@ end = struct
     | {ast= Typ _; _} -> None
     | {ctx= Exp {pexp_desc; _}; ast= Exp exp} -> (
       match pexp_desc with
-      | Pexp_tuple (e0 :: _) ->
+      | Pexp_tuple ((_, e0) :: _) ->
           Some (Comma, if exp == e0 then Left else Right)
       | Pexp_cons l ->
           Some (ColonColon, if exp == List.last_exn l then Right else Left)
@@ -1848,6 +1855,9 @@ end = struct
           ( Str {pstr_desc= Pstr_exception _; _}
           | Sig {psig_desc= Psig_exception _; _} ) } ->
         true
+    | { ast= {ptyp_desc= Ptyp_tuple ((Some _, _) :: _); _}
+      ; ctx= Typ {ptyp_desc= Ptyp_arrow _; _} } ->
+        true
     | _ -> (
       match ambig_prec (sub_ast ~ctx (Typ typ)) with
       | `Ambiguous -> true
@@ -2087,7 +2097,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 -> continue (snd @@ List.last_exn es)
         | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
          |Pexp_constraint _
          |Pexp_construct (_, None)
@@ -2168,7 +2178,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 -> continue (snd @@ List.last_exn es)
       | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
        |Pexp_constraint _
        |Pexp_construct (_, None)
@@ -2220,7 +2230,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 -> snd (List.last_exn e1N) == xexp.ast
         | _ -> 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 (snd @@ List.hd_exn l)
     | 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 (snd @@ List.last_exn l)
       | Ptyp_object _ -> true
       | _ -> false )
 

lib/Extended_ast.ml

@@ -222,26 +222,6 @@ 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= []})
-          }
       | e -> Ast_mapper.default_mapper.expr m e
     in
     Ast_mapper.{default_mapper with expr; pat; binding_op}