flambda-backend: API for constructing a labeled tuple AST is more permissive (#2146)

* Labeled tuple creation is more flexible

* promote-menhir

* promote test output I forgot to promote earlier

Author: ncik-roberts

boot/menhir/parser.ml

@@ -69,8 +69,8 @@ let iterator =
   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) ->
+    | Jtyp_tuple ([] | [_]) -> invalid_tuple loc
+    | Jtyp_tuple l ->
       if labeled_tuple_without_label l then unlabeled_labeled_tuple_typ loc
   in
   let typ self ty =
@@ -91,12 +91,12 @@ let iterator =
     | Jpat_layout (Lpat_constant _) -> ()
     | Jpat_tuple lt -> begin
         match lt with
-        | Ltpat_tuple ([], Open) -> empty_open_labeled_tuple_pat loc
-        | Ltpat_tuple (([] | [_]), Closed) ->
+        | ([], Open) -> empty_open_labeled_tuple_pat loc
+        | (([] | [_]), Closed) ->
           short_closed_labeled_tuple_pat loc
-        | Ltpat_tuple (l, Closed) ->
+        | (l, Closed) ->
           if labeled_tuple_without_label l then unlabeled_labeled_tuple_pat loc
-        | Ltpat_tuple (_ :: _, Open) -> ()
+        | (_ :: _, Open) -> ()
       end
   in
   let pat self pat =
@@ -143,8 +143,8 @@ let iterator =
         empty_comprehension loc
     | Jexp_tuple lt -> begin
         match lt with
-        | Ltexp_tuple ([] | [_]) -> invalid_tuple loc
-        | Ltexp_tuple l ->
+        | [] | [_] -> invalid_tuple loc
+        | l ->
           if labeled_tuple_without_label l then unlabeled_labeled_tuple_exp loc
       end
     | Jexp_comprehension _

parsing/ast_invariants.ml

@@ -140,7 +140,7 @@ module T = struct
       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
+    | 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
@@ -526,7 +526,7 @@ module E = struct
       iter_function_body sub body
 
   let iter_labeled_tuple sub : LT.expression -> _ = function
-    | Ltexp_tuple el -> List.iter (iter_snd (sub.expr sub)) el
+    | 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
@@ -636,7 +636,7 @@ module P = struct
       List.iter (sub.pat sub) elts
 
   let iter_labeled_tuple sub : LT.pattern -> _ = function
-    | Ltpat_tuple (pl, _) ->
+    | (pl, _) ->
       List.iter (iter_snd (sub.pat sub)) pl
 
   let iter_jst sub : Jane_syntax.Pattern.t -> _ = function

parsing/ast_iterator.ml

@@ -175,7 +175,7 @@ module T = struct
 
   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)
+    | tl -> List.map (map_snd (sub.typ sub)) tl
 
   let map_jst sub : Jane_syntax.Core_type.t -> Jane_syntax.Core_type.t =
     function
@@ -627,7 +627,7 @@ module E = struct
 
   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)
+    | el -> List.map (map_snd (sub.expr sub)) el
 
   let map_jst sub : Jane_syntax.Expression.t -> Jane_syntax.Expression.t =
     function
@@ -755,8 +755,8 @@ module P = struct
 
   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)
+    | (pl, closed) ->
+      (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)

parsing/ast_mapper.ml

@@ -146,7 +146,7 @@ and add_type_jst_layouts bv : Jane_syntax.Layouts.core_type -> _ = function
     add_jkind bv jkind
 
 and add_type_jst_labeled_tuple bv : Jane_syntax.Labeled_tuples.core_type -> _ =
-  function Lttyp_tuple tl -> List.iter (fun (_, ty) -> add_type bv ty) tl
+  fun tl -> List.iter (fun (_, ty) -> add_type bv ty) tl
 
 and add_package_type bv (lid, l) =
   add bv lid;
@@ -242,7 +242,7 @@ and add_pattern_jane_syntax bv : Jane_syntax.Pattern.t -> _ = function
   | Jpat_immutable_array (Iapat_immutable_array pl) ->
       List.iter (add_pattern bv) pl
   | Jpat_layout (Lpat_constant _) -> add_constant
-  | Jpat_tuple (Ltpat_tuple (labeled_pl, _)) ->
+  | Jpat_tuple (labeled_pl, _) ->
       List.iter (fun (_, p) -> add_pattern bv p) labeled_pl
 
 let add_pattern bv pat =
@@ -410,7 +410,7 @@ and add_function_constraint bv
       add_type bv ty2
 
 and add_labeled_tuple_expr bv : Jane_syntax.Labeled_tuples.expression -> _ =
-  function Ltexp_tuple el -> List.iter (add_expr bv) (List.map snd el)
+  function el -> List.iter (add_expr bv) (List.map snd el)
 
 and add_cases bv cases =
   List.iter (add_case bv) cases

parsing/depend.ml

@@ -1169,12 +1169,11 @@ module Labeled_tuples = struct
   module Of_ast = Of_ast (Ext)
   include Ext
 
-  type nonrec core_type = Lttyp_tuple of (string option * core_type) list
+  type nonrec core_type = (string option * core_type) list
 
-  type nonrec expression = Ltexp_tuple of (string option * expression) list
+  type nonrec expression = (string option * expression) list
 
-  type nonrec pattern =
-    | Ltpat_tuple of (string option * pattern) list * closed_flag
+  type nonrec pattern = (string option * pattern) list * closed_flag
 
   let string_of_label = function None -> "" | Some lbl -> lbl
 
@@ -1218,8 +1217,19 @@ module Labeled_tuples = struct
     | PStr [] -> names, attrs
     | _ -> Desugaring_error.raise loc (Has_payload payload)
 
-  let typ_of ~loc = function
-    | Lttyp_tuple tl ->
+  type 'a label_check_result =
+    | No_labels of 'a list
+    | At_least_one_label of (string option * 'a) list
+
+  let check_for_any_label xs =
+    if List.for_all (fun (lbl, _x) -> Option.is_none lbl) xs
+    then No_labels (List.map snd xs)
+    else At_least_one_label xs
+
+  let typ_of ~loc tl =
+    match check_for_any_label tl with
+    | No_labels tl -> Ast_helper.Typ.tuple ~loc tl
+    | At_least_one_label 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
@@ -1238,11 +1248,13 @@ module Labeled_tuples = struct
       let labeled_components =
         List.map2 (fun s t -> label_of_string s, t) labels components
       in
-      Lttyp_tuple labeled_components, ptyp_attributes
+      labeled_components, ptyp_attributes
     | _ -> Desugaring_error.raise typ.ptyp_loc Malformed
 
-  let expr_of ~loc = function
-    | Ltexp_tuple el ->
+  let expr_of ~loc el =
+    match check_for_any_label el with
+    | No_labels el -> Ast_helper.Exp.tuple ~loc el
+    | At_least_one_label 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
@@ -1261,17 +1273,25 @@ module Labeled_tuples = struct
       let labeled_components =
         List.map2 (fun s e -> label_of_string s, e) labels components
       in
-      Ltexp_tuple labeled_components, pexp_attributes
+      labeled_components, pexp_attributes
     | _ -> Desugaring_error.raise expr.pexp_loc Malformed
 
-  let pat_of ~loc = function
-    | Ltpat_tuple (pl, closed) ->
+  let pat_of =
+    let make_jane_syntax ~loc 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)
           @@ Ast_helper.Pat.tuple (List.map snd pl))
+    in
+    fun ~loc (pl, closed) ->
+      match closed with
+      | Open -> make_jane_syntax ~loc pl closed
+      | Closed -> (
+        match check_for_any_label pl with
+        | No_labels pl -> Ast_helper.Pat.tuple ~loc pl
+        | At_least_one_label pl -> make_jane_syntax ~loc pl closed)
 
   (* Returns remaining unconsumed attributes *)
   let of_pat pat =
@@ -1286,7 +1306,7 @@ module Labeled_tuples = struct
       let labeled_components =
         List.map2 (fun s e -> label_of_string s, e) labels components
       in
-      Ltpat_tuple (labeled_components, closed), ppat_attributes
+      (labeled_components, closed), ppat_attributes
     | _ -> Desugaring_error.raise pat.ppat_loc Malformed
 end
 

parsing/jane_syntax.ml

@@ -202,48 +202,53 @@ 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:
+  (** [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.
+          Invariant: [n >= 2].
       *)
+  type core_type = (string option * Parsetree.core_type) list
 
-  type expression =
-    | Ltexp_tuple of (string option * Parsetree.expression) list
-        (** [Ltexp_tuple(el)] represents
+  (** [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.
+          Invariant: [n >= 2].
       *)
+  type expression = (string option * Parsetree.expression) list
 
-  type pattern =
-    | Ltpat_tuple of
-        (string option * Parsetree.pattern) list * Asttypes.closed_flag
-        (** [Ltpat_tuple(pl, Closed)] represents
+  (** [(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]
+        - If Closed, [n >= 2].
+        - If Open, [n >= 1].
       *)
+  type pattern = (string option * Parsetree.pattern) list * Asttypes.closed_flag
 
+  (** Embeds the core type in Jane Syntax only if there are any labels.
+      Otherwise, returns a normal [Ptyp_tuple].
+  *)
   val typ_of : loc:Location.t -> core_type -> Parsetree.core_type
 
+  (** Embeds the expression in Jane Syntax only if there are any labels.
+      Otherwise, returns a normal [Pexp_tuple].
+  *)
   val expr_of : loc:Location.t -> expression -> Parsetree.expression
 
+  (** Embeds the pattern in Jane Syntax only if there are any labels or
+      if the pattern is open. Otherwise, returns a normal [Ppat_tuple].
+  *)
   val pat_of : loc:Location.t -> pattern -> Parsetree.pattern
 end
 

parsing/jane_syntax.mli

@@ -443,26 +443,20 @@ let expecting (loc : Lexing.position * Lexing.position) nonterm =
 let removed_string_set loc =
   raise(Syntaxerr.Error(Syntaxerr.Removed_string_set(make_loc loc)))
 
-let ppat_lttuple loc elts closed =
+let ppat_ltuple loc elts closed =
   Jane_syntax.Labeled_tuples.pat_of
     ~loc:(make_loc loc)
-    (Ltpat_tuple (elts, closed))
+    (elts, closed)
 
-let ptyp_lttuple loc tl =
+let ptyp_ltuple loc tl =
   Jane_syntax.Labeled_tuples.typ_of
     ~loc:(make_loc loc)
-    (Lttyp_tuple tl)
+    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 =
+let pexp_ltuple loc args =
   Jane_syntax.Labeled_tuples.expr_of
     ~loc:(make_loc loc)
-    (Ltexp_tuple args)
+    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
@@ -2873,11 +2867,7 @@ fun_expr:
   | simple_expr nonempty_llist(labeled_simple_expr)
       { 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
-      }
+      { pexp_ltuple $sloc $1 }
   | mkrhs(constr_longident) simple_expr %prec below_HASH
       { mkexp ~loc:$sloc (Pexp_construct($1, Some $2)) }
   | name_tag simple_expr %prec below_HASH
@@ -3530,12 +3520,7 @@ pattern_no_exn:
   ) { $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
+        ppat_ltuple $sloc (List.rev pats) closed
       }
 ;
 
@@ -4307,7 +4292,7 @@ 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 = ptyp_ltuple $loc(tuple) ((None, ty) :: ltys) in
            let domain = extra_rhs_core_type domain ~pos:$endpos(tuple) in
            Ptyp_arrow(label, mktyp_with_modes unique_local domain , codomain) }
     )
@@ -4321,7 +4306,7 @@ strict_function_or_labeled_tuple_type:
       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 = ptyp_ltuple $loc(tuple) ((None, ty) :: ltys) in
            let domain = extra_rhs_core_type domain ~pos:$endpos(tuple) in
            Ptyp_arrow(label,
             mktyp_with_modes arg_unique_local domain ,
@@ -4331,7 +4316,7 @@ strict_function_or_labeled_tuple_type:
     { $1 }
   | label = LIDENT COLON proper_tuple_type %prec MINUSGREATER
     { let ty, ltys = $3 in
-      ptyp_lttuple $sloc ((Some label, ty) :: ltys)
+      ptyp_ltuple $sloc ((Some label, ty) :: ltys)
     }
 ;
 
@@ -4388,7 +4373,7 @@ tuple_type:
       { ty }
   | proper_tuple_type %prec below_FUNCTOR
     { let ty, ltys = $1 in
-      mktyp_tuple $sloc ((None, ty) :: ltys)
+      ptyp_ltuple $sloc ((None, ty) :: ltys)
     }
 ;