Revert "more hints about what types we are looking at"

This reverts commit 55476b9.

Author: zth

compiler/ml/ctype.ml

@@ -53,9 +53,8 @@ open Btype
 *)
 
 (**** Errors ****)
-type type_pairs = (type_expr * type_expr) list
 
-exception Unify of type_pairs
+exception Unify of (type_expr * type_expr) list
 
 exception Tags of label * label
 
@@ -101,20 +100,11 @@ type subtype_context =
       issues: Record_coercion.record_field_subtype_violation list;
     }
 
-type subtype_type_position =
-  | RecordField of {
-      field_name: string;
-      left_record_name: Path.t;
-      right_record_name: Path.t;
-    }
-  | TupleElement of {index: int}
-
 exception
   Subtype of
-    type_pairs
-    * type_pairs
+    (type_expr * type_expr) list
+    * (type_expr * type_expr) list
     * subtype_context option
-    * subtype_type_position option
 
 exception Cannot_expand
 
@@ -123,7 +113,7 @@ exception Cannot_apply
 exception Recursive_abbrev
 
 (* GADT: recursive abbrevs can appear as a result of local constraints *)
-exception Unification_recursive_abbrev of type_pairs
+exception Unification_recursive_abbrev of (type_expr * type_expr) list
 
 (**** Type level management ****)
 
@@ -3589,15 +3579,15 @@ let enlarge_type env ty =
 
 let subtypes = TypePairs.create 17
 
-let subtype_error ?type_position ?ctx env trace =
-  raise (Subtype (expand_trace env (List.rev trace), [], ctx, type_position))
+let subtype_error ?ctx env trace =
+  raise (Subtype (expand_trace env (List.rev trace), [], ctx))
 
 let extract_concrete_typedecl_opt env t =
   match extract_concrete_typedecl env t with
   | v -> Some v
   | exception Not_found -> None
 
-let rec subtype_rec ?type_position env trace t1 t2 cstrs =
+let rec subtype_rec env trace t1 t2 cstrs =
   let t1 = repr t1 in
   let t2 = repr t2 in
   if t1 == t2 then cstrs
@@ -3608,16 +3598,14 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
     with Not_found -> (
       TypePairs.add subtypes (t1, t2) ();
       match (t1.desc, t2.desc) with
-      | Tvar _, _ | _, Tvar _ ->
-        (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs
+      | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs
       | Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _)
         when Asttypes.Noloc.same_arg_label l1 l2 ->
         let cstrs = subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs in
         subtype_rec env ((u1, u2) :: trace) u1 u2 cstrs
       | Ttuple tl1, Ttuple tl2 ->
-        subtype_list
-          ~make_type_position:(fun i -> Some (TupleElement {index = i}))
-          env trace tl1 tl2 cstrs
+        (* TODO(subtype-errors) Tuple as context *)
+        subtype_list env trace tl1 tl2 cstrs
       | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> cstrs
       | Tconstr (p1, _tl1, _abbrev1), _
         when generic_abbrev env p1 && safe_abbrev env t1 ->
@@ -3643,15 +3631,13 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
                       newty2 t1.level (Ttuple [t1]),
                       newty2 t2.level (Ttuple [t2]),
                       !univar_pairs,
-                      None,
-                      type_position )
+                      None )
                     :: cstrs
                 else subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs
               else if cn then subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs
               else cstrs)
             cstrs decl.type_variance (List.combine tl1 tl2)
-        with Not_found ->
-          (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
+        with Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
       | Tconstr (p1, _, _), _ when generic_private_abbrev env p1 ->
         subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
       | Tconstr (p1, [], _), Tconstr (p2, [], _)
@@ -3678,8 +3664,7 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
             !univar_pairs,
             Some
               (Primitive_coercion_target_variant_not_unboxed
-                 {variant_name = p; primitive = path}),
-            type_position )
+                 {variant_name = p; primitive = path}) )
           :: cstrs
         | Some (p, constructors, true) ->
           if
@@ -3693,17 +3678,11 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
               !univar_pairs,
               Some
                 (Primitive_coercion_target_variant_no_catch_all
-                   {variant_name = p; primitive = path}),
-              type_position )
+                   {variant_name = p; primitive = path}) )
             :: cstrs
         | None ->
           (* Unclear when this case actually happens. *)
-          ( trace,
-            t1,
-            t2,
-            !univar_pairs,
-            Some (Generic {errorCode = "VCPMMVD"}),
-            type_position )
+          (trace, t1, t2, !univar_pairs, Some (Generic {errorCode = "VCPMMVD"}))
           :: cstrs)
       | Tconstr (_, [], _), Tconstr (path, [], _)
         when Variant_coercion.can_coerce_primitive path
@@ -3729,11 +3708,11 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
               !univar_pairs,
               Some
                 (Variant_constructor_runtime_representation_mismatch
-                   {issues = runtime_representation_issues; variant_name = p}),
-              type_position )
+                   {issues = runtime_representation_issues; variant_name = p})
+            )
             :: cstrs
           else cstrs
-        | None -> (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
+        | None -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
       | Tconstr (_, [], _), Tconstr (_, [], _) -> (
         (* type coercion for variants and records *)
         match
@@ -3743,7 +3722,7 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
             (p2, _, {type_kind = Type_variant c2; type_attributes = t2attrs}) )
           -> (
           match
-            Variant_coercion.variant_configuration_can_be_coerced t1attrs
+            Variant_coercion.variant_configuration_can_be_coerced2 t1attrs
               t2attrs
           with
           | Error issue ->
@@ -3753,8 +3732,7 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
               !univar_pairs,
               Some
                 (Variant_configurations_mismatch
-                   {left_variant_name = p1; right_variant_name = p2; issue}),
-              type_position )
+                   {left_variant_name = p1; right_variant_name = p2; issue}) )
             :: cstrs
           | Ok () ->
             let c1_len = List.length c1 in
@@ -3782,8 +3760,7 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
                        issue =
                          Incompatible_constructor_count
                            {constructor_names = incompatible_constructor_names};
-                     }),
-                type_position )
+                     }) )
               :: cstrs
             else
               let constructor_map = Hashtbl.create c1_len in
@@ -3845,7 +3822,7 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
                        | _ -> Some [ (* TODO(subtype-errors) *) ])
               in
               if field_subtype_violations = [] then cstrs
-              else (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
+              else (trace, t1, t2, !univar_pairs, None) :: cstrs)
         | ( (p1, _, {type_kind = Type_record (fields1, repr1)}),
             (p2, _, {type_kind = Type_record (fields2, repr2)}) ) ->
           (* TODO(subtype-errors) Record representation *)
@@ -3873,24 +3850,10 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
                        left_record_name = p1;
                        right_record_name = p2;
                        issues = violations;
-                     }),
-                type_position )
+                     }) )
               :: cstrs
-            else
-              subtype_list
-                ~make_type_position:(fun i ->
-                  match List.nth_opt fields1 i with
-                  | None -> None
-                  | Some field ->
-                    Some
-                      (RecordField
-                         {
-                           field_name = field.ld_id.name;
-                           left_record_name = p1;
-                           right_record_name = p2;
-                         }))
-                env trace tl1 tl2 cstrs
-          else (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs
+            else subtype_list env trace tl1 tl2 cstrs
+          else (trace, t1, t2, !univar_pairs, None) :: cstrs
         | (p1, _, {type_kind = tk1}), (p2, _, {type_kind = tk2}) ->
           ( trace,
             t1,
@@ -3903,22 +3866,19 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
                    right_typename = p2;
                    left_type_kind = tk1;
                    right_type_kind = tk2;
-                 }),
-            type_position )
+                 }) )
           :: cstrs
-        | exception Not_found ->
-          (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
+        | exception Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
       (* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 ->
          subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *)
       | Tobject (f1, _), Tobject (f2, _)
         when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
         (* Same row variable implies same object. *)
-        (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs
+        (trace, t1, t2, !univar_pairs, None) :: cstrs
       | Tobject (f1, _), Tobject (f2, _) -> subtype_fields env trace f1 f2 cstrs
       | Tvariant row1, Tvariant row2 -> (
         try subtype_row env trace row1 row2 cstrs
-        with Exit ->
-          (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
+        with Exit -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
       | Tvariant {row_closed = true; row_fields}, Tconstr (_, [], _)
         when extract_concrete_typedecl_opt env t2
              |> Variant_coercion.type_is_variant -> (
@@ -3932,9 +3892,8 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
               ~variant_constructors ~type_attributes
           with
           | Ok _ -> cstrs
-          | Error _ ->
-            (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
-        | _ -> (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
+          | Error _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
+        | _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
       | Tvariant v, _ when !variant_is_subtype env (row_repr v) t2 -> cstrs
       | Tpoly (u1, []), Tpoly (u2, []) -> subtype_rec env trace u1 u2 cstrs
       | Tpoly (u1, tl1), Tpoly (u2, []) ->
@@ -3944,8 +3903,7 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
         try
           enter_poly env univar_pairs u1 tl1 u2 tl2 (fun t1 t2 ->
               subtype_rec env trace t1 t2 cstrs)
-        with Unify _ ->
-          (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
+        with Unify _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
       | Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2) -> (
         try
           let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1
@@ -3956,49 +3914,32 @@ let rec subtype_rec ?type_position env trace t1 t2 cstrs =
           let cstrs' =
             List.map
               (fun (n2, t2) ->
-                ( trace,
-                  List.assoc n2 ntl1,
-                  t2,
-                  !univar_pairs,
-                  None,
-                  type_position ))
+                (trace, List.assoc n2 ntl1, t2, !univar_pairs, None))
               ntl2
           in
           if eq_package_path env p1 p2 then cstrs' @ cstrs
           else
             (* need to check module subtyping *)
             let snap = Btype.snapshot () in
             try
-              List.iter (fun (_, t1, t2, _, _, _) -> unify env t1 t2) cstrs';
+              List.iter (fun (_, t1, t2, _, _) -> unify env t1 t2) cstrs';
               if !package_subtype env p1 nl1 tl1 p2 nl2 tl2 then (
                 Btype.backtrack snap;
                 cstrs' @ cstrs)
               else raise (Unify [])
             with Unify _ ->
               Btype.backtrack snap;
               raise Not_found
-        with Not_found ->
-          (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
-      | _, _ -> (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs)
-
-and subtype_list ?make_type_position env trace tl1 tl2 cstrs =
-  if List.length tl1 <> List.length tl2 then
-    (* TODO(subtype-errors): Not the same length error *)
-    subtype_error env trace;
-  let idx = ref 0 in
+        with Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
+      | _, _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
+
+and subtype_list env trace tl1 tl2 cstrs =
+  if List.length tl1 <> List.length tl2 then subtype_error env trace;
   List.fold_left2
-    (fun cstrs t1 t2 ->
-      let index = !idx in
-      incr idx;
-      let type_position =
-        match make_type_position with
-        | Some f -> f index
-        | None -> None
-      in
-      subtype_rec ?type_position env ((t1, t2) :: trace) t1 t2 cstrs)
+    (fun cstrs t1 t2 -> subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs)
     cstrs tl1 tl2
 
-and subtype_fields ?type_position env trace ty1 ty2 cstrs =
+and subtype_fields env trace ty1 ty2 cstrs =
   (* Assume that either rest1 or rest2 is not Tvar *)
   let fields1, rest1 = flatten_fields ty1 in
   let fields2, rest2 = flatten_fields ty2 in
@@ -4012,8 +3953,7 @@ and subtype_fields ?type_position env trace ty1 ty2 cstrs =
         build_fields (repr ty1).level miss1 rest1,
         rest2,
         !univar_pairs,
-        None,
-        type_position )
+        None )
       :: cstrs
   in
   let cstrs =
@@ -4023,8 +3963,7 @@ and subtype_fields ?type_position env trace ty1 ty2 cstrs =
         rest1,
         build_fields (repr ty2).level miss2 (newvar ()),
         !univar_pairs,
-        None,
-        type_position )
+        None )
       :: cstrs
   in
   List.fold_left
@@ -4081,15 +4020,14 @@ let subtype env ty1 ty2 =
   | () ->
     List.iter
       (function
-        | trace0, t1, t2, pairs, ctx, type_position -> (
+        | trace0, t1, t2, pairs, ctx -> (
           try unify_pairs (ref env) t1 t2 pairs
           with Unify trace ->
             raise
               (Subtype
                  ( expand_trace env (List.rev trace0),
                    List.tl (List.tl trace),
-                   ctx,
-                   type_position ))))
+                   ctx ))))
       (List.rev cstrs)
 
 (*******************)

compiler/ml/ctype.mli

@@ -18,8 +18,6 @@
 open Asttypes
 open Types
 
-type type_pairs = (type_expr * type_expr) list
-
 type subtype_context =
   | Generic of {errorCode: string}
   | Primitive_coercion_target_variant_not_unboxed of {
@@ -51,26 +49,17 @@ type subtype_context =
       issues: Record_coercion.record_field_subtype_violation list;
     }
 
-type subtype_type_position =
-  | RecordField of {
-      field_name: string;
-      left_record_name: Path.t;
-      right_record_name: Path.t;
-    }
-  | TupleElement of {index: int}
-
-exception Unify of type_pairs
+exception Unify of (type_expr * type_expr) list
 exception Tags of label * label
 exception
   Subtype of
-    type_pairs
-    * type_pairs
+    (type_expr * type_expr) list
+    * (type_expr * type_expr) list
     * subtype_context option
-    * subtype_type_position option
 exception Cannot_expand
 exception Cannot_apply
 exception Recursive_abbrev
-exception Unification_recursive_abbrev of type_pairs
+exception Unification_recursive_abbrev of (type_expr * type_expr) list
 
 val init_def : int -> unit
 (* Set the initial variable level *)