Hint about coercion in error msg (#7505)

* print type coercion hint when appropriate

* refactor

* changelog

* do not suggest coercion for constant expressions

* tighten wording

Author: zth

CHANGELOG.md

@@ -28,6 +28,7 @@
 - Complete from `RegExp` stdlib module for regexes. https://github.com/rescript-lang/rescript/pull/7425
 - Allow oneliner formatting when including module with single type alias. https://github.com/rescript-lang/rescript/pull/7502
 - Improve error messages for JSX type mismatches, passing objects where record is expected, passing array literal where tuple is expected, and more. https://github.com/rescript-lang/rescript/pull/7500
+- Show in error messages when coercion can be used to fix a type mismatch. https://github.com/rescript-lang/rescript/pull/7505
 
 # 12.0.0-alpha.13
 

compiler/ml/error_message_utils.ml

@@ -11,6 +11,8 @@ let with_configured_jsx_module s =
 module Parser : sig
   type comment
 
+  val extract_text_at_loc : Location.t -> string
+
   val parse_source : (string -> Parsetree.structure * comment list) ref
 
   val reprint_source : (Parsetree.structure -> comment list -> string) ref
@@ -38,10 +40,13 @@ end = struct
     let end_offset = end_pos.pos_cnum in
     String.sub src start_offset (end_offset - start_offset)
 
-  let parse_expr_at_loc loc =
+  let extract_text_at_loc loc =
     (* TODO: Maybe cache later on *)
     let src = Ext_io.load_file loc.Location.loc_start.pos_fname in
-    let sub_src = extract_location_string ~src loc in
+    extract_location_string ~src loc
+
+  let parse_expr_at_loc loc =
+    let sub_src = extract_text_at_loc loc in
     let parsed, comments = !parse_source sub_src in
     match parsed with
     | [{Parsetree.pstr_desc = Pstr_eval (exp, _)}] -> Some (exp, comments)
@@ -59,6 +64,11 @@ end = struct
     | None -> None
 end
 
+let type_expr ppf typ =
+  (* print a type and avoid infinite loops *)
+  Printtyp.reset_and_mark_loops typ;
+  Printtyp.type_expr ppf typ
+
 type type_clash_statement = FunctionCall
 type type_clash_context =
   | SetRecordField
@@ -345,6 +355,43 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
          single JSX element.@,"
         (with_configured_jsx_module "array")
     | _ -> ())
+  | _, Some (t1, t2) ->
+    let is_subtype =
+      try
+        Ctype.subtype env t1 t2 ();
+        true
+      with _ -> false
+    in
+    let target_type_string = Format.asprintf "%a" type_expr t2 in
+    let target_expr_text = Parser.extract_text_at_loc loc in
+    let suggested_rewrite =
+      match
+        !Parser.parse_source
+          (Printf.sprintf "(%s :> %s)" target_expr_text target_type_string)
+      with
+      | [], _ -> None
+      | structure, comments -> Some (!Parser.reprint_source structure comments)
+    in
+
+    (* Suggesting coercion only makes sense for non-constant values. *)
+    let is_constant =
+      match !Parser.parse_source target_expr_text with
+      | ( [{Parsetree.pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant _}, _)}],
+          _ ) ->
+        true
+      | _ -> false
+    in
+
+    if is_subtype && not is_constant then (
+      fprintf ppf
+        "@,\
+         @,\
+         Possible solutions: @,\
+         - These types are compatible at runtime. You can use the coercion \
+         operator to convert to the expected type";
+      match suggested_rewrite with
+      | Some rewrite -> fprintf ppf ": @{<info>%s@}@," rewrite
+      | None -> fprintf ppf ": @{<info>:>@}@,")
   | _ -> ()
 
 let type_clash_context_from_function sexp sfunct =

compiler/ml/typecore.ml

@@ -4168,10 +4168,8 @@ let longident = Printtyp.longident
 let super_report_unification_error = Printtyp.super_report_unification_error
 let report_ambiguous_type_error = Printtyp.report_ambiguous_type_error
 let report_subtyping_error = Printtyp.report_subtyping_error
-let type_expr ppf typ =
-  (* print a type and avoid infinite loops *)
-  Printtyp.reset_and_mark_loops typ;
-  Printtyp.type_expr ppf typ
+
+let type_expr = Error_message_utils.type_expr
 
 let report_error env loc ppf error =
   match error with

tests/build_tests/super_errors/expected/subtype_record.res.expected

@@ -0,0 +1,15 @@
+
+  We've found a bug for you!
+  /.../fixtures/subtype_record.res:23:23
+
+  21 │ }
+  22 │ 
+  23 │ let x = takesSomeType(v)
+  24 │ 
+
+  This has type: someOtherType
+  But this function argument is expecting: SomeModule.someType
+  
+  Possible solutions: 
+  - These types are compatible at runtime. You can use the coercion operator to convert to the expected type: (v :> SomeModule.someType)
+

tests/build_tests/super_errors/expected/subtype_string.res.expected

@@ -0,0 +1,15 @@
+
+  We've found a bug for you!
+  /.../fixtures/subtype_string.res:7:18-20
+
+  5 │ }
+  6 │ 
+  7 │ let x = takesStr(One)
+  8 │ 
+
+  This has type: variant
+  But it's expected to have type: string
+  
+  Possible solutions: 
+  - These types are compatible at runtime. You can use the coercion operator to convert to the expected type: (One :> string)
+

tests/build_tests/super_errors/fixtures/subtype_record.res

@@ -0,0 +1,23 @@
+module SomeModule = {
+  type someType = {
+    one: bool,
+    two: int,
+  }
+}
+
+type someOtherType = {
+  ...SomeModule.someType,
+  three: string,
+}
+
+let v = {
+  one: true,
+  two: 1,
+  three: "hello",
+}
+
+let takesSomeType = (s: SomeModule.someType) => {
+  s.one
+}
+
+let x = takesSomeType(v)

tests/build_tests/super_errors/fixtures/subtype_string.res

@@ -0,0 +1,7 @@
+type variant = One | Two
+
+let takesStr = (s: string) => {
+  s ++ "hello"
+}
+
+let x = takesStr(One)