From 162e918afdd2428e9837f65e788a4cb68c72f729 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 29 Jan 2018 17:13:10 +0100 Subject: [PATCH 1/2] [SuperErrors] Check arity mismatch for uncurried [@bs] application. The following repro: ``` /lib/bsc.exe -bs-super-errors -bs-eval 'let add = ((fun x -> fun y -> x + y)[@bs ]) let x = ((add 3)[@bs ])' ``` Now gives: ``` Found uncurried application [@bs] with arity 2, where arity 1 was expected. This has type: (int -> int -> int [@bs]) (defined as (int -> int -> int [@bs])) But somewhere wanted: ('a -> 'b [@bs]) (defined as ('a -> 'b [@bs])) These two variant types have no intersection ``` --- jscomp/super_errors/super_typecore.ml | 30 +++++++++++++++++++++++++++ lib/whole_compiler.ml | 30 +++++++++++++++++++++++++++ 2 files changed, 60 insertions(+) diff --git a/jscomp/super_errors/super_typecore.ml b/jscomp/super_errors/super_typecore.ml index ff0a9cafa5..5a3d9faa30 100644 --- a/jscomp/super_errors/super_typecore.ml +++ b/jscomp/super_errors/super_typecore.ml @@ -67,6 +67,35 @@ 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 len = String.length label in + if len > 6 && + String.sub label 0 6 = "Arity_" + then + try + Some (int_of_string (String.sub label 6 (len-6))) + 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 +158,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..46d7c831ed 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -117446,6 +117446,35 @@ 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 len = String.length label in + if len > 6 && + String.sub label 0 6 = "Arity_" + then + try + Some (int_of_string (String.sub label 6 (len-6))) + 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 +117537,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:") From 5a97eadc17d4c19eff066cec0a2233578d9e681c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 30 Jan 2018 15:10:59 +0100 Subject: [PATCH 2/2] cleanup --- jscomp/super_errors/super_typecore.ml | 10 ++++++---- lib/whole_compiler.ml | 10 ++++++---- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/jscomp/super_errors/super_typecore.ml b/jscomp/super_errors/super_typecore.ml index 5a3d9faa30..6b0c0f8fea 100644 --- a/jscomp/super_errors/super_typecore.ml +++ b/jscomp/super_errors/super_typecore.ml @@ -70,12 +70,14 @@ let rec collect_missing_arguments rettype targettype = match rettype with let check_bs_arity_mismatch ppf trace = let arity t = match t.desc with | Tvariant { row_fields = [(label,_)] } -> - let len = String.length label in - if len > 6 && - String.sub label 0 6 = "Arity_" + 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 6 (len-6))) + Some (int_of_string (String.sub label arity_len (label_len-arity_len))) with _ -> None else None | _ -> diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index 46d7c831ed..df128b6e57 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -117449,12 +117449,14 @@ let rec collect_missing_arguments rettype targettype = match rettype with let check_bs_arity_mismatch ppf trace = let arity t = match t.desc with | Tvariant { row_fields = [(label,_)] } -> - let len = String.length label in - if len > 6 && - String.sub label 0 6 = "Arity_" + 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 6 (len-6))) + Some (int_of_string (String.sub label arity_len (label_len-arity_len))) with _ -> None else None | _ ->