flambda-backend: Labeled Tuples (#2009)

* Labeled tuples

* A couple minor error message improvements

* Turn on labeled tuples by default

* Delete some CRs in ocamldoc - we don't care about this tool

* Move source test to correct location

* Final nits

* Add test with attribute

* Add more attributes in tests

* Address review feedback about jane syntax attributes

* An additional test for reordering

---------

Co-authored-by: Ryan Tjoa <[email protected]>
Co-authored-by: Nick Roberts <[email protected]>

debugger/eval.ml

@@ -120,7 +120,10 @@ let rec expression event env = function
         Ttuple ty_list ->
           if n < 1 || n > List.length ty_list
           then raise(Error(Tuple_index(ty, List.length ty_list, n)))
-          else (Debugcom.Remote_value.field v (n-1), List.nth ty_list (n-1))
+          (* CR labeled tuples: handle labels in debugger (also see "E_field"
+             case) *)
+          else (Debugcom.Remote_value.field v (n-1),
+                snd (List.nth ty_list (n-1)))
       | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array ->
           let size = Debugcom.Remote_value.size v in
           if n >= size

lambda/matching.ml

@@ -309,7 +309,8 @@ end = struct
       match p.pat_desc with
       | `Any -> `Any
       | `Constant cst -> `Constant cst
-      | `Tuple ps -> `Tuple (List.map (alpha_pat env) ps)
+      | `Tuple ps ->
+          `Tuple (List.map (fun (label, p) -> label, alpha_pat env p) ps)
       | `Construct (cstr, cst_descr, args) ->
           `Construct (cstr, cst_descr, List.map (alpha_pat env) args)
       | `Variant (cstr, argo, row_desc) ->
@@ -642,7 +643,7 @@ end
 let rec flatten_pat_line size p k =
   match p.pat_desc with
   | Tpat_any | Tpat_var _ -> Patterns.omegas size :: k
-  | Tpat_tuple args -> args :: k
+  | Tpat_tuple args -> (List.map snd args) :: k
   | Tpat_or (p1, p2, _) ->
       flatten_pat_line size p1 (flatten_pat_line size p2 k)
   | Tpat_alias (p, _, _, _, _) ->
@@ -2211,7 +2212,7 @@ let divide_lazy ~scopes head ctx pm =
 let get_pat_args_tuple arity p rem =
   match p with
   | { pat_desc = Tpat_any } -> Patterns.omegas arity @ rem
-  | { pat_desc = Tpat_tuple args } -> args @ rem
+  | { pat_desc = Tpat_tuple args } -> (List.map snd args) @ rem
   | _ -> assert false
 
 let get_expr_args_tuple ~scopes head (arg, _mut, _sort, _layout) rem =
@@ -3985,10 +3986,13 @@ let assign_pat ~scopes body_layout opt nraise catch_ids loc pat pat_sort lam =
     match (pat.pat_desc, lam) with
     | Tpat_tuple patl, Lprim (Pmakeblock _, lams, _) ->
         opt := true;
-        List.fold_left2 (collect Jkind.Sort.for_tuple_element) acc patl lams
+        List.fold_left2
+          (fun acc (_, pat) lam ->
+             collect Jkind.Sort.for_tuple_element acc pat lam)
+          acc patl lams
     | Tpat_tuple patl, Lconst (Const_block (_, scl)) ->
         opt := true;
-        let collect_const acc pat sc =
+        let collect_const acc (_, pat) sc =
           collect Jkind.Sort.for_tuple_element acc pat (Lconst sc)
         in
         List.fold_left2 collect_const acc patl scl
@@ -4070,13 +4074,13 @@ let for_tupled_function ~scopes ~return_layout loc paraml pats_act_list partial
 
 let flatten_pattern size p =
   match p.pat_desc with
-  | Tpat_tuple args -> args
+  | Tpat_tuple args -> List.map snd args
   | Tpat_any -> Patterns.omegas size
   | _ -> raise Cannot_flatten
 
 let flatten_simple_pattern size (p : Simple.pattern) =
   match p.pat_desc with
-  | `Tuple args -> args
+  | `Tuple args -> (List.map snd args)
   | `Any -> Patterns.omegas size
   | `Array _
   | `Variant _

lambda/translcore.ml

@@ -226,7 +226,7 @@ let rec trivial_pat pat =
   | Tpat_construct (_, cd, [], _) ->
       not cd.cstr_generalized && cd.cstr_consts = 1 && cd.cstr_nonconsts = 0
   | Tpat_tuple patl ->
-      List.for_all trivial_pat patl
+      List.for_all (fun (_, p) -> trivial_pat p) patl
   | _ -> false
 
 let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases
@@ -461,7 +461,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
   | Texp_tuple (el, alloc_mode) ->
       let ll, shape =
         transl_list_with_shape ~scopes
-          (List.map (fun a -> (a, Jkind.Sort.for_tuple_element)) el)
+          (List.map (fun (_, a) -> (a, Jkind.Sort.for_tuple_element)) el)
       in
       begin try
         Lconst(Const_block(0, List.map extract_constant ll))
@@ -1700,11 +1700,15 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial =
     | {exp_desc = Texp_tuple (argl, alloc_mode)}, [] ->
       assert (static_handlers = []);
       let mode = transl_alloc_mode alloc_mode in
-      let argl = List.map (fun a -> (a, Jkind.Sort.for_tuple_element)) argl in
+      let argl =
+        List.map (fun (_, a) -> (a, Jkind.Sort.for_tuple_element)) argl
+      in
       Matching.for_multiple_match ~scopes ~return_layout e.exp_loc
         (transl_list_with_layout ~scopes argl) mode val_cases partial
     | {exp_desc = Texp_tuple (argl, alloc_mode)}, _ :: _ ->
-        let argl = List.map (fun a -> (a, Jkind.Sort.for_tuple_element)) argl in
+        let argl =
+          List.map (fun (_, a) -> (a, Jkind.Sort.for_tuple_element)) argl
+        in
         let val_ids, lvars =
           List.map
             (fun (arg,s) ->

ocamldoc/odoc_ast.ml

@@ -262,7 +262,7 @@ module Analyser =
 
         | Typedtree.Tpat_tuple patlist ->
             Tuple
-              (List.map iter_pattern patlist,
+              (List.map (fun (_, p) -> iter_pattern p) patlist,
                Odoc_env.subst_type env pat.pat_type)
 
         | Typedtree.Tpat_construct (_, cons_desc, _, _) when

ocamldoc/odoc_value.ml

@@ -91,7 +91,7 @@ let dummy_parameter_list typ =
         let open Asttypes in
         if label = Nolabel then
           Odoc_parameter.Tuple
-            (List.map (fun t2 -> iter (Nolabel, t2)) l, t)
+            (List.map (fun t2 -> iter (Nolabel, t2)) (List.map snd l), t)
         else
           (* if there is a label, then we don't want to decompose the tuple *)
           Odoc_parameter.Simple_name

parsing/ast_invariants.ml

@@ -20,6 +20,17 @@ let err = Syntaxerr.ill_formed_ast
 
 let empty_record loc = err loc "Records cannot be empty."
 let invalid_tuple loc = err loc "Tuples must have at least 2 components."
+let unlabeled_labeled_tuple_typ loc =
+  err loc "Labeled tuple types must have at least one labeled component."
+let unlabeled_labeled_tuple_exp loc =
+  err loc "Labeled tuples must have at least one labeled component."
+let unlabeled_labeled_tuple_pat loc =
+  err loc
+    "Closed labeled tuple patterns must have at least one labeled component."
+let empty_open_labeled_tuple_pat loc =
+  err loc "Open labeled tuple patterns must have at least one component."
+let short_closed_labeled_tuple_pat loc =
+  err loc "Closed labeled tuple patterns must have at least 2 components."
 let no_args loc = err loc "Function application with no argument."
 let empty_let loc = err loc "Let with no bindings."
 let empty_type loc = err loc "Type declarations cannot be empty."
@@ -43,6 +54,9 @@ let simple_longident id =
   in
   if not (is_simple id.txt) then complex_id id.loc
 
+let labeled_tuple_without_label lt =
+  List.for_all (fun (lbl,_) -> Option.is_none lbl) lt
+
 let iterator =
   let super = Ast_iterator.default_iterator in
   let type_declaration self td =
@@ -52,15 +66,39 @@ let iterator =
     | Ptype_record [] -> empty_record loc
     | _ -> ()
   in
+  let jtyp _self loc (jtyp : Jane_syntax.Core_type.t) =
+    match jtyp with
+    | Jtyp_layout (Ltyp_var _ | Ltyp_poly _ | Ltyp_alias _) -> ()
+    | Jtyp_tuple (Lttyp_tuple ([] | [_])) -> invalid_tuple loc
+    | Jtyp_tuple (Lttyp_tuple l) ->
+      if labeled_tuple_without_label l then unlabeled_labeled_tuple_typ loc
+  in
   let typ self ty =
     super.typ self ty;
     let loc = ty.ptyp_loc in
+    match Jane_syntax.Core_type.of_ast ty with
+    | Some (jtyp_, _attrs) -> jtyp self ty.ptyp_loc jtyp_
+    | None ->
     match ty.ptyp_desc with
     | Ptyp_tuple ([] | [_]) -> invalid_tuple loc
     | Ptyp_package (_, cstrs) ->
       List.iter (fun (id, _) -> simple_longident id) cstrs
     | _ -> ()
   in
+  let jpat _self loc (jpat : Jane_syntax.Pattern.t) =
+    match jpat with
+    | Jpat_immutable_array (Iapat_immutable_array _)-> ()
+    | Jpat_layout (Lpat_constant _) -> ()
+    | Jpat_tuple lt -> begin
+        match lt with
+        | Ltpat_tuple ([], Open) -> empty_open_labeled_tuple_pat loc
+        | Ltpat_tuple (([] | [_]), Closed) ->
+          short_closed_labeled_tuple_pat loc
+        | Ltpat_tuple (l, Closed) ->
+          if labeled_tuple_without_label l then unlabeled_labeled_tuple_pat loc
+        | Ltpat_tuple (_ :: _, Open) -> ()
+      end
+  in
   let pat self pat =
     begin match pat.ppat_desc with
     | Ppat_construct (_, Some (_, ({ppat_desc = Ppat_tuple _} as p)))
@@ -70,6 +108,9 @@ let iterator =
         super.pat self pat
     end;
     let loc = pat.ppat_loc in
+    match Jane_syntax.Pattern.of_ast pat with
+    | Some (jpat_, _attrs) -> jpat self pat.ppat_loc jpat_
+    | None ->
     match pat.ppat_desc with
     | Ppat_tuple ([] | [_]) -> invalid_tuple loc
     | Ppat_record ([], _) -> empty_record loc
@@ -100,6 +141,12 @@ let iterator =
         | Cexp_array_comprehension (_, {clauses = []; body = _}) )
       ->
         empty_comprehension loc
+    | Jexp_tuple lt -> begin
+        match lt with
+        | Ltexp_tuple ([] | [_]) -> invalid_tuple loc
+        | Ltexp_tuple l ->
+          if labeled_tuple_without_label l then unlabeled_labeled_tuple_exp loc
+      end
     | Jexp_comprehension _
     | Jexp_immutable_array _
     | Jexp_layout _

parsing/ast_iterator.ml

@@ -98,6 +98,8 @@ let iter_loc_txt sub f { loc; txt } =
 module T = struct
   (* Type expressions for the core language *)
 
+  module LT = Jane_syntax.Labeled_tuples
+
   let row_field sub {
       prf_desc;
       prf_loc;
@@ -137,8 +139,12 @@ module T = struct
       sub.typ sub aliased_type;
       iter_loc_txt sub sub.jkind_annotation jkind
 
+  let iter_jst_labeled_tuple sub : LT.core_type -> _ = function
+    | Lttyp_tuple tl -> List.iter (iter_snd (sub.typ sub)) tl
+
   let iter_jst sub : Jane_syntax.Core_type.t -> _ = function
     | Jtyp_layout typ -> iter_jst_layout sub typ
+    | Jtyp_tuple lt_typ -> iter_jst_labeled_tuple sub lt_typ
 
   let iter sub ({ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs}
                   as typ) =
@@ -438,6 +444,7 @@ module E = struct
   module IA = Jane_syntax.Immutable_arrays
   module L = Jane_syntax.Layouts
   module N_ary = Jane_syntax.N_ary_functions
+  module LT = Jane_syntax.Labeled_tuples
 
   let iter_iterator sub : C.iterator -> _ = function
     | Range { start; stop; direction = _ } ->
@@ -511,11 +518,15 @@ module E = struct
       Option.iter (iter_function_constraint sub) constraint_;
       iter_function_body sub body
 
+  let iter_labeled_tuple sub : LT.expression -> _ = function
+    | Ltexp_tuple el -> List.iter (iter_snd (sub.expr sub)) el
+
   let iter_jst sub : Jane_syntax.Expression.t -> _ = function
     | Jexp_comprehension comp_exp -> iter_comp_exp sub comp_exp
     | Jexp_immutable_array iarr_exp -> iter_iarr_exp sub iarr_exp
     | Jexp_layout layout_exp -> iter_layout_exp sub layout_exp
     | Jexp_n_ary_function n_ary_exp -> iter_n_ary_function sub n_ary_exp
+    | Jexp_tuple lt_exp -> iter_labeled_tuple sub lt_exp
 
   let iter sub
         ({pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} as expr)=
@@ -611,14 +622,20 @@ module P = struct
   (* Patterns *)
 
   module IA = Jane_syntax.Immutable_arrays
+  module LT = Jane_syntax.Labeled_tuples
 
   let iter_iapat sub : IA.pattern -> _ = function
     | Iapat_immutable_array elts ->
       List.iter (sub.pat sub) elts
 
+  let iter_labeled_tuple sub : LT.pattern -> _ = function
+    | Ltpat_tuple (pl, _) ->
+      List.iter (iter_snd (sub.pat sub)) pl
+
   let iter_jst sub : Jane_syntax.Pattern.t -> _ = function
     | Jpat_immutable_array iapat -> iter_iapat sub iapat
     | Jpat_layout (Lpat_constant _) -> iter_constant
+    | Jpat_tuple ltpat -> iter_labeled_tuple sub ltpat
 
   let iter sub
         ({ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} as pat) =

parsing/ast_mapper.ml

@@ -121,6 +121,8 @@ end
 module T = struct
   (* Type expressions for the core language *)
 
+  module LT = Jane_syntax.Labeled_tuples
+
   let row_field sub {
       prf_desc;
       prf_loc;
@@ -171,9 +173,14 @@ module T = struct
       let jkind = map_loc_txt sub sub.jkind_annotation jkind in
       Ltyp_alias { aliased_type; name; jkind }
 
+  let map_jst_labeled_tuple sub : LT.core_type -> LT.core_type = function
+    (* CR labeled tuples: Eventually mappers may want to see the labels. *)
+    | Lttyp_tuple tl -> Lttyp_tuple (List.map (map_snd (sub.typ sub)) tl)
+
   let map_jst sub : Jane_syntax.Core_type.t -> Jane_syntax.Core_type.t =
     function
     | Jtyp_layout typ -> Jtyp_layout (map_jst_layouts sub typ)
+    | Jtyp_tuple x -> Jtyp_tuple (map_jst_labeled_tuple sub x)
 
   let map sub ({ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs}
                  as typ) =
@@ -518,6 +525,7 @@ module E = struct
   module IA = Jane_syntax.Immutable_arrays
   module L = Jane_syntax.Layouts
   module N_ary = Jane_syntax.N_ary_functions
+  module LT = Jane_syntax.Labeled_tuples
 
   let map_iterator sub : C.iterator -> C.iterator = function
     | Range { start; stop; direction } ->
@@ -607,12 +615,17 @@ module E = struct
       let body = map_function_body sub body in
       params, constraint_, body
 
+  let map_ltexp sub : LT.expression -> LT.expression = function
+    (* CR labeled tuples: Eventually mappers may want to see the labels. *)
+    | Ltexp_tuple el -> Ltexp_tuple (List.map (map_snd (sub.expr sub)) el)
+
   let map_jst sub : Jane_syntax.Expression.t -> Jane_syntax.Expression.t =
     function
     | Jexp_comprehension x -> Jexp_comprehension (map_cexp sub x)
     | Jexp_immutable_array x -> Jexp_immutable_array (map_iaexp sub x)
     | Jexp_layout x -> Jexp_layout (map_layout_exp sub x)
     | Jexp_n_ary_function x -> Jexp_n_ary_function (map_n_ary_exp sub x)
+    | Jexp_tuple ltexp -> Jexp_tuple (map_ltexp sub ltexp)
 
   let map sub
         ({pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} as exp) =
@@ -718,6 +731,7 @@ module P = struct
 
   module IA = Jane_syntax.Immutable_arrays
   module L = Jane_syntax.Layouts
+  module LT = Jane_syntax.Labeled_tuples
 
   let map_iapat sub : IA.pattern -> IA.pattern = function
     | Iapat_immutable_array elts ->
@@ -729,10 +743,16 @@ module P = struct
     *)
     | Float _ | Integer _ as x -> x
 
+  let map_ltpat sub : LT.pattern -> LT.pattern = function
+    (* CR labeled tuples: Eventually mappers may want to see the labels. *)
+    | Ltpat_tuple (pl, closed) ->
+      Ltpat_tuple (List.map (map_snd (sub.pat sub)) pl, closed)
+
   let map_jst sub : Jane_syntax.Pattern.t -> Jane_syntax.Pattern.t = function
     | Jpat_immutable_array x -> Jpat_immutable_array (map_iapat sub x)
     | Jpat_layout (Lpat_constant x) ->
         Jpat_layout (Lpat_constant (map_unboxed_constant_pat sub x))
+    | Jpat_tuple ltpat -> Jpat_tuple (map_ltpat sub ltpat)
 
   let map sub
         ({ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} as pat) =