diff --git a/jscomp/super_errors/super_typecore.ml b/jscomp/super_errors/super_typecore.ml index ff0a9cafa5..6b0c0f8fea 100644 --- a/jscomp/super_errors/super_typecore.ml +++ b/jscomp/super_errors/super_typecore.ml @@ -67,6 +67,37 @@ let rec collect_missing_arguments rettype targettype = match rettype with end | _ -> None +let check_bs_arity_mismatch ppf trace = + let arity t = match t.desc with + | Tvariant { row_fields = [(label,_)] } -> + let label_len = String.length label in + let arity_str = "Arity_" in + let arity_len = String.length arity_str in + if arity_len < label_len && + String.sub label 0 arity_len = arity_str + then + try + Some (int_of_string (String.sub label arity_len (label_len-arity_len))) + with _ -> None + else None + | _ -> + None in + let check_mismatch t1 t2 = match (arity t1, arity t2) with + | Some n1, Some n2 -> + fprintf ppf "@[@{Found uncurried application [@bs] with arity %d, where arity %d was expected.@}@]" n1 n2; + true + | None, _ + | _, None -> + false in + let rec traverse = function + | (_arity1, type1) :: (_arity2, type2) :: rest -> + if traverse rest + then true + else check_mismatch type1 type2 + | _ -> + false in + ignore (traverse trace) + (* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/typecore.ml#L3769 *) (* modified branches are commented *) let report_error env ppf = function @@ -129,6 +160,7 @@ let report_error env ppf = function else fprintf ppf "~%s: %a" label type_expr argtype )) arguments | None -> + check_bs_arity_mismatch ppf trace; super_report_unification_error ppf env trace (function ppf -> fprintf ppf "This has type:") diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index 6e4eb86292..df128b6e57 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -117446,6 +117446,37 @@ let rec collect_missing_arguments rettype targettype = match rettype with end | _ -> None +let check_bs_arity_mismatch ppf trace = + let arity t = match t.desc with + | Tvariant { row_fields = [(label,_)] } -> + let label_len = String.length label in + let arity_str = "Arity_" in + let arity_len = String.length arity_str in + if arity_len < label_len && + String.sub label 0 arity_len = arity_str + then + try + Some (int_of_string (String.sub label arity_len (label_len-arity_len))) + with _ -> None + else None + | _ -> + None in + let check_mismatch t1 t2 = match (arity t1, arity t2) with + | Some n1, Some n2 -> + fprintf ppf "@[@{Found uncurried application [@bs] with arity %d, where arity %d was expected.@}@]" n1 n2; + true + | None, _ + | _, None -> + false in + let rec traverse = function + | (_arity1, type1) :: (_arity2, type2) :: rest -> + if traverse rest + then true + else check_mismatch type1 type2 + | _ -> + false in + ignore (traverse trace) + (* taken from https://github.com/BuckleScript/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/typecore.ml#L3769 *) (* modified branches are commented *) let report_error env ppf = function @@ -117508,6 +117539,7 @@ let report_error env ppf = function else fprintf ppf "~%s: %a" label type_expr argtype )) arguments | None -> + check_bs_arity_mismatch ppf trace; super_report_unification_error ppf env trace (function ppf -> fprintf ppf "This has type:")