[1523] Respond to comments, update core_type_desc

Author: rtjoa

ocaml/parsing/ast_mapper.ml

@@ -160,7 +160,9 @@ module T = struct
     | Ptyp_var s -> var ~loc ~attrs s
     | Ptyp_arrow (lab, t1, t2) ->
         arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
-    | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (fun (label,typ) -> label, sub.typ sub typ) tyl)
+    | Ptyp_tuple tyl ->
+        tuple ~loc ~attrs
+          (List.map (fun (label,typ) -> label, sub.typ sub typ) tyl)
     | Ptyp_constr (lid, tl) ->
         constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
     | Ptyp_object (l, o) ->
@@ -637,7 +639,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 (fun (label, p) -> label, sub.pat sub p) pl)
+    | Ppat_tuple pl ->
+        tuple ~loc ~attrs (List.map (fun (label, p) -> label, sub.pat sub p) pl)
     | Ppat_construct (l, p) ->
         construct ~loc ~attrs (map_loc sub l)
           (map_opt

ocaml/parsing/parser.mly

@@ -3132,7 +3132,8 @@ pattern_no_exn:
 
 %inline pattern_(self):
   | self COLONCOLON pattern
-      { mkpat_cons ~loc:$sloc $loc($2) (ghpat ~loc:$sloc (Ppat_tuple[None,$1;None,$3])) }
+      { mkpat_cons ~loc:$sloc $loc($2)
+          (ghpat ~loc:$sloc (Ppat_tuple[None,$1;None,$3])) }
   | self attribute
       { Pat.attr $1 $2 }
   | pattern_gen
@@ -3145,7 +3146,7 @@ pattern_no_exn:
     (* CR labeled tuples: merge the below two cases *)
     | pattern_comma_list(self) %prec below_COMMA
         { Ppat_tuple(List.rev_map (fun p -> None, p) $1) }
-    | TILDETILDELPAREN labeled_pattern_comma_list(self) RPAREN // %prec below_COMMA
+    | TILDETILDELPAREN labeled_pattern_comma_list(self) RPAREN
         { Ppat_tuple(List.rev $2) }
     | self COLONCOLON error
         { expecting $loc($3) "pattern" }
@@ -3869,7 +3870,7 @@ tuple_type:
   | TILDETILDELPAREN mktyp(
       labeled_tys = separated_nontrivial_llist(STAR, labeled_atomic_type)
         { Ptyp_tuple labeled_tys }
-  ) RPAREN
+    ) RPAREN
       { $2 }
 ;
 

ocaml/parsing/parsetree.mli

@@ -356,9 +356,12 @@ and expression_desc =
       (** [try E0 with P1 -> E1 | ... | Pn -> En] *)
   | 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)],
-           - Any mix, e.g. [(L1: E1, E2)] when [el] is [(Some L1, E1); (None, E2)]
+           - [(E1, ..., En)]
+               when [el] is [(None, E1);...;(None, En)]
+           - [(~L1:E1, ..., ~Ln:En)]
+               when [el] is [(Some L1, E1);...;(Some Ln, En)]
+           - Any mix, e.g.:
+               [(~L1:E1, E2)] when [el] is [(Some L1, E1); (None, E2)]
 
            Invariant: [n >= 2]
         *)

ocaml/testsuite/tests/typing-labeled-tuples/labeledtuples.ml

@@ -205,7 +205,8 @@ Line 1, characters 4-23:
 Error: Labeled tuple patterns are not yet supported
 |}]
 
-(* Labeled tuple pattern in constructor pattern *)
+(* 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
@@ -216,7 +217,10 @@ Line 2, characters 2-20:
 Error: Constructors cannot have labeled arguments. Consider using an inline record instead.
 |}]
 
-(* Labeled tuple pattern in constructor pattern *)
+(* Labeled tuple patterns in constructor patterns with that can union with the
+   constructor pattern type.
+   
+   CR labeled tuples: these should eventually work. *)
 let f = function
 | Some (~~(~x=5; 2)) -> true
 | _ -> false
@@ -227,6 +231,19 @@ Line 2, characters 7-20:
 Error: Labeled tuple patterns are not yet supported
 |}]
 
+
+type t = Foo of (~~(x:int * int))
+let f = function
+| Foo (~~(~x=5; 2)) -> true
+| _ -> false
+[%%expect{|
+type t = Foo of (x:int * int)
+Line 3, characters 6-19:
+3 | | Foo (~~(~x=5; 2)) -> true
+          ^^^^^^^^^^^^^
+Error: Labeled tuple patterns are not yet supported
+|}]
+
 (* CR labeled tuples: test constructor special cases thoroughly once patterns
    are typed. *)
 

ocaml/testsuite/tests/typing-labeled-tuples/labeledtuples_dsource.ml

@@ -31,4 +31,4 @@ Line 1, characters 4-32:
 1 | let (~~(~x=x0; ~s; ~(y:int); _)) : ~~(x:int * s:string * y:int * string) =
         ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Labeled tuple patterns are not yet supported
-|}]
+|}]

ocaml/typing/printtyped.ml

@@ -215,7 +215,7 @@ let rec core_type i ppf x =
       core_type i ppf ct2;
   | Ttyp_tuple l ->
       line i ppf "Ttyp_tuple\n";
-      list i core_type ppf l;
+      list i labeled_core_type ppf l;
   | Ttyp_constr (li, _, l) ->
       line i ppf "Ttyp_constr %a\n" fmt_path li;
       list i core_type ppf l;
@@ -250,6 +250,10 @@ let rec core_type i ppf x =
       line i ppf "Ttyp_package %a\n" fmt_path s;
       list i package_with ppf l;
 
+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 s;
   core_type i ppf t

ocaml/typing/tast_iterator.ml

@@ -462,7 +462,7 @@ let typ sub {ctyp_desc; ctyp_env; _} =
   | Ttyp_arrow (_, ct1, ct2) ->
       sub.typ sub ct1;
       sub.typ sub ct2
-  | Ttyp_tuple list -> List.iter (sub.typ sub) list
+  | Ttyp_tuple list -> List.iter (fun (_, t) -> sub.typ sub t) list
   | Ttyp_constr (_, _, list) ->  List.iter (sub.typ sub) list
   | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list
   | Ttyp_class (_, _, list) -> List.iter (sub.typ sub) list

ocaml/typing/tast_mapper.ml

@@ -692,7 +692,8 @@ let typ sub x =
     | Ttyp_var _ as d -> d
     | Ttyp_arrow (label, ct1, ct2) ->
         Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
-    | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list)
+    | Ttyp_tuple list ->
+        Ttyp_tuple (List.map (fun (label, t) -> label, sub.typ sub t) list)
     | Ttyp_constr (path, lid, list) ->
         Ttyp_constr (path, lid, List.map (sub.typ sub) list)
     | Ttyp_object (list, closed) ->

ocaml/typing/typecore.ml

@@ -2415,6 +2415,9 @@ and type_pat_aux
             List.map
             (fun (label, p) ->
               if Option.is_some label then
+                (* CR labeled tuples: is this the best error to give?
+                   It's a bit unexpected because a constructor can take a
+                   labeled tuple for a single arg. *)
                 raise(Error(loc, !env, Constructor_labeled_arg));
               p)
             spl

ocaml/typing/typedtree.ml

@@ -525,7 +525,7 @@ and core_type_desc =
     Ttyp_any
   | Ttyp_var of string
   | Ttyp_arrow of arg_label * core_type * core_type
-  | Ttyp_tuple of core_type list
+  | Ttyp_tuple of (string option * core_type) list
   | Ttyp_constr of Path.t * Longident.t loc * core_type list
   | Ttyp_object of object_field list * closed_flag
   | Ttyp_class of Path.t * Longident.t loc * core_type list

ocaml/typing/typedtree.mli

@@ -726,7 +726,7 @@ and core_type_desc =
     Ttyp_any
   | Ttyp_var of string
   | Ttyp_arrow of arg_label * core_type * core_type
-  | Ttyp_tuple of core_type list
+  | Ttyp_tuple of (string option * core_type) list
   | Ttyp_constr of Path.t * Longident.t loc * core_type list
   | Ttyp_object of object_field list * closed_flag
   | Ttyp_class of Path.t * Longident.t loc * core_type list

ocaml/typing/types.mli

@@ -79,10 +79,10 @@ and type_desc =
 
   | Ttuple of (string option * type_expr) list
   (** [Ttuple [None, t1; ...; None, tn]] ==> [t1 * ... * tn]
-      [Ttuple [Some "l1", t1; ...; Some "ln", tn]] ==> [l1: t1 * ... * ln: tn]
+      [Ttuple [Some "l1", t1; ...; Some "ln", tn]] ==> [l1:t1 * ... * ln:tn]
       
       Any mix of labeled and unlabeled components also works:
-      [Ttuple [Some "l1", t1; None, t2; Some "l3", t3]] ==> [l1: t1 * t2 * l3: t3]    
+      [Ttuple [Some "l1", t1; None, t2; Some "l3", t3]] ==> [l1:t1 * t2 * l3:t3]
   *)
 
   | Tconstr of Path.t * type_expr list * abbrev_memo ref

ocaml/typing/typetexp.ml

@@ -514,7 +514,11 @@ and transl_type_aux env policy mode styp =
       loop mode args
   | Ptyp_tuple stl ->
     assert (List.length stl >= 2);
-    let labeled_ctys = List.map (fun (label, t) -> label, transl_type env policy Alloc_mode.Global t) stl in
+    let labeled_ctys =
+      List.map
+        (fun (label, t) -> label, transl_type env policy Alloc_mode.Global t)
+        stl
+    in
     List.iter (fun (_, {ctyp_type; ctyp_loc}) ->
       (* CR layouts v5: remove value requirement *)
       match
@@ -527,8 +531,12 @@ and transl_type_aux env policy mode styp =
                      Non_value {vloc = Tuple; err = e; typ = ctyp_type})))
       labeled_ctys;
     (* CR labeled tuples: handle labeled tuple type expressions *)
-    let ty = newty (Ttuple (List.map (fun (label, ctyp) -> label, ctyp.ctyp_type) labeled_ctys)) in
-    ctyp (Ttyp_tuple (List.map snd labeled_ctys)) ty
+    let ty =
+      newty 
+        (Ttuple
+          (List.map (fun (label, ctyp) -> label, ctyp.ctyp_type) labeled_ctys))
+    in
+    ctyp (Ttyp_tuple labeled_ctys) ty
   | Ptyp_constr(lid, stl) ->
       let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in
       let stl =

ocaml/typing/untypeast.ml

@@ -349,7 +349,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
     | Tpat_constant cst -> Ppat_constant (constant cst)
     | Tpat_tuple list ->
         (* CR labeled tuples: update once Tpat_tuple has labels *)
-        Ppat_tuple (List.map (fun p -> None,(sub.pat sub p)) list)
+        Ppat_tuple (List.map (fun p -> None, (sub.pat sub p)) list)
     | Tpat_construct (lid, _, args, vto) ->
         let tyo =
           match vto with
@@ -899,7 +899,9 @@ let core_type sub ct =
     | Ttyp_arrow (label, ct1, ct2) ->
         Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
     (* CR labeled tuples: update when Ttyp_tuple has labels *)
-    | Ttyp_tuple list -> Ptyp_tuple (List.map (fun typ -> None, sub.typ sub typ) list)
+    | Ttyp_tuple list ->
+        Ptyp_tuple
+          (List.map (fun (label, typ) -> label, sub.typ sub typ) list)
     | Ttyp_constr (_path, lid, list) ->
         Ptyp_constr (map_loc sub lid,
           List.map (sub.typ sub) list)