From 77fc6a7ea34ab38ecdf3445cf9021f47b7a04f33 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Mon, 4 Dec 2023 16:27:46 -0500
Subject: [PATCH 01/22] parser-standard updates for labeled tuples

---
 vendor/parser-standard/jane_syntax.ml         | 142 ++++++++
 vendor/parser-standard/jane_syntax.mli        |  55 +++
 vendor/parser-standard/language_extension.ml  |   6 +-
 vendor/parser-standard/language_extension.mli |   1 +
 .../language_extension_kernel.ml              |   5 +
 .../language_extension_kernel.mli             |   1 +
 vendor/parser-standard/parser.mly             | 316 ++++++++++++++++--
 7 files changed, 493 insertions(+), 33 deletions(-)

diff --git a/vendor/parser-standard/jane_syntax.ml b/vendor/parser-standard/jane_syntax.ml
index f15dc7c98e..f7595f47ae 100644
--- a/vendor/parser-standard/jane_syntax.ml
+++ b/vendor/parser-standard/jane_syntax.ml
@@ -567,6 +567,136 @@ module Immutable_arrays = struct
     | _ -> failwith "Malformed immutable array pattern"
 end
 
+(** Labeled tuples *)
+module Labeled_tuples = struct
+  module Ext = struct
+    let feature : Feature.t = Language_extension Labeled_tuples
+  end
+
+  include Ext
+
+  type nonrec core_type = Lttyp_tuple of (string option * core_type) list
+
+  type nonrec expression = Ltexp_tuple of (string option * expression) list
+
+  type nonrec pattern =
+    | Ltpat_tuple of (string option * pattern) list * closed_flag
+
+  let string_of_label = function None -> "" | Some lbl -> lbl
+
+  let label_of_string = function "" -> None | s -> Some s
+
+  let string_of_closed_flag = function Closed -> "closed" | Open -> "open"
+
+  let closed_flag_of_string = function
+    | "closed" -> Closed
+    | "open" -> Open
+    | _ -> failwith "bad closed flag"
+
+  module Desugaring_error = struct
+    type error =
+      | Malformed
+      | Has_payload of payload
+
+    let report_error ~loc = function
+      | Malformed ->
+        Location.errorf ~loc "Malformed embedded labeled tuple term"
+      | Has_payload payload ->
+        Location.errorf ~loc
+          "Labeled tuples attribute has an unexpected payload:@;%a"
+          (Printast.payload 0) payload
+
+    exception Error of Location.t * error
+
+    let () =
+      Location.register_error_of_exn (function
+        | Error (loc, err) -> Some (report_error ~loc err)
+        | _ -> None)
+
+    let raise loc err = raise (Error (loc, err))
+  end
+
+  let typ_of ~loc ~attrs = function
+    | Lttyp_tuple tl ->
+      (* See Note [Wrapping with make_entire_jane_syntax] *)
+      Core_type.make_entire_jane_syntax ~loc feature (fun () ->
+          let names = List.map (fun (label, _) -> string_of_label label) tl in
+          Core_type.make_jane_syntax feature names
+          @@ Core_type.add_attributes attrs
+               (Ast_helper.Typ.tuple (List.map snd tl)))
+
+  (* Returns remaining unconsumed attributes *)
+  let of_typ typ =
+    let loc = typ.ptyp_loc in
+    let typ, labels, payload =
+      Core_type.match_payload_jane_syntax feature typ
+    in
+    match typ.ptyp_desc, payload with
+    | Ptyp_tuple components, PStr [] ->
+      if List.length labels <> List.length components
+      then Desugaring_error.raise typ.ptyp_loc Malformed;
+      let labeled_components =
+        List.map2 (fun s t -> label_of_string s, t) labels components
+      in
+      Lttyp_tuple labeled_components
+    | _, PStr [] -> Desugaring_error.raise loc Malformed
+    | _, _ -> Desugaring_error.raise loc (Has_payload payload)
+
+  let expr_of ~loc ~attrs = function
+    | Ltexp_tuple el ->
+      (* See Note [Wrapping with make_entire_jane_syntax] *)
+      Expression.make_entire_jane_syntax ~loc feature (fun () ->
+          let names = List.map (fun (label, _) -> string_of_label label) el in
+          Expression.make_jane_syntax feature names
+          @@ Expression.add_attributes attrs
+               (Ast_helper.Exp.tuple (List.map snd el)))
+
+  (* Returns remaining unconsumed attributes *)
+  let of_expr expr =
+    let loc = expr.pexp_loc in
+    let expr, labels, payload =
+      Expression.match_payload_jane_syntax feature expr
+    in
+    match expr.pexp_desc, payload with
+    | Pexp_tuple components, PStr [] ->
+      if List.length labels <> List.length components
+      then Desugaring_error.raise expr.pexp_loc Malformed;
+      let labeled_components =
+        List.map2 (fun s e -> label_of_string s, e) labels components
+      in
+      Ltexp_tuple labeled_components
+    | _, PStr [] -> Desugaring_error.raise expr.pexp_loc Malformed
+    | _, _ -> Desugaring_error.raise loc (Has_payload payload)
+
+  let pat_of ~loc ~attrs = function
+    | Ltpat_tuple (pl, closed) ->
+      (* See Note [Wrapping with make_entire_jane_syntax] *)
+      Pattern.make_entire_jane_syntax ~loc feature (fun () ->
+          let names = List.map (fun (label, _) -> string_of_label label) pl in
+          Pattern.make_jane_syntax feature
+            (string_of_closed_flag closed :: names)
+          @@ Pattern.add_attributes attrs
+               (Ast_helper.Pat.tuple (List.map snd pl)))
+
+  (* Returns remaining unconsumed attributes *)
+  let of_pat pat =
+    let loc = pat.ppat_loc in
+    let pat, labels, payload =
+      Pattern.match_payload_jane_syntax feature pat
+    in
+    match labels, pat.ppat_desc, payload with
+    | closed :: labels, Ppat_tuple components, PStr [] ->
+      if List.length labels <> List.length components
+      then Desugaring_error.raise pat.ppat_loc Malformed;
+      let closed = closed_flag_of_string closed in
+      let labeled_components =
+        List.map2 (fun s e -> label_of_string s, e) labels components
+      in
+      Ltpat_tuple (labeled_components, closed)
+    | _, _, PStr [] -> Desugaring_error.raise pat.ppat_loc Malformed
+    | _, _, _ -> Desugaring_error.raise loc (Has_payload payload)
+end
+
 (** [include functor] *)
 module Include_functor = struct
   type signature_item =
@@ -1041,10 +1171,13 @@ module Core_type = struct
   type t =
     | Jtyp_local of Local.core_type
     | Jtyp_layout of Layouts.core_type
+    | Jtyp_tuple of Labeled_tuples.core_type
 
   let of_ast_internal (feat : Feature.t) typ = match feat with
     | Language_extension Local -> Some (Jtyp_local (Local.of_type typ))
     | Language_extension Layouts -> Some (Jtyp_layout (Layouts.of_type typ))
+    | Language_extension Labeled_tuples ->
+      Some (Jtyp_tuple (Labeled_tuples.of_typ typ))
     | _ -> None
 
   let of_ast = Core_type.make_of_ast ~of_ast_internal
@@ -1053,6 +1186,7 @@ module Core_type = struct
     match jtyp with
     | Jtyp_local x -> Local.type_of ~loc ~attrs x
     | Jtyp_layout x -> Layouts.type_of ~loc ~attrs x
+    | Jtyp_tuple x -> Labeled_tuples.typ_of ~loc ~attrs x
 end
 
 module Constructor_argument = struct
@@ -1075,6 +1209,7 @@ module Expression = struct
     | Jexp_comprehension   of Comprehensions.expression
     | Jexp_immutable_array of Immutable_arrays.expression
     | Jexp_layout of Layouts.expression
+    | Jexp_tuple of Labeled_tuples.expression
 
   let of_ast_internal (feat : Feature.t) expr = match feat with
     | Language_extension Local ->
@@ -1084,6 +1219,8 @@ module Expression = struct
     | Language_extension Immutable_arrays ->
       Some (Jexp_immutable_array (Immutable_arrays.of_expr expr))
     | Language_extension Layouts -> Some (Jexp_layout (Layouts.of_expr expr))
+    | Language_extension Labeled_tuples ->
+      Some (Jexp_tuple (Labeled_tuples.of_expr expr))
     | _ -> None
 
   let of_ast = Expression.make_of_ast ~of_ast_internal
@@ -1093,6 +1230,7 @@ module Expression = struct
     | Jexp_comprehension    x -> Comprehensions.expr_of    ~loc ~attrs x
     | Jexp_immutable_array  x -> Immutable_arrays.expr_of  ~loc ~attrs x
     | Jexp_layout x -> Layouts.expr_of ~loc ~attrs x
+    | Jexp_tuple x -> Labeled_tuples.expr_of ~loc ~attrs x
 end
 
 module Pattern = struct
@@ -1100,6 +1238,7 @@ module Pattern = struct
     | Jpat_local           of Local.pattern
     | Jpat_immutable_array of Immutable_arrays.pattern
     | Jpat_layout of Layouts.pattern
+    | Jpat_tuple of Labeled_tuples.pattern
 
   let of_ast_internal (feat : Feature.t) pat = match feat with
     | Language_extension Local ->
@@ -1108,6 +1247,8 @@ module Pattern = struct
       Some (Jpat_immutable_array (Immutable_arrays.of_pat pat))
     | Language_extension Layouts ->
       Some (Jpat_layout (Layouts.of_pat pat))
+    | Language_extension Labeled_tuples ->
+      Some (Jpat_tuple (Labeled_tuples.of_pat pat))
     | _ -> None
 
   let of_ast = Pattern.make_of_ast ~of_ast_internal
@@ -1116,6 +1257,7 @@ module Pattern = struct
     | Jpat_local x -> Local.pat_of ~loc ~attrs x
     | Jpat_immutable_array x -> Immutable_arrays.pat_of ~loc ~attrs x
     | Jpat_layout x -> Layouts.pat_of ~loc ~attrs x
+    | Jpat_tuple x -> Labeled_tuples.pat_of ~loc ~attrs x
 end
 
 module Module_type = struct
diff --git a/vendor/parser-standard/jane_syntax.mli b/vendor/parser-standard/jane_syntax.mli
index a12cc85929..14484779a1 100644
--- a/vendor/parser-standard/jane_syntax.mli
+++ b/vendor/parser-standard/jane_syntax.mli
@@ -165,6 +165,58 @@ module Immutable_arrays : sig
     pattern -> Parsetree.pattern
 end
 
+
+(** The ASTs for labeled tuples. When we merge this upstream, we'll replace
+    existing [P{typ,exp,pat}_tuple] constructors with these. *)
+module Labeled_tuples : sig
+  type core_type =
+    | Lttyp_tuple of (string option * Parsetree.core_type) list
+        (** [Lttyp_tuple(tl)] represents a product type:
+          - [T1 * ... * Tn]       when [tl] is [(None,T1);...;(None,Tn)]
+          - [L1:T1 * ... * Ln:Tn] when [tl] is [(Some L1,T1);...;(Some Ln,Tn)]
+          - A mix, e.g. [L1:T1,T2] when [tl] is [(Some L1,T1);(None,T2)]
+
+          Invariant: [n >= 2] and there is at least one label.
+      *)
+
+  type expression =
+    | Ltexp_tuple of (string option * Parsetree.expression) list
+        (** [Ltexp_tuple(el)] represents
+          - [(E1, ..., En)]
+              when [el] is [(None, E1);...;(None, En)]
+          - [(~L1:E1, ..., ~Ln:En)]
+              when [el] is [(Some L1, E1);...;(Some Ln, En)]
+          - A mix, e.g.:
+              [(~L1:E1, E2)] when [el] is [(Some L1, E1); (None, E2)]
+
+          Invariant: [n >= 2] and there is at least one label.
+      *)
+
+  type pattern =
+    | Ltpat_tuple of
+        (string option * Parsetree.pattern) list * Asttypes.closed_flag
+        (** [Ltpat_tuple(pl, Closed)] represents
+          - [(P1, ..., Pn)]       when [pl] is [(None, P1);...;(None, Pn)]
+          - [(L1:P1, ..., Ln:Pn)] when [pl] is
+                                              [(Some L1, P1);...;(Some Ln, Pn)]
+          - A mix, e.g. [(L1:P1, P2)] when [pl] is [(Some L1, P1);(None, P2)]
+          - If pattern is open, then it also ends in a [..]
+
+        Invariant:
+        - If Closed, [n >= 2] and there is at least one label.
+        - If Open, [n >= 1]
+      *)
+
+  val typ_of : loc:Location.t -> attrs:Parsetree.attributes
+    -> core_type -> Parsetree.core_type
+
+  val expr_of : loc:Location.t -> attrs:Parsetree.attributes
+     -> expression -> Parsetree.expression
+
+  val pat_of : loc:Location.t -> attrs:Parsetree.attributes
+     -> pattern -> Parsetree.pattern
+end
+
 (** The ASTs for [include functor].  When we merge this upstream, we'll merge
     these into the existing [P{sig,str}_include] constructors (similar to what
     we did with [T{sig,str}_include], but without depending on typechecking). *)
@@ -389,6 +441,7 @@ module Core_type : sig
   type t =
     | Jtyp_local of Local.core_type
     | Jtyp_layout of Layouts.core_type
+    | Jtyp_tuple of Labeled_tuples.core_type
 
   include AST
     with type t := t * Parsetree.attributes
@@ -415,6 +468,7 @@ module Expression : sig
     | Jexp_comprehension    of Comprehensions.expression
     | Jexp_immutable_array  of Immutable_arrays.expression
     | Jexp_layout of Layouts.expression
+    | Jexp_tuple of Labeled_tuples.expression
 
   include AST
     with type t := t * Parsetree.attributes
@@ -427,6 +481,7 @@ module Pattern : sig
     | Jpat_local           of Local.pattern
     | Jpat_immutable_array of Immutable_arrays.pattern
     | Jpat_layout of Layouts.pattern
+    | Jpat_tuple of Labeled_tuples.pattern
 
   include AST
     with type t := t * Parsetree.attributes
diff --git a/vendor/parser-standard/language_extension.ml b/vendor/parser-standard/language_extension.ml
index 141e8b7f7b..cfb951a7b3 100644
--- a/vendor/parser-standard/language_extension.ml
+++ b/vendor/parser-standard/language_extension.ml
@@ -51,6 +51,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
   | Module_strengthening -> (module Unit)
   | Layouts -> (module Maturity)
   | SIMD -> (module Unit)
+  | Labeled_tuples -> (module Unit)
 
 type extn_pair = Exist_pair.t = Pair : 'a t * 'a -> extn_pair
 type exist = Exist.t = Pack : _ t -> exist
@@ -75,8 +76,10 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = match a, b
   | Module_strengthening, Module_strengthening -> Some Refl
   | Layouts, Layouts -> Some Refl
   | SIMD, SIMD -> Some Refl
+  | Labeled_tuples, Labeled_tuples -> Some Refl
   | (Comprehensions | Local | Include_functor | Polymorphic_parameters |
-     Immutable_arrays | Module_strengthening | Layouts | SIMD), _ -> None
+     Immutable_arrays | Module_strengthening | Layouts | SIMD |
+     Labeled_tuples ), _ -> None
 
 let equal a b = Option.is_some (equal_t a b)
 
@@ -171,6 +174,7 @@ let default_extensions : extn_pair list =
   [ Pair (Local, ())
   ; Pair (Include_functor, ())
   ; Pair (Polymorphic_parameters, ())
+  ; Pair (Labeled_tuples, ())
   ]
 let extensions : extn_pair list ref = ref default_extensions
 
diff --git a/vendor/parser-standard/language_extension.mli b/vendor/parser-standard/language_extension.mli
index e685e34959..ae7b3da4ed 100644
--- a/vendor/parser-standard/language_extension.mli
+++ b/vendor/parser-standard/language_extension.mli
@@ -17,6 +17,7 @@ type 'a t = 'a Language_extension_kernel.t =
   | Module_strengthening : unit t
   | Layouts : maturity t
   | SIMD : unit t
+  | Labeled_tuples : unit t
 
 (** Existentially packed language extension *)
 module Exist : sig
diff --git a/vendor/parser-standard/language_extension_kernel.ml b/vendor/parser-standard/language_extension_kernel.ml
index eae564c13d..41de716572 100644
--- a/vendor/parser-standard/language_extension_kernel.ml
+++ b/vendor/parser-standard/language_extension_kernel.ml
@@ -10,6 +10,7 @@ type _ t =
   | Module_strengthening : unit t
   | Layouts : maturity t
   | SIMD : unit t
+  | Labeled_tuples : unit t
 
 type 'a language_extension_kernel = 'a t
 
@@ -25,6 +26,7 @@ module Exist = struct
     ; Pack Module_strengthening
     ; Pack Layouts
     ; Pack SIMD
+    ; Pack Labeled_tuples
     ]
 end
 
@@ -42,6 +44,7 @@ let to_string : type a. a t -> string = function
   | Module_strengthening -> "module_strengthening"
   | Layouts -> "layouts"
   | SIMD -> "simd"
+  | Labeled_tuples -> "labeled_tuples"
 
 (* converts full extension names, like "layouts_alpha" to a pair of
    an extension and its maturity. For extensions that don't take an
@@ -59,6 +62,7 @@ let pair_of_string extn_name : Exist_pair.t option =
   | "layouts_alpha" -> Some (Pair (Layouts, Alpha))
   | "layouts_beta" -> Some (Pair (Layouts, Beta))
   | "simd" -> Some (Pair (SIMD, ()))
+  | "labeled_tuples" -> Some (Pair (Labeled_tuples, ()))
   | _ -> None
 
 let maturity_to_string = function
@@ -88,6 +92,7 @@ let is_erasable : type a. a t -> bool = function
   | Polymorphic_parameters
   | Immutable_arrays
   | Module_strengthening
+  | Labeled_tuples
   | SIMD ->
       false
 
diff --git a/vendor/parser-standard/language_extension_kernel.mli b/vendor/parser-standard/language_extension_kernel.mli
index 7ccbd98160..9d115aae81 100644
--- a/vendor/parser-standard/language_extension_kernel.mli
+++ b/vendor/parser-standard/language_extension_kernel.mli
@@ -19,6 +19,7 @@ type _ t =
   | Module_strengthening : unit t
   | Layouts : maturity t
   | SIMD : unit t
+  | Labeled_tuples : unit t
 
 module Exist : sig
   type 'a extn = 'a t
diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly
index a90fafc537..108a49ecc6 100644
--- a/vendor/parser-standard/parser.mly
+++ b/vendor/parser-standard/parser.mly
@@ -178,6 +178,16 @@ let local_if : type ast. ast Local_syntax_category.t -> _ -> _ -> ast -> ast =
   else
     x
 
+let local_if_has_flags flags sloc x =
+  (* Jane Street: This is horrible temporary code until we properly add
+     support for more modes. *)
+  let is_local =
+    match flags with
+    | [] -> false
+    | _ :: _ -> true
+  in
+  local_if Type is_local sloc x
+
 let global_if global_flag sloc carg =
   match global_flag with
   | Global ->
@@ -303,6 +313,30 @@ let removed_string_set loc =
   raise(Syntaxerr.Error(Syntaxerr.Removed_string_set(make_loc loc)))
 *)
 
+let ppat_lttuple loc elts closed =
+  Jane_syntax.Labeled_tuples.pat_of
+    ~attrs:[]
+    ~loc:(make_loc loc)
+    (Ltpat_tuple (elts, closed))
+
+let ptyp_lttuple loc tl =
+  Jane_syntax.Labeled_tuples.typ_of
+    ~attrs:[]
+    ~loc:(make_loc loc)
+    (Lttyp_tuple tl)
+
+let mktyp_tuple loc ltys =
+  if List.for_all (fun (lbl, _) -> Option.is_none lbl) ltys then
+    mktyp ~loc (Ptyp_tuple (List.map snd ltys))
+  else
+    ptyp_lttuple loc ltys
+
+let pexp_lttuple loc args =
+  Jane_syntax.Labeled_tuples.expr_of
+    ~attrs:[]
+    ~loc:(make_loc loc)
+    (Ltexp_tuple args)
+
 (* Using the function [not_expecting] in a semantic action means that this
    syntactic form is recognized by the parser but is in fact incorrect. This
    idiom is used in a few places to produce ad hoc syntax error messages. *)
@@ -2540,7 +2574,7 @@ expr:
   | expr_attrs
       { let desc, attrs = $1 in
         mkexp_attrs ~loc:$sloc desc attrs }
-  | mkexp(expr_)
+  | expr_
       { $1 }
   | let_bindings(ext) IN seq_expr
       { expr_of_let_bindings ~loc:$sloc $1 $3 }
@@ -2630,15 +2664,19 @@ expr:
 ;
 %inline expr_:
   | simple_expr nonempty_llist(labeled_simple_expr)
-      { Pexp_apply($1, $2) }
-  | expr_comma_list %prec below_COMMA
-      { Pexp_tuple($1) }
+      { mkexp ~loc:$sloc (Pexp_apply($1, $2)) }
+  | labeled_tuple %prec below_COMMA
+      { if List.for_all (fun (l,_) -> Option.is_none l) $1 then
+          mkexp ~loc:$sloc (Pexp_tuple (List.map snd $1))
+        else
+          pexp_lttuple $sloc $1
+      }
   | mkrhs(constr_longident) simple_expr %prec below_HASH
-      { Pexp_construct($1, Some $2) }
+      { mkexp ~loc:$sloc (Pexp_construct($1, Some $2)) }
   | name_tag simple_expr %prec below_HASH
-      { Pexp_variant($1, Some $2) }
+      { mkexp ~loc:$sloc (Pexp_variant($1, Some $2)) }
   | e1 = expr op = op(infix_operator) e2 = expr
-      { mkinfix e1 op e2 }
+      { mkexp ~loc:$sloc (mkinfix e1 op e2) }
 ;
 
 simple_expr:
@@ -3054,10 +3092,86 @@ fun_def:
   | LPAREN TYPE mkrhs(LIDENT) COLON layout_annotation RPAREN fun_def
       { mk_newtypes ~loc:$sloc [$3, Some $5] $7 }
 ;
-%inline expr_comma_list:
-  es = separated_nontrivial_llist(COMMA, expr)
-    { es }
+
+(* Parsing labeled tuple expressions
+
+   The grammar we want to parse is something like:
+
+     labeled_tuple_element := expr | ~x:expr | ~x | ~(x:ty)
+     labeled_tuple := lt_element [, lt_element]+
+
+   (The last case of [labeled_tuple_element] is a punned label with a type
+   constraint, which is allowed for functions, so we allow it here).
+
+   So you might think [labeled_tuple] could therefore just be:
+
+     labeled_tuple :
+       separated_nontrivial_llist(COMMA, labeled_tuple_element)
+
+   But this doesn't work:
+
+   - If we don't mark [labeled_tuple_element] %inline, this causes many
+     reduce/reduce conflicts (basically just ambiguities) because
+     [labeled_tuple_element] trivially reduces to [expr].
+
+   - If we do mark [labeled_tuple_element] %inline, it is not allowed to have
+     %prec annotations.  Menhir doesn't permit these on %inline non-terminals
+     that are used in non-tail position.
+
+   To get around this, we do mark it inlined, and then because we can only use
+   it in tail position it is _manually_ inlined into the occurrences in
+   [separated_nontrivial_llist] where it doesn't appear in tail position.  This
+   results in [labeled_tuple] and [reversed_labeled_tuple_body] below.  So the
+   latter is just a list of comma-separated labeled tuple elements, with length
+   at least two, where the first element in the base case is inlined (resulting
+   in one base case for each case of [labeled_tuple_element].  *)
+%inline labeled_tuple_element :
+  | expr
+     { None, $1 }
+  | LABEL simple_expr %prec below_HASH
+     { Some $1, $2 }
+  | TILDE label = LIDENT
+     { let loc = $loc(label) in
+       Some label, mkexpvar ~loc label }
+  | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN %prec below_HASH
+      { Some label,
+        mkexp_constraint
+          ~loc:($startpos($2), $endpos) (mkexpvar ~loc:$loc(label) label) ty }
+;
+reversed_labeled_tuple_body:
+  (* > 2 elements *)
+  xs = reversed_labeled_tuple_body
+  COMMA
+  x = labeled_tuple_element
+    { x :: xs }
+  (* base cases (2 elements) *)
+| x1 = expr
+  COMMA
+  x2 = labeled_tuple_element
+    { [ x2; None, x1 ] }
+| l1 = LABEL x1 = simple_expr
+  COMMA
+  x2 = labeled_tuple_element
+    { [ x2; Some l1, x1 ] }
+| TILDE l1 = LIDENT
+  COMMA
+  x2 = labeled_tuple_element
+  { let loc = $loc(l1) in
+    [ x2; Some l1, mkexpvar ~loc l1] }
+| TILDE LPAREN l1 = LIDENT ty1 = type_constraint RPAREN
+  COMMA
+  x2 = labeled_tuple_element
+  { let x1 =
+      mkexp_constraint
+        ~loc:($startpos($2), $endpos) (mkexpvar ~loc:$loc(l1) l1) ty1
+    in
+    [ x2; Some l1, x1] }
+;
+%inline labeled_tuple:
+  xs = rev(reversed_labeled_tuple_body)
+    { xs }
 ;
+
 record_expr_content:
   eo = ioption(terminated(simple_expr, WITH))
   fields = separated_or_terminated_nonempty_list(SEMI, record_expr_field)
@@ -3162,8 +3276,6 @@ pattern_no_exn:
         { Ppat_alias($1, $3) }
     | self AS error
         { expecting $loc($3) "identifier" }
-    | pattern_comma_list(self) %prec below_COMMA
-        { Ppat_tuple(List.rev $1) }
     | self COLONCOLON error
         { expecting $loc($3) "pattern" }
     | self BAR pattern
@@ -3171,8 +3283,71 @@ pattern_no_exn:
     | self BAR error
         { expecting $loc($3) "pattern" }
   ) { $1 }
+  | reversed_labeled_tuple_pattern(self)
+      { let closed, pats = $1 in
+        if    closed = Closed
+           && List.for_all (fun (l,_) -> Option.is_none l) pats
+        then
+          mkpat ~loc:$sloc (Ppat_tuple(List.rev_map snd pats))
+        else
+          ppat_lttuple $sloc (List.rev pats) closed
+      }
 ;
 
+(* Parsing labeled tuple patterns
+
+   Here we play essentially the same game we did for expressions - see the
+   comment beginning "Parsing labeled tuple expressions".
+
+   One difference is that we would need to manually inline the definition of
+   individual elements in two places: Once in the base case for lists 2 or more
+   elements, and once in the special case for open patterns with just one
+   element (e.g., [~x, ..]).  Rather than manually inlining
+   [labeled_tuple_pat_element] twice, we simply define it twice: once with the
+   [%prec] annotations needed for its occurrences in tail position, and once
+   without them suitable for use in other locations.
+*)
+%inline labeled_tuple_pat_element(self):
+  | self { None, $1 }
+  | LABEL simple_pattern %prec COMMA
+      { Some $1, $2 }
+  | TILDE label = LIDENT
+      { let loc = $loc(label) in
+        Some label, mkpatvar ~loc label }
+  | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN %prec COMMA
+      { let loc = $loc(label) in
+        let pat = mkpatvar ~loc label in
+        Some label, mkpat_opt_constraint ~loc pat (Some cty) }
+
+%inline labeled_tuple_pat_element_noprec(self):
+  | self { None, $1 }
+  | LABEL simple_pattern
+      { Some $1, $2 }
+  | TILDE label = LIDENT
+      { let loc = $loc(label) in
+        Some label, mkpatvar ~loc label }
+  | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN
+      { let loc = $loc(label) in
+        let pat = mkpatvar ~loc label in
+        Some label, mkpat_opt_constraint ~loc pat (Some cty) }
+
+labeled_tuple_pat_element_list(self):
+  | labeled_tuple_pat_element_list(self) COMMA labeled_tuple_pat_element(self)
+      { $3 :: $1 }
+  | labeled_tuple_pat_element_noprec(self) COMMA labeled_tuple_pat_element(self)
+      { [ $3; $1 ] }
+  | self COMMA error
+      { expecting $loc($3) "pattern" }
+;
+
+reversed_labeled_tuple_pattern(self):
+  | labeled_tuple_pat_element_list(self) %prec below_COMMA
+      { Closed, $1 }
+  | labeled_tuple_pat_element_list(self) COMMA DOTDOT
+      { Open, $1 }
+  | labeled_tuple_pat_element_noprec(self) COMMA DOTDOT
+      { Open, [ $1 ] }
+
 pattern_gen:
     simple_pattern
       { $1 }
@@ -3274,11 +3449,6 @@ simple_delimited_pattern:
             $1 }
   ) { $1 }
 
-pattern_comma_list(self):
-    pattern_comma_list(self) COMMA pattern      { $3 :: $1 }
-  | self COMMA pattern                          { [$3; $1] }
-  | self COMMA error                            { expecting $loc($3) "pattern" }
-;
 %inline pattern_semi_list:
   ps = separated_or_terminated_nonempty_list(SEMI, pattern)
     { ps }
@@ -3860,35 +4030,95 @@ function_type:
   | ty = tuple_type
     %prec MINUSGREATER
       { ty }
-  | ty = strict_function_type
+  | ty = strict_function_or_labeled_tuple_type
       { ty }
 ;
 
-strict_function_type:
+strict_function_or_labeled_tuple_type:
   | mktyp(
       label = arg_label
-      local = optional_local
+      unique_local = mode_flags
       domain = extra_rhs(param_type)
       MINUSGREATER
-      codomain = strict_function_type
-        { Ptyp_arrow(label, local_if Type local $loc(local) domain, codomain) }
+      codomain = strict_function_or_labeled_tuple_type
+        { Ptyp_arrow(label,
+                     local_if_has_flags unique_local $loc(unique_local) domain,
+                     codomain) }
     )
     { $1 }
   | mktyp(
       label = arg_label
-      arg_local = optional_local
+      arg_local = mode_flags
       domain = extra_rhs(param_type)
       MINUSGREATER
-      ret_local = optional_local
+      ret_local = mode_flags
       codomain = tuple_type
       %prec MINUSGREATER
         { Ptyp_arrow(label,
-            local_if Type arg_local $loc(arg_local) domain,
-            local_if Type ret_local $loc(ret_local)
+            local_if_has_flags arg_local $loc(arg_local) domain,
+            local_if_has_flags ret_local $loc(ret_local)
+              (Jane_syntax.Builtin.mark_curried
+                 ~loc:(make_loc $loc(codomain)) codomain)) }
+    )
+    { $1 }
+  (* These next three cases are for labled tuples - see comment on [tuple_type]
+     below.
+
+     The first two cases are present just to resolve a shift reduce conflict
+     in a module type [S with t := x:t1 * t2 -> ...] which might be the
+     beginning of
+       [S with t := x:t1 * t2 -> S']    or    [S with t := x:t1 * t2 -> t3]
+     They are the same as the previous two cases, but with [arg_label] replaced
+     with the more specific [LIDENT COLON] and [param_type] replaced with the
+     more specific [proper_tuple_type].  Apparently, this is sufficient for
+     menhir to be able to delay a decision about which of the above module type
+     cases we are in.  *)
+  | mktyp(
+      label = LIDENT COLON
+      local = mode_flags
+      tuple = proper_tuple_type
+      MINUSGREATER
+      codomain = strict_function_or_labeled_tuple_type
+         {
+           let ty, ltys = tuple in
+           let label = Labelled label in
+           let domain = mktyp_tuple $loc(tuple) ((None, ty) :: ltys) in
+           let domain = extra_rhs_core_type domain ~pos:$endpos(tuple) in
+           Ptyp_arrow(label, local_if_has_flags local $loc(local) domain , codomain) }
+    )
+    { $1 }
+  | mktyp(
+      label = LIDENT COLON
+      arg_local = mode_flags
+      tuple = proper_tuple_type
+      MINUSGREATER
+      ret_local = mode_flags
+      codomain = tuple_type
+         { let ty, ltys = tuple in
+           let label = Labelled label in
+           let domain = mktyp_tuple $loc(tuple) ((None, ty) :: ltys) in
+           let domain = extra_rhs_core_type domain ~pos:$endpos(tuple) in
+           Ptyp_arrow(label,
+            local_if_has_flags arg_local $loc(arg_local) domain ,
+            local_if_has_flags ret_local $loc(ret_local)
               (Jane_syntax.Builtin.mark_curried
                  ~loc:(make_loc $loc(codomain)) codomain)) }
     )
     { $1 }
+  | label = LIDENT COLON proper_tuple_type %prec MINUSGREATER
+    { let ty, ltys = $3 in
+      ptyp_lttuple $sloc ((Some label, ty) :: ltys)
+    }
+;
+(* jane street: hackily copied and modified from our parser - to be replaced with the
+   exact version from our parser when ocamlformat is updated for uniqueness. *)
+%inline mode_flag:
+   | LOCAL
+       { $sloc }
+;
+%inline mode_flags:
+   | flags = iloption(mode_flag+)
+       { flags }
 ;
 %inline param_type:
   | mktyp_jane_syntax_ltyp(
@@ -3899,11 +4129,15 @@ strict_function_type:
   | ty = tuple_type
     { ty }
 ;
-%inline arg_label:
+%inline strict_arg_label:
   | label = optlabel
       { Optional label }
   | label = LIDENT COLON
       { Labelled label }
+
+%inline arg_label:
+  | strict_arg_label
+      { $1 }
   | /* empty */
       { Nolabel }
 ;
@@ -3917,18 +4151,36 @@ strict_function_type:
    - atomic types (see below);
    - proper tuple types:                  int * int * int list
    A proper tuple type is a star-separated list of at least two atomic types.
+   Tuple components can also be labeled, as an [int * int list * y:bool].
+
+   However, the special case of labeled tuples where the first element has a
+   label is not parsed as a proper_tuple_type, but rather as a case of
+   strict_function_or_labled_tuple_type above.  This helps in dealing with
+   ambiguities around [x:t1 * t2 -> t3] which must continue to parse as a
+   function with one labeled argument even in the presense of labled tuples.
  *)
 tuple_type:
   | ty = atomic_type
     %prec below_HASH
       { ty }
-  | mktyp(
-      tys = separated_nontrivial_llist(STAR, atomic_type)
-        { Ptyp_tuple tys }
-    )
-    { $1 }
+  | proper_tuple_type %prec below_FUNCTOR
+    { let ty, ltys = $1 in
+      mktyp_tuple $sloc ((None, ty) :: ltys)
+    }
 ;
 
+%inline proper_tuple_type:
+  | ty = atomic_type
+    STAR
+    ltys = separated_nonempty_llist(STAR, labeled_tuple_typ_element)
+      { ty, ltys }
+
+%inline labeled_tuple_typ_element :
+  | atomic_type %prec STAR
+     { None, $1 }
+  | label = LIDENT COLON ty = atomic_type %prec STAR
+     { Some label, ty }
+
 (* Atomic types are the most basic level in the syntax of types.
    Atomic types include:
    - types between parentheses:           (int -> int)

From 1ad0af00544cf78ff18b492a453cb263e2f12589 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Tue, 5 Dec 2023 13:13:05 -0500
Subject: [PATCH 02/22] initial pass at all -extended stuff except parser

---
 lib/Ast.ml                                   | 25 +++++++---
 lib/Exposed.ml                               | 12 ++++-
 lib/Fmt_ast.ml                               | 52 +++++++++++++++++---
 vendor/parser-extended/ast_helper.ml         |  2 +-
 vendor/parser-extended/ast_mapper.ml         |  9 ++--
 vendor/parser-extended/extensions.ml         |  6 +--
 vendor/parser-extended/extensions_parsing.ml | 18 +++++--
 vendor/parser-extended/parsetree.mli         | 45 +++++++++++------
 vendor/parser-extended/printast.ml           | 33 +++++++++++--
 9 files changed, 157 insertions(+), 45 deletions(-)

diff --git a/lib/Ast.ml b/lib/Ast.ml
index 9500c173d3..cb02c350dc 100644
--- a/lib/Ast.ml
+++ b/lib/Ast.ml
@@ -960,7 +960,9 @@ 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 +1319,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 +1488,9 @@ 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 +1615,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,7 +1740,7 @@ end = struct
         Exp.maybe_extension ctx prec_ctx_extension
         @@ fun () ->
         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)
@@ -2171,7 +2180,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 +2269,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 +2295,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
index 60cba319f9..45bea715a8 100644
--- a/lib/Exposed.ml
+++ b/lib/Exposed.ml
@@ -15,7 +15,11 @@ 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 -> begin
+        match List.hd_exn l with
+        | Some _, _ -> false
+        | None, typ -> core_type typ
+      end
     | Ptyp_object _ -> true
     | Ptyp_alias (typ, _) -> core_type typ
     | _ -> false
@@ -29,7 +33,11 @@ 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 -> begin
+          match List.last_exn l with
+          | Some _, _ -> false
+          | None, typ -> core_type typ
+        end
       | Ptyp_object _ -> true
       | _ -> false )
 
diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index 774ab73f56..391ad348cf 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -931,10 +931,14 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
         $ fmt ".@ "
         $ fmt_core_type c ~box:true (sub_typ ~ctx t) )
   | Ptyp_tuple typs ->
+      (* XXX surely will need to tweak this for more parens in labeled case *)
       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 +1035,15 @@ 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 -> begin
+      str s
+      $ str ":"
+      $ fmt_core_type c xtyp
+    end
+
 and fmt_package_type c ctx cnstrs =
   let fmt_cstr ~first ~last:_ (lid, typ) =
     fmt_or first "@;<1 0>" "@;<1 1>"
@@ -1126,14 +1139,30 @@ 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 ->
+           (  str "~"
+            $ str lbl
+            $ 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
@@ -1338,6 +1367,8 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
         $ wrap_k (str opn) (str cls)
             (fmt "@;<0 2>" $ fmt_pattern c (sub_pat ~ctx pat)) )
 
+
+
 and fmt_pattern_extension ~ext:_ c ~pro:_ ~parens:_ ~box:_ ~ctx0 ~ctx
     ~ppat_loc : Extensions.Pattern.t -> _ = function
   | Epat_immutable_array (Iapat_immutable_array []) ->
@@ -2768,14 +2799,23 @@ 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 ->
+           (  str "~"
+            $ str lbl
+            $ 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/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml
index 1104d92da4..ef0bec57e9 100644
--- a/vendor/parser-extended/ast_helper.ml
+++ b/vendor/parser-extended/ast_helper.ml
@@ -98,7 +98,7 @@ module Pat = struct
   let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b))
   let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a)
   let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b))
-  let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a)
+  let tuple ?loc ?attrs a b = mk ?loc ?attrs (Ppat_tuple (a, b))
   let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b))
   let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b))
   let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b))
diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml
index 61ea76d353..c5a79c198a 100644
--- a/vendor/parser-extended/ast_mapper.ml
+++ b/vendor/parser-extended/ast_mapper.ml
@@ -204,7 +204,8 @@ module T = struct
     | Ptyp_arrow (params, t2) ->
         arrow ~loc ~attrs (List.map (map_arrow_param sub) params)
           (sub.typ sub t2)
-    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
+    | Ptyp_tuple tyl ->
+        tuple ~loc ~attrs (List.map (fun (lbl, t) -> lbl, sub.typ sub t) tyl)
     | Ptyp_constr (lid, tl) ->
         constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
     | Ptyp_object (l, o) ->
@@ -535,7 +536,8 @@ module E = struct
     | Pexp_match (e, pel) ->
         match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
     | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
-    | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el)
+    | Pexp_tuple el ->
+        tuple ~loc ~attrs (List.map (fun (lbl, e) -> lbl, sub.expr sub e) el)
     | Pexp_construct (lid, arg) ->
         construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
     | Pexp_variant (lab, eo) ->
@@ -657,7 +659,8 @@ module P = struct
     | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c)
     | Ppat_interval (c1, c2) ->
         interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2)
-    | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl)
+    | Ppat_tuple (pl, oc) ->
+        tuple ~loc ~attrs (List.map (fun (lbl, p) -> lbl, sub.pat sub p) pl) oc
     | Ppat_construct (l, p) ->
         construct ~loc ~attrs (map_loc sub l)
           (map_opt
diff --git a/vendor/parser-extended/extensions.ml b/vendor/parser-extended/extensions.ml
index b24277acd0..3113e0fcf1 100644
--- a/vendor/parser-extended/extensions.ml
+++ b/vendor/parser-extended/extensions.ml
@@ -106,7 +106,7 @@ module Comprehensions = struct
           ; match direction with
             | Upto   -> "upto"
             | Downto -> "downto" ]
-          (Ast_helper.Exp.tuple [start; stop])
+          (Ast_helper.Exp.tuple [None, start; None, stop])
     | In seq ->
         comprehension_expr ~loc ["for"; "in"] seq
 
@@ -219,10 +219,10 @@ module Comprehensions = struct
   let iterator_of_expr expr =
     match expand_comprehension_extension_expr expr with
     | ["for"; "range"; "upto"],
-      { pexp_desc = Pexp_tuple [start; stop]; _ } ->
+      { pexp_desc = Pexp_tuple [None, start; None, stop]; _ } ->
         Range { start; stop; direction = Upto }
     | ["for"; "range"; "downto"],
-      { pexp_desc = Pexp_tuple [start; stop]; _ } ->
+      { pexp_desc = Pexp_tuple [None, start; None, stop]; _ } ->
         Range { start; stop; direction = Downto }
     | ["for"; "in"], seq ->
         In seq
diff --git a/vendor/parser-extended/extensions_parsing.ml b/vendor/parser-extended/extensions_parsing.ml
index 824719e230..53b7d1ac6e 100644
--- a/vendor/parser-extended/extensions_parsing.ml
+++ b/vendor/parser-extended/extensions_parsing.ml
@@ -290,12 +290,24 @@ module Pattern = Make_AST(struct
   let make_extension_node = Ast_helper.Pat.extension
 
   let make_extension_use ~loc ~extension_node pat =
-    Ast_helper.Pat.tuple ~loc [extension_node; pat]
+    Ast_helper.Pat.tuple ~loc [None, extension_node; None, pat] Closed
+
+  exception Found_label
 
   let match_extension_use pat =
     match pat.ppat_desc with
-    | Ppat_tuple({ppat_desc = Ppat_extension ext; _} :: patterns) ->
-        Some (ext, patterns)
+    | Ppat_tuple((None, {ppat_desc = Ppat_extension ext; _}) :: patterns,
+                 Closed) -> begin
+        try
+          let patterns =
+            List.map (function | None, p -> p
+                               | Some _, _ -> raise Found_label)
+              patterns
+          in
+          Some (ext, patterns)
+        with
+        | Found_label -> None
+      end
     | _ ->
        None
 
diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli
index ba66b31c83..68e45ae2cd 100644
--- a/vendor/parser-extended/parsetree.mli
+++ b/vendor/parser-extended/parsetree.mli
@@ -132,12 +132,14 @@ and core_type_desc =
             - [?l:T1 -> T2] when [lbl] is
                                      {{!Asttypes.arg_label.Optional}[Optional]}.
          *)
-  | Ptyp_tuple of core_type list
-      (** [Ptyp_tuple([T1 ; ... ; Tn])]
-          represents a product type [T1 * ... * Tn].
+  | Ptyp_tuple of (string option * core_type) list
+        (** [Lttyp_tuple(tl)] represents a product type:
+          - [T1 * ... * Tn]       when [tl] is [(None,T1);...;(None,Tn)]
+          - [L1:T1 * ... * Ln:Tn] when [tl] is [(Some L1,T1);...;(Some Ln,Tn)]
+          - A mix, e.g. [L1:T1,T2] when [tl] is [(Some L1,T1);(None,T2)]
 
-           Invariant: [n >= 2].
-        *)
+          Invariant: [n >= 2]
+      *)
   | Ptyp_constr of Longident.t loc * core_type list
       (** [Ptyp_constr(lident, l)] represents:
             - [tconstr]               when [l=[]],
@@ -268,11 +270,18 @@ and pattern_desc =
 
            Other forms of interval are recognized by the parser
            but rejected by the type-checker. *)
-  | Ppat_tuple of pattern list
-      (** Patterns [(P1, ..., Pn)].
-
-           Invariant: [n >= 2]
-        *)
+  | Ppat_tuple of (string option * pattern) list * Asttypes.closed_flag
+        (** [Ppat_tuple(pl, Closed)] represents
+          - [(P1, ..., Pn)]       when [pl] is [(None, P1);...;(None, Pn)]
+          - [(L1:P1, ..., Ln:Pn)] when [pl] is
+                                              [(Some L1, P1);...;(Some Ln, Pn)]
+          - A mix, e.g. [(L1:P1, P2)] when [pl] is [(Some L1, P1);(None, P2)]
+          - If pattern is open, then it also ends in a [..]
+
+        Invariant:
+        - If Closed, [n >= 2].
+        - If Open, [n >= 1].
+      *)
   | Ppat_construct of Longident.t loc * (string loc list * pattern) option
       (** [Ppat_construct(C, args)] represents:
             - [C]               when [args] is [None],
@@ -363,11 +372,17 @@ and expression_desc =
       (** [match E0 with P1 -> E1 | ... | Pn -> En] *)
   | Pexp_try of expression * case list
       (** [try E0 with P1 -> E1 | ... | Pn -> En] *)
-  | Pexp_tuple of expression list
-      (** Expressions [(E1, ..., En)]
-
-           Invariant: [n >= 2]
-        *)
+  | Pexp_tuple of (string option * expression) list
+        (** [Pexp_tuple(el)] represents
+          - [(E1, ..., En)]
+              when [el] is [(None, E1);...;(None, En)]
+          - [(~L1:E1, ..., ~Ln:En)]
+              when [el] is [(Some L1, E1);...;(Some Ln, En)]
+          - A mix, e.g.:
+              [(~L1:E1, E2)] when [el] is [(Some L1, E1); (None, E2)]
+
+          Invariant: [n >= 2].
+      *)
   | Pexp_construct of Longident.t loc * expression option
       (** [Pexp_construct(C, exp)] represents:
            - [C]               when [exp] is [None],
diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml
index f769737d61..edd534d9a2 100644
--- a/vendor/parser-extended/printast.ml
+++ b/vendor/parser-extended/printast.ml
@@ -214,6 +214,11 @@ let fmt_layout_opt ppf l = Format.fprintf ppf "%s"
 let fmt_ty_var ppf (name, layout) =
   Format.fprintf ppf "%a:%a" fmt_str_opt_loc name fmt_layout_opt layout
 
+let tuple_component_label i ppf = function
+  | None -> line i ppf "Label: None\n"
+  | Some s -> line i ppf "Label: Some \"%s\"\n" s
+;;
+
 let typevars ppf vs =
   List.iter (fun x ->
       fprintf ppf " %a" fmt_ty_var x) vs
@@ -236,7 +241,7 @@ let rec core_type i ppf x =
       core_type i ppf ct2;
   | Ptyp_tuple l ->
       line i ppf "Ptyp_tuple\n";
-      list i core_type ppf l;
+      list i labeled_core_type ppf l;
   | Ptyp_constr (li, l) ->
       line i ppf "Ptyp_constr %a\n" fmt_longident_loc li;
       list i core_type ppf l;
@@ -286,6 +291,10 @@ and object_field i ppf x =
       line i ppf "Oinherit\n";
       core_type i ppf ct
 
+and labeled_core_type i ppf (l, t) =
+  tuple_component_label i ppf l;
+  core_type i ppf t
+
 and package_with i ppf (s, t) =
   line i ppf "with type %a\n" fmt_longident_loc s;
   core_type i ppf t
@@ -311,9 +320,10 @@ and pattern i ppf x =
       line i ppf "Ppat_interval\n";
       fmt_constant i ppf c1;
       fmt_constant i ppf c2;
-  | Ppat_tuple (l) ->
+  | Ppat_tuple (l,op) ->
       line i ppf "Ppat_tuple\n";
-      list i pattern ppf l;
+      list i labeled_pattern ppf l;
+      open_closed i ppf op
   | Ppat_construct (li, po) ->
       line i ppf "Ppat_construct %a\n" fmt_longident_loc li;
       option i
@@ -363,6 +373,16 @@ and pattern i ppf x =
       line i ppf "Ppat_cons\n";
       list i pattern ppf l
 
+and labeled_pattern =
+  fun i ppf (label, x) ->
+    tuple_component_label i ppf label;
+    pattern i ppf x
+
+and open_closed i ppf =
+  function
+  | Open -> string i ppf "Open"
+  | Closed -> string i ppf "Closed"
+
 and expression i ppf x =
   line i ppf "expression %a\n" fmt_location x.pexp_loc;
   attributes i ppf x.pexp_attributes;
@@ -397,7 +417,7 @@ and expression i ppf x =
       list i case ppf l;
   | Pexp_tuple (l) ->
       line i ppf "Pexp_tuple\n";
-      list i expression ppf l;
+      list i labeled_expression ppf l;
   | Pexp_construct (li, eo) ->
       line i ppf "Pexp_construct %a\n" fmt_longident_loc li;
       option i expression ppf eo;
@@ -541,6 +561,11 @@ and expression i ppf x =
       expression i ppf e1;
       expression i ppf e2
 
+and labeled_expression i ppf (l, e) =
+  line i ppf "<tuple component>\n";
+  tuple_component_label i ppf l;
+  expression (i+1) ppf e;
+
 and if_branch i ppf { if_cond; if_body } =
   line i ppf "if_branch\n";
   expression i ppf if_cond;

From da844cc9a6b6f51b56c7f9b06e9a880b706e97a0 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Tue, 5 Dec 2023 15:20:43 -0500
Subject: [PATCH 03/22] labeled tuples parser and run formatter

---
 lib/Ast.ml                        |   6 +-
 lib/Exposed.ml                    |  18 +-
 lib/Fmt_ast.ml                    |  37 ++--
 vendor/parser-extended/parser.mly | 296 ++++++++++++++++++++++++++----
 4 files changed, 284 insertions(+), 73 deletions(-)

diff --git a/lib/Ast.ml b/lib/Ast.ml
index cb02c350dc..017a3dce80 100644
--- a/lib/Ast.ml
+++ b/lib/Ast.ml
@@ -960,8 +960,7 @@ 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 ->
-          assert (List.exists t1N ~f:(fun (_, t) -> f t))
+      | Ptyp_tuple t1N -> assert (List.exists t1N ~f:(fun (_, t) -> f t))
       | Ptyp_constr (_, t1N) -> assert (List.exists t1N ~f)
       | Ptyp_variant (r1N, _, _) ->
           assert (
@@ -1488,8 +1487,7 @@ end = struct
         | Pexp_apply (e0, e1N) ->
             (* FAIL *)
             assert (e0 == exp || List.exists e1N ~f:snd_f)
-        | Pexp_tuple e1N ->
-            assert (List.exists e1N ~f:(fun (_, e) -> f e))
+        | 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) ->
diff --git a/lib/Exposed.ml b/lib/Exposed.ml
index 45bea715a8..48078e9f33 100644
--- a/lib/Exposed.ml
+++ b/lib/Exposed.ml
@@ -15,11 +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 -> begin
-        match List.hd_exn l with
-        | Some _, _ -> false
-        | None, typ -> core_type typ
-      end
+    | 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
@@ -33,11 +32,10 @@ module Right = struct
     | {ptyp_desc; _} -> (
       match ptyp_desc with
       | Ptyp_arrow (_, t) -> core_type t
-      | Ptyp_tuple l -> begin
-          match List.last_exn l with
-          | Some _, _ -> false
-          | None, typ -> core_type typ
-        end
+      | 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
index 391ad348cf..2886b29cd0 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -931,14 +931,14 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
         $ fmt ".@ "
         $ fmt_core_type c ~box:true (sub_typ ~ctx t) )
   | Ptyp_tuple typs ->
-      (* XXX surely will need to tweak this for more parens in labeled case *)
+      (* XXX surely will need to tweak this for more parens in labeled
+         case *)
       hvbox 0
         (wrap_if parenze_constraint_ctx "(" ")"
            (wrap_fits_breaks_if ~space:false c.conf parens "(" ")"
-              (list typs "@ * "
-                 (fun (lbl, typ) ->
-                    let typ = sub_typ ~ctx typ in
-                    fmt_labeled_tuple_type c lbl typ)) ) )
+              (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 =
@@ -1038,11 +1038,7 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
 and fmt_labeled_tuple_type c lbl xtyp =
   match lbl with
   | None -> fmt_core_type c xtyp
-  | Some s -> begin
-      str s
-      $ str ":"
-      $ fmt_core_type c xtyp
-    end
+  | Some s -> str s $ str ":" $ fmt_core_type c xtyp
 
 and fmt_package_type c ctx cnstrs =
   let fmt_cstr ~first ~last:_ (lid, typ) =
@@ -1147,22 +1143,19 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
         let pat = sub_pat ~ctx pat in
         match lbl with
         | None -> fmt_pattern c pat
-        | Some lbl ->
-           (  str "~"
-            $ str lbl
-            $ str ":"
-            $ fmt_pattern c pat)
+        | Some lbl -> str "~" $ str lbl $ 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
+      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
-           (fmt_elements $ fmt_oc))
+           (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
@@ -1367,8 +1360,6 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
         $ wrap_k (str opn) (str cls)
             (fmt "@;<0 2>" $ fmt_pattern c (sub_pat ~ctx pat)) )
 
-
-
 and fmt_pattern_extension ~ext:_ c ~pro:_ ~parens:_ ~box:_ ~ctx0 ~ctx
     ~ppat_loc : Extensions.Pattern.t -> _ = function
   | Epat_immutable_array (Iapat_immutable_array []) ->
@@ -2803,11 +2794,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
         let exp = sub_exp ~ctx exp in
         match lbl with
         | None -> fmt_expression c exp
-        | Some lbl ->
-           (  str "~"
-            $ str lbl
-            $ str ":"
-            $ fmt_expression c exp)
+        | Some lbl -> str "~" $ str lbl $ str ":" $ fmt_expression c exp
       in
       pro
       $ hvbox_if outer_wrap 0
@@ -2815,7 +2802,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
              ( hvbox 0
                  (Params.wrap_tuple ~parens:inner_wrap ~no_parens_if_break
                     c.conf
-                    (list es (Params.comma_sep c.conf) (fmt_lt_exp_element) ) )
+                    (list es (Params.comma_sep c.conf) fmt_lt_exp_element) )
              $ fmt_atrs ) )
   | Pexp_lazy e ->
       pro
diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly
index 79be6294c6..8bffc86b11 100644
--- a/vendor/parser-extended/parser.mly
+++ b/vendor/parser-extended/parser.mly
@@ -245,6 +245,16 @@ let mkpat_local_if p pat =
 let mktyp_local_if p typ =
   if p then mktyp_stack typ else typ
 
+let mktyp_modes modes =
+  (* Jane Street: This is horrible temporary code until we properly add
+     support for more modes. *)
+  let is_local =
+    match modes with
+    | [] -> false
+    | _ :: _ -> true
+  in
+  mktyp_local_if is_local
+
 let exclave_ext_loc loc = mkloc "extension.exclave" loc
 
 let exclave_extension loc =
@@ -2438,7 +2448,7 @@ expr:
   | expr_attrs
       { let desc, attrs = $1 in
         mkexp_attrs ~loc:$sloc desc attrs }
-  | mkexp(expr_)
+  | expr_
       { $1 }
   | let_bindings(ext) IN seq_expr
       { expr_of_let_bindings ~loc:$sloc $1 $3 }
@@ -2531,19 +2541,19 @@ expr:
 ;
 %inline expr_:
   | simple_expr nonempty_llist(labeled_simple_expr)
-      { Pexp_apply($1, $2) }
-  | expr_comma_list %prec below_COMMA
-      { Pexp_tuple($1) }
+      { mkexp ~loc:$sloc (Pexp_apply($1, $2)) }
+  | labeled_tuple %prec below_COMMA
+      { mkexp ~loc:$sloc (Pexp_tuple $1) }
   | mkrhs(constr_longident) simple_expr %prec below_HASH
-      { Pexp_construct($1, Some $2) }
+      { mkexp ~loc:$sloc (Pexp_construct($1, Some $2)) }
   | name_tag simple_expr %prec below_HASH
-      { Pexp_variant($1, Some $2) }
+      { mkexp ~loc:$sloc (Pexp_variant($1, Some $2)) }
   | e1 = expr op = op(infix_operator) e2 = expr
-      { mkinfix e1 op e2 }
+      { mkexp ~loc:$sloc (mkinfix e1 op e2) }
   | subtractive expr %prec prec_unary_minus
-      { mkuminus ~oploc:$loc($1) $1 $2 }
+      { mkexp ~loc:$sloc (mkuminus ~oploc:$loc($1) $1 $2) }
   | additive expr %prec prec_unary_plus
-      { mkuplus ~oploc:$loc($1) $1 $2 }
+      { mkexp ~loc:$sloc (mkuplus ~oploc:$loc($1) $1 $2) }
 ;
 
 simple_expr:
@@ -2958,10 +2968,86 @@ fun_def:
     RPAREN fun_def
       { mk_newtypes ~loc:$sloc [name, Some layout] $7 }
 ;
-%inline expr_comma_list:
-  es = separated_nontrivial_llist(COMMA, expr)
-    { es }
+
+(* Parsing labeled tuple expressions
+
+   The grammar we want to parse is something like:
+
+     labeled_tuple_element := expr | ~x:expr | ~x | ~(x:ty)
+     labeled_tuple := lt_element [, lt_element]+
+
+   (The last case of [labeled_tuple_element] is a punned label with a type
+   constraint, which is allowed for functions, so we allow it here).
+
+   So you might think [labeled_tuple] could therefore just be:
+
+     labeled_tuple :
+       separated_nontrivial_llist(COMMA, labeled_tuple_element)
+
+   But this doesn't work:
+
+   - If we don't mark [labeled_tuple_element] %inline, this causes many
+     reduce/reduce conflicts (basically just ambiguities) because
+     [labeled_tuple_element] trivially reduces to [expr].
+
+   - If we do mark [labeled_tuple_element] %inline, it is not allowed to have
+     %prec annotations.  Menhir doesn't permit these on %inline non-terminals
+     that are used in non-tail position.
+
+   To get around this, we do mark it inlined, and then because we can only use
+   it in tail position it is _manually_ inlined into the occurrences in
+   [separated_nontrivial_llist] where it doesn't appear in tail position.  This
+   results in [labeled_tuple] and [reversed_labeled_tuple_body] below.  So the
+   latter is just a list of comma-separated labeled tuple elements, with length
+   at least two, where the first element in the base case is inlined (resulting
+   in one base case for each case of [labeled_tuple_element].  *)
+%inline labeled_tuple_element :
+  | expr
+     { None, $1 }
+  | LABEL simple_expr %prec below_HASH
+     { Some $1, $2 }
+  | TILDE label = LIDENT
+     { let loc = $loc(label) in
+       Some label, mkexpvar ~loc label }
+  | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN %prec below_HASH
+      { Some label,
+        mkexp_constraint
+          ~loc:($startpos($2), $endpos) (mkexpvar ~loc:$loc(label) label) ty }
+;
+reversed_labeled_tuple_body:
+  (* > 2 elements *)
+  xs = reversed_labeled_tuple_body
+  COMMA
+  x = labeled_tuple_element
+    { x :: xs }
+  (* base cases (2 elements) *)
+| x1 = expr
+  COMMA
+  x2 = labeled_tuple_element
+    { [ x2; None, x1 ] }
+| l1 = LABEL x1 = simple_expr
+  COMMA
+  x2 = labeled_tuple_element
+    { [ x2; Some l1, x1 ] }
+| TILDE l1 = LIDENT
+  COMMA
+  x2 = labeled_tuple_element
+  { let loc = $loc(l1) in
+    [ x2; Some l1, mkexpvar ~loc l1] }
+| TILDE LPAREN l1 = LIDENT ty1 = type_constraint RPAREN
+  COMMA
+  x2 = labeled_tuple_element
+  { let x1 =
+      mkexp_constraint
+        ~loc:($startpos($2), $endpos) (mkexpvar ~loc:$loc(l1) l1) ty1
+    in
+    [ x2; Some l1, x1] }
+;
+%inline labeled_tuple:
+  xs = rev(reversed_labeled_tuple_body)
+    { xs }
 ;
+
 record_expr_content:
   eo = ioption(terminated(simple_expr, WITH))
   fields = separated_or_terminated_nonempty_list(SEMI, record_expr_field)
@@ -3062,8 +3148,6 @@ pattern_no_exn:
         { Ppat_alias($1, $3) }
     | self AS error
         { expecting $loc($3) "identifier" }
-    | pattern_comma_list(self) %prec below_COMMA
-        { Ppat_tuple(List.rev $1) }
     | self COLONCOLON error
         { expecting $loc($3) "pattern" }
     | self BAR pattern
@@ -3076,8 +3160,66 @@ pattern_no_exn:
     | self BAR error
         { expecting $loc($3) "pattern" }
   ) { $1 }
+  | reversed_labeled_tuple_pattern(self)
+      { let closed, pats = $1 in
+        mkpat ~loc:$sloc (Ppat_tuple (List.rev pats, closed))
+      }
 ;
 
+(* Parsing labeled tuple patterns
+
+   Here we play essentially the same game we did for expressions - see the
+   comment beginning "Parsing labeled tuple expressions".
+
+   One difference is that we would need to manually inline the definition of
+   individual elements in two places: Once in the base case for lists 2 or more
+   elements, and once in the special case for open patterns with just one
+   element (e.g., [~x, ..]).  Rather than manually inlining
+   [labeled_tuple_pat_element] twice, we simply define it twice: once with the
+   [%prec] annotations needed for its occurrences in tail position, and once
+   without them suitable for use in other locations.
+*)
+%inline labeled_tuple_pat_element(self):
+  | self { None, $1 }
+  | LABEL simple_pattern %prec COMMA
+      { Some $1, $2 }
+  | TILDE label = LIDENT
+      { let loc = $loc(label) in
+        Some label, mkpatvar ~loc label }
+  | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN %prec COMMA
+      { let loc = $loc(label) in
+        let pat = mkpatvar ~loc label in
+        Some label, mkpat ~loc (Ppat_constraint (pat, cty)) }
+
+%inline labeled_tuple_pat_element_noprec(self):
+  | self { None, $1 }
+  | LABEL simple_pattern
+      { Some $1, $2 }
+  | TILDE label = LIDENT
+      { let loc = $loc(label) in
+        Some label, mkpatvar ~loc label }
+  | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN
+      { let loc = $loc(label) in
+        let pat = mkpatvar ~loc label in
+        Some label, mkpat ~loc (Ppat_constraint (pat, cty)) }
+
+labeled_tuple_pat_element_list(self):
+  | labeled_tuple_pat_element_list(self) COMMA labeled_tuple_pat_element(self)
+      { $3 :: $1 }
+  | labeled_tuple_pat_element_noprec(self) COMMA labeled_tuple_pat_element(self)
+      { [ $3; $1 ] }
+  | self COMMA error
+      { expecting $loc($3) "pattern" }
+;
+
+reversed_labeled_tuple_pattern(self):
+  | labeled_tuple_pat_element_list(self) %prec below_COMMA
+      { Closed, $1 }
+  | labeled_tuple_pat_element_list(self) COMMA DOTDOT
+      { Open, $1 }
+  | labeled_tuple_pat_element_noprec(self) COMMA DOTDOT
+      { Open, [ $1 ] }
+
 pattern_gen:
     simple_pattern
       { $1 }
@@ -3175,11 +3317,6 @@ simple_delimited_pattern:
             $1 }
   ) { $1 }
 
-pattern_comma_list(self):
-    pattern_comma_list(self) COMMA pattern      { $3 :: $1 }
-  | self COMMA pattern                          { [$3; $1] }
-  | self COMMA error                            { expecting $loc($3) "pattern" }
-;
 %inline pattern_semi_list:
   ps = separated_or_terminated_nonempty_list(SEMI, pattern)
     { ps }
@@ -3725,20 +3862,20 @@ function_type:
   | ty = tuple_type
     %prec MINUSGREATER
       { ty }
-  | ty = strict_function_type
+  | ty = strict_function_or_labeled_tuple_type
       { ty }
 ;
-strict_function_type:
+strict_function_or_labeled_tuple_type:
   | mktyp(
       label = arg_label
-      local = optional_local
+      local = mode_flags
       domain = extra_rhs(param_type)
       MINUSGREATER
-      codomain = strict_function_type
+      codomain = strict_function_or_labeled_tuple_type
         { let arrow_type = {
             pap_label = label;
             pap_loc = make_loc $sloc;
-            pap_type = mktyp_local_if local domain;
+            pap_type = mktyp_modes local domain;
           }
           in
           let params, codomain =
@@ -3752,25 +3889,87 @@ strict_function_type:
     { $1 }
   | mktyp(
       label = arg_label
-      arg_local = optional_local
+      arg_local = mode_flags
       domain = extra_rhs(param_type)
       MINUSGREATER
-      ret_local = optional_local
+      ret_local = mode_flags
       codomain = tuple_type
       %prec MINUSGREATER
          { let arrow_type = {
              pap_label = label;
              pap_loc = make_loc $sloc;
-             pap_type = mktyp_local_if arg_local domain
+             pap_type = mktyp_modes arg_local domain
            }
            in
            let codomain =
-             mktyp_local_if ret_local (maybe_curry_typ codomain)
+             mktyp_modes ret_local (maybe_curry_typ codomain)
            in
            Ptyp_arrow([arrow_type], codomain)
          }
       )
       { $1 }
+  (* These next three cases are for labled tuples - see comment on [tuple_type]
+     below.
+
+     The first two cases are present just to resolve a shift reduce conflict
+     in a module type [S with t := x:t1 * t2 -> ...] which might be the
+     beginning of
+       [S with t := x:t1 * t2 -> S']    or    [S with t := x:t1 * t2 -> t3]
+     They are the same as the previous two cases, but with [arg_label] replaced
+     with the more specific [LIDENT COLON] and [param_type] replaced with the
+     more specific [proper_tuple_type].  Apparently, this is sufficient for
+     menhir to be able to delay a decision about which of the above module type
+     cases we are in.  *)
+  | mktyp(
+      label = LIDENT COLON
+      unique_local = mode_flags
+      tuple = proper_tuple_type
+      MINUSGREATER
+      codomain = strict_function_or_labeled_tuple_type
+         {
+           let ty, ltys = tuple in
+           let label = mk_labelled label $loc(label) in
+           let domain =
+             mktyp ~loc:$loc(tuple) (Ptyp_tuple ((None, ty) :: ltys))
+           in
+           let domain = extra_rhs_core_type domain ~pos:$endpos(tuple) in
+           let arrow_type = {
+             pap_label = label;
+             pap_loc = make_loc $sloc;
+             pap_type = mktyp_modes unique_local domain
+           }
+           in
+           Ptyp_arrow([arrow_type], codomain) }
+    )
+    { $1 }
+  | mktyp(
+      label = LIDENT COLON
+      arg_unique_local = mode_flags
+      tuple = proper_tuple_type
+      MINUSGREATER
+      ret_unique_local = mode_flags
+      codomain = tuple_type
+         { let ty, ltys = tuple in
+           let label = mk_labelled label $loc(label) in
+           let domain =
+             mktyp ~loc:$loc(tuple) (Ptyp_tuple ((None, ty) :: ltys))
+           in
+           let domain = extra_rhs_core_type domain ~pos:$endpos(tuple) in
+           let arrow_type = {
+             pap_label = label;
+             pap_loc = make_loc $sloc;
+             pap_type = mktyp_modes arg_unique_local domain
+           }
+           in
+           Ptyp_arrow([arrow_type],
+            mktyp_modes ret_unique_local (maybe_curry_typ codomain))
+         }
+    )
+    { $1 }
+  | label = LIDENT COLON proper_tuple_type %prec MINUSGREATER
+    { let ty, ltys = $3 in
+      mktyp ~loc:$sloc (Ptyp_tuple ((Some label, ty) :: ltys))
+    }
 ;
 %inline param_type:
   | mktyp(
@@ -3795,22 +3994,51 @@ strict_function_type:
   | LOCAL
     { true }
 ;
+(* jane street: hackily copied and modified from our parser - to be replaced with the
+   exact version from our parser when ocamlformat is updated for uniqueness. *)
+%inline mode_flag:
+   | LOCAL
+       { $sloc }
+;
+%inline mode_flags:
+   | flags = iloption(mode_flag+)
+       { flags }
+;
 (* Tuple types include:
    - atomic types (see below);
    - proper tuple types:                  int * int * int list
    A proper tuple type is a star-separated list of at least two atomic types.
- *)
+
+   Tuple components can also be labeled, as an [int * int list * y:bool].
+
+   However, the special case of labeled tuples where the first element has a
+   label is not parsed as a proper_tuple_type, but rather as a case of
+   strict_function_or_labled_tuple_type above.  This helps in dealing with
+   ambiguities around [x:t1 * t2 -> t3] which must continue to parse as a
+   function with one labeled argument even in the presense of labled tuples.
+*)
 tuple_type:
   | ty = atomic_type
     %prec below_HASH
       { ty }
-  | mktyp(
-      tys = separated_nontrivial_llist(STAR, atomic_type)
-        { Ptyp_tuple tys }
-    )
-    { $1 }
+  | proper_tuple_type %prec below_FUNCTOR
+    { let ty, ltys = $1 in
+      mktyp ~loc:$sloc (Ptyp_tuple ((None, ty) :: ltys))
+    }
 ;
 
+%inline proper_tuple_type:
+  | ty = atomic_type
+    STAR
+    ltys = separated_nonempty_llist(STAR, labeled_tuple_typ_element)
+      { ty, ltys }
+
+%inline labeled_tuple_typ_element :
+  | atomic_type %prec STAR
+     { None, $1 }
+  | label = LIDENT COLON ty = atomic_type %prec STAR
+     { Some label, ty }
+
 (* Atomic types are the most basic level in the syntax of types.
    Atomic types include:
    - types between parentheses:           (int -> int)

From d158640036ec480cb721421baf875e731c0bd252 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Tue, 5 Dec 2023 15:53:42 -0500
Subject: [PATCH 04/22] Initial patterns test

---
 test/passing/dune.inc                        |  18 ++
 test/passing/tests/labeled_tuple_patterns.ml | 279 +++++++++++++++++++
 2 files changed, 297 insertions(+)
 create mode 100644 test/passing/tests/labeled_tuple_patterns.ml

diff --git a/test/passing/dune.inc b/test/passing/dune.inc
index 3beda3fa42..a9a6b1e115 100644
--- a/test/passing/dune.inc
+++ b/test/passing/dune.inc
@@ -3356,6 +3356,24 @@
  (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 %{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)
diff --git a/test/passing/tests/labeled_tuple_patterns.ml b/test/passing/tests/labeled_tuple_patterns.ml
new file mode 100644
index 0000000000..de1cb72c93
--- /dev/null
+++ b/test/passing/tests/labeled_tuple_patterns.ml
@@ -0,0 +1,279 @@
+(* This file is a copy of a labeled tuples test from the compiler.  Not everything here
+   typechecks, but everything should parse. *)
+
+(* Test match statements with exception patterns *)
+
+exception Odd
+
+let x_must_be_even (~x, y) =
+   if x mod 2 = 1 then
+      raise Odd
+   else
+      (~x, y)
+
+let foo xy k_good k_bad =
+   match x_must_be_even xy with
+   | (~x, y) -> k_good ()
+   | exception Odd -> k_bad ()
+
+(* Test correctness *)
+let _ = foo (~x:2, 5) (fun () -> true) (fun () -> false)
+let _ = foo (~x:3, 5) (fun () -> false) (fun () -> true)
+
+(* Test that the actions occur outside of the exception handler *)
+let _ =
+   try
+      foo (~x:2, 5) (fun () -> raise Odd) (fun () -> false)
+   with Odd -> true
+let _ =
+   try
+      foo (~x:3, 5) (fun () -> false) (fun () -> raise Odd)
+   with Odd -> true
+
+(* Labeled tuple pattern *)
+let (~x:x0, ~y:y0, _) = ~x: 1, ~y: 2, "ignore me"
+
+(* Pattern with punning and type annotation *)
+let (~(x:int), ~y, _) = ~x: 1, ~y: 2, "ignore me"
+
+(* Patterns in functions *)
+let f = fun (~foo, ~bar:bar) -> foo * 10 + bar
+let bar = 5
+let _ = f (~foo:1, ~bar)
+
+(* Correct annotation *)
+let f : (foo:int * bar:int) -> int =
+   fun (~foo, ~bar:bar) -> foo * 10 + bar
+
+let f = fun (~foo, ~bar:bar) : (foo:int * bar:int) -> foo * 10 + bar
+
+(* Missing label *)
+let f : (int * bar:int) -> int = fun (~foo, ~bar:bar) -> foo * 10 + bar
+
+let f = fun (~foo, ~bar:bar) : (foo:int * int) -> foo * 10 + bar
+
+(* Wrong label *)
+let f : (foo:int * foo:int) -> int =
+   fun (~foo, ~bar:bar) -> foo * 10 + bar
+
+(* Wrong type *)
+let f : (foo:float * foo:int) -> int =
+   fun (~foo, ~bar:bar) -> foo * 10 + bar
+
+(* Annotated pattern *)
+let f (~x,y : (x:int * int)) : int = x + y
+
+(* Misannotated pattern *)
+let f (~x,y : (int * int)) : int = x + y
+
+let f (~x,y : (int * x:int)) : int = x + y
+
+(* Annotation within pattern *)
+let f (~(x:int),y : (x:int * int)) : int = x + y
+
+let f (~(x:int),y) = x + y
+
+let f (~x:(x0:int),y) = x0 + y
+
+(* Misannotation within pattern *)
+let f (~(x:float),y) = x + y
+(* Reordering in functions *)
+type xy = (x:int * y:int)
+type yx = (y:int * x:int)
+let xy_id (pt : xy) = pt
+let yx_id (pt : yx) = pt
+
+let xy_id (~y, ~x) : xy = ~x, ~y
+
+let swap (~x, ~y) = ~y, ~x
+
+let swap (~y, ~x : xy) = ~y, ~x
+
+let swap (~x, ~y) = (~x, ~y : yx)
+
+let swap (pt : xy) : yx = pt
+
+let swap : xy -> yx = Fun.id
+
+let swap : xy -> yx = xy_id
+
+let swap : xy -> yx = yx_id
+
+(* Reordering and partial matches *)
+let lt = ~x:1, ~y:2, ~x:3, 4
+
+(* Full match, in order *)
+let matches =
+  let ~x, ~y, ~x:x2, z = lt in
+  x, y, x2, z
+
+(* Full match, over-bound *)
+let matches =
+  let ~x, ~y, ~x, z = lt in
+  x, y, z
+
+(* Full match, missing label *)
+let matches =
+  let ~x, ~y, z = lt in
+  x, y, z
+
+(* Full match, wrong label *)
+let matches =
+  let ~x, ~y, ~w, z = lt in
+  x, y, z
+
+(* Full match, extra label *)
+let matches =
+  let ~x, ~y, ~x, ~y, z = lt in
+  x, y, z
+
+(* Full match, extra unlabeled label *)
+let matches =
+  let ~x, ~y, ~x, z, w = lt in
+  x, y, z
+
+(* Partial match *)
+let matches =
+  let ~x, ~y, .. = lt in
+  x, y
+
+(* Partial match, reordered *)
+let matches =
+  let ~y, ~x, .. = lt in
+  x, y
+
+(* Partial match, reordered, over-bound *)
+let matches =
+  let ~y:x, ~x, .. = lt in
+  x
+
+(* Partial match one *)
+let matches =
+  let ~x, .. = lt in
+  x
+
+(* Partial match all *)
+let matches =
+   let ~x, ~y, ~x:x2, z, .. = lt in
+   x, y, x2, z
+
+(* Partial match too many of a name *)
+let matches =
+   let ~y, ~y:y2, ~x, .. = lt in
+   x, y
+
+(* Partial match bad name *)
+let matches =
+   let ~w, ~y, ~x, .. = lt in
+   x, y, x2, z
+
+(* Nested pattern *)
+let f (z, (~y, ~x)) = x, y, z
+
+(* Non-principally known patterns *)
+
+let f (z, (~y, ~x, ..)) = x, y, z
+
+let f (~x, ~y, ..) = x, y
+
+(* Labeled tuples nested in records *)
+
+let x = ref (~x:1, ~y:2, ~x:3, 4)
+
+(* Good match *)
+let _1234 = match x with
+| { contents = ~x:x0, ~y, ~x , z } -> x0, y, x, z
+
+(* Good partial match *)
+let _1  = match x with
+| { contents = ~x, ..} -> x
+
+(* Wrong label *)
+let () = match x with
+| { contents = ~w , .. } -> w
+
+(* Missing unordered label *)
+let () = match x with
+| { contents = ~x:x0, ~y , ~x } -> y
+
+(* Extra unordered label *)
+let () = match x with
+| { contents = ~x:x0, ~y, ~x, w1, w2 } -> y
+
+(* Extra unordered label, open *)
+let () = match x with
+| { contents = ~x:x0, ~y, ~x, w1, w2, .. } -> y
+
+(* Missing label *)
+let () = match x with
+| { contents = ~x:x0, ~y, x } -> y
+
+(* Extra label *)
+let () = match x with
+| { contents = ~y:y0, ~y, ~x } -> y
+
+(* Behavior w.r.t whether types are principally known *)
+
+let f (z : (x:_ * y:_)) =
+  match z with
+  | ~y, ~x -> x + y
+
+let f = function ~x, ~y -> x + y
+
+let g z =
+  (f z, match z with ~y, ~x -> x + y)
+
+let f = function ~x, ~y -> x + y
+
+let g z =
+  match z with ~y, ~x -> x + y, f z
+
+(* More re-ordering stress tests *)
+type t =
+  x:int *
+  y:int *
+  int *
+  x:int *
+  x:int *
+  y:int *
+  y:int *
+  int *
+  int *
+  y:int *
+  x:int
+
+let t : t = ~x:1, ~y:2, 3, ~x:4, ~x:5, ~y:6, ~y:7, 8, 9, ~y:10, ~x:11
+
+let _ =
+  let (~y, ~y:y2, ~y:y3, ..) = t in
+  y, y2, y3
+
+let _ =
+  let (a, b, c, ..) = t in
+  (a, b, c)
+
+let _ =
+  let (n3, ~y:n2, ~y, ~x:n1, ..) = t in
+  (n1, n2, n3, y)
+
+let _ =
+  let (~x:x1, ~x:x2, ~x:x3, ~x, ..) = t in
+  (x1, x2, x3, x)
+
+let _ =
+  let (~y:n2, ~y:n6, n3, ~x:n1, ~y:n7, n8, ~y:n10, ~x:n4, ~x:n5, ~x:n11, n9) =
+    t
+  in
+  (n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11)
+
+let _ =
+  let (n3, n8, n9, ~y:n2, ~y:n6, ~y:n7, ~y:n10, ~x:n1, ~x:n4, ~x:n5, ~x:n11) =
+    t
+  in
+  (n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11)
+
+let _ =
+  let (~x:n1, ~y:n2, n3, ~x:n4, ~x:n5, ~y:n6, ~y:n7, n8, n9, ~y:n10, ~x:n11) =
+    t
+  in
+  (n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11)

From 3ee19714799860e80634d7938a309be94fa2f4e7 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Tue, 5 Dec 2023 15:53:52 -0500
Subject: [PATCH 05/22] Fix arrow argument type parens

---
 lib/Fmt_ast.ml | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index 2886b29cd0..0cbf1def98 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -781,9 +781,14 @@ and fmt_arrow_param c ctx
         Some (str "?" $ str l.txt $ fmt ":@," $ fmt_if localI "local_ ")
   in
   let xtI = sub_typ ~ctx tI in
+  let arg_parens =
+    match tI.ptyp_desc with
+    | Ptyp_tuple ((Some _, _) :: _) -> true
+    | _ -> false
+  in
   let arg =
     match arg_label lI with
-    | None -> fmt_core_type c xtI
+    | None -> Params.parens_if arg_parens c.conf (fmt_core_type c xtI)
     | Some f -> hovbox 2 (f $ fmt_core_type c xtI)
   in
   hvbox 0 (Cmts.fmt_before c locI $ arg)

From 8d438b1a4fe22e656dca0c1d4ff55ebf6b5e0063 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Tue, 5 Dec 2023 17:57:41 -0500
Subject: [PATCH 06/22] Print punned patterns better

---
 lib/Fmt_ast.ml | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index 0cbf1def98..e459b6b495 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -1145,10 +1145,18 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
         parens || Poly.(c.conf.fmt_opts.parens_tuple_patterns.v = `Always)
       in
       let fmt_lt_pat_element (lbl, pat) =
+        let pat_desc = pat.ppat_desc in
         let pat = sub_pat ~ctx pat in
         match lbl with
         | None -> fmt_pattern c pat
-        | Some lbl -> str "~" $ str lbl $ str ":" $ fmt_pattern c pat
+        | Some lbl ->
+            let punned =
+              match pat_desc with
+              | Ppat_var var -> String.equal var.txt lbl
+              | _ -> false
+            in
+            if punned then str "~" $ str lbl
+            else str "~" $ str lbl $ str ":" $ fmt_pattern c pat
       in
       let fmt_elements =
         list pats (Params.comma_sep c.conf) fmt_lt_pat_element

From d6a3ae0afb8e2154cc99f1394eae875832fc9c88 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Tue, 5 Dec 2023 18:11:05 -0500
Subject: [PATCH 07/22] Fix punned patterns with type annotations

---
 lib/Fmt_ast.ml | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index e459b6b495..34ae5ca949 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -1155,7 +1155,14 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
               | Ppat_var var -> String.equal var.txt lbl
               | _ -> false
             in
+            let punned_with_constraint =
+              match pat_desc with
+              | Ppat_constraint ({ppat_desc= Ppat_var var; _}, _) ->
+                  String.equal var.txt lbl
+              | _ -> false
+            in
             if punned then str "~" $ str lbl
+            else if punned_with_constraint then str "~" $ fmt_pattern c pat
             else str "~" $ str lbl $ str ":" $ fmt_pattern c pat
       in
       let fmt_elements =

From 3afc78388515c1dc61fe1b10b0e62911f90c3e97 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Tue, 5 Dec 2023 18:28:44 -0500
Subject: [PATCH 08/22] punned expressions

---
 lib/Fmt_ast.ml | 19 ++++++++++++++++++-
 1 file changed, 18 insertions(+), 1 deletion(-)

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index 34ae5ca949..3c0c42ff2d 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -2811,10 +2811,27 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
       let outer_wrap = has_attr && parens in
       let inner_wrap = has_attr || parens in
       let fmt_lt_exp_element (lbl, exp) =
+        let exp_desc = exp.pexp_desc in
         let exp = sub_exp ~ctx exp in
         match lbl with
         | None -> fmt_expression c exp
-        | Some lbl -> str "~" $ str lbl $ str ":" $ fmt_expression c exp
+        | Some lbl ->
+            let punned =
+              match exp_desc with
+              | Pexp_ident {txt= Lident var; _} -> String.equal lbl var
+              | _ -> false
+            in
+            let punned_with_constraint =
+              match exp_desc with
+              | Pexp_constraint
+                  ({pexp_desc= Pexp_ident {txt= Lident var; _}; _}, _) ->
+                  String.equal var lbl
+              | _ -> false
+            in
+            if punned then str "~" $ str lbl
+            else if punned_with_constraint then
+              str "~" $ fmt_expression c exp
+            else str "~" $ str lbl $ str ":" $ fmt_expression c exp
       in
       pro
       $ hvbox_if outer_wrap 0

From c7bea00962abb68fdcf5c43fa931887ca800be91 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Tue, 5 Dec 2023 19:07:17 -0500
Subject: [PATCH 09/22] update test options to js config

---
 test/passing/dune.inc                             | 2 +-
 test/passing/tests/labeled_tuple_patterns.ml.opts | 2 ++
 2 files changed, 3 insertions(+), 1 deletion(-)
 create mode 100644 test/passing/tests/labeled_tuple_patterns.ml.opts

diff --git a/test/passing/dune.inc b/test/passing/dune.inc
index a9a6b1e115..593476de1b 100644
--- a/test/passing/dune.inc
+++ b/test/passing/dune.inc
@@ -3362,7 +3362,7 @@
  (action
   (with-stdout-to labeled_tuple_patterns.ml.stdout
    (with-stderr-to labeled_tuple_patterns.ml.stderr
-     (run %{bin:ocamlformat} --margin-check %{dep:tests/labeled_tuple_patterns.ml})))))
+     (run %{bin:ocamlformat} --margin-check --profile=janestreet --max-iters=3 %{dep:tests/labeled_tuple_patterns.ml})))))
 
 (rule
  (alias runtest)
diff --git a/test/passing/tests/labeled_tuple_patterns.ml.opts b/test/passing/tests/labeled_tuple_patterns.ml.opts
new file mode 100644
index 0000000000..1be40ffecb
--- /dev/null
+++ b/test/passing/tests/labeled_tuple_patterns.ml.opts
@@ -0,0 +1,2 @@
+--profile=janestreet
+--max-iters=3

From db4ec48b91ee54ae4e24cab5840e1b03a1b37128 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Tue, 5 Dec 2023 19:12:35 -0500
Subject: [PATCH 10/22] accept test diffs now that they look reasonable

---
 test/passing/tests/labeled_tuple_patterns.ml | 230 ++++++++++---------
 1 file changed, 121 insertions(+), 109 deletions(-)

diff --git a/test/passing/tests/labeled_tuple_patterns.ml b/test/passing/tests/labeled_tuple_patterns.ml
index de1cb72c93..780d3ff356 100644
--- a/test/passing/tests/labeled_tuple_patterns.ml
+++ b/test/passing/tests/labeled_tuple_patterns.ml
@@ -5,16 +5,13 @@
 
 exception Odd
 
-let x_must_be_even (~x, y) =
-   if x mod 2 = 1 then
-      raise Odd
-   else
-      (~x, y)
+let x_must_be_even (~x, y) = if x mod 2 = 1 then raise Odd else ~x, y
 
 let foo xy k_good k_bad =
-   match x_must_be_even xy with
-   | (~x, y) -> k_good ()
-   | exception Odd -> k_bad ()
+  match x_must_be_even xy with
+  | ~x, y -> k_good ()
+  | exception Odd -> k_bad ()
+;;
 
 (* Test correctness *)
 let _ = foo (~x:2, 5) (fun () -> true) (fun () -> false)
@@ -22,81 +19,68 @@ let _ = foo (~x:3, 5) (fun () -> false) (fun () -> true)
 
 (* Test that the actions occur outside of the exception handler *)
 let _ =
-   try
-      foo (~x:2, 5) (fun () -> raise Odd) (fun () -> false)
-   with Odd -> true
+  try foo (~x:2, 5) (fun () -> raise Odd) (fun () -> false) with
+  | Odd -> true
+;;
+
 let _ =
-   try
-      foo (~x:3, 5) (fun () -> false) (fun () -> raise Odd)
-   with Odd -> true
+  try foo (~x:3, 5) (fun () -> false) (fun () -> raise Odd) with
+  | Odd -> true
+;;
 
 (* Labeled tuple pattern *)
-let (~x:x0, ~y:y0, _) = ~x: 1, ~y: 2, "ignore me"
+let ~x:x0, ~y:y0, _ = ~x:1, ~y:2, "ignore me"
 
 (* Pattern with punning and type annotation *)
-let (~(x:int), ~y, _) = ~x: 1, ~y: 2, "ignore me"
+let ~(x : int), ~y, _ = ~x:1, ~y:2, "ignore me"
 
 (* Patterns in functions *)
-let f = fun (~foo, ~bar:bar) -> foo * 10 + bar
+let f (~foo, ~bar) = (foo * 10) + bar
 let bar = 5
 let _ = f (~foo:1, ~bar)
 
 (* Correct annotation *)
-let f : (foo:int * bar:int) -> int =
-   fun (~foo, ~bar:bar) -> foo * 10 + bar
-
-let f = fun (~foo, ~bar:bar) : (foo:int * bar:int) -> foo * 10 + bar
+let f : (foo:int * bar:int) -> int = fun (~foo, ~bar) -> (foo * 10) + bar
+let f (~foo, ~bar) : foo:int * bar:int = (foo * 10) + bar
 
 (* Missing label *)
-let f : (int * bar:int) -> int = fun (~foo, ~bar:bar) -> foo * 10 + bar
-
-let f = fun (~foo, ~bar:bar) : (foo:int * int) -> foo * 10 + bar
+let f : int * bar:int -> int = fun (~foo, ~bar) -> (foo * 10) + bar
+let f (~foo, ~bar) : foo:int * int = (foo * 10) + bar
 
 (* Wrong label *)
-let f : (foo:int * foo:int) -> int =
-   fun (~foo, ~bar:bar) -> foo * 10 + bar
+let f : (foo:int * foo:int) -> int = fun (~foo, ~bar) -> (foo * 10) + bar
 
 (* Wrong type *)
-let f : (foo:float * foo:int) -> int =
-   fun (~foo, ~bar:bar) -> foo * 10 + bar
+let f : (foo:float * foo:int) -> int = fun (~foo, ~bar) -> (foo * 10) + bar
 
 (* Annotated pattern *)
-let f (~x,y : (x:int * int)) : int = x + y
+let f ((~x, y) : x:int * int) : int = x + y
 
 (* Misannotated pattern *)
-let f (~x,y : (int * int)) : int = x + y
-
-let f (~x,y : (int * x:int)) : int = x + y
+let f ((~x, y) : int * int) : int = x + y
+let f ((~x, y) : int * x:int) : int = x + y
 
 (* Annotation within pattern *)
-let f (~(x:int),y : (x:int * int)) : int = x + y
-
-let f (~(x:int),y) = x + y
-
-let f (~x:(x0:int),y) = x0 + y
+let f ((~(x : int), y) : x:int * int) : int = x + y
+let f (~(x : int), y) = x + y
+let f (~x:(x0 : int), y) = x0 + y
 
 (* Misannotation within pattern *)
-let f (~(x:float),y) = x + y
+let f (~(x : float), y) = x + y
+
 (* Reordering in functions *)
-type xy = (x:int * y:int)
-type yx = (y:int * x:int)
+type xy = x:int * y:int
+type yx = y:int * x:int
+
 let xy_id (pt : xy) = pt
 let yx_id (pt : yx) = pt
-
 let xy_id (~y, ~x) : xy = ~x, ~y
-
 let swap (~x, ~y) = ~y, ~x
-
-let swap (~y, ~x : xy) = ~y, ~x
-
-let swap (~x, ~y) = (~x, ~y : yx)
-
+let swap ((~y, ~x) : xy) = ~y, ~x
+let swap (~x, ~y) : yx = ~x, ~y
 let swap (pt : xy) : yx = pt
-
 let swap : xy -> yx = Fun.id
-
 let swap : xy -> yx = xy_id
-
 let swap : xy -> yx = yx_id
 
 (* Reordering and partial matches *)
@@ -106,66 +90,79 @@ let lt = ~x:1, ~y:2, ~x:3, 4
 let matches =
   let ~x, ~y, ~x:x2, z = lt in
   x, y, x2, z
+;;
 
 (* Full match, over-bound *)
 let matches =
   let ~x, ~y, ~x, z = lt in
   x, y, z
+;;
 
 (* Full match, missing label *)
 let matches =
   let ~x, ~y, z = lt in
   x, y, z
+;;
 
 (* Full match, wrong label *)
 let matches =
   let ~x, ~y, ~w, z = lt in
   x, y, z
+;;
 
 (* Full match, extra label *)
 let matches =
   let ~x, ~y, ~x, ~y, z = lt in
   x, y, z
+;;
 
 (* Full match, extra unlabeled label *)
 let matches =
   let ~x, ~y, ~x, z, w = lt in
   x, y, z
+;;
 
 (* Partial match *)
 let matches =
   let ~x, ~y, .. = lt in
   x, y
+;;
 
 (* Partial match, reordered *)
 let matches =
   let ~y, ~x, .. = lt in
   x, y
+;;
 
 (* Partial match, reordered, over-bound *)
 let matches =
   let ~y:x, ~x, .. = lt in
   x
+;;
 
 (* Partial match one *)
 let matches =
   let ~x, .. = lt in
   x
+;;
 
 (* Partial match all *)
 let matches =
-   let ~x, ~y, ~x:x2, z, .. = lt in
-   x, y, x2, z
+  let ~x, ~y, ~x:x2, z, .. = lt in
+  x, y, x2, z
+;;
 
 (* Partial match too many of a name *)
 let matches =
-   let ~y, ~y:y2, ~x, .. = lt in
-   x, y
+  let ~y, ~y:y2, ~x, .. = lt in
+  x, y
+;;
 
 (* Partial match bad name *)
 let matches =
-   let ~w, ~y, ~x, .. = lt in
-   x, y, x2, z
+  let ~w, ~y, ~x, .. = lt in
+  x, y, x2, z
+;;
 
 (* Nested pattern *)
 let f (z, (~y, ~x)) = x, y, z
@@ -173,7 +170,6 @@ let f (z, (~y, ~x)) = x, y, z
 (* Non-principally known patterns *)
 
 let f (z, (~y, ~x, ..)) = x, y, z
-
 let f (~x, ~y, ..) = x, y
 
 (* Labeled tuples nested in records *)
@@ -181,99 +177,115 @@ let f (~x, ~y, ..) = x, y
 let x = ref (~x:1, ~y:2, ~x:3, 4)
 
 (* Good match *)
-let _1234 = match x with
-| { contents = ~x:x0, ~y, ~x , z } -> x0, y, x, z
+let _1234 =
+  match x with
+  | { contents = ~x:x0, ~y, ~x, z } -> x0, y, x, z
+;;
 
 (* Good partial match *)
-let _1  = match x with
-| { contents = ~x, ..} -> x
+let _1 =
+  match x with
+  | { contents = ~x, .. } -> x
+;;
 
 (* Wrong label *)
-let () = match x with
-| { contents = ~w , .. } -> w
+let () =
+  match x with
+  | { contents = ~w, .. } -> w
+;;
 
 (* Missing unordered label *)
-let () = match x with
-| { contents = ~x:x0, ~y , ~x } -> y
+let () =
+  match x with
+  | { contents = ~x:x0, ~y, ~x } -> y
+;;
 
 (* Extra unordered label *)
-let () = match x with
-| { contents = ~x:x0, ~y, ~x, w1, w2 } -> y
+let () =
+  match x with
+  | { contents = ~x:x0, ~y, ~x, w1, w2 } -> y
+;;
 
 (* Extra unordered label, open *)
-let () = match x with
-| { contents = ~x:x0, ~y, ~x, w1, w2, .. } -> y
+let () =
+  match x with
+  | { contents = ~x:x0, ~y, ~x, w1, w2, .. } -> y
+;;
 
 (* Missing label *)
-let () = match x with
-| { contents = ~x:x0, ~y, x } -> y
+let () =
+  match x with
+  | { contents = ~x:x0, ~y, x } -> y
+;;
 
 (* Extra label *)
-let () = match x with
-| { contents = ~y:y0, ~y, ~x } -> y
+let () =
+  match x with
+  | { contents = ~y:y0, ~y, ~x } -> y
+;;
 
 (* Behavior w.r.t whether types are principally known *)
 
-let f (z : (x:_ * y:_)) =
+let f (z : x:_ * y:_) =
   match z with
   | ~y, ~x -> x + y
+;;
 
-let f = function ~x, ~y -> x + y
+let f = function
+  | ~x, ~y -> x + y
+;;
 
 let g z =
-  (f z, match z with ~y, ~x -> x + y)
+  ( f z
+  , match z with
+    | ~y, ~x -> x + y )
+;;
 
-let f = function ~x, ~y -> x + y
+let f = function
+  | ~x, ~y -> x + y
+;;
 
 let g z =
-  match z with ~y, ~x -> x + y, f z
+  match z with
+  | ~y, ~x -> x + y, f z
+;;
 
 (* More re-ordering stress tests *)
-type t =
-  x:int *
-  y:int *
-  int *
-  x:int *
-  x:int *
-  y:int *
-  y:int *
-  int *
-  int *
-  y:int *
-  x:int
+type t = x:int * y:int * int * x:int * x:int * y:int * y:int * int * int * y:int * x:int
 
 let t : t = ~x:1, ~y:2, 3, ~x:4, ~x:5, ~y:6, ~y:7, 8, 9, ~y:10, ~x:11
 
 let _ =
-  let (~y, ~y:y2, ~y:y3, ..) = t in
+  let ~y, ~y:y2, ~y:y3, .. = t in
   y, y2, y3
+;;
 
 let _ =
-  let (a, b, c, ..) = t in
-  (a, b, c)
+  let a, b, c, .. = t in
+  a, b, c
+;;
 
 let _ =
-  let (n3, ~y:n2, ~y, ~x:n1, ..) = t in
-  (n1, n2, n3, y)
+  let n3, ~y:n2, ~y, ~x:n1, .. = t in
+  n1, n2, n3, y
+;;
 
 let _ =
-  let (~x:x1, ~x:x2, ~x:x3, ~x, ..) = t in
-  (x1, x2, x3, x)
+  let ~x:x1, ~x:x2, ~x:x3, ~x, .. = t in
+  x1, x2, x3, x
+;;
 
 let _ =
-  let (~y:n2, ~y:n6, n3, ~x:n1, ~y:n7, n8, ~y:n10, ~x:n4, ~x:n5, ~x:n11, n9) =
-    t
-  in
-  (n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11)
+  let ~y:n2, ~y:n6, n3, ~x:n1, ~y:n7, n8, ~y:n10, ~x:n4, ~x:n5, ~x:n11, n9 = t in
+  n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11
+;;
 
 let _ =
-  let (n3, n8, n9, ~y:n2, ~y:n6, ~y:n7, ~y:n10, ~x:n1, ~x:n4, ~x:n5, ~x:n11) =
-    t
-  in
-  (n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11)
+  let n3, n8, n9, ~y:n2, ~y:n6, ~y:n7, ~y:n10, ~x:n1, ~x:n4, ~x:n5, ~x:n11 = t in
+  n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11
+;;
 
 let _ =
-  let (~x:n1, ~y:n2, n3, ~x:n4, ~x:n5, ~y:n6, ~y:n7, n8, n9, ~y:n10, ~x:n11) =
-    t
-  in
-  (n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11)
+  let ~x:n1, ~y:n2, n3, ~x:n4, ~x:n5, ~y:n6, ~y:n7, n8, n9, ~y:n10, ~x:n11 = t in
+  n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11
+;;

From 2708a05b029c8fbc0984bae3fb002fdc1eadcb36 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Wed, 6 Dec 2023 09:49:23 -0500
Subject: [PATCH 11/22] add test that does not yet work

---
 test/passing/dune.inc                     |  18 ++
 test/passing/tests/labeled_tuples.ml      | 247 ++++++++++++++++++++++
 test/passing/tests/labeled_tuples.ml.opts |   2 +
 3 files changed, 267 insertions(+)
 create mode 100644 test/passing/tests/labeled_tuples.ml
 create mode 100644 test/passing/tests/labeled_tuples.ml.opts

diff --git a/test/passing/dune.inc b/test/passing/dune.inc
index 593476de1b..1d6bb7b595 100644
--- a/test/passing/dune.inc
+++ b/test/passing/dune.inc
@@ -3374,6 +3374,24 @@
  (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)
diff --git a/test/passing/tests/labeled_tuples.ml b/test/passing/tests/labeled_tuples.ml
new file mode 100644
index 0000000000..b2ba00b7c6
--- /dev/null
+++ b/test/passing/tests/labeled_tuples.ml
@@ -0,0 +1,247 @@
+(* This test file is a copy of the compiler's "labeledtuples.ml" and
+   "labeled_tuples_dsource.ml" tests.  Not everything here is expected to typecheck, but
+   it should all parse.
+*)
+
+(* Basic expressions *)
+let x = ~x:1, ~y:2
+;;
+
+let z = 5
+let punned = 2
+let _ = ~x: 5, 2, ~z, ~(punned:int)
+
+(* Basic annotations *)
+let (x : x:int * y:int) = ~x:1, ~y:2
+
+let (x : x:int * int) = ~x:1, 2
+
+(* Incorrect annotations *)
+let (x : int * int) = ~x:1, 2
+
+let (x : x:string * int) = ~x:1, 2
+
+let (x : int * y:int) = ~x:1, 2
+
+(* Happy case *)
+let foo b = if b then
+   ~a: "s", 10, ~c: "hi"
+else
+   ~a: "5", 10, ~c: "hi"
+
+(* Missing label (the type vars in the error aren't ideal, but the same thing
+   happens when unifying normal tuples of different lengths) *)
+let foo b = if b then
+   ~a: "s", 10, "hi"
+else
+   ~a: "5", 10, ~c: "hi"
+
+(* Missing labeled component *)
+let foo b = if b then
+   ~a: "s", 10
+else
+   ~a: "5", 10, ~c: "hi"
+
+(* Wrong label *)
+let foo b = if b then
+   ~a: "s", 10, ~a: "hi"
+else
+   ~a: "5", 10, ~c: "hi"
+
+(* Types in function argument/return *)
+let default = ~x: 1, ~y: 2
+let choose_pt replace_with_default pt =
+   if replace_with_default then
+      default
+   else
+      pt
+
+(* Application happy case *)
+let a = choose_pt true (~x: 5, ~y: 6)
+
+(* Wrong order *)
+let a = choose_pt true (~y: 6, ~x: 5)
+
+(* Mutually-recursive definitions *)
+let rec a = 1, ~lbl:b
+and b = 2, ~lbl:a
+
+let rec l = ~lbl: 5, ~lbl2: 10 :: l
+
+(* Tuple containing labeled tuples *)
+let tup = (~a:1, ~b:2), (~b:3, ~a:4), 5
+
+(* Polymorphic variant containing labeled tuple *)
+let a = `Some (~a: 1, ~b:2, 3)
+
+(* List of labeled tuples *)
+let lst = ~a: 1, ~b: 2 :: []
+
+(* Ref of labeled tuple *)
+let x = ref (~x:"hello", 5)
+
+(* Polymorphic record containing a labeled tuple *)
+type 'a box = {thing: 'a}
+let boxed = {thing = "hello", ~x:5}
+
+(* Punned tuple components with type annotations. *)
+let x = 42
+let y = "hi"
+
+let z = ~x, ~(y:string);;;;
+
+let z = ~(x:int), ~y:"baz";;;;
+
+let z = ~(x:string), ~y:"baz";;;;
+
+(* Take a [a:'a * b:'a] and an int, and returns a
+   [swapped:[a:'a * b:'a] * same:bool].
+   The swapped component is the input with the [a] and [b] components swapped
+   as many times as the input int. The second component is whether the first
+   equals the input. *)
+let rec swap (~a, ~b) =
+   function
+   | 0 -> ~swapped:(~a, ~b), ~same:true
+   | n -> swap' (~a:b, ~b:a) (n-1)
+and swap' (~a, ~b) =
+   function
+   | 0 -> ~swapped:(~a, ~b), ~same:false
+   | n -> swap (~a:b, ~b:a) (n-1)
+
+let foobar = swap (~a:"foo", ~b:"bar") 86
+let barfoo = swap (~a:"foo", ~b:"bar") 87
+
+(* Labeled tuple type annotations *)
+(* Bad type *)
+let x: string * a:int * int = ~lbl:5, "hi"
+
+(* Well-typed *)
+let x: string * a:int * int = "hi", ~a:1, 2
+
+(* Function type *)
+let mk_x : (foo:unit * bar:unit) -> string * a:int * int = fun _ -> x
+
+let x = mk_x (~foo:(), ~bar:())
+
+(* Labeled tuples in records *)
+
+type bad_t = {x : lbl:bad_type * int}
+
+type tx = { x : foo:int * bar:int }
+type tx_unlabeled = { x : int * int }
+
+
+let _ = { x = ~foo:1, ~bar:2}
+
+let _ : tx = { x = ~foo:1, ~bar:2 }
+
+let _ : tx = {x = 1, ~bar:2}
+
+let _ : tx = { x = ~foo:1, 2}
+
+let _ : tx = { x = 1, 2}
+
+let _ = { x = 1, 2 }
+
+(* Module inclusion *)
+
+module IntString : sig
+   type t
+   val mk : (x: int * string) -> t
+   val unwrap : t -> x:int * string
+end = struct
+  type t = string * x:int
+  let mk (~x, s) = s, ~x
+  let unwrap (s, ~x) = ~x, s
+end
+
+module Stringable = struct
+   module type Has_unwrap = sig
+      type t
+      val unwrap : t -> x: int * string
+   end
+
+   module type Has_to_string = sig
+      include Has_unwrap
+      val to_string : t -> string
+   end
+
+   module Make (M : Has_unwrap) : Has_to_string with type t := M.t = struct
+      include M
+      let to_string int_string =
+         let (~x, s) = unwrap int_string in
+         (Int.to_string x) ^ " " ^ s
+   end
+end
+
+module StringableIntString = struct
+   include IntString
+   include functor Stringable.Make
+end
+
+let _ = StringableIntString.to_string (StringableIntString.mk (~x:1, "hi"))
+
+module M : sig
+  val f : (x:int * string) -> x:int * string
+  val mk : unit -> x:bool * y:string
+end = struct
+  let f x = x
+  let mk () = ~x:false, ~y:"hi"
+end
+
+(* Module inclusion failure *)
+module X_int_int = struct
+   type t = x:int * int
+end
+
+module Y_int_int : sig
+   type t = y:int * int
+end = struct
+   include X_int_int
+end
+
+module Int_int : sig
+   type t = int * int
+end = X_int_int
+
+(* Recursive modules *)
+module rec Tree : sig
+   type t = Leaf of string | Branch of string * TwoTrees.t
+   val in_order : t -> string list
+end = struct
+   type t = Leaf of string | Branch of string * TwoTrees.t
+   let rec in_order = function
+   | Leaf s -> [s]
+   | Branch (s, (~left, ~right)) -> (in_order left) @ [s] @ (in_order right)
+end
+and TwoTrees : sig
+   type t = left:Tree.t * right:Tree.t
+end = struct
+   type t = left:Tree.t * right:Tree.t
+end
+
+let leaf s = Tree.Leaf s
+let tree_abc = Tree.Branch ("b", (~left:(leaf "a"), ~right:(leaf "c")))
+let tree_abcde = Tree.Branch ("d", (~left:tree_abc, ~right:(leaf "e")))
+let _ = Tree.in_order tree_abcde
+
+(* Motivating example *)
+let two_kinds_of_sums ints =
+  let init = (~normal_sum:0, ~absolute_value_sum:0) in
+  List.fold_left (fun (~normal_sum, ~absolute_value_sum) elem ->
+    let normal_sum         = elem + normal_sum             in
+    let absolute_value_sum = abs elem + absolute_value_sum in
+    (~normal_sum, ~absolute_value_sum))
+    init ints
+
+let _ = two_kinds_of_sums [1;2;3;4]
+let _ = two_kinds_of_sums [1;2;-3;42;-17]
+
+let x = ~x:1, ~y:2
+
+(* Attribute should prevent punning *)
+let z = 5
+let y = ~z:z, ~z, ~z:(z [@attr])
+
+let (~x:x0, ~s, ~(y:int), ..) : x:int * s:string * y:int * string =
+   ~x: 1, ~s: "a", ~y: 2, "ignore me"
diff --git a/test/passing/tests/labeled_tuples.ml.opts b/test/passing/tests/labeled_tuples.ml.opts
new file mode 100644
index 0000000000..1be40ffecb
--- /dev/null
+++ b/test/passing/tests/labeled_tuples.ml.opts
@@ -0,0 +1,2 @@
+--profile=janestreet
+--max-iters=3

From 9565bdba9a9045ba0837f9b36c9dd3edc67f7161 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Wed, 6 Dec 2023 13:09:52 -0500
Subject: [PATCH 12/22] Precedence for labeled exps

---
 lib/Ast.ml | 20 ++++++++++++++++++--
 1 file changed, 18 insertions(+), 2 deletions(-)

diff --git a/lib/Ast.ml b/lib/Ast.ml
index 017a3dce80..cd88328a33 100644
--- a/lib/Ast.ml
+++ b/lib/Ast.ml
@@ -1738,8 +1738,24 @@ 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

From 1e87dcd8f2b762713610888662ed4def0cb56222 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Wed, 6 Dec 2023 13:14:48 -0500
Subject: [PATCH 13/22] formatting

---
 lib/Ast.ml | 31 +++++++++++++------------------
 1 file changed, 13 insertions(+), 18 deletions(-)

diff --git a/lib/Ast.ml b/lib/Ast.ml
index cd88328a33..2462283432 100644
--- a/lib/Ast.ml
+++ b/lib/Ast.ml
@@ -1738,24 +1738,19 @@ end = struct
         Exp.maybe_extension ctx prec_ctx_extension
         @@ fun () ->
         match pexp_desc with
-        | 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_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

From 88553f948851e6e85ffe71b60932a99a17ea547e Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Wed, 6 Dec 2023 13:27:08 -0500
Subject: [PATCH 14/22] Don't print things with attributes as punned

---
 lib/Fmt_ast.ml | 20 ++++++++++++--------
 1 file changed, 12 insertions(+), 8 deletions(-)

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index 3c0c42ff2d..9a0baea5f0 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -1145,20 +1145,22 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
         parens || Poly.(c.conf.fmt_opts.parens_tuple_patterns.v = `Always)
       in
       let fmt_lt_pat_element (lbl, pat) =
-        let pat_desc = pat.ppat_desc in
         let pat = sub_pat ~ctx pat in
         match lbl with
         | None -> fmt_pattern c pat
         | Some lbl ->
             let punned =
-              match pat_desc with
-              | Ppat_var var -> String.equal var.txt lbl
+              match pat.ast.ppat_desc with
+              | Ppat_var var ->
+                  String.equal var.txt lbl
+                  && List.is_empty pat.ast.ppat_attributes
               | _ -> false
             in
             let punned_with_constraint =
-              match pat_desc with
+              match pat.ast.ppat_desc with
               | Ppat_constraint ({ppat_desc= Ppat_var var; _}, _) ->
                   String.equal var.txt lbl
+                  && List.is_empty pat.ast.ppat_attributes
               | _ -> false
             in
             if punned then str "~" $ str lbl
@@ -2811,21 +2813,23 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
       let outer_wrap = has_attr && parens in
       let inner_wrap = has_attr || parens in
       let fmt_lt_exp_element (lbl, exp) =
-        let exp_desc = exp.pexp_desc in
         let exp = sub_exp ~ctx exp in
         match lbl with
         | None -> fmt_expression c exp
         | Some lbl ->
             let punned =
-              match exp_desc with
-              | Pexp_ident {txt= Lident var; _} -> String.equal lbl var
+              match exp.ast.pexp_desc with
+              | Pexp_ident {txt= Lident var; _} ->
+                  String.equal lbl var
+                  && List.is_empty exp.ast.pexp_attributes
               | _ -> false
             in
             let punned_with_constraint =
-              match exp_desc with
+              match exp.ast.pexp_desc with
               | Pexp_constraint
                   ({pexp_desc= Pexp_ident {txt= Lident var; _}; _}, _) ->
                   String.equal var lbl
+                  && List.is_empty exp.ast.pexp_attributes
               | _ -> false
             in
             if punned then str "~" $ str lbl

From ef826280c3b16bdb3371d4cfe2d49d495ffa6a85 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Wed, 6 Dec 2023 14:11:03 -0500
Subject: [PATCH 15/22] Do parens on arrow params better so it doesn't apply to
 rets too

---
 lib/Ast.ml     | 4 ++++
 lib/Fmt_ast.ml | 7 +------
 2 files changed, 5 insertions(+), 6 deletions(-)

diff --git a/lib/Ast.ml b/lib/Ast.ml
index 2462283432..6ec4765d66 100644
--- a/lib/Ast.ml
+++ b/lib/Ast.ml
@@ -1971,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
diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index 9a0baea5f0..f82b9a9174 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -781,14 +781,9 @@ and fmt_arrow_param c ctx
         Some (str "?" $ str l.txt $ fmt ":@," $ fmt_if localI "local_ ")
   in
   let xtI = sub_typ ~ctx tI in
-  let arg_parens =
-    match tI.ptyp_desc with
-    | Ptyp_tuple ((Some _, _) :: _) -> true
-    | _ -> false
-  in
   let arg =
     match arg_label lI with
-    | None -> Params.parens_if arg_parens c.conf (fmt_core_type c xtI)
+    | None -> fmt_core_type c xtI
     | Some f -> hovbox 2 (f $ fmt_core_type c xtI)
   in
   hvbox 0 (Cmts.fmt_before c locI $ arg)

From 9aba7459448d8d2abc56e3d2805b5e1896f465bb Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Wed, 6 Dec 2023 14:13:47 -0500
Subject: [PATCH 16/22] accept formatting in test

---
 test/passing/tests/labeled_tuples.ml | 207 +++++++++++++--------------
 1 file changed, 97 insertions(+), 110 deletions(-)

diff --git a/test/passing/tests/labeled_tuples.ml b/test/passing/tests/labeled_tuples.ml
index b2ba00b7c6..6e0fd02f7c 100644
--- a/test/passing/tests/labeled_tuples.ml
+++ b/test/passing/tests/labeled_tuples.ml
@@ -5,178 +5,153 @@
 
 (* Basic expressions *)
 let x = ~x:1, ~y:2
-;;
-
 let z = 5
 let punned = 2
-let _ = ~x: 5, 2, ~z, ~(punned:int)
+let _ = ~x:5, 2, ~z, ~(punned : int)
 
 (* Basic annotations *)
 let (x : x:int * y:int) = ~x:1, ~y:2
-
 let (x : x:int * int) = ~x:1, 2
 
 (* Incorrect annotations *)
 let (x : int * int) = ~x:1, 2
-
 let (x : x:string * int) = ~x:1, 2
-
 let (x : int * y:int) = ~x:1, 2
 
 (* Happy case *)
-let foo b = if b then
-   ~a: "s", 10, ~c: "hi"
-else
-   ~a: "5", 10, ~c: "hi"
+let foo b = if b then ~a:"s", 10, ~c:"hi" else ~a:"5", 10, ~c:"hi"
 
 (* Missing label (the type vars in the error aren't ideal, but the same thing
    happens when unifying normal tuples of different lengths) *)
-let foo b = if b then
-   ~a: "s", 10, "hi"
-else
-   ~a: "5", 10, ~c: "hi"
+let foo b = if b then ~a:"s", 10, "hi" else ~a:"5", 10, ~c:"hi"
 
 (* Missing labeled component *)
-let foo b = if b then
-   ~a: "s", 10
-else
-   ~a: "5", 10, ~c: "hi"
+let foo b = if b then ~a:"s", 10 else ~a:"5", 10, ~c:"hi"
 
 (* Wrong label *)
-let foo b = if b then
-   ~a: "s", 10, ~a: "hi"
-else
-   ~a: "5", 10, ~c: "hi"
+let foo b = if b then ~a:"s", 10, ~a:"hi" else ~a:"5", 10, ~c:"hi"
 
 (* Types in function argument/return *)
-let default = ~x: 1, ~y: 2
-let choose_pt replace_with_default pt =
-   if replace_with_default then
-      default
-   else
-      pt
+let default = ~x:1, ~y:2
+let choose_pt replace_with_default pt = if replace_with_default then default else pt
 
 (* Application happy case *)
-let a = choose_pt true (~x: 5, ~y: 6)
+let a = choose_pt true (~x:5, ~y:6)
 
 (* Wrong order *)
-let a = choose_pt true (~y: 6, ~x: 5)
+let a = choose_pt true (~y:6, ~x:5)
 
 (* Mutually-recursive definitions *)
 let rec a = 1, ~lbl:b
 and b = 2, ~lbl:a
 
-let rec l = ~lbl: 5, ~lbl2: 10 :: l
+let rec l = (~lbl:5, ~lbl2:10) :: l
 
 (* Tuple containing labeled tuples *)
 let tup = (~a:1, ~b:2), (~b:3, ~a:4), 5
 
 (* Polymorphic variant containing labeled tuple *)
-let a = `Some (~a: 1, ~b:2, 3)
+let a = `Some (~a:1, ~b:2, 3)
 
 (* List of labeled tuples *)
-let lst = ~a: 1, ~b: 2 :: []
+let lst = (~a:1, ~b:2) :: []
 
 (* Ref of labeled tuple *)
 let x = ref (~x:"hello", 5)
 
 (* Polymorphic record containing a labeled tuple *)
-type 'a box = {thing: 'a}
-let boxed = {thing = "hello", ~x:5}
+type 'a box = { thing : 'a }
+
+let boxed = { thing = "hello", ~x:5 }
 
 (* Punned tuple components with type annotations. *)
 let x = 42
 let y = "hi"
-
-let z = ~x, ~(y:string);;;;
-
-let z = ~(x:int), ~y:"baz";;;;
-
-let z = ~(x:string), ~y:"baz";;;;
+let z = ~x, ~(y : string)
+let z = ~(x : int), ~y:"baz"
+let z = ~(x : string), ~y:"baz"
 
 (* Take a [a:'a * b:'a] and an int, and returns a
    [swapped:[a:'a * b:'a] * same:bool].
    The swapped component is the input with the [a] and [b] components swapped
    as many times as the input int. The second component is whether the first
    equals the input. *)
-let rec swap (~a, ~b) =
-   function
-   | 0 -> ~swapped:(~a, ~b), ~same:true
-   | n -> swap' (~a:b, ~b:a) (n-1)
-and swap' (~a, ~b) =
-   function
-   | 0 -> ~swapped:(~a, ~b), ~same:false
-   | n -> swap (~a:b, ~b:a) (n-1)
+let rec swap (~a, ~b) = function
+  | 0 -> ~swapped:(~a, ~b), ~same:true
+  | n -> swap' (~a:b, ~b:a) (n - 1)
+
+and swap' (~a, ~b) = function
+  | 0 -> ~swapped:(~a, ~b), ~same:false
+  | n -> swap (~a:b, ~b:a) (n - 1)
+;;
 
 let foobar = swap (~a:"foo", ~b:"bar") 86
 let barfoo = swap (~a:"foo", ~b:"bar") 87
 
 (* Labeled tuple type annotations *)
 (* Bad type *)
-let x: string * a:int * int = ~lbl:5, "hi"
+let x : string * a:int * int = ~lbl:5, "hi"
 
 (* Well-typed *)
-let x: string * a:int * int = "hi", ~a:1, 2
+let x : string * a:int * int = "hi", ~a:1, 2
 
 (* Function type *)
 let mk_x : (foo:unit * bar:unit) -> string * a:int * int = fun _ -> x
-
 let x = mk_x (~foo:(), ~bar:())
 
 (* Labeled tuples in records *)
 
-type bad_t = {x : lbl:bad_type * int}
-
+type bad_t = { x : lbl:bad_type * int }
 type tx = { x : foo:int * bar:int }
 type tx_unlabeled = { x : int * int }
 
-
-let _ = { x = ~foo:1, ~bar:2}
-
+let _ = { x = ~foo:1, ~bar:2 }
 let _ : tx = { x = ~foo:1, ~bar:2 }
-
-let _ : tx = {x = 1, ~bar:2}
-
-let _ : tx = { x = ~foo:1, 2}
-
-let _ : tx = { x = 1, 2}
-
+let _ : tx = { x = 1, ~bar:2 }
+let _ : tx = { x = ~foo:1, 2 }
+let _ : tx = { x = 1, 2 }
 let _ = { x = 1, 2 }
 
 (* Module inclusion *)
 
 module IntString : sig
-   type t
-   val mk : (x: int * string) -> t
-   val unwrap : t -> x:int * string
+  type t
+
+  val mk : (x:int * string) -> t
+  val unwrap : t -> x:int * string
 end = struct
   type t = string * x:int
+
   let mk (~x, s) = s, ~x
   let unwrap (s, ~x) = ~x, s
 end
 
 module Stringable = struct
-   module type Has_unwrap = sig
-      type t
-      val unwrap : t -> x: int * string
-   end
-
-   module type Has_to_string = sig
-      include Has_unwrap
-      val to_string : t -> string
-   end
-
-   module Make (M : Has_unwrap) : Has_to_string with type t := M.t = struct
-      include M
-      let to_string int_string =
-         let (~x, s) = unwrap int_string in
-         (Int.to_string x) ^ " " ^ s
-   end
+  module type Has_unwrap = sig
+    type t
+
+    val unwrap : t -> x:int * string
+  end
+
+  module type Has_to_string = sig
+    include Has_unwrap
+
+    val to_string : t -> string
+  end
+
+  module Make (M : Has_unwrap) : Has_to_string with type t := M.t = struct
+    include M
+
+    let to_string int_string =
+      let ~x, s = unwrap int_string in
+      Int.to_string x ^ " " ^ s
+    ;;
+  end
 end
 
 module StringableIntString = struct
-   include IntString
-   include functor Stringable.Make
+  include IntString
+  include functor Stringable.Make
 end
 
 let _ = StringableIntString.to_string (StringableIntString.mk (~x:1, "hi"))
@@ -191,33 +166,42 @@ end
 
 (* Module inclusion failure *)
 module X_int_int = struct
-   type t = x:int * int
+  type t = x:int * int
 end
 
 module Y_int_int : sig
-   type t = y:int * int
+  type t = y:int * int
 end = struct
-   include X_int_int
+  include X_int_int
 end
 
 module Int_int : sig
-   type t = int * int
-end = X_int_int
+  type t = int * int
+end =
+  X_int_int
 
 (* Recursive modules *)
 module rec Tree : sig
-   type t = Leaf of string | Branch of string * TwoTrees.t
-   val in_order : t -> string list
+  type t =
+    | Leaf of string
+    | Branch of string * TwoTrees.t
+
+  val in_order : t -> string list
 end = struct
-   type t = Leaf of string | Branch of string * TwoTrees.t
-   let rec in_order = function
-   | Leaf s -> [s]
-   | Branch (s, (~left, ~right)) -> (in_order left) @ [s] @ (in_order right)
+  type t =
+    | Leaf of string
+    | Branch of string * TwoTrees.t
+
+  let rec in_order = function
+    | Leaf s -> [ s ]
+    | Branch (s, (~left, ~right)) -> in_order left @ [ s ] @ in_order right
+  ;;
 end
+
 and TwoTrees : sig
-   type t = left:Tree.t * right:Tree.t
+  type t = left:Tree.t * right:Tree.t
 end = struct
-   type t = left:Tree.t * right:Tree.t
+  type t = left:Tree.t * right:Tree.t
 end
 
 let leaf s = Tree.Leaf s
@@ -227,21 +211,24 @@ let _ = Tree.in_order tree_abcde
 
 (* Motivating example *)
 let two_kinds_of_sums ints =
-  let init = (~normal_sum:0, ~absolute_value_sum:0) in
-  List.fold_left (fun (~normal_sum, ~absolute_value_sum) elem ->
-    let normal_sum         = elem + normal_sum             in
-    let absolute_value_sum = abs elem + absolute_value_sum in
-    (~normal_sum, ~absolute_value_sum))
-    init ints
-
-let _ = two_kinds_of_sums [1;2;3;4]
-let _ = two_kinds_of_sums [1;2;-3;42;-17]
+  let init = ~normal_sum:0, ~absolute_value_sum:0 in
+  List.fold_left
+    (fun (~normal_sum, ~absolute_value_sum) elem ->
+      let normal_sum = elem + normal_sum in
+      let absolute_value_sum = abs elem + absolute_value_sum in
+      ~normal_sum, ~absolute_value_sum)
+    init
+    ints
+;;
 
+let _ = two_kinds_of_sums [ 1; 2; 3; 4 ]
+let _ = two_kinds_of_sums [ 1; 2; -3; 42; -17 ]
 let x = ~x:1, ~y:2
 
 (* Attribute should prevent punning *)
 let z = 5
-let y = ~z:z, ~z, ~z:(z [@attr])
+let y = ~z, ~z, ~z:(z [@attr])
 
-let (~x:x0, ~s, ~(y:int), ..) : x:int * s:string * y:int * string =
-   ~x: 1, ~s: "a", ~y: 2, "ignore me"
+let (~x:x0, ~s, ~(y : int), ..) : x:int * s:string * y:int * string =
+  ~x:1, ~s:"a", ~y:2, "ignore me"
+;;

From 5f69d48c9210c495959851c4fb2ebc194b3c368c Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Wed, 6 Dec 2023 15:15:13 -0500
Subject: [PATCH 17/22] Fix comment printing by adding a hovbox (?!)

---
 lib/Fmt_ast.ml | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index f82b9a9174..5a34da04fc 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -931,8 +931,6 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
         $ fmt ".@ "
         $ fmt_core_type c ~box:true (sub_typ ~ctx t) )
   | Ptyp_tuple typs ->
-      (* XXX surely will need to tweak this for more parens in labeled
-         case *)
       hvbox 0
         (wrap_if parenze_constraint_ctx "(" ")"
            (wrap_fits_breaks_if ~space:false c.conf parens "(" ")"
@@ -1158,7 +1156,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
                   && List.is_empty pat.ast.ppat_attributes
               | _ -> false
             in
-            if punned then str "~" $ str lbl
+            if punned then hovbox 0 (str "~" $ str lbl)
             else if punned_with_constraint then str "~" $ fmt_pattern c pat
             else str "~" $ str lbl $ str ":" $ fmt_pattern c pat
       in
@@ -2827,7 +2825,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
                   && List.is_empty exp.ast.pexp_attributes
               | _ -> false
             in
-            if punned then str "~" $ str lbl
+            if punned then
+              Cmts.fmt c exp.ast.pexp_loc @@ hovbox 0 (str "~" $ str lbl)
             else if punned_with_constraint then
               str "~" $ fmt_expression c exp
             else str "~" $ str lbl $ str ":" $ fmt_expression c exp

From 5725265edf6fdc4c2618f95ba49a64d14b655fbf Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Wed, 6 Dec 2023 16:33:07 -0500
Subject: [PATCH 18/22] Handling for comments and attributes

---
 lib/Fmt_ast.ml                                | 29 ++++++----
 test/passing/dune.inc                         | 36 ++++++++++++
 .../tests/labeled_tuples_cmts_attrs.ml        | 58 +++++++++++++++++++
 .../tests/labeled_tuples_cmts_attrs.ml.opts   |  2 +
 .../tests/labeled_tuples_cmts_attrs_move.ml   | 26 +++++++++
 .../labeled_tuples_cmts_attrs_move.ml.opts    |  2 +
 .../labeled_tuples_cmts_attrs_move.ml.ref     | 26 +++++++++
 vendor/parser-extended/ast_mapper.ml          |  6 +-
 vendor/parser-extended/parser.mly             | 42 +++++++++-----
 vendor/parser-extended/parsetree.mli          |  6 +-
 vendor/parser-extended/printast.ml            |  2 +-
 11 files changed, 202 insertions(+), 33 deletions(-)
 create mode 100644 test/passing/tests/labeled_tuples_cmts_attrs.ml
 create mode 100644 test/passing/tests/labeled_tuples_cmts_attrs.ml.opts
 create mode 100644 test/passing/tests/labeled_tuples_cmts_attrs_move.ml
 create mode 100644 test/passing/tests/labeled_tuples_cmts_attrs_move.ml.opts
 create mode 100644 test/passing/tests/labeled_tuples_cmts_attrs_move.ml.ref

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index 5a34da04fc..d7ee33ec25 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -1036,7 +1036,8 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
 and fmt_labeled_tuple_type c lbl xtyp =
   match lbl with
   | None -> fmt_core_type c xtyp
-  | Some s -> str s $ str ":" $ 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) =
@@ -1145,20 +1146,24 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
             let punned =
               match pat.ast.ppat_desc with
               | Ppat_var var ->
-                  String.equal var.txt lbl
+                  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
+                  String.equal var.txt lbl.txt
                   && List.is_empty pat.ast.ppat_attributes
               | _ -> false
             in
-            if punned then hovbox 0 (str "~" $ str lbl)
-            else if punned_with_constraint then str "~" $ fmt_pattern c pat
-            else str "~" $ str lbl $ str ":" $ fmt_pattern c pat
+            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
@@ -2813,7 +2818,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
             let punned =
               match exp.ast.pexp_desc with
               | Pexp_ident {txt= Lident var; _} ->
-                  String.equal lbl var
+                  String.equal lbl.txt var
                   && List.is_empty exp.ast.pexp_attributes
               | _ -> false
             in
@@ -2821,15 +2826,17 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
               match exp.ast.pexp_desc with
               | Pexp_constraint
                   ({pexp_desc= Pexp_ident {txt= Lident var; _}; _}, _) ->
-                  String.equal var lbl
+                  String.equal var lbl.txt
                   && List.is_empty exp.ast.pexp_attributes
               | _ -> false
             in
             if punned then
-              Cmts.fmt c exp.ast.pexp_loc @@ hovbox 0 (str "~" $ str lbl)
+              Cmts.fmt c lbl.loc
+              @@ Cmts.fmt c exp.ast.pexp_loc
+              @@ hovbox 0 (str "~" $ str lbl.txt)
             else if punned_with_constraint then
-              str "~" $ fmt_expression c exp
-            else str "~" $ str lbl $ str ":" $ fmt_expression c exp
+              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
diff --git a/test/passing/dune.inc b/test/passing/dune.inc
index 1d6bb7b595..24096b1ca0 100644
--- a/test/passing/dune.inc
+++ b/test/passing/dune.inc
@@ -3392,6 +3392,42 @@
  (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)
diff --git a/test/passing/tests/labeled_tuples_cmts_attrs.ml b/test/passing/tests/labeled_tuples_cmts_attrs.ml
new file mode 100644
index 0000000000..b9fe81f614
--- /dev/null
+++ b/test/passing/tests/labeled_tuples_cmts_attrs.ml
@@ -0,0 +1,58 @@
+(* Tests making sure comments and attributes are handled reasonably by labeled tuple
+   printing.  This test has examples where the comments stay in exactly the same place -
+   see [labeled_tuples_cmts_attrs_move.ml] for examples where we allow ourselves to
+   slightly shift a comment or add a pun.  *)
+
+(* Attrs around expressions *)
+let y = ~z, ~z:(z [@attr])
+let y = ~z, (z [@attr])
+let y = ~z, ~z [@@attr]
+let y = ~z:((42 [@attr]) : int), 42
+
+(* Comments around expressions *)
+let _ = (* baz *) ~z:42, ~y
+let _ = ~z:(* baz *) 42, ~y
+let _ = ~z:42 (* baz *), ~y
+let _ = ~z:42, (* baz *) ~y
+let _ = ~z:42, ~y (* baz *)
+let _ = (* baz *) ~z, ~(y : int)
+let _ = ~z (* baz *), ~(y : int)
+let _ = ~z, ~(* baz *) (y : int)
+let _ = ~z, ~((* baz *) y : int)
+let _ = ~z, ~(y : (* baz *) int)
+let _ = ~z, ~(y : int (* baz *))
+let _ = ~z, ~(y : int) (* baz *)
+
+(* Attrs around types *)
+type t = z:(int[@attr]) * y:bool
+type t = (z:int * y:bool[@attr])
+type t = z:int * y:(bool[@attr])
+type t = z:int * y:bool [@@attr]
+
+(* Comments around types *)
+type t = (* baz *) z:int * y:bool
+type t = z (* baz *):int * y:bool
+type t = z:(* baz *) int * y:bool
+type t = z:int (* baz *) * y:bool
+type t = z:int * (* baz *) y:bool
+type t = z:int * y (* baz *):bool
+type t = z:int * y:(* baz *) bool
+type t = z:int * y:bool (* baz *)
+
+(* Attrs around patterns *)
+let ~z:(z [@attr]), ~y = ()
+let ~z, ~y:(42 [@attr]) = ()
+let ((~z, ~y:42) [@attr]) = ()
+
+(* Comments around patterns *)
+let (* baz *) ~z, ~y = ()
+let ~z (* baz *), ~y = ()
+let ~z, (* baz *) ~y = ()
+let ~z, ~y (* baz *) = ()
+let (* baz *) ~z:42, ~(y : int) = ()
+let ~z:(* baz *) 42, ~(y : int) = ()
+let ~z:42 (* baz *), ~(y : int) = ()
+let ~z:42, ~((* baz *) y : int) = ()
+let ~z:42, ~(y : (* baz *) int) = ()
+let ~z:42, ~(y : int (* baz *)) = ()
+let ~z:42, ~(y : int) (* baz *) = ()
diff --git a/test/passing/tests/labeled_tuples_cmts_attrs.ml.opts b/test/passing/tests/labeled_tuples_cmts_attrs.ml.opts
new file mode 100644
index 0000000000..1be40ffecb
--- /dev/null
+++ b/test/passing/tests/labeled_tuples_cmts_attrs.ml.opts
@@ -0,0 +1,2 @@
+--profile=janestreet
+--max-iters=3
diff --git a/test/passing/tests/labeled_tuples_cmts_attrs_move.ml b/test/passing/tests/labeled_tuples_cmts_attrs_move.ml
new file mode 100644
index 0000000000..ba9858cf2e
--- /dev/null
+++ b/test/passing/tests/labeled_tuples_cmts_attrs_move.ml
@@ -0,0 +1,26 @@
+(* Tests making sure comments and attributes are handled reasonably by labeled tuple
+   printing.  This test has where we allow ourselves to slightly move a comment or add a
+   pun or parens that aren't strictly necessary.  These examples are all analagous to
+   similar cases with other forms (e.g., labeled arguments).  See
+   [labeled_tuples_cmts_attrs.ml] for examples that stay exactly the same after
+   formatting. *)
+
+(* Attrs around expressions *)
+let y = ~z, z [@attr]
+let y = ~z, ~z:z [@@attr]
+let y = ~z:(42[@attr]:int), 42
+
+(* Comments around expressions *)
+let _ = ~(* baz *)z, ~(y : int)
+let _ = ~z, (* baz *)~(y : int)
+let _ = ~z, ~(y(* baz *) : int)
+
+(* Attrs around types *)
+type t = z:int * y:bool[@attr]
+
+(* Comments around patterns *)
+let ~(* baz *)z, ~y = ()
+let ~z, ~(* baz *)y = ()
+let ~z:42, (* baz *)~(y : int) = ()
+let ~z:42, ~(* baz *)(y : int) = ()
+let ~z:42, ~(y(* baz *) : int) = ()
diff --git a/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.opts b/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.opts
new file mode 100644
index 0000000000..1be40ffecb
--- /dev/null
+++ b/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.opts
@@ -0,0 +1,2 @@
+--profile=janestreet
+--max-iters=3
diff --git a/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.ref b/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.ref
new file mode 100644
index 0000000000..e68570f159
--- /dev/null
+++ b/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.ref
@@ -0,0 +1,26 @@
+(* Tests making sure comments and attributes are handled reasonably by labeled tuple
+   printing.  This test has where we allow ourselves to slightly move a comment or add a
+   pun or parens that aren't strictly necessary.  These examples are all analagous to
+   similar cases with other forms (e.g., labeled arguments).  See
+   [labeled_tuples_cmts_attrs.ml] for examples that stay exactly the same after
+   formatting. *)
+
+(* Attrs around expressions *)
+let y = ~z, (z [@attr])
+let y = ~z, ~z [@@attr]
+let y = ~z:((42 [@attr]) : int), 42
+
+(* Comments around expressions *)
+let _ = (* baz *) ~z, ~(y : int)
+let _ = ~z, ~(* baz *) (y : int)
+let _ = ~z, ~(* baz *) (y : int)
+
+(* Attrs around types *)
+type t = (z:int * y:bool[@attr])
+
+(* Comments around patterns *)
+let (* baz *) ~z, ~y = ()
+let ~z, (* baz *) ~y = ()
+let ~z:42, ~((* baz *) y : int) = ()
+let ~z:42, ~((* baz *) y : int) = ()
+let ~z:42, ~((* baz *) y : int) = ()
diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml
index c5a79c198a..6d102f902e 100644
--- a/vendor/parser-extended/ast_mapper.ml
+++ b/vendor/parser-extended/ast_mapper.ml
@@ -205,7 +205,7 @@ module T = struct
         arrow ~loc ~attrs (List.map (map_arrow_param sub) params)
           (sub.typ sub t2)
     | Ptyp_tuple tyl ->
-        tuple ~loc ~attrs (List.map (fun (lbl, t) -> lbl, sub.typ sub t) tyl)
+        tuple ~loc ~attrs (List.map (fun (lbl, t) -> map_opt (map_loc sub) lbl, sub.typ sub t) tyl)
     | Ptyp_constr (lid, tl) ->
         constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
     | Ptyp_object (l, o) ->
@@ -537,7 +537,7 @@ module E = struct
         match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
     | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
     | Pexp_tuple el ->
-        tuple ~loc ~attrs (List.map (fun (lbl, e) -> lbl, sub.expr sub e) el)
+        tuple ~loc ~attrs (List.map (fun (lbl, e) -> map_opt (map_loc sub) lbl, sub.expr sub e) el)
     | Pexp_construct (lid, arg) ->
         construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg)
     | Pexp_variant (lab, eo) ->
@@ -660,7 +660,7 @@ module P = struct
     | Ppat_interval (c1, c2) ->
         interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2)
     | Ppat_tuple (pl, oc) ->
-        tuple ~loc ~attrs (List.map (fun (lbl, p) -> lbl, sub.pat sub p) pl) oc
+        tuple ~loc ~attrs (List.map (fun (lbl, p) -> map_opt (map_loc sub) lbl, sub.pat sub p) pl) oc
     | Ppat_construct (l, p) ->
         construct ~loc ~attrs (map_loc sub l)
           (map_opt
diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly
index 8bffc86b11..4704fdd398 100644
--- a/vendor/parser-extended/parser.mly
+++ b/vendor/parser-extended/parser.mly
@@ -100,9 +100,7 @@ let mkcf ~loc ?attrs ?docs d =
   Cf.mk ~loc:(make_loc loc) ?attrs ?docs d
 
 let mkrhs rhs loc = mkloc rhs (make_loc loc)
-(*
 let ghrhs rhs loc = mkloc rhs (ghost_loc loc)
-*)
 
 let mk_optional lbl loc = Optional (mkrhs lbl loc)
 let mk_labelled lbl loc = Labelled (mkrhs lbl loc)
@@ -3005,12 +3003,15 @@ fun_def:
   | expr
      { None, $1 }
   | LABEL simple_expr %prec below_HASH
-     { Some $1, $2 }
+     { let label = mkrhs $1 $loc($1) in
+       Some label, $2 }
   | TILDE label = LIDENT
      { let loc = $loc(label) in
-       Some label, mkexpvar ~loc label }
+       let lbl = ghrhs label loc in
+       Some lbl, mkexpvar ~loc label }
   | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN %prec below_HASH
-      { Some label,
+      { let lbl = ghrhs label $loc(label) in
+        Some lbl,
         mkexp_constraint
           ~loc:($startpos($2), $endpos) (mkexpvar ~loc:$loc(label) label) ty }
 ;
@@ -3028,12 +3029,14 @@ reversed_labeled_tuple_body:
 | l1 = LABEL x1 = simple_expr
   COMMA
   x2 = labeled_tuple_element
-    { [ x2; Some l1, x1 ] }
+  { let label = mkrhs l1 $loc(l1) in
+    [ x2; Some label, x1 ] }
 | TILDE l1 = LIDENT
   COMMA
   x2 = labeled_tuple_element
   { let loc = $loc(l1) in
-    [ x2; Some l1, mkexpvar ~loc l1] }
+    let label = ghrhs l1 loc in
+    [ x2; Some label, mkexpvar ~loc l1] }
 | TILDE LPAREN l1 = LIDENT ty1 = type_constraint RPAREN
   COMMA
   x2 = labeled_tuple_element
@@ -3041,7 +3044,8 @@ reversed_labeled_tuple_body:
       mkexp_constraint
         ~loc:($startpos($2), $endpos) (mkexpvar ~loc:$loc(l1) l1) ty1
     in
-    [ x2; Some l1, x1] }
+    let label = ghrhs l1 $loc(l1) in
+    [ x2; Some label, x1] }
 ;
 %inline labeled_tuple:
   xs = rev(reversed_labeled_tuple_body)
@@ -3182,26 +3186,32 @@ pattern_no_exn:
 %inline labeled_tuple_pat_element(self):
   | self { None, $1 }
   | LABEL simple_pattern %prec COMMA
-      { Some $1, $2 }
+      { let label = mkrhs $1 $loc($1) in
+        Some label, $2 }
   | TILDE label = LIDENT
       { let loc = $loc(label) in
-        Some label, mkpatvar ~loc label }
+        let lbl = ghrhs label loc in
+        Some lbl, mkpatvar ~loc label }
   | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN %prec COMMA
       { let loc = $loc(label) in
         let pat = mkpatvar ~loc label in
-        Some label, mkpat ~loc (Ppat_constraint (pat, cty)) }
+        let lbl = ghrhs label loc in
+        Some lbl, mkpat ~loc (Ppat_constraint (pat, cty)) }
 
 %inline labeled_tuple_pat_element_noprec(self):
   | self { None, $1 }
   | LABEL simple_pattern
-      { Some $1, $2 }
+      { let label = mkrhs $1 $loc($1) in
+        Some label, $2 }
   | TILDE label = LIDENT
       { let loc = $loc(label) in
-        Some label, mkpatvar ~loc label }
+        let lbl = ghrhs label loc in
+        Some lbl, mkpatvar ~loc label }
   | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN
       { let loc = $loc(label) in
         let pat = mkpatvar ~loc label in
-        Some label, mkpat ~loc (Ppat_constraint (pat, cty)) }
+        let lbl = ghrhs label loc in
+        Some lbl, mkpat ~loc (Ppat_constraint (pat, cty)) }
 
 labeled_tuple_pat_element_list(self):
   | labeled_tuple_pat_element_list(self) COMMA labeled_tuple_pat_element(self)
@@ -3968,6 +3978,7 @@ strict_function_or_labeled_tuple_type:
     { $1 }
   | label = LIDENT COLON proper_tuple_type %prec MINUSGREATER
     { let ty, ltys = $3 in
+      let label = mkrhs label $loc(label) in
       mktyp ~loc:$sloc (Ptyp_tuple ((Some label, ty) :: ltys))
     }
 ;
@@ -4037,7 +4048,8 @@ tuple_type:
   | atomic_type %prec STAR
      { None, $1 }
   | label = LIDENT COLON ty = atomic_type %prec STAR
-     { Some label, ty }
+     { let label = mkrhs label $loc(label) in
+       Some label, ty }
 
 (* Atomic types are the most basic level in the syntax of types.
    Atomic types include:
diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli
index 68e45ae2cd..8a6134151f 100644
--- a/vendor/parser-extended/parsetree.mli
+++ b/vendor/parser-extended/parsetree.mli
@@ -132,7 +132,7 @@ and core_type_desc =
             - [?l:T1 -> T2] when [lbl] is
                                      {{!Asttypes.arg_label.Optional}[Optional]}.
          *)
-  | Ptyp_tuple of (string option * core_type) list
+  | Ptyp_tuple of (string loc option * core_type) list
         (** [Lttyp_tuple(tl)] represents a product type:
           - [T1 * ... * Tn]       when [tl] is [(None,T1);...;(None,Tn)]
           - [L1:T1 * ... * Ln:Tn] when [tl] is [(Some L1,T1);...;(Some Ln,Tn)]
@@ -270,7 +270,7 @@ and pattern_desc =
 
            Other forms of interval are recognized by the parser
            but rejected by the type-checker. *)
-  | Ppat_tuple of (string option * pattern) list * Asttypes.closed_flag
+  | Ppat_tuple of (string loc option * pattern) list * Asttypes.closed_flag
         (** [Ppat_tuple(pl, Closed)] represents
           - [(P1, ..., Pn)]       when [pl] is [(None, P1);...;(None, Pn)]
           - [(L1:P1, ..., Ln:Pn)] when [pl] is
@@ -372,7 +372,7 @@ and expression_desc =
       (** [match E0 with P1 -> E1 | ... | Pn -> En] *)
   | Pexp_try of expression * case list
       (** [try E0 with P1 -> E1 | ... | Pn -> En] *)
-  | Pexp_tuple of (string option * expression) list
+  | Pexp_tuple of (string loc option * expression) list
         (** [Pexp_tuple(el)] represents
           - [(E1, ..., En)]
               when [el] is [(None, E1);...;(None, En)]
diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml
index edd534d9a2..3c5a3ebeba 100644
--- a/vendor/parser-extended/printast.ml
+++ b/vendor/parser-extended/printast.ml
@@ -216,7 +216,7 @@ let fmt_ty_var ppf (name, layout) =
 
 let tuple_component_label i ppf = function
   | None -> line i ppf "Label: None\n"
-  | Some s -> line i ppf "Label: Some \"%s\"\n" s
+  | Some s -> line i ppf "Label: Some \"%s\"\n" s.txt
 ;;
 
 let typevars ppf vs =

From 10560aa3806798e9e49465309faa44c6d22dd608 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Sun, 10 Dec 2023 09:40:26 -0500
Subject: [PATCH 19/22] Add the tests from labeled_tuples_and_constructors.ml

---
 test/passing/tests/labeled_tuples.ml | 43 ++++++++++++++++++++++++++--
 1 file changed, 40 insertions(+), 3 deletions(-)

diff --git a/test/passing/tests/labeled_tuples.ml b/test/passing/tests/labeled_tuples.ml
index 6e0fd02f7c..cd94542c96 100644
--- a/test/passing/tests/labeled_tuples.ml
+++ b/test/passing/tests/labeled_tuples.ml
@@ -1,6 +1,9 @@
-(* This test file is a copy of the compiler's "labeledtuples.ml" and
-   "labeled_tuples_dsource.ml" tests.  Not everything here is expected to typecheck, but
-   it should all parse.
+(* This test file is just a copy of some of the compiler's labeled tuple tests as a
+   convenient source of examples.  It include:
+   - labeledtuples.ml
+   - labeled_tuples_dsource.ml
+   - labeld_tuples_and_constructors.ml
+   Not everything here is expected to typecheck, but it should all parse.
 *)
 
 (* Basic expressions *)
@@ -232,3 +235,37 @@ let y = ~z, ~z, ~z:(z [@attr])
 let (~x:x0, ~s, ~(y : int), ..) : x:int * s:string * y:int * string =
   ~x:1, ~s:"a", ~y:2, "ignore me"
 ;;
+
+(* Constructor with labeled arguments (disallowed) *)
+
+type ('a, 'b) pair = Pair of 'a * 'b
+
+let x = Pair (~x:5, 2)
+
+(* Labeled tuple pattern in constructor pattern, with the same arity as the
+   constructor. This is intentionally disallowed. *)
+let f = function
+  | Pair (~x:5, 2) -> true
+  | _ -> false
+;;
+
+(* Labeled tuple patterns in constructor patterns with that can union with the
+   constructor pattern type. *)
+let f = function
+  | Some (~x:5, 2) -> true
+  | _ -> false
+;;
+
+type t = Foo of (x:int * int)
+
+let f = function
+  | Foo (~x:5, 2) -> true
+  | _ -> false
+;;
+
+let _ = f (Foo (~x:5, 2))
+let _ = f (Foo (~x:4, 2))
+let _ = f (Foo (~x:5, 1))
+let _ = f (Foo (5, 1))
+let _ = f (Foo (5, ~x:1))
+let _ = f (Foo (5, ~y:1))

From 143e007873183d6498b07cc3fc515768b650eb55 Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Sun, 10 Dec 2023 09:43:09 -0500
Subject: [PATCH 20/22] comment indentation

---
 vendor/parser-extended/parsetree.mli | 38 ++++++++++++++--------------
 1 file changed, 19 insertions(+), 19 deletions(-)

diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli
index 8a6134151f..0099c3fe17 100644
--- a/vendor/parser-extended/parsetree.mli
+++ b/vendor/parser-extended/parsetree.mli
@@ -133,10 +133,10 @@ and core_type_desc =
                                      {{!Asttypes.arg_label.Optional}[Optional]}.
          *)
   | Ptyp_tuple of (string loc option * core_type) list
-        (** [Lttyp_tuple(tl)] represents a product type:
-          - [T1 * ... * Tn]       when [tl] is [(None,T1);...;(None,Tn)]
-          - [L1:T1 * ... * Ln:Tn] when [tl] is [(Some L1,T1);...;(Some Ln,Tn)]
-          - A mix, e.g. [L1:T1,T2] when [tl] is [(Some L1,T1);(None,T2)]
+      (** [Ptyp_tuple(tl)] represents a product type:
+            - [T1 * ... * Tn]       when [tl] is [(None,T1);...;(None,Tn)]
+            - [L1:T1 * ... * Ln:Tn] when [tl] is [(Some L1,T1);...;(Some Ln,Tn)]
+            - A mix, e.g. [L1:T1,T2] when [tl] is [(Some L1,T1);(None,T2)]
 
           Invariant: [n >= 2]
       *)
@@ -271,16 +271,16 @@ and pattern_desc =
            Other forms of interval are recognized by the parser
            but rejected by the type-checker. *)
   | Ppat_tuple of (string loc option * pattern) list * Asttypes.closed_flag
-        (** [Ppat_tuple(pl, Closed)] represents
-          - [(P1, ..., Pn)]       when [pl] is [(None, P1);...;(None, Pn)]
-          - [(L1:P1, ..., Ln:Pn)] when [pl] is
-                                              [(Some L1, P1);...;(Some Ln, Pn)]
-          - A mix, e.g. [(L1:P1, P2)] when [pl] is [(Some L1, P1);(None, P2)]
-          - If pattern is open, then it also ends in a [..]
+      (** [Ppat_tuple(pl, Closed)] represents
+            - [(P1, ..., Pn)]       when [pl] is [(None, P1);...;(None, Pn)]
+            - [(L1:P1, ..., Ln:Pn)] when [pl] is
+                                                [(Some L1, P1);...;(Some Ln, Pn)]
+            - A mix, e.g. [(L1:P1, P2)] when [pl] is [(Some L1, P1);(None, P2)]
+            - If pattern is open, then it also ends in a [..]
 
         Invariant:
-        - If Closed, [n >= 2].
-        - If Open, [n >= 1].
+            - If Closed, [n >= 2].
+            - If Open, [n >= 1].
       *)
   | Ppat_construct of Longident.t loc * (string loc list * pattern) option
       (** [Ppat_construct(C, args)] represents:
@@ -373,13 +373,13 @@ and expression_desc =
   | Pexp_try of expression * case list
       (** [try E0 with P1 -> E1 | ... | Pn -> En] *)
   | Pexp_tuple of (string loc option * expression) list
-        (** [Pexp_tuple(el)] represents
-          - [(E1, ..., En)]
-              when [el] is [(None, E1);...;(None, En)]
-          - [(~L1:E1, ..., ~Ln:En)]
-              when [el] is [(Some L1, E1);...;(Some Ln, En)]
-          - A mix, e.g.:
-              [(~L1:E1, E2)] when [el] is [(Some L1, E1); (None, E2)]
+      (** [Pexp_tuple(el)] represents
+            - [(E1, ..., En)]
+                when [el] is [(None, E1);...;(None, En)]
+            - [(~L1:E1, ..., ~Ln:En)]
+                when [el] is [(Some L1, E1);...;(Some Ln, En)]
+            - A mix, e.g.:
+                [(~L1:E1, E2)] when [el] is [(Some L1, E1); (None, E2)]
 
           Invariant: [n >= 2].
       *)

From 5651798837641c2ca215ddc793547d8fa209eb1b Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Sun, 10 Dec 2023 09:58:31 -0500
Subject: [PATCH 21/22] nits

---
 vendor/parser-extended/printast.ml | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml
index 3c5a3ebeba..95d504623c 100644
--- a/vendor/parser-extended/printast.ml
+++ b/vendor/parser-extended/printast.ml
@@ -216,7 +216,7 @@ let fmt_ty_var ppf (name, layout) =
 
 let tuple_component_label i ppf = function
   | None -> line i ppf "Label: None\n"
-  | Some s -> line i ppf "Label: Some \"%s\"\n" s.txt
+  | Some s -> line i ppf "Label: Some %a\n" fmt_string_loc s
 ;;
 
 let typevars ppf vs =
@@ -373,8 +373,7 @@ and pattern i ppf x =
       line i ppf "Ppat_cons\n";
       list i pattern ppf l
 
-and labeled_pattern =
-  fun i ppf (label, x) ->
+and labeled_pattern i ppf (label, x) =
     tuple_component_label i ppf label;
     pattern i ppf x
 

From b016235e4685255ffb8c8a904eee2a7f991631ce Mon Sep 17 00:00:00 2001
From: Chris Casinghino <ccasinghino@janestreet.com>
Date: Sun, 10 Dec 2023 09:58:42 -0500
Subject: [PATCH 22/22] Adjust printing of comments in puns with constraints

---
 lib/Fmt_ast.ml                                           | 4 ++--
 test/passing/tests/labeled_tuples_cmts_attrs_move.ml.ref | 4 ++--
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index d7ee33ec25..43c8e026e7 100644
--- a/lib/Fmt_ast.ml
+++ b/lib/Fmt_ast.ml
@@ -1162,7 +1162,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
               @@ 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
+              Cmts.fmt c lbl.loc @@ (str "~" $ fmt_pattern c pat)
             else str "~" $ str lbl.txt $ str ":" $ fmt_pattern c pat
       in
       let fmt_elements =
@@ -2835,7 +2835,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
               @@ 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
+              Cmts.fmt c lbl.loc @@ (str "~" $ fmt_expression c exp)
             else str "~" $ str lbl.txt $ str ":" $ fmt_expression c exp
       in
       pro
diff --git a/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.ref b/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.ref
index e68570f159..f80dfcb2f6 100644
--- a/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.ref
+++ b/test/passing/tests/labeled_tuples_cmts_attrs_move.ml.ref
@@ -13,7 +13,7 @@ let y = ~z:((42 [@attr]) : int), 42
 (* Comments around expressions *)
 let _ = (* baz *) ~z, ~(y : int)
 let _ = ~z, ~(* baz *) (y : int)
-let _ = ~z, ~(* baz *) (y : int)
+let _ = ~z, ~(y : int) (* baz *)
 
 (* Attrs around types *)
 type t = (z:int * y:bool[@attr])
@@ -23,4 +23,4 @@ let (* baz *) ~z, ~y = ()
 let ~z, (* baz *) ~y = ()
 let ~z:42, ~((* baz *) y : int) = ()
 let ~z:42, ~((* baz *) y : int) = ()
-let ~z:42, ~((* baz *) y : int) = ()
+let ~z:42, ~(y : int) (* baz *) = ()