Improve error messages for pattern matching mismatches for options/co…

…ncrete values (#7035)

* improve error messages for pattern matching mismatches for options/concrete values

* changelog

CHANGELOG.md

@@ -22,6 +22,7 @@
 
 #### :nail_care: Polish
 
+- Improve error messages for pattern matching on option vs non-option, and vice versa. https://github.com/rescript-lang/rescript-compiler/pull/7035
 - Improve bigint literal comparison. https://github.com/rescript-lang/rescript-compiler/pull/7029
 - Improve output of `@variadic` bindings. https://github.com/rescript-lang/rescript-compiler/pull/7030
 

jscomp/build_tests/super_errors/expected/pattern_matching_on_option_but_value_not_option.res.expected

@@ -0,0 +1,15 @@
+
+  We've found a bug for you!
+  /.../fixtures/pattern_matching_on_option_but_value_not_option.res:4:3-9
+
+  2 │ 
+  3 │ switch x {
+  4 │ | Some(1) => ()
+  5 │ }
+  6 │ 
+
+  This pattern matches values of type option<'a>
+  but a pattern was expected which matches values of type int
+
+  You're expecting the value you're pattern matching on to be an option, but the value is actually not an option.
+  Change your pattern match to work on the concrete value (remove Some(_) or None from the pattern) to make it work.

jscomp/build_tests/super_errors/expected/pattern_matching_on_value_but_is_option.res.expected

@@ -0,0 +1,15 @@
+
+  We've found a bug for you!
+  /.../fixtures/pattern_matching_on_value_but_is_option.res:4:3
+
+  2 │ 
+  3 │ switch x {
+  4 │ | 1 => ()
+  5 │ }
+  6 │ 
+
+  This pattern matches values of type int
+  but a pattern was expected which matches values of type option<int>
+
+  The value you're pattern matching on here is wrapped in an option, but you're trying to match on the actual value.
+  Wrap the highlighted pattern in Some() to make it work.

jscomp/build_tests/super_errors/fixtures/pattern_matching_on_option_but_value_not_option.res

@@ -0,0 +1,5 @@
+let x = 1
+
+switch x {
+| Some(1) => ()
+}

jscomp/build_tests/super_errors/fixtures/pattern_matching_on_value_but_is_option.res

@@ -0,0 +1,5 @@
+let x = Some(1)
+
+switch x {
+| 1 => ()
+}

jscomp/ml/error_message_utils.ml

@@ -213,3 +213,27 @@ let type_clash_context_in_statement sexp =
   match sexp.Parsetree.pexp_desc with
   | Pexp_apply _ -> Some (Statement FunctionCall)
   | _ -> None
+
+let print_contextual_unification_error ppf t1 t2 =
+  (* TODO: Maybe we should do the same for Null.t and Nullable.t as we do for options 
+    below, now that they also are more first class for values that might not exist? *)
+
+  match (t1.Types.desc, t2.Types.desc) with
+  | Tconstr (p1, _, _), Tconstr (p2, _, _)
+    when Path.same p1 Predef.path_option
+          && Path.same p2 Predef.path_option <> true ->
+    fprintf ppf
+      "@,@\n\
+        @[<v 0>You're expecting the value you're pattern matching on to be an \
+        @{<info>option@}, but the value is actually not an option.@ Change your \
+        pattern match to work on the concrete value (remove @{<error>Some(_)@} \
+        or @{<error>None@} from the pattern) to make it work.@]"
+  | Tconstr (p1, _, _), Tconstr (p2, _, _)
+    when Path.same p2 Predef.path_option
+          && Path.same p1 Predef.path_option <> true ->
+    fprintf ppf
+      "@,@\n\
+        @[<v 0>The value you're pattern matching on here is wrapped in an \
+        @{<info>option@}, but you're trying to match on the actual value.@ Wrap \
+        the highlighted pattern in @{<info>Some()@} to make it work.@]"
+  | _ -> ()

jscomp/ml/printtyp.ml

@@ -1471,7 +1471,7 @@ let super_trace ppf =
     | _ -> ()
   in super_trace true ppf
 
-let super_unification_error unif tr txt1 ppf txt2 = begin
+let super_unification_error ?print_extra_info unif tr txt1 ppf txt2 = begin
   reset ();
   trace_same_names tr;
   let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
@@ -1490,18 +1490,20 @@ let super_unification_error unif tr txt1 ppf txt2 = begin
           @[<hov 2>%t@ %a@]\
           %a\
           %t\
+          %t\
         @]"
         txt1 (super_type_expansion ~tag:"error" t1) t1'
         txt2 (super_type_expansion ~tag:"info" t2) t2'
         super_trace tr
-        (explanation unif mis);
+        (explanation unif mis)
+        (fun ppf -> match print_extra_info with | None -> () | Some f -> f ppf t1 t2);
     with exn ->
       raise exn
 end
 
-let super_report_unification_error ppf env ?(unif=true)
+let super_report_unification_error ?print_extra_info ppf env ?(unif=true)
     tr txt1 txt2 =
-  wrap_printing_env env (fun () -> super_unification_error unif tr txt1 ppf txt2)
+  wrap_printing_env env (fun () -> super_unification_error ?print_extra_info unif tr txt1 ppf txt2)
 ;;
 
 

jscomp/ml/printtyp.mli

@@ -75,6 +75,7 @@ val report_unification_error:
 
 
 val super_report_unification_error:
+    ?print_extra_info:(formatter -> type_expr -> type_expr -> unit) ->
     formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list ->
     (formatter -> unit) -> (formatter -> unit) ->
     unit

jscomp/ml/typecore.ml

@@ -3771,6 +3771,7 @@ let report_error env ppf = function
   | Pattern_type_clash trace ->
     (* modified *)
     super_report_unification_error ppf env trace
+      ~print_extra_info:Error_message_utils.print_contextual_unification_error
       (function ppf ->
          fprintf ppf "This pattern matches values of type")
       (function ppf ->