Concrete node for tuple element punning

Author: Octachron

lib/Ast.ml

@@ -978,7 +978,7 @@ end = struct
       | 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 x -> x.te_elt == typ))
+          assert (List.exists t1N ~f:(fun x -> x.lte_elt == typ))
       | Ptyp_constr (_, t1N) -> assert (List.exists t1N ~f)
       | Ptyp_variant (r1N, _, _) ->
           assert (
@@ -1023,6 +1023,11 @@ end = struct
           assert (List.exists ptyp.ppt_cstrs ~f:(fun (_, t) -> typ == t))
       | Ppat_record (l, _) ->
           assert (List.exists l ~f:(fun (_, t, _) -> Option.exists t ~f))
+      | Ppat_tuple (l, _) ->
+          assert (
+            List.exists l ~f:(function
+              | Lte_constrained_pun x -> x.type_constraint == typ
+              | _ -> false ) )
       | _ -> assert false )
     | Exp ctx -> (
       match ctx.pexp_desc with
@@ -1041,6 +1046,16 @@ end = struct
                 Option.exists c ~f:check_type_constraint ) )
       | Pexp_let (lbs, _, _) -> assert (check_let_bindings lbs)
       | Pexp_function (_, Some t1, _, _) -> assert (check_type_constraint t1)
+      | Pexp_tuple l ->
+          assert (
+            List.exists l ~f:(function
+              | Lte_constrained_pun
+                  {type_constraint= Pconstraint t | Pcoerce (None, t); _} ->
+                  t == typ
+              | Lte_constrained_pun
+                  {type_constraint= Pcoerce (Some bty, ty); _} ->
+                  typ == bty || typ == ty
+              | _ -> false ) )
       | _ -> assert false )
     | Fpe _ | Fpc _ -> assert false
     | Vc c -> assert (check_value_constraint c)
@@ -1258,7 +1273,10 @@ end = struct
         let f pI = pI == pat in
         match ctx.ppat_desc with
         | Ppat_tuple (p1N, _) ->
-            assert (List.exists p1N ~f:(fun x -> f x.te_elt))
+            assert (
+              List.exists p1N ~f:(function
+                | Lte_simple s -> f s.lte_elt
+                | _ -> false ) )
         | Ppat_array p1N | Ppat_list p1N | Ppat_cons p1N ->
             assert (List.exists p1N ~f)
         | Ppat_record (p1N, _) ->
@@ -1428,7 +1446,10 @@ end = struct
             (* FAIL *)
             assert (e0 == exp || List.exists e1N ~f:snd_f)
         | Pexp_tuple e1N ->
-            assert (List.exists e1N ~f:(fun te -> te.te_elt == exp))
+            assert (
+              List.exists e1N ~f:(function
+                | Lte_simple te -> te.lte_elt == exp
+                | _ -> false ) )
         | Pexp_array e1N | Pexp_list e1N | Pexp_cons e1N ->
             assert (List.exists e1N ~f)
         | Pexp_construct (_, e) | Pexp_variant (_, e) ->
@@ -1536,7 +1557,10 @@ end = struct
     | Pexp_construct (_, Some e0) | Pexp_variant (_, Some e0) ->
         Exp.is_trivial e0
     | Pexp_tuple e1N ->
-        List.for_all e1N ~f:(fun te -> Exp.is_trivial te.te_elt)
+        List.for_all e1N ~f:(function
+          | Lte_pun _ -> true
+          | Lte_constrained_pun _ -> false
+          | Lte_simple lte -> Exp.is_trivial lte.lte_elt )
         && fit_margin c (width xexp)
     | Pexp_array e1N | Pexp_list e1N ->
         List.for_all e1N ~f:Exp.is_trivial && fit_margin c (width xexp)
@@ -1640,8 +1664,9 @@ end = struct
     | {ast= Typ _; _} -> None
     | {ctx= Exp {pexp_desc; _}; ast= Exp exp} -> (
       match pexp_desc with
-      | Pexp_tuple ({te_elt= e0; _} :: _) ->
+      | Pexp_tuple (Lte_simple {lte_elt= e0; _} :: _) ->
           Some (Comma, if exp == e0 then Left else Right)
+      | Pexp_tuple (_ :: _) -> Some (Comma, Right)
       | Pexp_cons l ->
           Some (ColonColon, if exp == List.last_exn l then Right else Left)
       | Pexp_construct
@@ -1857,7 +1882,7 @@ end = struct
           ( Str {pstr_desc= Pstr_exception _; _}
           | Sig {psig_desc= Psig_exception _; _} ) } ->
         true
-    | { ast= {ptyp_desc= Ptyp_tuple ({te_label= Some _; _} :: _); _}
+    | { ast= {ptyp_desc= Ptyp_tuple ({lte_label= Some _; _} :: _); _}
       ; ctx= Typ {ptyp_desc= Ptyp_arrow _; _} } ->
         true
     | _ -> (
@@ -2051,6 +2076,9 @@ end = struct
     register_reset (fun () -> Hashtbl.clear memo) ;
     memo
 
+  let last_tuple_and_simple f l =
+    match List.last_exn l with Lte_simple l -> f l.lte_elt | _ -> false
+
   (** [exposed cls exp] holds if there is a right-most subexpression of [exp]
       which satisfies [Exp.mem_cls cls] and is not parenthesized. *)
   let rec exposed_right_exp =
@@ -2099,7 +2127,7 @@ end = struct
          |Pexp_try (_, cases, _) ->
             continue (List.last_exn cases).pc_rhs
         | Pexp_apply (_, args) -> continue (snd (List.last_exn args))
-        | Pexp_tuple es -> continue (List.last_exn es).te_elt
+        | Pexp_tuple es -> last_tuple_and_simple continue es
         | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
          |Pexp_constraint _
          |Pexp_construct (_, None)
@@ -2180,7 +2208,7 @@ end = struct
       | Pexp_indexop_access {pia_rhs= rhs; _} -> (
         match rhs with Some e -> continue e | None -> false )
       | Pexp_apply (_, args) -> continue (snd (List.last_exn args))
-      | Pexp_tuple es -> continue (List.last_exn es).te_elt
+      | Pexp_tuple es -> last_tuple_and_simple continue es
       | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _
        |Pexp_constraint _
        |Pexp_construct (_, None)
@@ -2232,7 +2260,7 @@ end = struct
                && Option.value_map ~default:false (prec_ast ctx) ~f:(fun p ->
                    Prec.compare p Apply < 0 ) ->
             true
-        | Pexp_tuple e1N -> (List.last_exn e1N).te_elt == xexp.ast
+        | Pexp_tuple e1N -> last_tuple_and_simple (( == ) xexp.ast) e1N
         | _ -> false
       in
       match ambig_prec (sub_ast ~ctx (Exp exp)) with

lib/Exposed.ml

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

lib/Extended_ast.ml

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

lib/Fmt_ast.ml

@@ -966,7 +966,7 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
         $ fmt_core_type c ?box:box_core_type ~pro_space:false
             (sub_typ ~ctx t) )
   | Ptyp_tuple typs ->
-      let with_label {te_label= lbl; te_elt= typ} =
+      let with_label {lte_label= lbl; lte_elt= typ} =
         let label = fmt_tuple_label c lbl (str ":") in
         label $ fmt_core_type c (sub_typ ~ctx typ)
       in
@@ -1164,20 +1164,20 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
       let parens =
         parens || Poly.(c.conf.fmt_opts.parens_tuple_patterns.v = `Always)
       in
-      let with_label {te_label= lbl; te_elt= pat} =
-        match (lbl, pat) with
-        | ( Some {txt= label; loc}
-          , { ppat_desc=
-                ( Ppat_var var
-                | Ppat_constraint ({ppat_desc= Ppat_var var; _}, _) )
-            ; ppat_attributes= []
-            ; _ } )
-          when String.(var.txt = label) ->
-            Cmts.fmt c loc @@ str "~" $ fmt_pattern c (sub_pat ~ctx pat)
-        | (Some _ as lbl), {ppat_desc= Ppat_construct _; _} ->
+      let with_label = function
+        | Lte_pun l -> fmt_str_loc c ~pre:"~" l
+        | Lte_constrained_pun {loc; label; type_constraint} ->
+            Cmts.fmt c loc
+              ( str "~(" $ fmt_str_loc c label $ space_break $ str ":"
+              $ space_break
+              $ fmt_core_type c (sub_typ ~ctx type_constraint)
+              $ str ")" )
+        | Lte_simple
+            { lte_label= Some _ as lbl
+            ; lte_elt= {ppat_desc= Ppat_construct _; _} as pat } ->
             let label = fmt_tuple_label c ~pre:"~" lbl (str ":") in
             label $ fmt_pattern ~parens:true c (sub_pat ~ctx pat)
-        | lbl, _ ->
+        | Lte_simple {lte_label= lbl; lte_elt= pat} ->
             let label = fmt_tuple_label c ~pre:"~" lbl (str ":") in
             label $ fmt_pattern c (sub_pat ~ctx pat)
       in
@@ -2863,23 +2863,22 @@ 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 with_label {te_label= lbl; te_elt= exp} =
-        match (lbl, exp) with
-        | ( Some {txt; loc}
-          , { pexp_desc=
-                ( Pexp_ident {txt= Lident i; _}
-                | Pexp_constraint
-                    ({pexp_desc= Pexp_ident {txt= Lident i; _}; _}, _) )
-            ; pexp_attributes= []
-            ; _ } )
-          when String.equal i txt ->
-            Cmts.fmt c loc @@ str "~" $ fmt_expression c (sub_exp ~ctx exp)
-        | (Some _ as lbl), {pexp_desc= Pexp_apply _ | Pexp_function _; _} ->
+      let with_label = function
+        | Lte_pun l -> fmt_str_loc c ~pre:"~" l
+        | Lte_constrained_pun {loc; label; type_constraint} ->
+            Cmts.fmt c loc
+              ( str "~(" $ fmt_str_loc c label
+              $ fmt_type_constraint c ctx type_constraint
+              $ str ")" )
+        | Lte_simple
+            { lte_label= Some _ as lbl
+            ; lte_elt= {pexp_desc= Pexp_apply _ | Pexp_function _; _} as exp
+            } ->
             fmt_tuple_label c ~pre:"~" lbl (str ":")
             $ fmt_expression ~parens:true c (sub_exp ~ctx exp)
-        | lbl, _ ->
-            fmt_tuple_label c ~pre:"~" lbl (str ":")
-            $ fmt_expression c (sub_exp ~ctx exp)
+        | Lte_simple {lte_label= lbl; lte_elt= pat} ->
+            let label = fmt_tuple_label c ~pre:"~" lbl (str ":") in
+            label $ fmt_expression c (sub_exp ~ctx pat)
       in
       pro
       $ hvbox_if outer_wrap 0

test/passing/refs.ahrefs/labeled_tuples.ml.ref

@@ -593,6 +593,12 @@ let ~(x : int), _ = ~x:0, 1
 
 let _ = ~(x : int), ~(y : int)
 
+let _ = ~(x : int :> float), ~y, ~z
+
+(** Normalization *)
+
+let ~x:{ x }, ~y, ~(z : t), .. = ~x:{ x }, ~y, ~(z : t), ~(w : t :> t)
+
 (** Comment tests *)
 type t =
   (*before*)
@@ -601,3 +607,25 @@ type t =
   y:(*after y, before the type*) int (* after the type, before * *)
   * (* before the z label *)
   z:(*after z label *) float (*end*)
+
+let
+  (*before*)
+  ( ~(x
+    (*l-ty*)
+    :
+    int (*after-ty*))
+    (*after x*),
+    (*before y*)
+    ~y
+    (* after y *),
+    (* bz *)
+    ~z:(*zv*) 0 (*end*) ) =
+  (*before*)
+  ( ~(x
+    : (*l-ty*) int (*after-ty*))
+    (*after x*),
+    (*before y*)
+    ~y
+    (* after y *),
+    (* bz *)
+    ~z:(*zv*) 0 (*end*) )