From e759c61a1a0d0e5a8cde3dd699ef453d9caac4d2 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 13 Mar 2025 13:25:38 +0100 Subject: [PATCH 1/2] Fix issue with typing application and polymorphic types. Fixes https://github.com/rescript-lang/rescript/issues/7323 When typing application there's a special treatment for polymorphic types, where the arity and kinds of arguments are inferred. For example: `f => f(~lbl1, ~lbl2)` assigns a polymorphic type `'a` to `f` initially which is then instantated to `(~lbl1:t1, ~lbl2:t2) => t3`. That same mechanism currently applies when a function is annotated to return a polymorphic type such as `(string, ~wrongLabelName: int=?) => 'a`, where the `'a` is further instantiated to extend the function type with additional arguments. This mechanism is OK for curried function, but incorrect for uncurried functions: while e.g. `'a => 'b` with curried function designates any function where the first argument is unlabeled, with uncurried function it only designates functions of arity 1. So when processing application, `'b` should not be expanded further. Two examples of problematic code that now gives type error: ```res let r: (string, ~wrongLabelName: int=?) => 'a = (_s, ~wrongLabelName=3) => { let _ = wrongLabelName assert(false) } let tst1 = r("", ~initialValue=2) let tst2 = r("")(~initialValue=2) ``` and ```res let f = (_, ~def=3) => assert(false) let g1 = f(1,2) let g2 = f(1)(2) ``` --- compiler/ml/typecore.ml | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index ffbfc0ac42..33d3359572 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3449,6 +3449,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) and type_application ?type_clash_context total_app env funct (sargs : sargs) : targs * Types.type_expr * bool = + (* Printf.eprintf "type_application: #args:%d\n" (List.length sargs); *) let result_type omitted ty_fun = List.fold_left (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok, None))) @@ -3465,6 +3466,7 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : | Tvar _ when total_app -> true | _ -> false in + (* Printf.eprintf "force_tvar:%b\n" force_tvar; *) let has_arity funct = let t = funct.exp_type in if force_tvar then Some (List.length sargs) @@ -3550,11 +3552,15 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : type_unknown_args max_arity ~args ~top_arity:None omitted ty_fun [] | (l1, sarg1) :: sargl -> let l1 = to_noloc l1 in + (* let lbl_name = label_name l1 in + Printf.eprintf " type_unknown_args: lbl_name:%s\n" lbl_name; *) let ty1, ty2 = let ty_fun = expand_head env ty_fun in let arity_ok = List.length args < max_arity in match ty_fun.desc with - | Tvar _ -> + | Tvar _ when (* l1 = Nolabel || *) force_tvar -> + (* This is a total application when the toplevel type is a polymorphic variable, + so the function type including arity can be inferred. *) let t1 = newvar () and t2 = newvar () in if ty_fun.level >= t1.level && not_identity funct.exp_desc then Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; @@ -3605,9 +3611,11 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : when sargs <> [] && commu_repr com = Cok && List.length args < max_arity -> let name = label_name l and optional = is_optional l in + (* Printf.eprintf " type_args: name:%s, optional:%b\n" name optional; *) let sargs, omitted, arg = match extract_label name sargs with | None -> + (* Printf.eprintf " extract_label: None\n"; *) if optional && (total_app || label_assoc Nolabel sargs) then ( ignored := (l, ty, lv) :: !ignored; ( sargs, @@ -3640,8 +3648,14 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : sargs (* This is the hot path for non-labeled function*) in if total_app then force_uncurried_type funct; + (* Printf.eprintf "total_app:%b\n" total_app; *) let max_arity = get_max_arity funct in + (* Printf.eprintf "max_arity:%d\n" max_arity; *) let top_arity = if total_app then Some max_arity else None in + (* Printf.eprintf "top_arity:%s\n" + (match top_arity with + | Some _ -> "Some" + | None -> "None"); *) match sargs with (* Special case for ignore: avoid discarding warning *) | [(Nolabel, sarg)] when is_ignore ~env ~arity:top_arity funct -> From 656c3c275cfbb13fed3c51a4ad3fd86a44934a76 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 14 Mar 2025 08:16:05 +0100 Subject: [PATCH 2/2] Cleanup and type errot tests. --- CHANGELOG.md | 1 + compiler/ml/typecore.ml | 14 +---------- .../expected/fun_return_poly1.res.expected | 23 ++++++++++++++++++ .../expected/fun_return_poly2.res.expected | 24 +++++++++++++++++++ .../fixtures/fun_return_poly1.res | 4 ++++ .../fixtures/fun_return_poly2.res | 7 ++++++ 6 files changed, 60 insertions(+), 13 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/fun_return_poly1.res.expected create mode 100644 tests/build_tests/super_errors/expected/fun_return_poly2.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/fun_return_poly1.res create mode 100644 tests/build_tests/super_errors/fixtures/fun_return_poly2.res diff --git a/CHANGELOG.md b/CHANGELOG.md index a9582b35bd..f248204808 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,6 +38,7 @@ #### :bug: Bug fix - Fix recursive untagged variant type checking by delaying well-formedness checks until environment construction completes. [#7320](https://github.com/rescript-lang/rescript/pull/7320) +- Fix incorrect expansion of polymorphic return types in uncurried function applications. https://github.com/rescript-lang/rescript/pull/7338 # 12.0.0-alpha.9 diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 33d3359572..4d14ddc3f2 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3449,7 +3449,6 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) and type_application ?type_clash_context total_app env funct (sargs : sargs) : targs * Types.type_expr * bool = - (* Printf.eprintf "type_application: #args:%d\n" (List.length sargs); *) let result_type omitted ty_fun = List.fold_left (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok, None))) @@ -3466,7 +3465,6 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : | Tvar _ when total_app -> true | _ -> false in - (* Printf.eprintf "force_tvar:%b\n" force_tvar; *) let has_arity funct = let t = funct.exp_type in if force_tvar then Some (List.length sargs) @@ -3552,13 +3550,11 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : type_unknown_args max_arity ~args ~top_arity:None omitted ty_fun [] | (l1, sarg1) :: sargl -> let l1 = to_noloc l1 in - (* let lbl_name = label_name l1 in - Printf.eprintf " type_unknown_args: lbl_name:%s\n" lbl_name; *) let ty1, ty2 = let ty_fun = expand_head env ty_fun in let arity_ok = List.length args < max_arity in match ty_fun.desc with - | Tvar _ when (* l1 = Nolabel || *) force_tvar -> + | Tvar _ when force_tvar -> (* This is a total application when the toplevel type is a polymorphic variable, so the function type including arity can be inferred. *) let t1 = newvar () and t2 = newvar () in @@ -3611,11 +3607,9 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : when sargs <> [] && commu_repr com = Cok && List.length args < max_arity -> let name = label_name l and optional = is_optional l in - (* Printf.eprintf " type_args: name:%s, optional:%b\n" name optional; *) let sargs, omitted, arg = match extract_label name sargs with | None -> - (* Printf.eprintf " extract_label: None\n"; *) if optional && (total_app || label_assoc Nolabel sargs) then ( ignored := (l, ty, lv) :: !ignored; ( sargs, @@ -3648,14 +3642,8 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : sargs (* This is the hot path for non-labeled function*) in if total_app then force_uncurried_type funct; - (* Printf.eprintf "total_app:%b\n" total_app; *) let max_arity = get_max_arity funct in - (* Printf.eprintf "max_arity:%d\n" max_arity; *) let top_arity = if total_app then Some max_arity else None in - (* Printf.eprintf "top_arity:%s\n" - (match top_arity with - | Some _ -> "Some" - | None -> "None"); *) match sargs with (* Special case for ignore: avoid discarding warning *) | [(Nolabel, sarg)] when is_ignore ~env ~arity:top_arity funct -> diff --git a/tests/build_tests/super_errors/expected/fun_return_poly1.res.expected b/tests/build_tests/super_errors/expected/fun_return_poly1.res.expected new file mode 100644 index 0000000000..e19cffd36e --- /dev/null +++ b/tests/build_tests/super_errors/expected/fun_return_poly1.res.expected @@ -0,0 +1,23 @@ + + Warning number 20 + /.../fixtures/fun_return_poly1.res:3:15 + + 1 │ let f = (_, ~def=3) => assert(false) + 2 │ + 3 │ let ok = f(1)(2) + 4 │ let err = f(1, 2) + 5 │ + + this argument will not be used by the function. + + + We've found a bug for you! + /.../fixtures/fun_return_poly1.res:4:16 + + 2 │ + 3 │ let ok = f(1)(2) + 4 │ let err = f(1, 2) + 5 │ + + The function applied to this argument has type ('a, ~def: int=?) => 'b +This argument cannot be applied without label \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/fun_return_poly2.res.expected b/tests/build_tests/super_errors/expected/fun_return_poly2.res.expected new file mode 100644 index 0000000000..54fcade1ac --- /dev/null +++ b/tests/build_tests/super_errors/expected/fun_return_poly2.res.expected @@ -0,0 +1,24 @@ + + Warning number 20 + /.../fixtures/fun_return_poly2.res:6:30 + + 4 │ } + 5 │ + 6 │ let ok = r("")(~initialValue=2) + 7 │ let err = r("", ~initialValue=2) + 8 │ + + this argument will not be used by the function. + + + We've found a bug for you! + /.../fixtures/fun_return_poly2.res:7:31 + + 5 │ + 6 │ let ok = r("")(~initialValue=2) + 7 │ let err = r("", ~initialValue=2) + 8 │ + + The function applied to this argument has type + (string, ~wrongLabelName: int=?) => 'a +This argument cannot be applied with label ~initialValue \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/fun_return_poly1.res b/tests/build_tests/super_errors/fixtures/fun_return_poly1.res new file mode 100644 index 0000000000..49922cd8e8 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/fun_return_poly1.res @@ -0,0 +1,4 @@ +let f = (_, ~def=3) => assert(false) + +let ok = f(1)(2) +let err = f(1, 2) diff --git a/tests/build_tests/super_errors/fixtures/fun_return_poly2.res b/tests/build_tests/super_errors/fixtures/fun_return_poly2.res new file mode 100644 index 0000000000..f9c465d95b --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/fun_return_poly2.res @@ -0,0 +1,7 @@ +let r: (string, ~wrongLabelName: int=?) => 'a = (_s, ~wrongLabelName=3) => { + let _ = wrongLabelName + assert(false) +} + +let ok = r("")(~initialValue=2) +let err = r("", ~initialValue=2)