oxcaml · ccasin · Dec 18, 2023 · Dec 4, 2023 · Dec 5, 2023 · Dec 5, 2023
diff --git a/lib/Ast.ml b/lib/Ast.ml
@@ -960,7 +960,8 @@ 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 (_, t) -> f t))
+      | Ptyp_constr (_, t1N) -> assert (List.exists t1N ~f)
       | Ptyp_variant (r1N, _, _) ->
           assert (
             List.exists r1N ~f:(function
@@ -1317,8 +1318,10 @@ end = struct
         Pat.maybe_extension ctx check_extension
         @@ fun () ->
         match ctx.ppat_desc with
-        | Ppat_array p1N | Ppat_list p1N | Ppat_tuple p1N | Ppat_cons p1N ->
+        | Ppat_array p1N | Ppat_list p1N | Ppat_cons p1N ->
             assert (List.exists p1N ~f)
+        | Ppat_tuple (p1N, _) ->
+            assert (List.exists p1N ~f:(fun (_, p) -> f p))
         | Ppat_record (p1N, _) ->
             assert (List.exists p1N ~f:(fun (_, _, x) -> Option.exists x ~f))
         | Ppat_or l -> assert (List.exists ~f:(fun p -> p == pat) l)
@@ -1484,7 +1487,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:(fun (_, e) -> f e))
+        | 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)
@@ -1609,8 +1613,11 @@ 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_array e1N | Pexp_list e1N ->
         List.for_all e1N ~f:Exp.is_trivial && fit_margin c (width xexp)
+    | Pexp_tuple e1N ->
+        List.for_all e1N ~f:(fun (_, e) -> Exp.is_trivial e)
+        && fit_margin c (width xexp)
     | Pexp_record (e1N, e0) ->
         Option.for_all e0 ~f:Exp.is_trivial
         && List.for_all e1N ~f:(fun (_, c, eo) ->
@@ -1731,8 +1738,19 @@ end = struct
         Exp.maybe_extension ctx prec_ctx_extension
         @@ fun () ->
         match pexp_desc with
-        | Pexp_tuple (e0 :: _) ->
-            Some (Comma, if exp == e0 then Left else Right)
+        | Pexp_tuple ((_, e0) :: _ as exps) ->
+            (* Jane Street: Here we pretend tuple elements with labels have
+               the same precedence as function arguments, because they need
+               to be parenthesized in the same cases. *)
+            let lr = if exp == e0 then Left else Right in
+            let prec =
+              List.find_map exps ~f:(fun (l, e) ->
+                  if exp == e then
+                    match l with Some _ -> Some Apply | None -> Some Comma
+                  else None )
+            in
+            let prec = match prec with Some p -> p | None -> Comma in
+            Some (prec, lr)
         | Pexp_cons l ->
             Some (ColonColon, if exp == List.last_exn l then Right else Left)
         | Pexp_construct
@@ -1953,6 +1971,10 @@ end = struct
         true
     | {ast= {ptyp_desc= Ptyp_var (_, l); _}; ctx= _} when Option.is_some l ->
         true
+    | { ast= {ptyp_desc= Ptyp_tuple ((Some _, _) :: _); _}
+      ; ctx= Typ {ptyp_desc= Ptyp_arrow (args, _); _} }
+      when List.exists args ~f:(fun arg -> arg.pap_type == typ) ->
+        true
     | _ -> (
       match ambig_prec (sub_ast ~ctx (Typ typ)) with
       | `Ambiguous -> true
@@ -2171,7 +2193,7 @@ end = struct
           when match cls with Then -> true | _ -> false ->
             true
         | 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)
@@ -2260,7 +2282,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)
@@ -2286,7 +2308,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

diff --git a/lib/Exposed.ml b/lib/Exposed.ml
@@ -15,7 +15,10 @@ 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 -> (
+      match List.hd_exn l with
+      | Some _, _ -> false
+      | None, typ -> core_type typ )
     | Ptyp_object _ -> true
     | Ptyp_alias (typ, _) -> core_type typ
     | _ -> false
@@ -29,7 +32,10 @@ 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 -> (
+        match List.last_exn l with
+        | Some _, _ -> false
+        | None, typ -> core_type typ )
       | Ptyp_object _ -> true
       | _ -> false )
 

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
@@ -934,7 +934,9 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
       hvbox 0
         (wrap_if parenze_constraint_ctx "(" ")"
            (wrap_fits_breaks_if ~space:false c.conf parens "(" ")"
-              (list typs "@ * " (sub_typ ~ctx >> fmt_core_type c)) ) )
+              (list typs "@ * " (fun (lbl, typ) ->
+                   let typ = sub_typ ~ctx typ in
+                   fmt_labeled_tuple_type c lbl typ ) ) ) )
   | Ptyp_var s -> fmt_type_var ~have_tick:true c s
   | Ptyp_variant (rfs, flag, lbls) ->
       let row_fields rfs =
@@ -1031,6 +1033,12 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
            (sub_typ ~ctx >> fmt_core_type c) )
       $ fmt "@ " $ fmt_longident_loc c lid $ char '#'
 
+and fmt_labeled_tuple_type c lbl xtyp =
+  match lbl with
+  | None -> fmt_core_type c xtyp
+  | Some s ->
+      hvbox 0 (Cmts.fmt c s.loc (str s.txt) $ str ":" $ fmt_core_type c xtyp)
+
 and fmt_package_type c ctx cnstrs =
   let fmt_cstr ~first ~last:_ (lid, typ) =
     fmt_or first "@;<1 0>" "@;<1 1>"
@@ -1126,14 +1134,48 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
                      "( " " )" (str txt) ) ) ) )
   | Ppat_constant const -> fmt_constant c const
   | Ppat_interval (l, u) -> fmt_constant c l $ str " .. " $ fmt_constant c u
-  | Ppat_tuple pats ->
+  | Ppat_tuple (pats, oc) ->
       let parens =
         parens || Poly.(c.conf.fmt_opts.parens_tuple_patterns.v = `Always)
       in
+      let fmt_lt_pat_element (lbl, pat) =
+        let pat = sub_pat ~ctx pat in
+        match lbl with
+        | None -> fmt_pattern c pat
+        | Some lbl ->
+            let punned =
+              match pat.ast.ppat_desc with
+              | Ppat_var var ->
+                  String.equal var.txt lbl.txt
+                  && List.is_empty pat.ast.ppat_attributes
+              | _ -> false
+            in
+            let punned_with_constraint =
+              match pat.ast.ppat_desc with
+              | Ppat_constraint ({ppat_desc= Ppat_var var; _}, _) ->
+                  String.equal var.txt lbl.txt
+                  && List.is_empty pat.ast.ppat_attributes
+              | _ -> false
+            in
+            if punned then
+              Cmts.fmt c lbl.loc
+              @@ Cmts.fmt c pat.ast.ppat_loc
+              @@ hovbox 0 (str "~" $ str lbl.txt)
+            else if punned_with_constraint then
+              Cmts.fmt c lbl.loc @@ (str "~" $ fmt_pattern c pat)
+            else str "~" $ str lbl.txt $ str ":" $ fmt_pattern c pat
+      in
+      let fmt_elements =
+        list pats (Params.comma_sep c.conf) fmt_lt_pat_element
+      in
+      let fmt_oc =
+        match oc with
+        | Closed -> noop
+        | Open -> fmt (Params.comma_sep c.conf) $ str ".."
+      in
       hvbox 0
         (Params.wrap_tuple ~parens ~no_parens_if_break:false c.conf
-           (list pats (Params.comma_sep c.conf)
-              (sub_pat ~ctx >> fmt_pattern c) ) )
+           (fmt_elements $ fmt_oc) )
   | Ppat_construct ({txt= Lident (("()" | "[]") as txt); loc}, None) ->
       let opn = txt.[0] and cls = txt.[1] in
       Cmts.fmt c loc
@@ -2768,14 +2810,41 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
       in
       let outer_wrap = has_attr && parens in
       let inner_wrap = has_attr || parens in
+      let fmt_lt_exp_element (lbl, exp) =
+        let exp = sub_exp ~ctx exp in
+        match lbl with
+        | None -> fmt_expression c exp
+        | Some lbl ->
+            let punned =
+              match exp.ast.pexp_desc with
+              | Pexp_ident {txt= Lident var; _} ->
+                  String.equal lbl.txt var
+                  && List.is_empty exp.ast.pexp_attributes
+              | _ -> false
+            in
+            let punned_with_constraint =
+              match exp.ast.pexp_desc with
+              | Pexp_constraint
+                  ({pexp_desc= Pexp_ident {txt= Lident var; _}; _}, _) ->
+                  String.equal var lbl.txt
+                  && List.is_empty exp.ast.pexp_attributes
+              | _ -> false
+            in
+            if punned then
+              Cmts.fmt c lbl.loc
+              @@ Cmts.fmt c exp.ast.pexp_loc
+              @@ hovbox 0 (str "~" $ str lbl.txt)
+            else if punned_with_constraint then
+              Cmts.fmt c lbl.loc @@ (str "~" $ fmt_expression c exp)
+            else str "~" $ str lbl.txt $ str ":" $ fmt_expression c exp
+      in
       pro
       $ hvbox_if outer_wrap 0
           (Params.parens_if outer_wrap c.conf
              ( hvbox 0
                  (Params.wrap_tuple ~parens:inner_wrap ~no_parens_if_break
                     c.conf
-                    (list es (Params.comma_sep c.conf)
-                       (sub_exp ~ctx >> fmt_expression c) ) )
+                    (list es (Params.comma_sep c.conf) fmt_lt_exp_element) )
              $ fmt_atrs ) )
   | Pexp_lazy e ->
       pro

diff --git a/test/passing/dune.inc b/test/passing/dune.inc
@@ -3356,6 +3356,78 @@
  (package ocamlformat)
  (action (diff tests/label_option_default_args.ml.err label_option_default_args.ml.stderr)))
 
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to labeled_tuple_patterns.ml.stdout
+   (with-stderr-to labeled_tuple_patterns.ml.stderr
+     (run %{bin:ocamlformat} --margin-check --profile=janestreet --max-iters=3 %{dep:tests/labeled_tuple_patterns.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/labeled_tuple_patterns.ml labeled_tuple_patterns.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/labeled_tuple_patterns.ml.err labeled_tuple_patterns.ml.stderr)))
+
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to labeled_tuples.ml.stdout
+   (with-stderr-to labeled_tuples.ml.stderr
+     (run %{bin:ocamlformat} --margin-check --profile=janestreet --max-iters=3 %{dep:tests/labeled_tuples.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/labeled_tuples.ml labeled_tuples.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/labeled_tuples.ml.err labeled_tuples.ml.stderr)))
+
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to labeled_tuples_cmts_attrs.ml.stdout
+   (with-stderr-to labeled_tuples_cmts_attrs.ml.stderr
+     (run %{bin:ocamlformat} --margin-check --profile=janestreet --max-iters=3 %{dep:tests/labeled_tuples_cmts_attrs.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/labeled_tuples_cmts_attrs.ml labeled_tuples_cmts_attrs.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/labeled_tuples_cmts_attrs.ml.err labeled_tuples_cmts_attrs.ml.stderr)))
+
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to labeled_tuples_cmts_attrs_move.ml.stdout
+   (with-stderr-to labeled_tuples_cmts_attrs_move.ml.stderr
+     (run %{bin:ocamlformat} --margin-check --profile=janestreet --max-iters=3 %{dep:tests/labeled_tuples_cmts_attrs_move.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/labeled_tuples_cmts_attrs_move.ml.ref labeled_tuples_cmts_attrs_move.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/labeled_tuples_cmts_attrs_move.ml.err labeled_tuples_cmts_attrs_move.ml.stderr)))
+
 (rule
  (deps tests/.ocamlformat )
  (package ocamlformat)