iron out a few more error messages

Author: zth

compiler/ml/error_message_utils.ml

@@ -69,10 +69,21 @@ let type_expr ppf typ =
   Printtyp.reset_and_mark_loops typ;
   Printtyp.type_expr ppf typ
 
+type jsx_prop_error_info = {
+  fields: Types.label_declaration list;
+  props_record_path: Path.t;
+  jsx_type: [`Fragment | `CustomComponent | `LowercaseComponent];
+}
+
 type type_clash_statement = FunctionCall
 type type_clash_context =
   | SetRecordField of string (* field name *)
-  | RecordField of string (* field name *)
+  | RecordField of {
+      jsx: jsx_prop_error_info option;
+      record_type: Types.type_expr;
+      field_name: string;
+      optional: bool;
+    }
   | ArrayValue
   | MaybeUnwrapOption
   | IfCondition
@@ -88,7 +99,7 @@ type type_clash_context =
       operator: string;
       is_constant: string option;
     }
-  | FunctionArgument
+  | FunctionArgument of {optional: bool}
   | Statement of type_clash_statement
   | ForLoopCondition
 
@@ -106,7 +117,7 @@ let context_to_string = function
   | Some SwitchReturn -> "SwitchReturn"
   | Some TryReturn -> "TryReturn"
   | Some StringConcat -> "StringConcat"
-  | Some FunctionArgument -> "FunctionArgument"
+  | Some (FunctionArgument _) -> "FunctionArgument"
   | Some ComparisonOperator -> "ComparisonOperator"
   | Some IfReturn -> "IfReturn"
   | None -> "None"
@@ -127,8 +138,11 @@ let error_type_text ppf type_clash_context =
 
 let error_expected_type_text ppf type_clash_context =
   match type_clash_context with
-  | Some FunctionArgument ->
-    fprintf ppf "But this function argument is expecting:"
+  | Some (FunctionArgument {optional}) ->
+    fprintf ppf "But this%s function argument is expecting:"
+      (match optional with
+      | false -> ""
+      | true -> " optional")
   | Some ComparisonOperator ->
     fprintf ppf "But it's being compared to something of type:"
   | Some SwitchReturn -> fprintf ppf "But this switch is expected to return:"
@@ -145,7 +159,19 @@ let error_expected_type_text ppf type_clash_context =
   | Some ArrayValue ->
     fprintf ppf "But this array is expected to have items of type:"
   | Some (SetRecordField _) -> fprintf ppf "But this record field is of type:"
-  | Some (RecordField field_name) ->
+  | Some
+      (RecordField {field_name = "children"; jsx = Some {jsx_type = `Fragment}})
+    ->
+    fprintf ppf "But children of JSX fragments is expected to have type:"
+  | Some
+      (RecordField
+         {field_name = "children"; jsx = Some {jsx_type = `CustomComponent}}) ->
+    fprintf ppf
+      "But children passed to this component is expected to have type:"
+  | Some (RecordField {field_name; jsx = Some _}) ->
+    fprintf ppf "But this component prop @{<info>%s@} is expected to have type:"
+      field_name
+  | Some (RecordField {field_name}) ->
     fprintf ppf "But this record field @{<info>%s@} is expected to have type:"
       field_name
   | Some (Statement FunctionCall) -> fprintf ppf "But it's expected to return:"
@@ -395,6 +421,40 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
          single JSX element.@,"
         (with_configured_jsx_module "array")
     | _ -> ())
+  | ( Some (RecordField {optional = true; field_name}),
+      Some ({desc = Tconstr (p, _, _)}, _) )
+    when Path.same Predef.path_option p ->
+    fprintf ppf
+      "@,\
+       @,\
+       @{<info>%s@} is an optional record field, and you're passing an \
+       optional value to it.@,\
+       Optional fields expect you to pass the concrete value, not an option, \
+       when passed directly.\n\
+      \             @,\
+       Possible solutions: @,\
+       - Unwrap the option and pass a concrete value directly@,\
+       - If you really do want to pass the optional value, prepend the value \
+       with @{<info>?@} to show you want to pass the option, like: \
+       @{<info>{%s: ?%s@}}"
+      field_name field_name
+      (Parser.extract_text_at_loc loc)
+  | ( Some (FunctionArgument {optional = true}),
+      Some ({desc = Tconstr (p, _, _)}, _) )
+    when Path.same Predef.path_option p ->
+    fprintf ppf
+      "@,\
+       @,\
+       You're passing an optional value into an optional function argument.@,\
+       Optional function arguments expect you to pass the concrete value, not \
+       an option, when passed directly.\n\
+      \             @,\
+       Possible solutions: @,\
+       - Unwrap the option and pass a concrete value directly@,\
+       - If you really do want to pass the optional value, prepend the value \
+       with @{<info>?@} to show you want to pass the option, like: \
+       @{<info>?%s@}"
+      (Parser.extract_text_at_loc loc)
   | _, Some (t1, t2) ->
     let is_subtype =
       try
@@ -450,7 +510,7 @@ let type_clash_context_from_function sexp sfunct =
     Some (MathOperator {for_float = true; operator; is_constant})
   | Pexp_ident {txt = Lident (("/" | "*" | "+" | "-") as operator)} ->
     Some (MathOperator {for_float = false; operator; is_constant})
-  | _ -> Some FunctionArgument
+  | _ -> Some (FunctionArgument {optional = false})
 
 let type_clash_context_for_function_argument type_clash_context sarg0 =
   match type_clash_context with
@@ -508,11 +568,6 @@ let print_contextual_unification_error ppf t1 t2 =
        the highlighted pattern in @{<info>Some()@} to make it work.@]"
   | _ -> ()
 
-type jsx_prop_error_info = {
-  fields: Types.label_declaration list;
-  props_record_path: Path.t;
-}
-
 let attributes_include_jsx_component_props (attrs : Parsetree.attributes) =
   attrs
   |> List.exists (fun ({Location.txt}, _) -> txt = "res.jsxComponentProps")
@@ -524,18 +579,24 @@ let path_to_jsx_component_name p =
 
 let get_jsx_component_props
     ~(extract_concrete_typedecl : extract_concrete_typedecl) env ty p =
-  match Path.last p with
-  | "props" -> (
-    try
-      match extract_concrete_typedecl env ty with
-      | ( _p0,
-          _p,
-          {Types.type_kind = Type_record (fields, _repr); type_attributes} )
-        when attributes_include_jsx_component_props type_attributes ->
-        Some {props_record_path = p; fields}
-      | _ -> None
-    with _ -> None)
-  | _ -> None
+  match p with
+  | Path.Pdot (Path.Pident {Ident.name = jsx_module_name}, "fragmentProps", _)
+    when Some jsx_module_name = !configured_jsx_module ->
+    Some {props_record_path = p; fields = []; jsx_type = `Fragment}
+  | _ -> (
+    (* TODO: handle lowercase components using JSXDOM.domProps *)
+    match Path.last p with
+    | "props" -> (
+      try
+        match extract_concrete_typedecl env ty with
+        | ( _p0,
+            _p,
+            {Types.type_kind = Type_record (fields, _repr); type_attributes} )
+          when attributes_include_jsx_component_props type_attributes ->
+          Some {props_record_path = p; fields; jsx_type = `CustomComponent}
+        | _ -> None
+      with _ -> None)
+    | _ -> None)
 
 let print_component_name ppf (p : Path.t) =
   match path_to_jsx_component_name p with

compiler/ml/typecore.ml

@@ -2500,7 +2500,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
         exp_env = env;
       }
   | Pexp_construct (lid, sarg) ->
-    type_construct env loc lid sarg ty_expected sexp.pexp_attributes
+    type_construct ~context env loc lid sarg ty_expected sexp.pexp_attributes
   | Pexp_variant (l, sarg) -> (
     (* Keep sharing *)
     let ty_expected0 = instance env ty_expected in
@@ -2567,13 +2567,15 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
         get_jsx_component_props ~extract_concrete_typedecl env ty_record p
       | None -> None
     in
+    (* React.fragmentProps, JSXDOM.domProps *)
+    let jsx_component_error_info = get_jsx_component_error_info () in
     let lbl_exp_list =
       wrap_disambiguate "This record expression is expected to have" ty_record
         (type_label_a_list loc true env
            (fun e k ->
              k
-               (type_label_exp ~call_context:`Regular true env loc ty_record
-                  (process_optional_label e)))
+               (type_label_exp ~call_context:(`Regular jsx_component_error_info)
+                  true env loc ty_record (process_optional_label e)))
            opath lid_sexp_list)
         (fun x -> x)
     in
@@ -2598,7 +2600,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
                  Labels_missing
                    {
                      labels = labels_missing;
-                     jsx_component_info = get_jsx_component_error_info ();
+                     jsx_component_info = jsx_component_error_info;
                    } ));
         ([||], representation)
       | [], _ ->
@@ -2631,7 +2633,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
              Labels_missing
                {
                  labels = List.rev !labels_missing;
-                 jsx_component_info = get_jsx_component_error_info ();
+                 jsx_component_info = jsx_component_error_info;
                } ));
     let fields =
       Array.map2
@@ -2677,13 +2679,14 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
         ty_record
     in
     let closed = false in
+    let jsx_component_error_info = get_jsx_component_error_info () in
     let lbl_exp_list =
       wrap_disambiguate "This record expression is expected to have" ty_record
         (type_label_a_list loc closed env
            (fun e k ->
              k
-               (type_label_exp ~call_context:`Regular true env loc ty_record
-                  (process_optional_label e)))
+               (type_label_exp ~call_context:(`Regular jsx_component_error_info)
+                  true env loc ty_record (process_optional_label e)))
            opath lid_sexp_list)
         (fun x -> x)
     in
@@ -3293,8 +3296,8 @@ and type_label_access env srecord lid =
 (* Typing format strings for printing or reading.
    These formats are used by functions in modules Printf, Format, and Scanf.
    (Handling of * modifiers contributed by Thorsten Ohl.) *)
-and type_label_exp ~(call_context : [`SetRecordField | `Regular]) create env loc
-    ty_expected (lid, label, sarg, opt) =
+and type_label_exp ~call_context create env loc ty_expected
+    (lid, label, sarg, opt) =
   (* Here also ty_expected may be at generic_level *)
   begin_def ();
   let separate = Env.has_local_constraints env in
@@ -3325,7 +3328,10 @@ and type_label_exp ~(call_context : [`SetRecordField | `Regular]) create env loc
     let field_context =
       match call_context with
       | `SetRecordField -> Some (Error_message_utils.SetRecordField field_name)
-      | `Regular -> Some (Error_message_utils.RecordField field_name)
+      | `Regular jsx ->
+        Some
+          (Error_message_utils.RecordField
+             {jsx; record_type = ty_expected; field_name; optional = false})
     in
     let arg =
       type_argument ~context:field_context env sarg ty_arg (instance env ty_arg)
@@ -3689,7 +3695,7 @@ and type_application ~context total_app env funct (sargs : sargs) :
     in
     (targs, ret_t, fully_applied)
 
-and type_construct env loc lid sarg ty_expected attrs =
+and type_construct ~context env loc lid sarg ty_expected attrs =
   let opath =
     try
       let p0, p, _ = extract_concrete_variant env ty_expected in
@@ -3736,7 +3742,21 @@ and type_construct env loc lid sarg ty_expected attrs =
         exp_env = env;
       }
   in
-  let context = type_clash_context_maybe_option ty_expected ty_res in
+  (* Forward context if this is a Some constructor injected (meaning it's 
+    an optional field or an optional argument) *)
+  let context =
+    match lid.txt with
+    | Longident.Ldot (Lident "*predef*", "Some") -> (
+      match context with
+      | Some (RecordField {record_type; jsx; field_name}) ->
+        Some
+          (Error_message_utils.RecordField
+             {record_type; jsx; field_name; optional = true})
+      | Some (FunctionArgument _) ->
+        Some (Error_message_utils.FunctionArgument {optional = true})
+      | _ -> None)
+    | _ -> None
+  in
   if separate then (
     end_def ();
     generalize_structure ty_res;

tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected

@@ -0,0 +1,14 @@
+
+  We've found a bug for you!
+  /.../fixtures/jsx_custom_component_children.res:24:28-29
+
+  22 │ }
+  23 │ 
+  24 │ let x = <CustomComponent> {1.} </CustomComponent>
+  25 │ 
+
+  This has type: float
+  But children passed to this component is expected to have type:
+    React.element (defined as Jsx.element)
+  
+  In JSX, all content must be JSX elements. You can convert float to a JSX element with React.float.

tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected

@@ -0,0 +1,13 @@
+
+  We've found a bug for you!
+  /.../fixtures/jsx_custom_component_optional.res:31:34-40
+
+  29 │ }
+  30 │ 
+  31 │ let x = <CustomComponent someOpt="hello" />
+  32 │ 
+
+  This has type: string
+  But this component prop someOpt is expected to have type: float
+  
+  You can convert string to float with Float.fromString.

tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected

@@ -8,6 +8,7 @@
   18 │ 
 
   This has type: float
-  But it's expected to have type: React.element (defined as Jsx.element)
+  But children of JSX fragments is expected to have type:
+    React.element (defined as Jsx.element)
 
   In JSX, all content must be JSX elements. You can convert float to a JSX element with React.float.

tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected

@@ -8,6 +8,7 @@
   18 │ 
 
   This has type: int
-  But it's expected to have type: React.element (defined as Jsx.element)
+  But children of JSX fragments is expected to have type:
+    React.element (defined as Jsx.element)
 
   In JSX, all content must be JSX elements. You can convert int to a JSX element with React.int.

tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected

@@ -8,6 +8,7 @@
   18 │ 
 
   This has type: string
-  But it's expected to have type: React.element (defined as Jsx.element)
+  But children of JSX fragments is expected to have type:
+    React.element (defined as Jsx.element)
 
   In JSX, all content must be JSX elements. You can convert string to a JSX element with React.string.

tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected

@@ -0,0 +1,17 @@
+
+  We've found a bug for you!
+  /.../fixtures/optional_record_field_pass_option.res:6:16
+
+  4 │ let t = Some(true)
+  5 │ 
+  6 │ let x = {test: t}
+
+  This has type: option<bool>
+  But this record field test is expected to have type: bool
+  
+  test is an optional record field, and you're passing an optional value to it.
+  Optional fields expect you to pass the concrete value, not an option, when passed directly.
+             
+  Possible solutions: 
+  - Unwrap the option and pass a concrete value directly
+  - If you really do want to pass the optional value, prepend the value with ? to show you want to pass the option, like: {test: ?t}

tests/build_tests/super_errors/fixtures/jsx_custom_component_children.res

@@ -0,0 +1,24 @@
+@@config({
+  flags: ["-bs-jsx", "4"],
+})
+
+module React = {
+  type element = Jsx.element
+  type componentLike<'props, 'return> = 'props => 'return
+  type component<'props> = Jsx.component<'props>
+
+  @module("react/jsx-runtime")
+  external jsx: (component<'props>, 'props) => element = "jsx"
+
+  type fragmentProps = {children?: element}
+  @module("react/jsx-runtime") external jsxFragment: component<fragmentProps> = "Fragment"
+}
+
+module CustomComponent = {
+  @react.component
+  let make = (~children) => {
+    <> {children} </>
+  }
+}
+
+let x = <CustomComponent> {1.} </CustomComponent>