improve array <-> tuple error message by looking at what the user actually wrote

Author: zth

compiler/bsc/rescript_compiler_main.ml

@@ -12,6 +12,26 @@
 
 let absname = ref false
 
+external to_comment : Res_comment.t -> Error_message_utils.comment = "%identity"
+external from_comment : Error_message_utils.comment -> Res_comment.t
+  = "%identity"
+
+let () =
+  Error_message_utils.parse_source :=
+    fun source ->
+      let res =
+        Res_driver.parse_implementation_from_source ~for_printer:false
+          ~display_filename:"<none>" ~source
+      in
+      (res.parsetree, res.comments |> List.map to_comment)
+
+let () =
+  Error_message_utils.reprint_source :=
+    fun parsetree comments ->
+      Res_printer.print_implementation parsetree
+        ~comments:(comments |> List.map from_comment)
+        ~width:80
+
 let set_abs_input_name sourcefile =
   let sourcefile =
     if !absname && Filename.is_relative sourcefile then

compiler/ml/error_message_utils.ml

@@ -1,6 +1,12 @@
 type extract_concrete_typedecl =
   Env.t -> Types.type_expr -> Path.t * Path.t * Types.type_declaration
 
+type comment
+let parse_source : (string -> Parsetree.structure * comment list) ref =
+  ref (fun _ -> ([], []))
+let reprint_source : (Parsetree.structure -> comment list -> string) ref =
+  ref (fun _ _ -> "")
+
 type type_clash_statement = FunctionCall
 type type_clash_context =
   | SetRecordField
@@ -62,7 +68,14 @@ let is_record_type ~extract_concrete_typedecl ~env ty =
     | _ -> false
   with _ -> false
 
-let print_extra_type_clash_help ~extract_concrete_typedecl ~env ppf
+let extract_location_string ~src (loc : Location.t) =
+  let start_pos = loc.loc_start in
+  let end_pos = loc.loc_end in
+  let start_offset = start_pos.pos_cnum in
+  let end_offset = end_pos.pos_cnum in
+  String.sub src start_offset (end_offset - start_offset)
+
+let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
     (bottom_aliases : (Types.type_expr * Types.type_expr) option)
     type_clash_context =
   match (type_clash_context, bottom_aliases) with
@@ -185,6 +198,39 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env ppf
   | _, Some ({Types.desc = Tconstr (p1, _, _)}, _)
     when Path.same p1 Predef.path_promise ->
     fprintf ppf "\n\n  - Did you mean to await this promise before using it?\n"
+  | _, Some ({Types.desc = Tconstr (p1, _, _)}, {Types.desc = Ttuple _})
+    when Path.same p1 Predef.path_array ->
+    let src = Ext_io.load_file loc.Location.loc_start.pos_fname in
+    let sub_src = extract_location_string ~src loc in
+    let parsed, comments = !parse_source sub_src in
+    let suggested_rewrite =
+      match parsed with
+      | [
+       ({
+          Parsetree.pstr_desc =
+            Pstr_eval (({pexp_desc = Pexp_array items} as exp), l);
+        } as str_item);
+      ] ->
+        Some
+          (!reprint_source
+             [
+               {
+                 str_item with
+                 pstr_desc =
+                   Pstr_eval ({exp with pexp_desc = Pexp_tuple items}, l);
+               };
+             ]
+             comments)
+      | _ -> None
+    in
+    fprintf ppf
+      "\n\n  - Fix this by passing a tuple instead of an array%s@{<info>%s@}\n"
+      (match suggested_rewrite with
+      | Some _ -> ", like: "
+      | None -> "")
+      (match suggested_rewrite with
+      | Some rewrite -> rewrite
+      | None -> "")
   | _ -> ()
 
 let type_clash_context_from_function sexp sfunct =

compiler/ml/typecore.ml

@@ -728,7 +728,7 @@ let rec collect_missing_arguments env type1 type2 =
     | None -> None)
   | _ -> None
 
-let print_expr_type_clash ?type_clash_context env trace ppf =
+let print_expr_type_clash ?type_clash_context env loc trace ppf =
   (* this is the most frequent error. We should do whatever we can to provide
       specific guidance to this generic error before giving up *)
   let bottom_aliases_result = bottom_aliases trace in
@@ -785,7 +785,7 @@ let print_expr_type_clash ?type_clash_context env trace ppf =
       (function
         | ppf -> error_type_text ppf type_clash_context)
       (function ppf -> error_expected_type_text ppf type_clash_context);
-    print_extra_type_clash_help ~extract_concrete_typedecl ~env ppf
+    print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
       bottom_aliases_result type_clash_context;
     show_extra_help ppf env trace
 
@@ -4173,7 +4173,7 @@ let type_expr ppf typ =
   Printtyp.reset_and_mark_loops typ;
   Printtyp.type_expr ppf typ
 
-let report_error env ppf error =
+let report_error env loc ppf error =
   match error with
   | Polymorphic_label lid ->
     fprintf ppf "@[The record field %a is polymorphic.@ %s@]" longident lid
@@ -4237,7 +4237,7 @@ let report_error env ppf error =
   | Expr_type_clash (trace, type_clash_context) ->
     (* modified *)
     fprintf ppf "@[<v>";
-    print_expr_type_clash ?type_clash_context env trace ppf;
+    print_expr_type_clash ?type_clash_context env loc trace ppf;
     fprintf ppf "@]"
   | Apply_non_function typ -> (
     (* modified *)
@@ -4542,13 +4542,13 @@ let report_error env ppf error =
     fprintf ppf
       "Direct field access on a dict is not supported. Use Dict.get instead."
 
-let report_error env ppf err =
-  Printtyp.wrap_printing_env env (fun () -> report_error env ppf err)
+let report_error env loc ppf err =
+  Printtyp.wrap_printing_env env (fun () -> report_error env loc ppf err)
 
 let () =
   Location.register_error_of_exn (function
     | Error (loc, env, err) ->
-      Some (Location.error_of_printer loc (report_error env) err)
+      Some (Location.error_of_printer loc (report_error env loc) err)
     | Error_forward err -> Some err
     | _ -> None)
 

compiler/ml/typecore.mli

@@ -108,7 +108,7 @@ type error =
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 
-val report_error : Env.t -> formatter -> error -> unit
+val report_error : Env.t -> Location.t -> formatter -> error -> unit
 (* Deprecated.  Use Location.{error_of_exn, report_error}. *)
 
 (* Forward declaration, to be filled in by Typemod.type_module *)

tests/build_tests/super_errors/expected/array_literal_passed_to_tuple.res.expected

@@ -0,0 +1,14 @@
+
+  We've found a bug for you!
+  /.../fixtures/array_literal_passed_to_tuple.res:5:17-34
+
+  3 │ }
+  4 │ 
+  5 │ let x = doStuff(["hello", "world"])
+  6 │ 
+
+  This has type: array<'a>
+  But it's expected to have type: (string, string)
+
+  - Fix this by passing a tuple instead of an array, like: ("hello", "world")
+

tests/build_tests/super_errors/expected/array_var_passed_to_tuple.res.expected

@@ -0,0 +1,13 @@
+
+  We've found a bug for you!
+  /.../fixtures/array_var_passed_to_tuple.res:7:17-18
+
+  5 │ let xx = ["hello", "world"]
+  6 │ 
+  7 │ let x = doStuff(xx)
+  8 │ 
+
+  This has type: array<string>
+  But this function argument is expecting: (string, string)
+
+  - Fix this by passing a tuple instead of an array

tests/build_tests/super_errors/fixtures/array_literal_passed_to_tuple.res

@@ -0,0 +1,5 @@
+let doStuff = ((one, two)) => {
+  one ++ two
+}
+
+let x = doStuff(["hello", "world"])

tests/build_tests/super_errors/fixtures/array_var_passed_to_tuple.res

@@ -0,0 +1,7 @@
+let doStuff = ((one, two)) => {
+  one ++ two
+}
+
+let xx = ["hello", "world"]
+
+let x = doStuff(xx)