structure for improving subtype errors

Author: zth

compiler/ml/ast_untagged_variants.ml

@@ -71,6 +71,17 @@ type block_type =
   | ObjectType
   | UnknownType
 
+let block_type_to_string = function
+  | IntType -> "int"
+  | StringType -> "string"
+  | FloatType -> "float"
+  | BigintType -> "bigint"
+  | BooleanType -> "bool"
+  | InstanceType i -> Instance.to_string i
+  | FunctionType -> "function"
+  | ObjectType -> "object"
+  | UnknownType -> "unknown"
+
 (*
   Type of the runtime representation of a tag.
   Can be a literal (case with no payload), or a block (case with payload).
@@ -89,6 +100,16 @@ type tag = {name: string; tag_type: tag_type option}
 type block = {tag: tag; tag_name: string option; block_type: block_type option}
 type switch_names = {consts: tag array; blocks: block array}
 
+let tag_type_to_type_string = function
+  | String _ -> "string"
+  | Int _ -> "int"
+  | Float _ -> "float"
+  | BigInt _ -> "bigint"
+  | Bool _ -> "bool"
+  | Null -> "null"
+  | Undefined -> "undefined"
+  | Untagged block_type -> block_type_to_string block_type
+
 let untagged = "unboxed"
 
 let block_type_can_be_undefined = function

compiler/ml/ctype.ml

@@ -69,7 +69,26 @@ let () =
             l l')
     | _ -> None)
 
-exception Subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
+type subtype_context =
+  | Generic of {errorCode: string}
+  | Primitive_coercion_target_variant_not_unboxed of {
+      variant_name: Path.t;
+      primitive: Path.t;
+    }
+  | Primitive_coercion_target_variant_no_catch_all of {
+      variant_name: Path.t;
+      primitive: Path.t;
+    }
+  | Variant_constructor_runtime_representation_mismatch of {
+      variant_name: Path.t;
+      issues: Variant_coercion.variant_runtime_representation_issue list;
+    }
+
+exception
+  Subtype of
+    (type_expr * type_expr) list
+    * (type_expr * type_expr) list
+    * subtype_context option
 
 exception Cannot_expand
 
@@ -3544,8 +3563,8 @@ let enlarge_type env ty =
 
 let subtypes = TypePairs.create 17
 
-let subtype_error env trace =
-  raise (Subtype (expand_trace env (List.rev trace), []))
+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
@@ -3563,7 +3582,7 @@ let rec subtype_rec 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) :: 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
@@ -3593,13 +3612,14 @@ let rec subtype_rec env trace t1 t2 cstrs =
                     ( trace,
                       newty2 t1.level (Ttuple [t1]),
                       newty2 t2.level (Ttuple [t2]),
-                      !univar_pairs )
+                      !univar_pairs,
+                      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) :: 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, [], _)
@@ -3617,13 +3637,34 @@ let rec subtype_rec env trace t1 t2 cstrs =
           Variant_coercion.can_try_coerce_variant_to_primitive_opt
             (extract_concrete_typedecl_opt env t2)
         with
-        | Some (constructors, true) ->
+        | Some (p, _, false) ->
+          (* Not @unboxed *)
+          ( trace,
+            t1,
+            t2,
+            !univar_pairs,
+            Some
+              (Primitive_coercion_target_variant_not_unboxed
+                 {variant_name = p; primitive = path}) )
+          :: cstrs
+        | Some (p, constructors, true) ->
           if
             Variant_coercion.variant_has_catch_all_case constructors (fun p ->
                 Path.same p path)
           then cstrs
-          else (trace, t1, t2, !univar_pairs) :: cstrs
-        | _ -> (trace, t1, t2, !univar_pairs) :: cstrs)
+          else
+            ( trace,
+              t1,
+              t2,
+              !univar_pairs,
+              Some
+                (Primitive_coercion_target_variant_no_catch_all
+                   {variant_name = p; primitive = path}) )
+            :: cstrs
+        | None ->
+          (* Unclear when this case actually happens. *)
+          (trace, t1, t2, !univar_pairs, Some (Generic {errorCode = "VCPMMVD"}))
+          :: cstrs)
       | Tconstr (_, [], _), Tconstr (path, [], _)
         when Variant_coercion.can_coerce_primitive path
              && extract_concrete_typedecl_opt env t1
@@ -3634,15 +3675,25 @@ let rec subtype_rec env trace t1 t2 cstrs =
           Variant_coercion.can_try_coerce_variant_to_primitive_opt
             (extract_concrete_typedecl_opt env t1)
         with
-        | Some (constructors, unboxed) ->
-          if
+        | Some (p, constructors, unboxed) ->
+          let runtime_representation_issues =
             constructors
             |> Variant_coercion
                .variant_has_same_runtime_representation_as_target
                  ~target_path:path ~unboxed
-          then cstrs
-          else (trace, t1, t2, !univar_pairs) :: cstrs
-        | None -> (trace, t1, t2, !univar_pairs) :: cstrs)
+          in
+          if List.length runtime_representation_issues <> 0 then
+            ( trace,
+              t1,
+              t2,
+              !univar_pairs,
+              Some
+                (Variant_constructor_runtime_representation_mismatch
+                   {issues = runtime_representation_issues; variant_name = p})
+            )
+            :: cstrs
+          else cstrs
+        | None -> (trace, t1, t2, !univar_pairs, None) :: cstrs)
       | Tconstr (_, [], _), Tconstr (_, [], _) -> (
         (* type coercion for variants and records *)
         match
@@ -3655,11 +3706,11 @@ let rec subtype_rec env trace t1 t2 cstrs =
             Variant_coercion.variant_configuration_can_be_coerced t1attrs
               t2attrs
             = false
-          then (trace, t1, t2, !univar_pairs) :: cstrs
+          then (trace, t1, t2, !univar_pairs, None) :: cstrs
           else
             let c1_len = List.length c1 in
             if c1_len > List.length c2 then
-              (trace, t1, t2, !univar_pairs) :: cstrs
+              (trace, t1, t2, !univar_pairs, None) :: cstrs
             else
               let constructor_map = Hashtbl.create c1_len in
               c2
@@ -3716,7 +3767,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
                          else false
                        | _ -> false)
               then cstrs
-              else (trace, t1, t2, !univar_pairs) :: cstrs
+              else (trace, t1, t2, !univar_pairs, None) :: cstrs
         | ( (_, _, {type_kind = Type_record (fields1, repr1)}),
             (_, _, {type_kind = Type_record (fields2, repr2)}) ) ->
           let same_repr =
@@ -3732,21 +3783,21 @@ let rec subtype_rec env trace t1 t2 cstrs =
             let violation, tl1, tl2 =
               Record_coercion.check_record_fields fields1 fields2
             in
-            if violation then (trace, t1, t2, !univar_pairs) :: cstrs
+            if violation then (trace, t1, t2, !univar_pairs, None) :: cstrs
             else subtype_list env trace tl1 tl2 cstrs
-          else (trace, t1, t2, !univar_pairs) :: cstrs
-        | _ -> (trace, t1, t2, !univar_pairs) :: cstrs
-        | exception Not_found -> (trace, t1, t2, !univar_pairs) :: cstrs)
+          else (trace, t1, t2, !univar_pairs, None) :: cstrs
+        | _ -> (trace, t1, t2, !univar_pairs, None) :: 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) :: 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) :: 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 -> (
@@ -3758,8 +3809,8 @@ let rec subtype_rec env trace t1 t2 cstrs =
               ~variant_constructors ~type_attributes
           with
           | Ok _ -> cstrs
-          | Error _ -> (trace, t1, t2, !univar_pairs) :: cstrs)
-        | _ -> (trace, t1, t2, !univar_pairs) :: 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, []) ->
@@ -3769,7 +3820,7 @@ let rec subtype_rec 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) :: 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
@@ -3779,24 +3830,25 @@ let rec subtype_rec env trace t1 t2 cstrs =
           in
           let cstrs' =
             List.map
-              (fun (n2, t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs))
+              (fun (n2, t2) ->
+                (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) :: cstrs)
-      | _, _ -> (trace, t1, t2, !univar_pairs) :: cstrs)
+        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;
@@ -3814,7 +3866,11 @@ and subtype_fields env trace ty1 ty2 cstrs =
     else if miss1 = [] then
       subtype_rec env ((rest1, rest2) :: trace) rest1 rest2 cstrs
     else
-      (trace, build_fields (repr ty1).level miss1 rest1, rest2, !univar_pairs)
+      ( trace,
+        build_fields (repr ty1).level miss1 rest1,
+        rest2,
+        !univar_pairs,
+        None )
       :: cstrs
   in
   let cstrs =
@@ -3823,7 +3879,8 @@ and subtype_fields env trace ty1 ty2 cstrs =
       ( trace,
         rest1,
         build_fields (repr ty2).level miss2 (newvar ()),
-        !univar_pairs )
+        !univar_pairs,
+        None )
       :: cstrs
   in
   List.fold_left
@@ -3880,12 +3937,14 @@ let subtype env ty1 ty2 =
   | () ->
     List.iter
       (function
-        | trace0, t1, t2, pairs -> (
+        | 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)))))
+                 ( expand_trace env (List.rev trace0),
+                   List.tl (List.tl trace),
+                   ctx ))))
       (List.rev cstrs)
 
 (*******************)

compiler/ml/ctype.mli

@@ -18,9 +18,28 @@
 open Asttypes
 open Types
 
+type subtype_context =
+  | Generic of {errorCode: string}
+  | Primitive_coercion_target_variant_not_unboxed of {
+      variant_name: Path.t;
+      primitive: Path.t;
+    }
+  | Primitive_coercion_target_variant_no_catch_all of {
+      variant_name: Path.t;
+      primitive: Path.t;
+    }
+  | Variant_constructor_runtime_representation_mismatch of {
+      variant_name: Path.t;
+      issues: Variant_coercion.variant_runtime_representation_issue list;
+    }
+
 exception Unify of (type_expr * type_expr) list
 exception Tags of label * label
-exception Subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
+exception
+  Subtype of
+    (type_expr * type_expr) list
+    * (type_expr * type_expr) list
+    * subtype_context option
 exception Cannot_expand
 exception Cannot_apply
 exception Recursive_abbrev