Typecheck labeled tuple terms

ocaml/debugger/eval.ml

@@ -120,7 +120,8 @@ 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

ocaml/lambda/translcore.ml

@@ -460,7 +460,8 @@ and transl_exp0 ~in_new_scope ~scopes e =
                  (transl_cases_try ~scopes pat_expr_list),
                layout)
   | Texp_tuple (el, alloc_mode) ->
-      let ll, shape = transl_list_with_shape ~scopes el in
+      (* CR labeled tuples: check that it's ok to erase when translating to lambda *)
+      let ll, shape = transl_list_with_shape ~scopes (List.map snd el) in
       begin try
         Lconst(Const_block(0, List.map extract_constant ll))
       with Not_constant ->
@@ -1609,16 +1610,18 @@ and transl_match ~scopes e arg sort pat_expr_list partial =
       assert (static_handlers = []);
       let mode = transl_alloc_mode alloc_mode in
       Matching.for_multiple_match ~scopes layout e.exp_loc
-        (transl_list_with_layout ~scopes argl) mode val_cases partial
+        (* CR labeled tuples: check that it's ok to erase when translating to lambda *)
+        (transl_list_with_layout ~scopes (List.map snd argl)) mode val_cases partial
     | {exp_desc = Texp_tuple (argl, alloc_mode)}, _ :: _ ->
         let val_ids =
           List.map
             (fun arg -> Typecore.name_pattern "val" [], layout_exp arg)
-            argl
+            (* CR labeled tuples: check that it's ok to erase when translating to lambda *)
+            (List.map snd argl)
         in
         let lvars = List.map (fun (id, layout) -> Lvar id, layout) val_ids in
         let mode = transl_alloc_mode alloc_mode in
-        static_catch (transl_list ~scopes argl) val_ids
+        static_catch (transl_list ~scopes (List.map snd argl)) val_ids
           (Matching.for_multiple_match ~scopes layout e.exp_loc
              lvars mode val_cases partial)
     | arg, [] ->

ocaml/ocamldoc/odoc_value.ml

@@ -106,7 +106,8 @@ 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)
+            (* CR labeled tuples: Show labels in odoc (note: "label" != tuple label) *)
+            (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

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

@@ -5,10 +5,7 @@
 let x = ~~(~x:1, ~y:2)
 
 [%%expect{|
-Line 1, characters 8-22:
-1 | let x = ~~(~x:1, ~y:2)
-            ^^^^^^^^^^^^^^
-Error: Labeled tuples are not yet supported
+val x : x: int * y: int = (~x: 1, ~y: 2)
 |}];;
 
 let z = 5
@@ -17,10 +14,7 @@ let _ = ~~( ~x: 5, 2, ~z, ~(punned:int))
 [%%expect{|
 val z : int = 5
 val punned : int = 2
-Line 3, characters 8-40:
-3 | let _ = ~~( ~x: 5, 2, ~z, ~(punned:int))
-            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Labeled tuples are not yet supported
+- : x: int * int * z: int * punned: int = (~x: 5, 2, ~z: 5, ~punned: 2)
 |}]
 
 type ('a, 'b) pair = Pair of 'a * 'b
@@ -33,3 +27,80 @@ Line 2, characters 8-27:
             ^^^^^^^^^^^^^^^^^^^
 Error: Constructors cannot receive labeled arguments. Consider using an inline record instead.
 |}]
+
+(* Happy case *)
+let foo b = if b then
+   ~~(~a: "s", 10, ~c: "hi")
+else
+   ~~(~a: "5", 10, ~c: "hi")
+[%%expect{|
+val foo : bool -> a: string * int * c: string = <fun>
+|}]
+
+(* 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")
+[%%expect{|
+Line 4, characters 3-28:
+4 |    ~~(~a: "5", 10, ~c: "hi")
+       ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type a: 'a * 'b * c: 'c
+       but an expression was expected of type a: string * int * string
+|}]
+
+(* Missing labeled component *)
+let foo b = if b then
+   ~~(~a: "s", 10)
+else
+   ~~(~a: "5", 10, ~c: "hi")
+[%%expect{|
+Line 4, characters 3-28:
+4 |    ~~(~a: "5", 10, ~c: "hi")
+       ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type a: 'a * 'b * c: 'c
+       but an expression was expected of type a: string * int
+|}]
+
+(* Wrong label *)
+let foo b = if b then
+   ~~(~a: "s", 10, ~a: "hi")
+else
+   ~~(~a: "5", 10, ~c: "hi")
+[%%expect{|
+Line 4, characters 3-28:
+4 |    ~~(~a: "5", 10, ~c: "hi")
+       ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type a: 'a * 'b * c: 'c
+       but an expression was expected of type a: string * int * a: string
+|}]
+
+(* 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
+[%%expect{|
+val default : x: int * y: int = (~x: 1, ~y: 2)
+val choose_pt : bool -> x: int * y: int -> x: int * y: int = <fun>
+|}]
+
+(* Application happy case *)
+let a = choose_pt true (~~(~x: 5, ~y: 6))
+[%%expect{|
+val a : x: int * y: int = (~x: 1, ~y: 2)
+|}]
+
+(* CR labeled tuples: reordering should eventually work *)
+let a = choose_pt true (~~(~y: 6, ~x: 5))
+[%%expect{|
+Line 1, characters 23-41:
+1 | let a = choose_pt true (~~(~y: 6, ~x: 5))
+                           ^^^^^^^^^^^^^^^^^^
+Error: This expression has type y: 'a * x: 'b
+       but an expression was expected of type x: int * y: int
+|}]

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

@@ -6,12 +6,10 @@ let x = ~~(~x:1, ~y:2)
 [%%expect{|
 
 let x = (~x:1, ~y:2);;
-Line 1, characters 8-22:
-1 | let x = ~~(~x:1, ~y:2)
-            ^^^^^^^^^^^^^^
-Error: Labeled tuples are not yet supported
+val x : x: int * y: int = (~x: 1, ~y: 2)
 |}]
 
+(* Attribute should prevent punning *)
 let z = 5
 let y = ~~(~z:z, ~z, ~z:(z [@attr]))
 [%%expect{|
@@ -20,8 +18,5 @@ let z = 5;;
 val z : int = 5
 
 let y = (~z, ~z, ~z:((z)[@attr ]));;
-Line 2, characters 8-36:
-2 | let y = ~~(~z:z, ~z, ~z:(z [@attr]))
-            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Labeled tuples are not yet supported
+val y : z: int * z: int * z: int = (~z: 5, ~z: 5, ~z: 5)
 |}]

ocaml/toplevel/genprintval.ml

@@ -266,9 +266,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
               Oval_stuff "<poly>"
           | Tarrow _ ->
               Oval_stuff "<fun>"
-          | Ttuple(ty_list) ->
-              let ty_list = List.map (fun t -> (t,false)) ty_list in
-              Oval_tuple (tree_of_val_list 0 depth obj ty_list)
+          | Ttuple(labeled_tys) ->
+              Oval_tuple (tree_of_labeled_val_list 0 depth obj labeled_tys)
           | Tconstr(path, [ty_arg], _)
             when Path.same path Predef.path_list ->
               if O.is_block obj then
@@ -534,6 +533,14 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         in
         Oval_record (tree_of_fields (pos = 0) pos lbl_list)
 
+      and tree_of_labeled_val_list start depth obj labeled_tys =
+        let rec tree_list i = function
+          | [] -> []
+          | (label, ty) :: labeled_tys ->
+              let tree = nest tree_of_val (depth - 1) (O.field obj i) ty in
+              (label, tree) :: tree_list (i + 1) labeled_tys in
+      tree_list start labeled_tys
+
       (* CR layouts v4: When we allow other layouts in tuples, this should be
          generalized to take a list or array of layouts, rather than just
          pairing each type with a bool indicating whether it is void *)

ocaml/typing/btype.ml

@@ -267,7 +267,7 @@ let fold_type_expr f init ty =
   | Tarrow (_, ty1, ty2, _) ->
       let result = f init ty1 in
       f result ty2
-  | Ttuple l            -> List.fold_left f init l
+  | Ttuple l            -> List.fold_left f init (List.map snd l)
   | Tconstr (_, l, _)   -> List.fold_left f init l
   | Tobject(ty, {contents = Some (_, p)}) ->
       let result = f init ty in
@@ -444,7 +444,7 @@ let rec copy_type_desc ?(keep_names=false) f = function
     Tvar { layout; _ } as tv ->
      if keep_names then tv else Tvar { name=None; layout }
   | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
-  | Ttuple l            -> Ttuple (List.map f l)
+  | Ttuple l            -> Ttuple (List.map (fun (label, t) -> label, f t) l)
   | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
   | Tobject(ty, {contents = Some (p, tl)})
                         -> Tobject (f ty, ref (Some(p, List.map f tl)))

ocaml/typing/ctype.ml

@@ -766,7 +766,7 @@ let rec generalize_spine ty =
       generalize_spine ty'
   | Ttuple tyl ->
       set_level ty generic_level;
-      List.iter generalize_spine tyl
+      List.iter generalize_spine (List.map snd tyl)
   | Tpackage (_, fl) ->
       set_level ty generic_level;
       List.iter (fun (_n, ty) -> generalize_spine ty) fl
@@ -2697,7 +2697,7 @@ let rec mcomp type_pairs env t1 t2 =
             mcomp type_pairs env t1 t2;
             mcomp type_pairs env u1 u2;
         | (Ttuple tl1, Ttuple tl2) ->
-            mcomp_list type_pairs env tl1 tl2
+            mcomp_labeled_list type_pairs env tl1 tl2
         | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
             mcomp_type_decl type_pairs env p1 p2 tl1 tl2
         | (Tconstr (_, [], _), _) when has_injective_univars env t2' ->
@@ -2743,6 +2743,13 @@ and mcomp_list type_pairs env tl1 tl2 =
     raise Incompatible;
   List.iter2 (mcomp type_pairs env) tl1 tl2
 
+and mcomp_labeled_list type_pairs env labeled_tl1 labeled_tl2 =
+  let labels1, tl1 = List.split labeled_tl1 in
+  let labels2, tl2 = List.split labeled_tl2 in
+  if not (List.equal (Option.equal String.equal) labels1 labels2) then
+    raise Incompatible;
+  List.iter2 (mcomp type_pairs env) tl1 tl2
+
 and mcomp_fields type_pairs env ty1 ty2 =
   if not (concrete_object ty1 && concrete_object ty2) then assert false;
   let (fields2, rest2) = flatten_fields ty2 in
@@ -3264,8 +3271,8 @@ and unify3 env t1 t1' t2 t2' =
           | false, false -> link_commu ~inside:c1 c2
           | true, true -> ()
           end
-      | (Ttuple tl1, Ttuple tl2) ->
-          unify_list env tl1 tl2
+      | (Ttuple labeled_tl1, Ttuple labeled_tl2) ->
+          unify_labeled_list env labeled_tl1 labeled_tl2
       | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
           if not (can_generate_equations ()) then
             unify_list env tl1 tl2
@@ -3406,6 +3413,13 @@ and unify_list env tl1 tl2 =
     raise_unexplained_for Unify;
   List.iter2 (unify env) tl1 tl2
 
+and unify_labeled_list env labeled_tl1 labeled_tl2 =
+  let labels1, tl1 = List.split labeled_tl1 in
+  let labels2, tl2 = List.split labeled_tl2 in
+  if not (List.equal (Option.equal String.equal) labels1 labels2) then
+    raise_unexplained_for Unify;
+  List.iter2 (unify env) tl1 tl2
+
 (* Build a fresh row variable for unification *)
 and make_rowvar level use1 rest1 use2 rest2  =
   let set_name ty name =
@@ -4324,8 +4338,8 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 =
               moregen inst_nongen variance type_pairs env u1 u2;
               moregen_alloc_mode (neg_variance variance) a1 a2;
               moregen_alloc_mode variance r1 r2
-          | (Ttuple tl1, Ttuple tl2) ->
-              moregen_list inst_nongen variance type_pairs env tl1 tl2
+          | (Ttuple labeled_tl1, Ttuple labeled_tl2) ->
+              moregen_labeled_list inst_nongen variance type_pairs env labeled_tl1 labeled_tl2
           | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
                 when Path.same p1 p2 -> begin
               match variance with
@@ -4375,6 +4389,13 @@ and moregen_list inst_nongen variance type_pairs env tl1 tl2 =
     raise_unexplained_for Moregen;
   List.iter2 (moregen inst_nongen variance type_pairs env) tl1 tl2
 
+and moregen_labeled_list inst_nongen variance type_pairs env labeled_tl1 labeled_tl2 =
+  let labels1, tl1 = List.split labeled_tl1 in
+  let labels2, tl2 = List.split labeled_tl2 in
+  if not (List.equal (Option.equal String.equal) labels1 labels2) then
+    raise_unexplained_for Moregen;
+  List.iter2 (moregen inst_nongen variance type_pairs env) tl1 tl2
+
 and moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 =
   match vl, tl1, tl2 with
   | [], [], [] -> ()
@@ -4695,8 +4716,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
               eqtype rename type_pairs subst env u1 u2;
               eqtype_alloc_mode a1 a2;
               eqtype_alloc_mode r1 r2
-          | (Ttuple tl1, Ttuple tl2) ->
-              eqtype_list rename type_pairs subst env tl1 tl2
+          | (Ttuple labeled_tl1, Ttuple labeled_tl2) ->
+              eqtype_labeled_list rename type_pairs subst env labeled_tl1 labeled_tl2
           | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
                 when Path.same p1 p2 ->
               eqtype_list rename type_pairs subst env tl1 tl2
@@ -4737,6 +4758,13 @@ and eqtype_list rename type_pairs subst env tl1 tl2 =
     raise_unexplained_for Equality;
   List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
 
+and eqtype_labeled_list rename type_pairs subst env labeled_tl1 labeled_tl2 =
+  let labels1, tl1 = List.split labeled_tl1 in
+  let labels2, tl2 = List.split labeled_tl2 in
+  if not (List.equal (Option.equal String.equal) labels1 labels2) then
+    raise_unexplained_for Equality;
+  List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
+
 and eqtype_fields rename type_pairs subst env ty1 ty2 =
   let (fields1, rest1) = flatten_fields ty1 in
   let (fields2, rest2) = flatten_fields ty2 in
@@ -5248,15 +5276,16 @@ let rec build_subtype env (visited : transient_expr list)
       if c > Unchanged
       then (newty (Tarrow((l,a',r'), t1', t2', commu_ok)), c)
       else (t, Unchanged)
-  | Ttuple tlist ->
+  | Ttuple labeled_tlist ->
       let tt = Transient_expr.repr t in
       if memq_warn tt visited then (t, Unchanged) else
       let visited = tt :: visited in
+      let labels, tlist = List.split labeled_tlist in
       let tlist' =
         List.map (build_subtype env visited loops posi level) tlist
       in
       let c = collect tlist' in
-      if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c)
+      if c > Unchanged then (newty (Ttuple (List.combine labels (List.map fst tlist'))), c)
       else (t, Unchanged)
   | Tconstr(p, tl, abbrev)
     when level > 0 && generic_abbrev env p && safe_abbrev env t
@@ -5463,7 +5492,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
           u1 u2
           cstrs
     | (Ttuple tl1, Ttuple tl2) ->
-        subtype_list env trace tl1 tl2 cstrs
+        subtype_labeled_list env trace tl1 tl2 cstrs
     | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
         cstrs
     | (Tconstr(p1, _tl1, _abbrev1), _)
@@ -5480,8 +5509,8 @@ let rec subtype_rec env trace t1 t2 cstrs =
               let (co, cn) = Variance.get_upper v in
               if co then
                 if cn then
-                  (trace, newty2 ~level:(get_level t1) (Ttuple[t1]),
-                   newty2 ~level:(get_level t2) (Ttuple[t2]), !univar_pairs)
+                  (trace, newty2 ~level:(get_level t1) (Ttuple[None, t1]),
+                   newty2 ~level:(get_level t2) (Ttuple[None, t2]), !univar_pairs)
                   :: cstrs
                 else
                   subtype_rec
@@ -5560,8 +5589,10 @@ let rec subtype_rec env trace t1 t2 cstrs =
         (trace, t1, t2, !univar_pairs)::cstrs
   end
 
-and subtype_list env trace tl1 tl2 cstrs =
-  if List.length tl1 <> List.length tl2 then
+and subtype_labeled_list env trace labeled_tl1 labeled_tl2 cstrs =
+  let labels1, tl1 = List.split labeled_tl1 in
+  let labels2, tl2 = List.split labeled_tl2 in
+  if not (List.equal (Option.equal String.equal) labels1 labels2) then
     subtype_error ~env ~trace ~unification_trace:[];
   List.fold_left2
     (fun cstrs t1 t2 ->
@@ -5838,7 +5869,8 @@ let rec normalize_type_rec visited ty =
         begin match !nm with
         | None -> ()
         | Some (n, v :: l) ->
-            if deep_occur ty (newgenty (Ttuple l)) then
+            let fake_ttuple = newgenty (Ttuple (List.map (fun ty -> None, ty) l)) in
+            if deep_occur ty fake_ttuple then
               (* The abbreviation may be hiding something, so remove it *)
               set_name nm None
             else