From 8668aec6bc1a6e2a165aefeb6a88ce5ab5cf0ea9 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 24 Apr 2025 10:15:37 +0200 Subject: [PATCH 1/9] structure for improving subtype errors --- compiler/ml/ast_untagged_variants.ml | 21 +++ compiler/ml/ctype.ml | 127 +++++++++++++----- compiler/ml/ctype.mli | 21 ++- compiler/ml/printtyp.ml | 98 +++++++++++++- compiler/ml/printtyp.mli | 1 + compiler/ml/typecore.ml | 17 ++- compiler/ml/typecore.mli | 5 +- compiler/ml/variant_coercion.ml | 116 +++++++++++++--- .../variant_coercion_bigint.res.expected | 5 +- .../variant_coercion_bigint_as.res.expected | 7 +- .../variant_coercion_float.res.expected | 5 +- .../variant_coercion_float_as.res.expected | 7 +- ...ariant_coercion_inline_record.res.expected | 11 ++ .../variant_coercion_int.res.expected | 5 +- .../variant_coercion_int_as.res.expected | 7 +- ...cion_non_unboxed_with_payload.res.expected | 13 ++ .../variant_coercion_string.res.expected | 5 +- .../variant_coercion_string_as.res.expected | 7 +- ..._string_to_variant_no_payload.res.expected | 5 +- .../variant_coercion_inline_record.res | 3 + ...iant_coercion_non_unboxed_with_payload.res | 3 + 21 files changed, 413 insertions(+), 76 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/variant_coercion_inline_record.res.expected create mode 100644 tests/build_tests/super_errors/expected/variant_coercion_non_unboxed_with_payload.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/variant_coercion_inline_record.res create mode 100644 tests/build_tests/super_errors/fixtures/variant_coercion_non_unboxed_with_payload.res diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 6966a7a10e..f27b3e9462 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/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 diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index e2289f600a..a2f56b3de9 100644 --- a/compiler/ml/ctype.ml +++ b/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,7 +3830,8 @@ 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 @@ -3787,7 +3839,7 @@ let rec subtype_rec env trace t1 t2 cstrs = (* 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) @@ -3795,8 +3847,8 @@ let rec subtype_rec env trace t1 t2 cstrs = 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) (*******************) diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index f3690efb51..71fd2db737 100644 --- a/compiler/ml/ctype.mli +++ b/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 diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index dd43032381..09091325e0 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -1525,18 +1525,102 @@ let trace fst keep_last txt ppf tr = | _ -> () with exn -> raise exn -let report_subtyping_error ppf env tr1 txt1 tr2 = +let print_variant_runtime_representation_issue ppf variant_name + (issue : Variant_coercion.variant_runtime_representation_issue) = + match issue with + | Cannot_coerce_non_unboxed_with_payload {constructor_name; expected_typename} + -> + fprintf ppf + "The constructor @{%s@} of variant @{%s@} has a payload, but \ + the variant itself is not unboxed. @ This means that the constructor \ + @{%s@} will be encoded as an object at runtime, which is not \ + compatible with @{%s@}." + constructor_name (Path.name variant_name) constructor_name + (Path.name expected_typename) + | Inline_record_cannot_be_coerced {constructor_name} -> + fprintf ppf + "The constructor @{%s@} of variant @{%s@} has an inline \ + record as payload. Inline records cannot be coerced." + constructor_name (Path.name variant_name) + | As_payload_cannot_be_coerced + {constructor_name; as_payload; expected_typename} -> + fprintf ppf + "The constructor @{%s@} of variant @{%s@} has an \ + @{@as@} payload that has a runtime representation of \ + @{%s@}, which is not compatible with the expected of \ + @{%s@}." + constructor_name (Path.name variant_name) + (Ast_untagged_variants.tag_type_to_type_string as_payload) + (Path.name expected_typename) + | Mismatched_unboxed_payload _ -> () + | Mismatched_as_payload {constructor_name; expected_typename; as_payload} -> + fprintf ppf "The constructor @{%s@} of variant @{%s@} has " + constructor_name (Path.name variant_name); + (match as_payload with + | None -> + fprintf ppf + "no @{@as@} payload, which makes it a @{string@} at \ + runtime." + | Some payload -> + fprintf ppf + "an @{@as@} payload that gives it the runtime type of \ + @{%s@}." + (Ast_untagged_variants.tag_type_to_type_string payload)); + fprintf ppf + "@ That runtime representation is not compatible with the expected \ + runtime representation of @{%s@}." + (Path.name expected_typename); + fprintf ppf + "@,\ + @ Fix this by making sure all constructors in variant @{%s@} has \ + a runtime representation of @{%s@}." + (Path.name variant_name) + (Path.name expected_typename) +let report_subtyping_error ppf env tr1 txt1 tr2 ctx = wrap_printing_env env (fun () -> reset (); let tr1 = List.map prepare_expansion tr1 and tr2 = List.map prepare_expansion tr2 in fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1; - if tr2 = [] then fprintf ppf "@]" - else - let mis = mismatch tr2 in - fprintf ppf "%a%t@]" - (trace false (mis = None) "is not compatible with type") - tr2 (explanation true mis)) + (if tr2 = [] then fprintf ppf "@]" + else + let mis = mismatch tr2 in + fprintf ppf "%a%t@]" + (trace false (mis = None) "is not compatible with type") + tr2 (explanation true mis)); + match ctx with + | Some ctx -> + fprintf ppf "@,@,@["; + (match ctx with + | Generic {errorCode} -> fprintf ppf "Error: %s" errorCode + | Primitive_coercion_target_variant_not_unboxed + {variant_name; primitive} -> + fprintf ppf + "@ The variant @{%s@} is not unboxed, so it cannot be \ + coerced to a @{%s@}. @ Fix this by adding the \ + @{@unboxed@} attribute to the variant @{%s@}." + (Path.name variant_name) (Path.name primitive) + (Path.name variant_name) + | Primitive_coercion_target_variant_no_catch_all + {variant_name; primitive} -> + fprintf ppf + "@ The variant @{%s@} is unboxed, but has no catch-all case \ + for the primitive @{%s@}, and therefore does not cover all \ + values of type @{%s@}. @ Fix this by adding a catch-all for \ + @{%s@} to @{%s@}, like @{%s(%s)@}." + (Path.name variant_name) (Path.name primitive) (Path.name primitive) + (Path.name variant_name) (Path.name primitive) + (String.capitalize_ascii (Path.name primitive)) + (Path.name primitive) + | Variant_constructor_runtime_representation_mismatch + {variant_name; issues} -> + List.iter + (fun issue -> + fprintf ppf "@ "; + print_variant_runtime_representation_issue ppf variant_name issue) + issues); + fprintf ppf "@]" + | None -> ()) let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = wrap_printing_env env (fun () -> diff --git a/compiler/ml/printtyp.mli b/compiler/ml/printtyp.mli index bb7c3bd7ea..bef44c2684 100644 --- a/compiler/ml/printtyp.mli +++ b/compiler/ml/printtyp.mli @@ -97,6 +97,7 @@ val report_subtyping_error : (type_expr * type_expr) list -> string -> (type_expr * type_expr) list -> + Ctype.subtype_context option -> unit val report_ambiguous_type_error : formatter -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index d1e593607f..756c67ab23 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -50,7 +50,10 @@ type error = | Undefined_method of type_expr * string * string list option | Private_type of type_expr | Private_label of Longident.t * type_expr - | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list + | Not_subtype of + (type_expr * type_expr) list + * (type_expr * type_expr) list + * Ctype.subtype_context option | Too_many_arguments of bool * type_expr | Abstract_wrong_label of Noloc.arg_label * type_expr | Scoping_let_module of string * type_expr @@ -602,8 +605,8 @@ let extract_type_from_pat_variant_spread env lid expected_ty = raise (Error (lid.loc, env, Type_params_not_supported lid.txt)); let ty = newgenty (Tconstr (path, [], ref Mnil)) in (try Ctype.subtype env ty expected_ty () - with Ctype.Subtype (tr1, tr2) -> - raise (Error (lid.loc, env, Not_subtype (tr1, tr2)))); + with Ctype.Subtype (tr1, tr2, ctx) -> + raise (Error (lid.loc, env, Not_subtype (tr1, tr2, ctx)))); (path, decl, constructors, ty) | _ -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt)) @@ -2950,9 +2953,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let force' = subtype env arg.exp_type ty' in force (); force' () - with Subtype (tr1, tr2) -> + with Subtype (tr1, tr2, ctx) -> (* prerr_endline "coercion failed"; *) - raise (Error (loc, env, Not_subtype (tr1, tr2)))); + raise (Error (loc, env, Not_subtype (tr1, tr2, ctx)))); (arg, ty', cty') in rue @@ -4353,8 +4356,8 @@ let report_error env ppf error = match valid_methods with | None -> () | Some valid_methods -> spellcheck ppf me valid_methods) - | Not_subtype (tr1, tr2) -> - report_subtyping_error ppf env tr1 "is not a subtype of" tr2 + | Not_subtype (tr1, tr2, ctx) -> + report_subtyping_error ppf env tr1 "is not a subtype of" tr2 ctx | Too_many_arguments (in_function, ty) -> if (* modified *) diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index 3aa23756d4..231a1c2f66 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -75,7 +75,10 @@ type error = | Undefined_method of type_expr * string * string list option | Private_type of type_expr | Private_label of Longident.t * type_expr - | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list + | Not_subtype of + (type_expr * type_expr) list + * (type_expr * type_expr) list + * Ctype.subtype_context option | Too_many_arguments of bool * type_expr | Abstract_wrong_label of Noloc.arg_label * type_expr | Scoping_let_module of string * type_expr diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index ecec066c63..c6f5b3d211 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -1,4 +1,23 @@ -(* TODO: Improve error messages? Say why we can't coerce. *) +type variant_runtime_representation_issue = + | Mismatched_unboxed_payload of { + constructor_name: string; + expected_typename: Path.t; + } + | Mismatched_as_payload of { + constructor_name: string; + expected_typename: Path.t; + as_payload: Ast_untagged_variants.tag_type option; + } + | As_payload_cannot_be_coerced of { + constructor_name: string; + expected_typename: Path.t; + as_payload: Ast_untagged_variants.tag_type; + } + | Inline_record_cannot_be_coerced of {constructor_name: string} + | Cannot_coerce_non_unboxed_with_payload of { + constructor_name: string; + expected_typename: Path.t; + } (* Right now we only allow coercing to primitives string/int/float *) let can_coerce_primitive (path : Path.t) = @@ -31,35 +50,98 @@ let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) match args with | Cstr_tuple [{desc = Tconstr (p, [], _)}] when unboxed -> + (* Unboxed type, and the constructor has a single item payload.*) let path_same = check_paths_same p target_path in - (* unboxed String(string) :> string *) - path_same Predef.path_string - (* unboxed Number(float) :> float *) - || path_same Predef.path_float - || - (* unboxed BigInt(bigint) :> bigint *) - path_same Predef.path_bigint + if + (* unboxed String(string) :> string *) + path_same Predef.path_string + (* unboxed Number(float) :> float *) + || path_same Predef.path_float + || + (* unboxed BigInt(bigint) :> bigint *) + path_same Predef.path_bigint + then None + else + Some + (Mismatched_unboxed_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + }) | Cstr_tuple [] -> ( (* Check that @as payloads match with the target path to coerce to. No @as means the default encoding, which is string *) match as_payload with - | None | Some (String _) -> Path.same target_path Predef.path_string - | Some (Int _) -> Path.same target_path Predef.path_int - | Some (Float _) -> Path.same target_path Predef.path_float - | Some (BigInt _) -> Path.same target_path Predef.path_bigint - | Some (Null | Undefined | Bool _ | Untagged _) -> false) - | _ -> false + | None | Some (String _) -> + if Path.same target_path Predef.path_string then None + else + Some + (Mismatched_as_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + as_payload; + }) + | Some (Int _) -> + if Path.same target_path Predef.path_int then None + else + Some + (Mismatched_as_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + as_payload; + }) + | Some (Float _) -> + if Path.same target_path Predef.path_float then None + else + Some + (Mismatched_as_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + as_payload; + }) + | Some (BigInt _) -> + if Path.same target_path Predef.path_bigint then None + else + Some + (Mismatched_as_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + as_payload; + }) + | Some ((Null | Undefined | Bool _ | Untagged _) as as_payload) -> + Some + (As_payload_cannot_be_coerced + { + constructor_name = Ident.name c.cd_id; + as_payload; + expected_typename = target_path; + })) + | Cstr_tuple _ -> + Some + (Cannot_coerce_non_unboxed_with_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + }) + | Cstr_record _ -> + Some + (Inline_record_cannot_be_coerced {constructor_name = Ident.name c.cd_id}) in - List.for_all has_same_runtime_representation constructors + List.filter_map has_same_runtime_representation constructors let can_try_coerce_variant_to_primitive ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = match typedecl with | {type_kind = Type_variant constructors; type_params = []; type_attributes} - when Path.name p <> "bool" -> + when not (Path.same p Predef.path_bool) -> (* bool is represented as a variant internally, so we need to account for that *) - Some (constructors, type_attributes |> Ast_untagged_variants.has_untagged) + (* TODO(subtype-errors) Report about bool? *) + Some (p, constructors, type_attributes |> Ast_untagged_variants.has_untagged) | _ -> None let can_try_coerce_variant_to_primitive_opt p = diff --git a/tests/build_tests/super_errors/expected/variant_coercion_bigint.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_bigint.res.expected index c179d49c12..a40923a28f 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_bigint.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_bigint.res.expected @@ -7,4 +7,7 @@ 5 │ let y = (x :> bigint) 6 │ - Type x is not a subtype of bigint \ No newline at end of file + Type x is not a subtype of bigint + + The constructor One of variant x has a payload, but the variant itself is not unboxed. + This means that the constructor One will be encoded as an object at runtime, which is not compatible with bigint. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_bigint_as.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_bigint_as.res.expected index a05508050b..43d6ab665a 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_bigint_as.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_bigint_as.res.expected @@ -7,4 +7,9 @@ 5 │ let y = (x :> bigint) 6 │ - Type x is not a subtype of bigint \ No newline at end of file + Type x is not a subtype of bigint + + The constructor Two of variant x has no @as payload, which makes it a string at runtime. + That runtime representation is not compatible with the expected runtime representation of bigint. + + Fix this by making sure all constructors in variant x has a runtime representation of bigint. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_float.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_float.res.expected index b78b995df4..36ff38277a 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_float.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_float.res.expected @@ -7,4 +7,7 @@ 5 │ let y = (x :> float) 6 │ - Type x is not a subtype of float \ No newline at end of file + Type x is not a subtype of float + + The constructor One of variant x has a payload, but the variant itself is not unboxed. + This means that the constructor One will be encoded as an object at runtime, which is not compatible with float. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_float_as.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_float_as.res.expected index a837b2e3e4..c14bc3d41c 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_float_as.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_float_as.res.expected @@ -7,4 +7,9 @@ 5 │ let y = (x :> float) 6 │ - Type x is not a subtype of float \ No newline at end of file + Type x is not a subtype of float + + The constructor Two of variant x has no @as payload, which makes it a string at runtime. + That runtime representation is not compatible with the expected runtime representation of float. + + Fix this by making sure all constructors in variant x has a runtime representation of float. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_inline_record.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_inline_record.res.expected new file mode 100644 index 0000000000..36602d45dc --- /dev/null +++ b/tests/build_tests/super_errors/expected/variant_coercion_inline_record.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/variant_coercion_inline_record.res:3:10-20 + + 1 │ type x = One({test: bool}) + 2 │ let x = One({test: true}) + 3 │ let y = (x :> string) + + Type x is not a subtype of string + + The constructor One of variant x has an inline record as payload. Inline records cannot be coerced. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_int.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_int.res.expected index c4344eeab4..2ccb7f548f 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_int.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_int.res.expected @@ -7,4 +7,7 @@ 5 │ let y = (x :> int) 6 │ - Type x is not a subtype of int \ No newline at end of file + Type x is not a subtype of int + + The constructor One of variant x has a payload, but the variant itself is not unboxed. + This means that the constructor One will be encoded as an object at runtime, which is not compatible with int. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_int_as.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_int_as.res.expected index 5a6f40e36b..7b68b06bd8 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_int_as.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_int_as.res.expected @@ -7,4 +7,9 @@ 5 │ let y = (x :> int) 6 │ - Type x is not a subtype of int \ No newline at end of file + Type x is not a subtype of int + + The constructor Two of variant x has no @as payload, which makes it a string at runtime. + That runtime representation is not compatible with the expected runtime representation of int. + + Fix this by making sure all constructors in variant x has a runtime representation of int. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_non_unboxed_with_payload.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_non_unboxed_with_payload.res.expected new file mode 100644 index 0000000000..bfe9af4068 --- /dev/null +++ b/tests/build_tests/super_errors/expected/variant_coercion_non_unboxed_with_payload.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/variant_coercion_non_unboxed_with_payload.res:3:10-20 + + 1 │ type x = One(bool) + 2 │ let x = One(true) + 3 │ let y = (x :> string) + 4 │ + + Type x is not a subtype of string + + The constructor One of variant x has a payload, but the variant itself is not unboxed. + This means that the constructor One will be encoded as an object at runtime, which is not compatible with string. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_string.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_string.res.expected index 73caae5341..0fd56040e1 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_string.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_string.res.expected @@ -7,4 +7,7 @@ 5 │ let y = (x :> string) 6 │ - Type x is not a subtype of string \ No newline at end of file + Type x is not a subtype of string + + The constructor One of variant x has a payload, but the variant itself is not unboxed. + This means that the constructor One will be encoded as an object at runtime, which is not compatible with string. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_string_as.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_string_as.res.expected index be12a2cfd4..885d44a90b 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_string_as.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_string_as.res.expected @@ -7,4 +7,9 @@ 5 │ let y = (x :> string) 6 │ - Type x is not a subtype of string \ No newline at end of file + Type x is not a subtype of string + + The constructor Two of variant x has an @as payload that gives it the runtime type of int. + That runtime representation is not compatible with the expected runtime representation of string. + + Fix this by making sure all constructors in variant x has a runtime representation of string. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_coercion_string_to_variant_no_payload.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_string_to_variant_no_payload.res.expected index 1b60c86925..ad4f073b3a 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_string_to_variant_no_payload.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_string_to_variant_no_payload.res.expected @@ -7,4 +7,7 @@ 6 │ let y = (x :> x) 7 │ - Type string is not a subtype of x \ No newline at end of file + Type string is not a subtype of x + + The variant x is unboxed, but has no catch-all case for the primitive string, and therefore does not cover all values of type string. + Fix this by adding a catch-all for x to string, like String(string). \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/variant_coercion_inline_record.res b/tests/build_tests/super_errors/fixtures/variant_coercion_inline_record.res new file mode 100644 index 0000000000..77bc7df664 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/variant_coercion_inline_record.res @@ -0,0 +1,3 @@ +type x = One({test: bool}) +let x = One({test: true}) +let y = (x :> string) \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/variant_coercion_non_unboxed_with_payload.res b/tests/build_tests/super_errors/fixtures/variant_coercion_non_unboxed_with_payload.res new file mode 100644 index 0000000000..adde6fcdfc --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/variant_coercion_non_unboxed_with_payload.res @@ -0,0 +1,3 @@ +type x = One(bool) +let x = One(true) +let y = (x :> string) From ef59ae4ad94765955dea4eec3c612811e794847a Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 24 Apr 2025 13:20:51 +0200 Subject: [PATCH 2/9] variant configuration errors --- compiler/ml/ctype.ml | 36 +++++++++++----- compiler/ml/ctype.mli | 5 +++ compiler/ml/printtyp.ml | 43 ++++++++++++++++++- compiler/ml/variant_coercion.ml | 31 +++++++++++++ ...riant_to_variant_coercion_tag.res.expected | 8 +++- ...t_to_variant_coercion_unboxed.res.expected | 8 +++- 6 files changed, 118 insertions(+), 13 deletions(-) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index a2f56b3de9..993124fedf 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -83,6 +83,11 @@ type subtype_context = variant_name: Path.t; issues: Variant_coercion.variant_runtime_representation_issue list; } + | Variant_configurations_mismatch of { + left_variant_name: Path.t; + right_variant_name: Path.t; + issue: Variant_coercion.variant_configuration_issue; + } exception Subtype of @@ -3587,7 +3592,9 @@ let rec subtype_rec env trace t1 t2 cstrs = 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 env trace tl1 tl2 cstrs + | Ttuple tl1, Ttuple tl2 -> + (* 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 -> @@ -3624,6 +3631,7 @@ let rec subtype_rec env trace t1 t2 cstrs = subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 Predef.path_int && Path.same p2 Predef.path_float -> + (* Int can always be coerced to float *) cstrs | Tconstr (path, [], _), Tconstr (_, [], _) when Variant_coercion.can_coerce_primitive path @@ -3699,15 +3707,23 @@ let rec subtype_rec env trace t1 t2 cstrs = match (extract_concrete_typedecl env t1, extract_concrete_typedecl env t2) with - | ( (_, _, {type_kind = Type_variant c1; type_attributes = t1attrs}), - (_, _, {type_kind = Type_variant c2; type_attributes = t2attrs}) ) - -> - if - Variant_coercion.variant_configuration_can_be_coerced t1attrs + | ( (p1, _, {type_kind = Type_variant c1; type_attributes = t1attrs}), + (p2, _, {type_kind = Type_variant c2; type_attributes = t2attrs}) ) + -> ( + match + Variant_coercion.variant_configuration_can_be_coerced2 t1attrs t2attrs - = false - then (trace, t1, t2, !univar_pairs, None) :: cstrs - else + with + | Error issue -> + ( trace, + t1, + t2, + !univar_pairs, + Some + (Variant_configurations_mismatch + {left_variant_name = p1; right_variant_name = p2; issue}) ) + :: cstrs + | Ok () -> let c1_len = List.length c1 in if c1_len > List.length c2 then (trace, t1, t2, !univar_pairs, None) :: cstrs @@ -3767,7 +3783,7 @@ let rec subtype_rec env trace t1 t2 cstrs = else false | _ -> false) then cstrs - else (trace, t1, t2, !univar_pairs, None) :: cstrs + else (trace, t1, t2, !univar_pairs, None) :: cstrs) | ( (_, _, {type_kind = Type_record (fields1, repr1)}), (_, _, {type_kind = Type_record (fields2, repr2)}) ) -> let same_repr = diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 71fd2db737..0029965a95 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -32,6 +32,11 @@ type subtype_context = variant_name: Path.t; issues: Variant_coercion.variant_runtime_representation_issue list; } + | Variant_configurations_mismatch of { + left_variant_name: Path.t; + right_variant_name: Path.t; + issue: Variant_coercion.variant_configuration_issue; + } exception Unify of (type_expr * type_expr) list exception Tags of label * label diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 09091325e0..7ca11deb9d 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -1576,6 +1576,43 @@ let print_variant_runtime_representation_issue ppf variant_name a runtime representation of @{%s@}." (Path.name variant_name) (Path.name expected_typename) + +let print_variant_configuration_issue ppf + (issue : Variant_coercion.variant_configuration_issue) ~left_variant_name + ~right_variant_name = + match issue with + | Unboxed_config_not_matching {left_unboxed; right_unboxed} -> + fprintf ppf + "@ The variants have different @{@unboxed@} configurations."; + let print_unboxed_status ppf unboxed name = + fprintf ppf "@ - Variant @{%s@} is @{%s@}unboxed." + (Path.name name) + (if unboxed then "not " else "") + in + print_unboxed_status ppf left_unboxed left_variant_name; + print_unboxed_status ppf right_unboxed right_variant_name; + fprintf ppf + "@,\ + @ Fix this by making sure the variants either both have, or don't have, \ + the @{@unboxed@} attribute." + | Tag_name_not_matching {left_tag; right_tag} -> + fprintf ppf "@ The variants have different @{@tag@} configurations."; + let print_tag ppf tag variant_name = + match tag with + | Some tag -> + fprintf ppf "@ - @{%s@} has tag @{%s@}." + (Path.name variant_name) tag + | None -> + fprintf ppf "@ - @{%s@} has no explicit tag." + (Path.name variant_name) + in + print_tag ppf left_tag left_variant_name; + print_tag ppf right_tag right_variant_name; + fprintf ppf + "@,\ + @ Fix this by making sure the variants either have the exact same \ + @{@tag@} configuration, or no @{@tag@} at all." + let report_subtyping_error ppf env tr1 txt1 tr2 ctx = wrap_printing_env env (fun () -> reset (); @@ -1618,7 +1655,11 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx = (fun issue -> fprintf ppf "@ "; print_variant_runtime_representation_issue ppf variant_name issue) - issues); + issues + | Variant_configurations_mismatch + {left_variant_name; right_variant_name; issue} -> + print_variant_configuration_issue ppf issue ~left_variant_name + ~right_variant_name); fprintf ppf "@]" | None -> ()) diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index c6f5b3d211..485b957050 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -173,6 +173,37 @@ type variant_error = exception VariantConfigurationError of variant_error +type variant_configuration_issue = + | Unboxed_config_not_matching of {left_unboxed: bool; right_unboxed: bool} + | Tag_name_not_matching of {left_tag: string option; right_tag: string option} + +let variant_configuration_can_be_coerced2 (a1 : Parsetree.attributes) + (a2 : Parsetree.attributes) = + let unboxed = + match + ( Ast_untagged_variants.process_untagged a1, + Ast_untagged_variants.process_untagged a2 ) + with + | true, true | false, false -> Ok () + | left, right -> + Error + (Unboxed_config_not_matching + {left_unboxed = left; right_unboxed = right}) + in + let tag = + match + ( Ast_untagged_variants.process_tag_name a1, + Ast_untagged_variants.process_tag_name a2 ) + with + | Some tag1, Some tag2 when tag1 = tag2 -> Ok () + | None, None -> Ok () + | tag1, tag2 -> + Error (Tag_name_not_matching {left_tag = tag1; right_tag = tag2}) + in + match (unboxed, tag) with + | Ok (), Ok () -> Ok () + | Error e, _ | _, Error e -> Error e + let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) (a2 : Parsetree.attributes) = let unboxed = diff --git a/tests/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected b/tests/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected index 33b2122b09..0f3f17cace 100644 --- a/tests/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected +++ b/tests/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected @@ -7,4 +7,10 @@ 6 │ let y = (x :> y) 7 │ - Type x is not a subtype of y \ No newline at end of file + Type x is not a subtype of y + + The variants have different @tag configurations. + - x has tag kind. + - y has no explicit tag. + + Fix this by making sure the variants either have the exact same @tag configuration, or no @tag at all. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected b/tests/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected index 6e4844a280..399af95df0 100644 --- a/tests/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected +++ b/tests/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected @@ -7,4 +7,10 @@ 6 │ let y = (x :> y) 7 │ - Type x is not a subtype of y \ No newline at end of file + Type x is not a subtype of y + + The variants have different @unboxed configurations. + - Variant x is not unboxed. + - Variant y is unboxed. + + Fix this by making sure the variants either both have, or don't have, the @unboxed attribute. \ No newline at end of file From a691b52a3bc7a6b95797ed2eaf36cb5cc3521ffb Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 24 Apr 2025 14:04:59 +0200 Subject: [PATCH 3/9] different constructor counts --- compiler/ml/ctype.ml | 26 ++++++++++++++++++- compiler/ml/printtyp.ml | 25 ++++++++++++++++++ compiler/ml/variant_coercion.ml | 1 + ..._different_constructor_counts.res.expected | 13 ++++++++++ ...o_variant_different_constructor_counts.res | 6 +++++ 5 files changed, 70 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/super_errors/expected/variant_to_variant_different_constructor_counts.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/variant_to_variant_different_constructor_counts.res diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 993124fedf..8bce6ba957 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -3726,7 +3726,31 @@ let rec subtype_rec env trace t1 t2 cstrs = | Ok () -> let c1_len = List.length c1 in if c1_len > List.length c2 then - (trace, t1, t2, !univar_pairs, None) :: cstrs + let c1_constructor_names = + c1 |> List.map (fun c -> c.cd_id.name) + in + let c2_constructor_names = + c2 |> List.map (fun c -> c.cd_id.name) + in + let incompatible_constructor_names = + c1_constructor_names + |> List.filter (fun name -> + not (List.mem name c2_constructor_names)) + in + ( trace, + t1, + t2, + !univar_pairs, + Some + (Variant_configurations_mismatch + { + left_variant_name = p1; + right_variant_name = p2; + issue = + Incompatible_constructor_count + {constructor_names = incompatible_constructor_names}; + }) ) + :: cstrs else let constructor_map = Hashtbl.create c1_len in c2 diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 7ca11deb9d..b5b5a164a5 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -1612,6 +1612,31 @@ let print_variant_configuration_issue ppf "@,\ @ Fix this by making sure the variants either have the exact same \ @{@tag@} configuration, or no @{@tag@} at all." + | Incompatible_constructor_count {constructor_names} -> + let total_constructor_count = List.length constructor_names in + let constructor_names_to_print = constructor_names |> List.take 3 in + let not_printed_constructor_count = + total_constructor_count - List.length constructor_names_to_print + in + fprintf ppf + "@ @{%s@} has %i constructor%s that @{%s@} does not have: " + (Path.name left_variant_name) + total_constructor_count + (if total_constructor_count = 1 then "" else "s") + (Path.name right_variant_name); + + constructor_names_to_print + |> List.iteri (fun index name -> + if index = 0 then () else fprintf ppf ", "; + fprintf ppf "@{%s@}" name); + if not_printed_constructor_count > 0 then + fprintf ppf " (+%i more)" not_printed_constructor_count; + + fprintf ppf + "@ Therefore, it is not possible for @{%s@} to represent \ + @{%s@}." + (Path.name right_variant_name) + (Path.name left_variant_name) let report_subtyping_error ppf env tr1 txt1 tr2 ctx = wrap_printing_env env (fun () -> diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index 485b957050..69c67bbaf5 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -176,6 +176,7 @@ exception VariantConfigurationError of variant_error type variant_configuration_issue = | Unboxed_config_not_matching of {left_unboxed: bool; right_unboxed: bool} | Tag_name_not_matching of {left_tag: string option; right_tag: string option} + | Incompatible_constructor_count of {constructor_names: string list} let variant_configuration_can_be_coerced2 (a1 : Parsetree.attributes) (a2 : Parsetree.attributes) = diff --git a/tests/build_tests/super_errors/expected/variant_to_variant_different_constructor_counts.res.expected b/tests/build_tests/super_errors/expected/variant_to_variant_different_constructor_counts.res.expected new file mode 100644 index 0000000000..54c6c8b80e --- /dev/null +++ b/tests/build_tests/super_errors/expected/variant_to_variant_different_constructor_counts.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/variant_to_variant_different_constructor_counts.res:6:10-15 + + 4 │ let x: x = One(true) + 5 │ + 6 │ let y = (x :> y) + 7 │ + + Type x is not a subtype of y + + x has 4 constructors that y does not have: Two, Three, Four (+1 more) + Therefore, it is not possible for y to represent x. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/variant_to_variant_different_constructor_counts.res b/tests/build_tests/super_errors/fixtures/variant_to_variant_different_constructor_counts.res new file mode 100644 index 0000000000..e7a2e4cb6e --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/variant_to_variant_different_constructor_counts.res @@ -0,0 +1,6 @@ +type x = One(bool) | Two | Three | Four | Five +type y = One(bool) + +let x: x = One(true) + +let y = (x :> y) From 99b253e9225c97ec2c8455c44217331717b175ce Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 24 Apr 2025 14:07:36 +0200 Subject: [PATCH 4/9] format --- .../super_errors/fixtures/variant_coercion_inline_record.res | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/build_tests/super_errors/fixtures/variant_coercion_inline_record.res b/tests/build_tests/super_errors/fixtures/variant_coercion_inline_record.res index 77bc7df664..b115a74fa8 100644 --- a/tests/build_tests/super_errors/fixtures/variant_coercion_inline_record.res +++ b/tests/build_tests/super_errors/fixtures/variant_coercion_inline_record.res @@ -1,3 +1,3 @@ type x = One({test: bool}) let x = One({test: true}) -let y = (x :> string) \ No newline at end of file +let y = (x :> string) From b89753b73b9d4aa09e493e6d539ee9cfb65ebee5 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 24 Apr 2025 14:13:09 +0200 Subject: [PATCH 5/9] update test output --- .../expected/variant_coercion_inline_record.res.expected | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/build_tests/super_errors/expected/variant_coercion_inline_record.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_inline_record.res.expected index 36602d45dc..8a915854b4 100644 --- a/tests/build_tests/super_errors/expected/variant_coercion_inline_record.res.expected +++ b/tests/build_tests/super_errors/expected/variant_coercion_inline_record.res.expected @@ -5,6 +5,7 @@ 1 │ type x = One({test: bool}) 2 │ let x = One({test: true}) 3 │ let y = (x :> string) + 4 │ Type x is not a subtype of string From 9c406535ace7cbf9293dcda0b0e0b02382810316 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 24 Apr 2025 14:23:36 +0200 Subject: [PATCH 6/9] different type kinds --- compiler/ml/ctype.ml | 23 ++++++++++++++++++- compiler/ml/ctype.mli | 6 +++++ compiler/ml/printtyp.ml | 22 ++++++++++++++---- ...nt_coercion_mismatching_types.res.expected | 14 +++++++++++ .../variant_coercion_mismatching_types.res | 9 ++++++++ 5 files changed, 69 insertions(+), 5 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/variant_coercion_mismatching_types.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/variant_coercion_mismatching_types.res diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 8bce6ba957..ec54761e83 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -88,6 +88,12 @@ type subtype_context = right_variant_name: Path.t; issue: Variant_coercion.variant_configuration_issue; } + | Different_type_kinds of { + left_typename: Path.t; + right_typename: Path.t; + left_type_kind: type_kind; + right_type_kind: type_kind; + } exception Subtype of @@ -3777,6 +3783,7 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.variant_representation_matches c1_attributes c2_attributes then + (* TODO(subtype-errors) Inline record coercion check, piggy back on record coercion check *) let violation, tl1, tl2 = Record_coercion.check_record_fields fields1 fields2 in @@ -3810,6 +3817,7 @@ let rec subtype_rec env trace t1 t2 cstrs = else (trace, t1, t2, !univar_pairs, None) :: cstrs) | ( (_, _, {type_kind = Type_record (fields1, repr1)}), (_, _, {type_kind = Type_record (fields2, repr2)}) ) -> + (* TODO(subtype-errors) Record representation *) let same_repr = match (repr1, repr2) with | Record_regular, Record_regular -> @@ -3826,7 +3834,20 @@ let rec subtype_rec env trace t1 t2 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, None) :: cstrs - | _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs + | (p1, _, {type_kind = tk1}), (p2, _, {type_kind = tk2}) -> + ( trace, + t1, + t2, + !univar_pairs, + Some + (Different_type_kinds + { + left_typename = p1; + right_typename = p2; + left_type_kind = tk1; + right_type_kind = tk2; + }) ) + :: 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 *) diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 0029965a95..add9788698 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -37,6 +37,12 @@ type subtype_context = right_variant_name: Path.t; issue: Variant_coercion.variant_configuration_issue; } + | Different_type_kinds of { + left_typename: Path.t; + right_typename: Path.t; + left_type_kind: type_kind; + right_type_kind: type_kind; + } exception Unify of (type_expr * type_expr) list exception Tags of label * label diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index b5b5a164a5..9c143a729c 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -1651,9 +1651,9 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx = (trace false (mis = None) "is not compatible with type") tr2 (explanation true mis)); match ctx with - | Some ctx -> + | Some ctx -> ( fprintf ppf "@,@,@["; - (match ctx with + match ctx with | Generic {errorCode} -> fprintf ppf "Error: %s" errorCode | Primitive_coercion_target_variant_not_unboxed {variant_name; primitive} -> @@ -1684,8 +1684,22 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx = | Variant_configurations_mismatch {left_variant_name; right_variant_name; issue} -> print_variant_configuration_issue ppf issue ~left_variant_name - ~right_variant_name); - fprintf ppf "@]" + ~right_variant_name + | Different_type_kinds + {left_typename; right_typename; left_type_kind; right_type_kind} -> + let type_kind_to_string = function + | Type_abstract -> "an abstract type" + | Type_record _ -> "a record" + | Type_variant _ -> "a variant" + | Type_open -> "an open type" + in + fprintf ppf + "@ The types of @{%s@} and @{%s@} are different:" + (Path.name left_typename) (Path.name right_typename); + fprintf ppf "@ - @{%s@} is %s" (Path.name left_typename) + (type_kind_to_string left_type_kind); + fprintf ppf "@ - @{%s@} is %s" (Path.name right_typename) + (type_kind_to_string right_type_kind)) | None -> ()) let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = diff --git a/tests/build_tests/super_errors/expected/variant_coercion_mismatching_types.res.expected b/tests/build_tests/super_errors/expected/variant_coercion_mismatching_types.res.expected new file mode 100644 index 0000000000..1c5958d741 --- /dev/null +++ b/tests/build_tests/super_errors/expected/variant_coercion_mismatching_types.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/variant_coercion_mismatching_types.res:9:10-15 + + 7 │ let x: x = One(true) + 8 │ + 9 │ let y = (x :> y) + 10 │ + + Type x is not a subtype of y + + The types of x and y are different: + - x is a variant + - y is a record \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/variant_coercion_mismatching_types.res b/tests/build_tests/super_errors/fixtures/variant_coercion_mismatching_types.res new file mode 100644 index 0000000000..cc6e968672 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/variant_coercion_mismatching_types.res @@ -0,0 +1,9 @@ +type x = One(bool) | Two | Three | Four | Five +type y = { + x: x, + y: int, +} + +let x: x = One(true) + +let y = (x :> y) From 318efa9217e5d6f0168c5e781738e4ebaf38c7d1 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 24 Apr 2025 15:03:07 +0200 Subject: [PATCH 7/9] missing fn --- compiler/ml/printtyp.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 9c143a729c..f2b175510f 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -1614,7 +1614,11 @@ let print_variant_configuration_issue ppf @{@tag@} configuration, or no @{@tag@} at all." | Incompatible_constructor_count {constructor_names} -> let total_constructor_count = List.length constructor_names in - let constructor_names_to_print = constructor_names |> List.take 3 in + let constructor_names_to_print = + match constructor_names with + | a :: b :: c :: _ -> [a; b; c] + | names -> names + in let not_printed_constructor_count = total_constructor_count - List.length constructor_names_to_print in From 48e1ff275f94dd68748d0101a8b3545d8cf261a1 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 24 Apr 2025 22:25:44 +0200 Subject: [PATCH 8/9] record fields mismatch --- compiler/ml/ctype.ml | 58 ++++++++++++------ compiler/ml/ctype.mli | 5 ++ compiler/ml/printtyp.ml | 60 ++++++++++++++++++- compiler/ml/record_coercion.ml | 46 +++++++++++--- ...cion_as_payload_mismatch_both.res.expected | 13 ++++ ...cion_as_payload_mismatch_left.res.expected | 13 ++++ ...ion_as_payload_mismatch_right.res.expected | 13 ++++ ...record_coercion_missing_field.res.expected | 13 ++++ ...rd_coercion_optional_mismatch.res.expected | 13 ++++ ...cord_coercion_as_payload_mismatch_both.res | 15 +++++ ...cord_coercion_as_payload_mismatch_left.res | 15 +++++ ...ord_coercion_as_payload_mismatch_right.res | 15 +++++ .../record_coercion_missing_field.res | 16 +++++ .../record_coercion_optional_mismatch.res | 14 +++++ 14 files changed, 283 insertions(+), 26 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_both.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_left.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_right.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_coercion_missing_field.res.expected create mode 100644 tests/build_tests/super_errors/expected/record_coercion_optional_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_both.res create mode 100644 tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_left.res create mode 100644 tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_right.res create mode 100644 tests/build_tests/super_errors/fixtures/record_coercion_missing_field.res create mode 100644 tests/build_tests/super_errors/fixtures/record_coercion_optional_mismatch.res diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index ec54761e83..a0bcd446a3 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -94,6 +94,11 @@ type subtype_context = left_type_kind: type_kind; right_type_kind: type_kind; } + | Record_fields_mismatch of { + left_record_name: Path.t; + right_record_name: Path.t; + issues: Record_coercion.record_field_subtype_violation list; + } exception Subtype of @@ -3762,9 +3767,9 @@ let rec subtype_rec env trace t1 t2 cstrs = c2 |> List.iter (fun (c : Types.constructor_declaration) -> Hashtbl.add constructor_map (Ident.name c.cd_id) c); - if + let field_subtype_violations = c1 - |> List.for_all (fun (c : Types.constructor_declaration) -> + |> List.filter_map (fun (c : Types.constructor_declaration) -> match ( c, Hashtbl.find_opt constructor_map (Ident.name c.cd_id) @@ -3783,17 +3788,18 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.variant_representation_matches c1_attributes c2_attributes then - (* TODO(subtype-errors) Inline record coercion check, piggy back on record coercion check *) - let violation, tl1, tl2 = + let violations, tl1, tl2 = Record_coercion.check_record_fields fields1 fields2 in - if violation then false - else + match violations with + | [] -> ( try let lst = subtype_list env trace tl1 tl2 cstrs in - List.length lst = List.length cstrs - with _ -> false - else false + if List.length lst = List.length cstrs then None + else Some [ (* TODO(subtype-errors) *) ] + with _ -> Some [ (* TODO(subtype-errors) *) ]) + | violations -> Some violations + else Some [ (* TODO(subtype-errors) *) ] | ( { Types.cd_args = Cstr_tuple tl1; cd_attributes = c1_attributes; @@ -3809,14 +3815,16 @@ let rec subtype_rec env trace t1 t2 cstrs = then try let lst = subtype_list env trace tl1 tl2 cstrs in - List.length lst = List.length cstrs - with _ -> false - else false - | _ -> false) - then cstrs + if List.length lst = List.length cstrs then None + else Some [ (* TODO(subtype-errors) *) ] + with _ -> Some [ (* TODO(subtype-errors) *) ] + else Some [ (* TODO(subtype-errors) *) ] + | _ -> Some [ (* TODO(subtype-errors) *) ]) + in + if field_subtype_violations = [] then cstrs else (trace, t1, t2, !univar_pairs, None) :: cstrs) - | ( (_, _, {type_kind = Type_record (fields1, repr1)}), - (_, _, {type_kind = Type_record (fields2, repr2)}) ) -> + | ( (p1, _, {type_kind = Type_record (fields1, repr1)}), + (p2, _, {type_kind = Type_record (fields2, repr2)}) ) -> (* TODO(subtype-errors) Record representation *) let same_repr = match (repr1, repr2) with @@ -3828,10 +3836,22 @@ let rec subtype_rec env trace t1 t2 cstrs = | _ -> false in if same_repr then - let violation, tl1, tl2 = + let violations, tl1, tl2 = Record_coercion.check_record_fields fields1 fields2 in - if violation then (trace, t1, t2, !univar_pairs, None) :: cstrs + if violations <> [] then + ( trace, + t1, + t2, + !univar_pairs, + Some + (Record_fields_mismatch + { + left_record_name = p1; + right_record_name = p2; + issues = violations; + }) ) + :: 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}) -> @@ -3862,6 +3882,8 @@ let rec subtype_rec env trace t1 t2 cstrs = | Tvariant {row_closed = true; row_fields}, Tconstr (_, [], _) when extract_concrete_typedecl_opt env t2 |> Variant_coercion.type_is_variant -> ( + (* TODO(subtype-errors) Polyvariant to variant *) + (* TODO(subtype-errors) Add Variant to polyvariant while we're at it? *) match extract_concrete_typedecl env t2 with | _, _, {type_kind = Type_variant variant_constructors; type_attributes} -> ( diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index add9788698..1752e4d0f7 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -43,6 +43,11 @@ type subtype_context = left_type_kind: type_kind; right_type_kind: type_kind; } + | Record_fields_mismatch of { + left_record_name: Path.t; + right_record_name: Path.t; + issues: Record_coercion.record_field_subtype_violation list; + } exception Unify of (type_expr * type_expr) list exception Tags of label * label diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index f2b175510f..9dc3ad8d44 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -1642,6 +1642,51 @@ let print_variant_configuration_issue ppf (Path.name right_variant_name) (Path.name left_variant_name) +let print_record_field_subtype_violation ppf + (issue : Record_coercion.record_field_subtype_violation) ~left_record_name + ~right_record_name = + match issue with + | Optional_mismatch {label; left_optional; right_optional} -> ( + fprintf ppf "The field @{%s@} " label; + match (left_optional, right_optional) with + | true, false -> + fprintf ppf + "is optional in record @{%s@}, but is not optional in record \ + @{%s@}" + (Path.name left_record_name) + (Path.name right_record_name) + | false, true -> + fprintf ppf + "is not optional in record @{%s@}, but is optional in record \ + @{%s@}" + (Path.name left_record_name) + (Path.name right_record_name) + | _ -> failwith "Invalid optional mismatch") + | Field_runtime_name_mismatch {label; left_as; right_as} -> + fprintf ppf "Field @{%s@} runtime representation" label; + (match left_as with + | Some as_name -> + fprintf ppf + " is configured to be @{\"%s\"@} (via the @as attribute)" as_name + | None -> fprintf ppf " is @{\"%s\"@}" label); + fprintf ppf " in record @{%s@}, but in record @{%s@}" + (Path.name right_record_name) + (Path.name left_record_name); + (match right_as with + | Some as_name -> + fprintf ppf + " it is configured to be @{\"%s\"@} (via the @as attribute)." + as_name + | None -> fprintf ppf " it is @{\"%s\"@}." label); + fprintf ppf " Runtime representations must match." + | Field_missing {label} -> + fprintf ppf + "The field @{%s@} is missing in record @{%s@}, but present \ + in record @{%s@}" + label + (Path.name right_record_name) + (Path.name left_record_name) + let report_subtyping_error ppf env tr1 txt1 tr2 ctx = wrap_printing_env env (fun () -> reset (); @@ -1703,7 +1748,20 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx = fprintf ppf "@ - @{%s@} is %s" (Path.name left_typename) (type_kind_to_string left_type_kind); fprintf ppf "@ - @{%s@} is %s" (Path.name right_typename) - (type_kind_to_string right_type_kind)) + (type_kind_to_string right_type_kind) + | Record_fields_mismatch {left_record_name; right_record_name; issues} + -> + fprintf ppf + "@ The record @{%s@} cannot be coerced to the record \ + @{%s@} because:" + (Path.name left_record_name) + (Path.name right_record_name); + List.iter + (fun issue -> + fprintf ppf "@ - "; + print_record_field_subtype_violation ppf issue ~left_record_name + ~right_record_name) + issues) | None -> ()) let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = diff --git a/compiler/ml/record_coercion.ml b/compiler/ml/record_coercion.ml index 0f2fbc96d6..1c1422523d 100644 --- a/compiler/ml/record_coercion.ml +++ b/compiler/ml/record_coercion.ml @@ -1,6 +1,20 @@ +type record_field_subtype_violation = + | Optional_mismatch of { + label: string; + left_optional: bool; + right_optional: bool; + } + | Field_runtime_name_mismatch of { + label: string; + left_as: string option; + right_as: string option; + } + | Field_missing of {label: string} + let check_record_fields (fields1 : Types.label_declaration list) (fields2 : Types.label_declaration list) = - let violation = ref false in + let violations = ref [] in + let add_violation v = violations := v :: !violations in let label_decl_sub (acc1, acc2) (ld2 : Types.label_declaration) = match Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name) @@ -8,21 +22,39 @@ let check_record_fields (fields1 : Types.label_declaration list) | Some ld1 -> if ld1.ld_optional <> ld2.ld_optional then (* optional field can't be modified *) - violation := true; + add_violation + (Optional_mismatch + { + label = ld1.ld_id.name; + left_optional = ld1.ld_optional; + right_optional = ld2.ld_optional; + }); let get_as (({txt}, payload) : Parsetree.attribute) = if txt = "as" then Ast_payload.is_single_string payload else None in let get_as_name (ld : Types.label_declaration) = match Ext_list.filter_map ld.ld_attributes get_as with - | [] -> ld.ld_id.name - | (s, _) :: _ -> s + | [] -> None + | (s, _) :: _ -> Some s in - if get_as_name ld1 <> get_as_name ld2 then violation := true; + let get_label_runtime_name (ld : Types.label_declaration) = + match get_as_name ld with + | None -> ld.ld_id.name + | Some s -> s + in + if get_label_runtime_name ld1 <> get_label_runtime_name ld2 then + add_violation + (Field_runtime_name_mismatch + { + label = ld1.ld_id.name; + left_as = get_as_name ld1; + right_as = get_as_name ld2; + }); (ld1.ld_type :: acc1, ld2.ld_type :: acc2) | None -> (* field must be present *) - violation := true; + add_violation (Field_missing {label = ld2.ld_id.name}); (acc1, acc2) in let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in - (!violation, tl1, tl2) + (!violations, tl1, tl2) diff --git a/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_both.res.expected b/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_both.res.expected new file mode 100644 index 0000000000..10c0da9df8 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_both.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/record_coercion_as_payload_mismatch_both.res:15:10-15 + + 13 │ } + 14 │ + 15 │ let y = (x :> y) + 16 │ + + Type x is not a subtype of y + + The record x cannot be coerced to the record y because: + - Field x runtime representation is configured to be "z" (via the @as attribute) in record y, but in record x it is configured to be "w" (via the @as attribute). Runtime representations must match. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_left.res.expected b/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_left.res.expected new file mode 100644 index 0000000000..4b7d00d1f6 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_left.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/record_coercion_as_payload_mismatch_left.res:15:10-15 + + 13 │ } + 14 │ + 15 │ let y = (x :> y) + 16 │ + + Type x is not a subtype of y + + The record x cannot be coerced to the record y because: + - Field x runtime representation is configured to be "z" (via the @as attribute) in record y, but in record x it is "x". Runtime representations must match. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_right.res.expected b/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_right.res.expected new file mode 100644 index 0000000000..7c0d45dd3d --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_coercion_as_payload_mismatch_right.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/record_coercion_as_payload_mismatch_right.res:15:10-15 + + 13 │ } + 14 │ + 15 │ let y = (x :> y) + 16 │ + + Type x is not a subtype of y + + The record x cannot be coerced to the record y because: + - Field x runtime representation is "x" in record y, but in record x it is configured to be "z" (via the @as attribute). Runtime representations must match. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_coercion_missing_field.res.expected b/tests/build_tests/super_errors/expected/record_coercion_missing_field.res.expected new file mode 100644 index 0000000000..017d5714c8 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_coercion_missing_field.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/record_coercion_missing_field.res:16:10-15 + + 14 │ } + 15 │ + 16 │ let y = (x :> y) + 17 │ + + Type x is not a subtype of y + + The record x cannot be coerced to the record y because: + - The field z is missing in record y, but present in record x \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/record_coercion_optional_mismatch.res.expected b/tests/build_tests/super_errors/expected/record_coercion_optional_mismatch.res.expected new file mode 100644 index 0000000000..7b8c1399f7 --- /dev/null +++ b/tests/build_tests/super_errors/expected/record_coercion_optional_mismatch.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/record_coercion_optional_mismatch.res:14:10-15 + + 12 │ } + 13 │ + 14 │ let y = (x :> y) + 15 │ + + Type x is not a subtype of y + + The record x cannot be coerced to the record y because: + - The field x is optional in record x, but is not optional in record y \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_both.res b/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_both.res new file mode 100644 index 0000000000..1585254967 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_both.res @@ -0,0 +1,15 @@ +type x = { + @as("z") x: int, + y: int, +} +type y = { + @as("w") x: int, + y: int, +} + +let x: x = { + x: 1, + y: 1, +} + +let y = (x :> y) diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_left.res b/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_left.res new file mode 100644 index 0000000000..ca409bd863 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_left.res @@ -0,0 +1,15 @@ +type x = { + @as("z") x: int, + y: int, +} +type y = { + x: int, + y: int, +} + +let x: x = { + x: 1, + y: 1, +} + +let y = (x :> y) diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_right.res b/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_right.res new file mode 100644 index 0000000000..d91735f2c7 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_coercion_as_payload_mismatch_right.res @@ -0,0 +1,15 @@ +type x = { + x: int, + y: int, +} +type y = { + @as("z")x: int, + y: int, +} + +let x: x = { + x: 1, + y: 1, +} + +let y = (x :> y) diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_missing_field.res b/tests/build_tests/super_errors/fixtures/record_coercion_missing_field.res new file mode 100644 index 0000000000..81adbfe82b --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_coercion_missing_field.res @@ -0,0 +1,16 @@ +type x = { + x: int, + y: int, +} +type y = { + x: int, + y: int, + z: int, +} + +let x: x = { + x: 1, + y: 1, +} + +let y = (x :> y) diff --git a/tests/build_tests/super_errors/fixtures/record_coercion_optional_mismatch.res b/tests/build_tests/super_errors/fixtures/record_coercion_optional_mismatch.res new file mode 100644 index 0000000000..7b272ec7c7 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/record_coercion_optional_mismatch.res @@ -0,0 +1,14 @@ +type x = { + x?: int, + y: int, +} +type y = { + x: int, + y: int, +} + +let x: x = { + y: 1, +} + +let y = (x :> y) From 95aca7652d3cb1f385f08653e50e13d7be961401 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 26 Apr 2025 19:42:27 +0200 Subject: [PATCH 9/9] more hints about what types we are looking at --- compiler/ml/ctype.ml | 152 ++++++++++++------ compiler/ml/ctype.mli | 19 ++- compiler/ml/printtyp.ml | 59 +++++-- compiler/ml/printtyp.mli | 5 +- compiler/ml/typecore.ml | 16 +- compiler/ml/typecore.mli | 5 +- compiler/ml/variant_coercion.ml | 25 +-- ...ple_coercion_element_mismatch.res.expected | 13 ++ ..._different_constructor_counts.res.expected | 2 +- .../tuple_coercion_element_mismatch.res | 7 + 10 files changed, 206 insertions(+), 97 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/tuple_coercion_element_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/tuple_coercion_element_mismatch.res diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index a0bcd446a3..24e5ce0099 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -53,8 +53,9 @@ open Btype *) (**** Errors ****) +type type_pairs = (type_expr * type_expr) list -exception Unify of (type_expr * type_expr) list +exception Unify of type_pairs exception Tags of label * label @@ -100,11 +101,20 @@ 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_expr * type_expr) list - * (type_expr * type_expr) list + type_pairs + * type_pairs * subtype_context option + * subtype_type_position option exception Cannot_expand @@ -113,7 +123,7 @@ exception Cannot_apply exception Recursive_abbrev (* GADT: recursive abbrevs can appear as a result of local constraints *) -exception Unification_recursive_abbrev of (type_expr * type_expr) list +exception Unification_recursive_abbrev of type_pairs (**** Type level management ****) @@ -3579,15 +3589,15 @@ let enlarge_type env ty = let subtypes = TypePairs.create 17 -let subtype_error ?ctx env trace = - raise (Subtype (expand_trace env (List.rev trace), [], ctx)) +let subtype_error ?type_position ?ctx env trace = + raise (Subtype (expand_trace env (List.rev trace), [], ctx, type_position)) 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 env trace t1 t2 cstrs = +let rec subtype_rec ?type_position env trace t1 t2 cstrs = let t1 = repr t1 in let t2 = repr t2 in if t1 == t2 then cstrs @@ -3598,14 +3608,16 @@ 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, None) :: cstrs + | Tvar _, _ | _, Tvar _ -> + (trace, t1, t2, !univar_pairs, None, type_position) :: 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 -> - (* TODO(subtype-errors) Tuple as context *) - subtype_list env trace tl1 tl2 cstrs + subtype_list + ~make_type_position:(fun i -> Some (TupleElement {index = i})) + 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 -> @@ -3631,13 +3643,15 @@ let rec subtype_rec env trace t1 t2 cstrs = newty2 t1.level (Ttuple [t1]), newty2 t2.level (Ttuple [t2]), !univar_pairs, - None ) + None, + type_position ) :: 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) :: cstrs) + with Not_found -> + (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs) | Tconstr (p1, _, _), _ when generic_private_abbrev env p1 -> subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs | Tconstr (p1, [], _), Tconstr (p2, [], _) @@ -3664,7 +3678,8 @@ let rec subtype_rec env trace t1 t2 cstrs = !univar_pairs, Some (Primitive_coercion_target_variant_not_unboxed - {variant_name = p; primitive = path}) ) + {variant_name = p; primitive = path}), + type_position ) :: cstrs | Some (p, constructors, true) -> if @@ -3678,11 +3693,17 @@ let rec subtype_rec env trace t1 t2 cstrs = !univar_pairs, Some (Primitive_coercion_target_variant_no_catch_all - {variant_name = p; primitive = path}) ) + {variant_name = p; primitive = path}), + type_position ) :: cstrs | None -> (* Unclear when this case actually happens. *) - (trace, t1, t2, !univar_pairs, Some (Generic {errorCode = "VCPMMVD"})) + ( trace, + t1, + t2, + !univar_pairs, + Some (Generic {errorCode = "VCPMMVD"}), + type_position ) :: cstrs) | Tconstr (_, [], _), Tconstr (path, [], _) when Variant_coercion.can_coerce_primitive path @@ -3708,11 +3729,11 @@ let rec subtype_rec env trace t1 t2 cstrs = !univar_pairs, Some (Variant_constructor_runtime_representation_mismatch - {issues = runtime_representation_issues; variant_name = p}) - ) + {issues = runtime_representation_issues; variant_name = p}), + type_position ) :: cstrs else cstrs - | None -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | None -> (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs) | Tconstr (_, [], _), Tconstr (_, [], _) -> ( (* type coercion for variants and records *) match @@ -3722,7 +3743,7 @@ let rec subtype_rec env trace t1 t2 cstrs = (p2, _, {type_kind = Type_variant c2; type_attributes = t2attrs}) ) -> ( match - Variant_coercion.variant_configuration_can_be_coerced2 t1attrs + Variant_coercion.variant_configuration_can_be_coerced t1attrs t2attrs with | Error issue -> @@ -3732,7 +3753,8 @@ let rec subtype_rec env trace t1 t2 cstrs = !univar_pairs, Some (Variant_configurations_mismatch - {left_variant_name = p1; right_variant_name = p2; issue}) ) + {left_variant_name = p1; right_variant_name = p2; issue}), + type_position ) :: cstrs | Ok () -> let c1_len = List.length c1 in @@ -3760,7 +3782,8 @@ let rec subtype_rec 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 @@ -3822,7 +3845,7 @@ let rec subtype_rec env trace t1 t2 cstrs = | _ -> Some [ (* TODO(subtype-errors) *) ]) in if field_subtype_violations = [] then cstrs - else (trace, t1, t2, !univar_pairs, None) :: cstrs) + else (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs) | ( (p1, _, {type_kind = Type_record (fields1, repr1)}), (p2, _, {type_kind = Type_record (fields2, repr2)}) ) -> (* TODO(subtype-errors) Record representation *) @@ -3850,10 +3873,24 @@ let rec subtype_rec env trace t1 t2 cstrs = left_record_name = p1; right_record_name = p2; issues = violations; - }) ) + }), + type_position ) :: cstrs - else subtype_list env trace tl1 tl2 cstrs - else (trace, t1, t2, !univar_pairs, None) :: 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 | (p1, _, {type_kind = tk1}), (p2, _, {type_kind = tk2}) -> ( trace, t1, @@ -3866,19 +3903,22 @@ let rec subtype_rec 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) :: cstrs) + | exception Not_found -> + (trace, t1, t2, !univar_pairs, None, type_position) :: 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) :: cstrs + (trace, t1, t2, !univar_pairs, None, type_position) :: 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) :: cstrs) + with Exit -> + (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs) | Tvariant {row_closed = true; row_fields}, Tconstr (_, [], _) when extract_concrete_typedecl_opt env t2 |> Variant_coercion.type_is_variant -> ( @@ -3892,8 +3932,9 @@ let rec subtype_rec env trace t1 t2 cstrs = ~variant_constructors ~type_attributes with | Ok _ -> cstrs - | Error _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) - | _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | Error _ -> + (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs) + | _ -> (trace, t1, t2, !univar_pairs, None, type_position) :: 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, []) -> @@ -3903,7 +3944,8 @@ 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, None) :: cstrs) + with Unify _ -> + (trace, t1, t2, !univar_pairs, None, type_position) :: cstrs) | Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2) -> ( try let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1 @@ -3914,7 +3956,12 @@ let rec subtype_rec env trace t1 t2 cstrs = let cstrs' = List.map (fun (n2, t2) -> - (trace, List.assoc n2 ntl1, t2, !univar_pairs, None)) + ( trace, + List.assoc n2 ntl1, + t2, + !univar_pairs, + None, + type_position )) ntl2 in if eq_package_path env p1 p2 then cstrs' @ cstrs @@ -3922,7 +3969,7 @@ let rec subtype_rec env trace t1 t2 cstrs = (* 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) @@ -3930,16 +3977,28 @@ let rec subtype_rec env trace t1 t2 cstrs = with Unify _ -> Btype.backtrack snap; raise Not_found - 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; + 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 List.fold_left2 - (fun cstrs t1 t2 -> subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs) + (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) cstrs tl1 tl2 -and subtype_fields env trace ty1 ty2 cstrs = +and subtype_fields ?type_position 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 @@ -3953,7 +4012,8 @@ and subtype_fields env trace ty1 ty2 cstrs = build_fields (repr ty1).level miss1 rest1, rest2, !univar_pairs, - None ) + None, + type_position ) :: cstrs in let cstrs = @@ -3963,7 +4023,8 @@ and subtype_fields env trace ty1 ty2 cstrs = rest1, build_fields (repr ty2).level miss2 (newvar ()), !univar_pairs, - None ) + None, + type_position ) :: cstrs in List.fold_left @@ -4020,14 +4081,15 @@ let subtype env ty1 ty2 = | () -> List.iter (function - | trace0, t1, t2, pairs, ctx -> ( + | trace0, t1, t2, pairs, ctx, type_position -> ( 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 )))) + ctx, + type_position )))) (List.rev cstrs) (*******************) diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 1752e4d0f7..14415a958d 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -18,6 +18,8 @@ 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 { @@ -49,17 +51,26 @@ type subtype_context = issues: Record_coercion.record_field_subtype_violation list; } -exception Unify of (type_expr * type_expr) 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 Tags of label * label exception Subtype of - (type_expr * type_expr) list - * (type_expr * type_expr) list + type_pairs + * type_pairs * subtype_context option + * subtype_type_position option exception Cannot_expand exception Cannot_apply exception Recursive_abbrev -exception Unification_recursive_abbrev of (type_expr * type_expr) list +exception Unification_recursive_abbrev of type_pairs val init_def : int -> unit (* Set the initial variable level *) diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 9dc3ad8d44..c6c9e3ac1f 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -1525,6 +1525,17 @@ let trace fst keep_last txt ppf tr = | _ -> () with exn -> raise exn +let add_context_text type_position left ppf = + match type_position with + | None -> () + | Some type_position -> ( + match type_position with + | RecordField {field_name; left_record_name; right_record_name} -> + fprintf ppf " (the type of field @{%s@} in @{%s@})" field_name + (Path.name (if left then left_record_name else right_record_name)) + | TupleElement {index} -> + if left then fprintf ppf "(tuple element at position %i)" (index + 1)) + let print_variant_runtime_representation_issue ppf variant_name (issue : Variant_coercion.variant_runtime_representation_issue) = match issue with @@ -1577,7 +1588,7 @@ let print_variant_runtime_representation_issue ppf variant_name (Path.name variant_name) (Path.name expected_typename) -let print_variant_configuration_issue ppf +let print_variant_configuration_issue ?type_position ppf (issue : Variant_coercion.variant_configuration_issue) ~left_variant_name ~right_variant_name = match issue with @@ -1623,11 +1634,14 @@ let print_variant_configuration_issue ppf total_constructor_count - List.length constructor_names_to_print in fprintf ppf - "@ @{%s@} has %i constructor%s that @{%s@} does not have: " + "@ Variant @{%s@}%t has @{%i@} constructor%s that variant \ + @{%s@}%t does not have: " (Path.name left_variant_name) + (add_context_text type_position true) total_constructor_count (if total_constructor_count = 1 then "" else "s") - (Path.name right_variant_name); + (Path.name right_variant_name) + (add_context_text type_position false); constructor_names_to_print |> List.iteri (fun index name -> @@ -1687,22 +1701,42 @@ let print_record_field_subtype_violation ppf (Path.name right_record_name) (Path.name left_record_name) -let report_subtyping_error ppf env tr1 txt1 tr2 ctx = +let report_subtyping_error ppf env tr1 txt1 tr2 ctx + (type_position : subtype_type_position option) = wrap_printing_env env (fun () -> reset (); let tr1 = List.map prepare_expansion tr1 and tr2 = List.map prepare_expansion tr2 in - fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1; - (if tr2 = [] then fprintf ppf "@]" + (fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1; + if tr2 = [] then fprintf ppf "@]" else let mis = mismatch tr2 in fprintf ppf "%a%t@]" (trace false (mis = None) "is not compatible with type") tr2 (explanation true mis)); + (match type_position with + | None -> () + | Some type_position -> + fprintf ppf "@,@[ @ "; + (match type_position with + | RecordField {field_name; left_record_name; right_record_name} -> + fprintf ppf + "Field @{%s@} is not compatible between @{%s@} and \ + @{%s@}:" + field_name + (Path.name left_record_name) + (Path.name right_record_name) + | TupleElement {index} -> + fprintf ppf "In the tuple element at position @{%i@}." + (index + 1)); + fprintf ppf "@]"); + match ctx with - | Some ctx -> ( - fprintf ppf "@,@,@["; - match ctx with + | Some ctx -> + (match type_position with + | None -> fprintf ppf "@,@[" + | Some _ -> fprintf ppf "@,@["); + (match ctx with | Generic {errorCode} -> fprintf ppf "Error: %s" errorCode | Primitive_coercion_target_variant_not_unboxed {variant_name; primitive} -> @@ -1732,8 +1766,8 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx = issues | Variant_configurations_mismatch {left_variant_name; right_variant_name; issue} -> - print_variant_configuration_issue ppf issue ~left_variant_name - ~right_variant_name + print_variant_configuration_issue ?type_position ppf issue + ~left_variant_name ~right_variant_name | Different_type_kinds {left_typename; right_typename; left_type_kind; right_type_kind} -> let type_kind_to_string = function @@ -1761,7 +1795,8 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx = fprintf ppf "@ - "; print_record_field_subtype_violation ppf issue ~left_record_name ~right_record_name) - issues) + issues); + fprintf ppf "@]" | None -> ()) let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = diff --git a/compiler/ml/printtyp.mli b/compiler/ml/printtyp.mli index bef44c2684..98d7b99022 100644 --- a/compiler/ml/printtyp.mli +++ b/compiler/ml/printtyp.mli @@ -94,10 +94,11 @@ val super_report_unification_error : val report_subtyping_error : formatter -> Env.t -> - (type_expr * type_expr) list -> + Ctype.type_pairs -> string -> - (type_expr * type_expr) list -> + Ctype.type_pairs -> Ctype.subtype_context option -> + Ctype.subtype_type_position option -> unit val report_ambiguous_type_error : formatter -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 756c67ab23..8428e1ee77 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -51,9 +51,10 @@ type error = | Private_type of type_expr | Private_label of Longident.t * type_expr | Not_subtype of - (type_expr * type_expr) list - * (type_expr * type_expr) list + Ctype.type_pairs + * Ctype.type_pairs * Ctype.subtype_context option + * Ctype.subtype_type_position option | Too_many_arguments of bool * type_expr | Abstract_wrong_label of Noloc.arg_label * type_expr | Scoping_let_module of string * type_expr @@ -605,8 +606,8 @@ let extract_type_from_pat_variant_spread env lid expected_ty = raise (Error (lid.loc, env, Type_params_not_supported lid.txt)); let ty = newgenty (Tconstr (path, [], ref Mnil)) in (try Ctype.subtype env ty expected_ty () - with Ctype.Subtype (tr1, tr2, ctx) -> - raise (Error (lid.loc, env, Not_subtype (tr1, tr2, ctx)))); + with Ctype.Subtype (tr1, tr2, ctx, type_position) -> + raise (Error (lid.loc, env, Not_subtype (tr1, tr2, ctx, type_position)))); (path, decl, constructors, ty) | _ -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt)) @@ -2953,9 +2954,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let force' = subtype env arg.exp_type ty' in force (); force' () - with Subtype (tr1, tr2, ctx) -> + with Subtype (tr1, tr2, ctx, type_position) -> (* prerr_endline "coercion failed"; *) - raise (Error (loc, env, Not_subtype (tr1, tr2, ctx)))); + raise (Error (loc, env, Not_subtype (tr1, tr2, ctx, type_position)))); (arg, ty', cty') in rue @@ -4356,8 +4357,9 @@ let report_error env ppf error = match valid_methods with | None -> () | Some valid_methods -> spellcheck ppf me valid_methods) - | Not_subtype (tr1, tr2, ctx) -> + | Not_subtype (tr1, tr2, ctx, type_position) -> report_subtyping_error ppf env tr1 "is not a subtype of" tr2 ctx + type_position | Too_many_arguments (in_function, ty) -> if (* modified *) diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index 231a1c2f66..3e23f3f6f5 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -76,9 +76,10 @@ type error = | Private_type of type_expr | Private_label of Longident.t * type_expr | Not_subtype of - (type_expr * type_expr) list - * (type_expr * type_expr) list + Ctype.type_pairs + * Ctype.type_pairs * Ctype.subtype_context option + * Ctype.subtype_type_position option | Too_many_arguments of bool * type_expr | Abstract_wrong_label of Noloc.arg_label * type_expr | Scoping_let_module of string * type_expr diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index 69c67bbaf5..45db5f62e1 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -178,7 +178,7 @@ type variant_configuration_issue = | Tag_name_not_matching of {left_tag: string option; right_tag: string option} | Incompatible_constructor_count of {constructor_names: string list} -let variant_configuration_can_be_coerced2 (a1 : Parsetree.attributes) +let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) (a2 : Parsetree.attributes) = let unboxed = match @@ -205,29 +205,6 @@ let variant_configuration_can_be_coerced2 (a1 : Parsetree.attributes) | Ok (), Ok () -> Ok () | Error e, _ | _, Error e -> Error e -let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) - (a2 : Parsetree.attributes) = - let unboxed = - match - ( Ast_untagged_variants.process_untagged a1, - Ast_untagged_variants.process_untagged a2 ) - with - | true, true | false, false -> true - | _ -> false - in - if not unboxed then false - else - let tag = - match - ( Ast_untagged_variants.process_tag_name a1, - Ast_untagged_variants.process_tag_name a2 ) - with - | Some tag1, Some tag2 when tag1 = tag2 -> true - | None, None -> true - | _ -> false - in - if not tag then false else true - let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc ~right_loc ~(left_attributes : Parsetree.attributes) ~(right_attributes : Parsetree.attributes) = diff --git a/tests/build_tests/super_errors/expected/tuple_coercion_element_mismatch.res.expected b/tests/build_tests/super_errors/expected/tuple_coercion_element_mismatch.res.expected new file mode 100644 index 0000000000..d679e23fc6 --- /dev/null +++ b/tests/build_tests/super_errors/expected/tuple_coercion_element_mismatch.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/tuple_coercion_element_mismatch.res:7:10-28 + + 5 │ let y = (1, 2, 3) + 6 │ + 7 │ let z = (x :> tupleOfStrings) + 8 │ + + Type (int, int) is not a subtype of tupleOfStrings = (string, string) + Type int is not a subtype of string + +In the tuple element at position 1. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/variant_to_variant_different_constructor_counts.res.expected b/tests/build_tests/super_errors/expected/variant_to_variant_different_constructor_counts.res.expected index 54c6c8b80e..a996089c51 100644 --- a/tests/build_tests/super_errors/expected/variant_to_variant_different_constructor_counts.res.expected +++ b/tests/build_tests/super_errors/expected/variant_to_variant_different_constructor_counts.res.expected @@ -9,5 +9,5 @@ Type x is not a subtype of y - x has 4 constructors that y does not have: Two, Three, Four (+1 more) + Variant x has 4 constructors that variant y does not have: Two, Three, Four (+1 more) Therefore, it is not possible for y to represent x. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/tuple_coercion_element_mismatch.res b/tests/build_tests/super_errors/fixtures/tuple_coercion_element_mismatch.res new file mode 100644 index 0000000000..9bb570e88b --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/tuple_coercion_element_mismatch.res @@ -0,0 +1,7 @@ +type tupleOfInts = (int, int) +type tupleOfStrings = (string, string) + +let x = (1, 2) +let y = (1, 2, 3) + +let z = (x :> tupleOfStrings)