Process uncurried application in the type checker.

- Do the processing of uncurried application in the type checker.
- Add support for default arguments in uncurried functions.
- Add custom error messages for uncurried application.
- Uncurried pipe processing does not require special handling.

The current encoding is based on arity. To support default arguments one cannot just look at the number of supplied arguments, but to know whether the required arguments are supplied one needs to inspect the function type.

Author: cristianoc

jscomp/build_tests/super_errors/expected/arity_mismatch.res.expected

@@ -6,4 +6,5 @@
   2 │ let makeVariables = makeVar(.~f=f => f)
   3 │ 
 
-  This function expected 2 arguments, but got 1
+  This uncurried function has type (. ~f: 'a => 'a, unit) => int
+  It is applied with 1 arguments but it requires 2.

jscomp/build_tests/super_errors/expected/arity_mismatch2.res.expected

@@ -6,4 +6,5 @@
   2 │ let makeVariables = makeVar(. 1, 2, 3)
   3 │ 
 
-  This function expected 2 arguments, but got 3
+  This uncurried function has type (. 'a, unit) => int
+  It is applied with 3 arguments but it requires 2.

jscomp/build_tests/super_errors/expected/method_arity_mismatch.res.expected

@@ -8,4 +8,5 @@
   4 │ }
   5 │ 
 
-  This function expected 2 arguments, but got 1
+  This uncurried function has type (. int, int) => unit
+  It is applied with 1 arguments but it requires 2.

jscomp/build_tests/super_errors/expected/warnings4.res.expected

@@ -10,4 +10,4 @@
   14 │ 
 
   You forgot to handle a possible case here, for example: 
-  #second(_) | #fourth | #third
+  #second(_) | #fourth | #third

jscomp/build_tests/super_errors/expected/warnings5.res.expected

@@ -187,4 +187,4 @@ Either bind these labels explicitly or add ', _' to the pattern.
   60 │ 
 
   You forgot to handle a possible case here, for example: 
-  (_, true)
+  (_, true)

jscomp/frontend/ast_attributes.ml

@@ -341,8 +341,7 @@ let locg = Location.none
 let is_bs (attr : attr) =
   match attr with { Location.txt = "bs"; _ }, _ -> true | _ -> false
 
-let is_res_uapp (attr : attr) =
-  match attr with { Location.txt = "res.uapp"; _ }, _ -> true | _ -> false
+let res_uapp : attr = ({ txt = "res.uapp"; loc = locg }, Ast_payload.empty)
 
 let bs_get : attr = ({ txt = "bs.get"; loc = locg }, Ast_payload.empty)
 

jscomp/frontend/ast_attributes.mli

@@ -73,7 +73,7 @@ val is_bs : attr -> bool
    val is_bs_as : attr -> bool *)
 
 (* Attribute for uncurried application coming from the ReScript parser *)
-val is_res_uapp : attr -> bool
+val res_uapp : attr
 
 val bs_get : attr
 

jscomp/frontend/ast_exp_apply.ml

@@ -124,7 +124,7 @@ let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) (fn : exp)
               {
                 pexp_desc = Pexp_apply (fn1, (Nolabel, a) :: args);
                 pexp_loc = e.pexp_loc;
-                pexp_attributes = e.pexp_attributes;
+                pexp_attributes = e.pexp_attributes @ f.pexp_attributes;
               }
           | Pexp_tuple xs ->
               bound a (fun bounded_obj_arg ->
@@ -158,38 +158,16 @@ let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) (fn : exp)
                   })
           | _ -> (
               match
-                ( Ext_list.exclude_with_val f_.pexp_attributes (fun a ->
-                      Ast_attributes.is_bs a
-                      || Ast_attributes.is_res_uapp a),
+                ( Ext_list.exclude_with_val f_.pexp_attributes
+                    Ast_attributes.is_bs,
                   f_.pexp_desc )
               with
-              | Some other_attributes, Pexp_apply (fn1, args) ->
-                  (* a |. f b c [@bs]
-                     Cannot process uncurried application early as the arity is wip *)
-                  let fn1 = self.expr self fn1 in
-                  let args =
-                    args |> List.map (fun (l, e) -> (l, self.expr self e))
-                  in
-                  Bs_ast_invariant.warn_discarded_unused_attributes
-                    fn1.pexp_attributes;
-                  {
-                    pexp_desc =
-                      Ast_uncurry_apply.uncurry_fn_apply ~arity0:(op = "|.")
-                        e.pexp_loc self fn1 ((Nolabel, a) :: args);
-                    pexp_loc = e.pexp_loc;
-                    pexp_attributes = e.pexp_attributes @ other_attributes;
-                  }
               | _ when op = "|.u" ->
                   (* a |.u f
                      Uncurried unary application *)
-                  {
-                    pexp_desc =
-                      Ast_uncurry_apply.uncurry_fn_apply ~arity0:false
-                        e.pexp_loc self f
-                        [ (Nolabel, a) ];
-                    pexp_loc = e.pexp_loc;
-                    pexp_attributes = e.pexp_attributes;
-                  }
+                  Ast_compatible.app1 ~loc
+                    ~attrs:(Ast_attributes.res_uapp :: e.pexp_attributes)
+                    f a
               | _ -> Ast_compatible.app1 ~loc ~attrs:e.pexp_attributes f a))
       | Some { op = "##"; loc; args = [ obj; rest ] } -> (
           (* - obj##property
@@ -289,21 +267,7 @@ let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) (fn : exp)
               {
                 e with
                 pexp_desc =
-                  Ast_uncurry_apply.uncurry_fn_apply ~arity0:true e.pexp_loc
-                    self fn args;
+                  Ast_uncurry_apply.uncurry_fn_apply e.pexp_loc self fn args;
                 pexp_attributes;
               }
-          | None -> (
-              match
-                Ext_list.exclude_with_val e.pexp_attributes
-                  Ast_attributes.is_res_uapp
-              with
-              | Some pexp_attributes ->
-                  {
-                    e with
-                    pexp_desc =
-                      Ast_uncurry_apply.uncurry_fn_apply ~arity0:false
-                        e.pexp_loc self fn args;
-                    pexp_attributes;
-                  }
-              | None -> default_expr_mapper self e)))
+          | None -> default_expr_mapper self e))

jscomp/frontend/ast_uncurry_apply.ml

@@ -44,9 +44,8 @@ let opaque_full_apply ~loc (e : exp) : Parsetree.expression_desc =
         [ (Nolabel, e) ],
       Typ.any ~loc () )
 
-let generic_apply ~arity0 loc (self : Bs_ast_mapper.mapper)
-    (obj : Parsetree.expression) (args : Ast_compatible.args)
-    (cb : loc -> exp -> exp) =
+let generic_apply loc (self : Bs_ast_mapper.mapper) (obj : Parsetree.expression)
+    (args : Ast_compatible.args) (cb : loc -> exp -> exp) =
   let obj = self.expr self obj in
   let args =
     Ext_list.map args (fun (lbl, e) ->
@@ -58,8 +57,7 @@ let generic_apply ~arity0 loc (self : Bs_ast_mapper.mapper)
     match args with
     | [
      (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) });
-    ]
-      when arity0 ->
+    ] ->
         []
     | _ -> args
   in
@@ -130,9 +128,9 @@ let method_apply loc (self : Bs_ast_mapper.mapper) (obj : Parsetree.expression)
             ])
          args)
 
-let uncurry_fn_apply ~arity0 loc self fn args =
-  generic_apply ~arity0 loc self fn args (fun _ obj -> obj)
+let uncurry_fn_apply loc self fn args =
+  generic_apply loc self fn args (fun _ obj -> obj)
 
 let property_apply loc self obj name args =
-  generic_apply ~arity0:true loc self obj args (fun loc obj ->
+  generic_apply loc self obj args (fun loc obj ->
       Exp.send ~loc obj { txt = name; loc })

jscomp/frontend/ast_uncurry_apply.mli

@@ -25,7 +25,6 @@
 (* TODO: the interface is not reusable, it depends on too much context *)
 
 val uncurry_fn_apply :
-  arity0:bool ->
   Location.t ->
   Bs_ast_mapper.mapper ->
   Parsetree.expression ->

jscomp/ml/typecore.ml

@@ -73,6 +73,7 @@ type error =
   | Illegal_letrec_pat
   | Labels_omitted of string list
   | Empty_record_literal
+  | Uncurried_arity_mismatch of type_expr * int * int * bool
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 
@@ -2015,15 +2016,35 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
       end_def ();
       wrap_trace_gadt_instances env (lower_args env []) ty;
       begin_def ();
-      let (args, ty_res) = type_application env funct sargs in
+      let uncurried = Ext_list.exists sexp.pexp_attributes (fun ({txt },_) -> txt = "res.uapp") in
+      let (args, ty_res, fully_applied) = type_application uncurried env funct sargs in
       end_def ();
       unify_var env (newvar()) funct.exp_type;
-      rue {
-        exp_desc = Texp_apply(funct, args);
-        exp_loc = loc; exp_extra = [];
-        exp_type = ty_res;
-        exp_attributes = sexp.pexp_attributes;
-        exp_env = env }
+
+      let mk_exp exp_desc exp_type =
+        { exp_desc;
+          exp_loc = Location.none; exp_extra = [];
+          exp_type;
+          exp_attributes = [];
+          exp_env = env } in
+      let apply_internal name e =
+        let lid:Longident.t = Ldot (Ldot (Lident "Js", "Internal"), name) in
+        let (path, desc) = Env.lookup_value lid env in
+        let id = mk_exp (Texp_ident(path, {txt=lid; loc=Location.none}, desc)) desc.val_type in
+        mk_exp (Texp_apply(id, [(Nolabel, Some e)])) e.exp_type in
+        
+      let mk_apply funct args =
+        rue {
+          exp_desc = Texp_apply(funct, args);
+          exp_loc = loc; exp_extra = [];
+          exp_type = ty_res;
+          exp_attributes = sexp.pexp_attributes;
+          exp_env = env } in
+
+      if fully_applied then
+        rue (apply_internal "opaqueFullApply" (mk_apply (apply_internal "opaque" funct) args))
+      else
+        rue (mk_apply funct args)
   | Pexp_match(sarg, caselist) ->
       begin_def ();
       let arg = type_exp env sarg in
@@ -2939,7 +2960,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
       unify_exp env texp ty_expected;
       texp
 
-and type_application env funct (sargs : sargs) : targs * Types.type_expr =
+and type_application uncurried env funct (sargs : sargs) : targs * Types.type_expr * bool =
   (* funct.exp_type may be generic *)
   let result_type omitted ty_fun =
     List.fold_left
@@ -2951,25 +2972,49 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
     tvar || List.mem l ls
   in
   let ignored = ref [] in
-  let extract_uncurried_type t =
+  let mk_js_fn arity t =
+    let a = "arity" ^ string_of_int arity in
+    let lid:Longident.t = Ldot (Ldot (Lident "Js", "Fn"), a) in
+    let path = Env.lookup_type lid env in
+    newconstr path [t] in
+  let has_uncurried_type t =
     match (expand_head env t).desc with
-    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),[t],_) -> t
-    | _ -> t in
-  let lower_uncurried_arity ~nargs t newT =
-    match (expand_head env t).desc with
-    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),a,_),[_],_) ->
+    | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),a,_),[t],_) ->
       let arity =
         if String.sub a 0 5 = "arity"
         then int_of_string (String.sub a 5 (String.length a - 5))
         else 0 in
+       Some (arity, t)
+    | _ -> None in
+  let force_uncurried_type funct =
+    match has_uncurried_type funct.exp_type with
+    | None ->
+      let arity = List.length sargs in
+      let js_fn = mk_js_fn arity (newvar()) in
+      unify_exp env funct js_fn
+    | Some _ -> () in
+  let extract_uncurried_type t =
+    match has_uncurried_type t with
+    | Some (arity, t1) ->
+      if List.length sargs > arity then
+        raise(Error(funct.exp_loc, env,
+          Uncurried_arity_mismatch (t, arity, List.length sargs, false)));
+      t1
+    | None -> t in
+  let update_uncurried_arity ~nargs t newT =
+    match has_uncurried_type t with
+    | Some (arity, _) ->
       let newarity = arity - nargs in
-      if newarity > 0 then
-        let a = "arity" ^ string_of_int newarity in
-        let lid:Longident.t = Ldot (Ldot (Lident "Js", "Fn"), a) in
-        let path = Env.lookup_type lid env in
-        newconstr path [newT]
-      else newT
-    | _ -> newT
+      if newarity < 0 then
+        raise(Error(funct.exp_loc, env,
+          Uncurried_arity_mismatch (t, arity, List.length sargs, true)));
+      let fully_applied = newarity = 0 in
+      if uncurried && not fully_applied then
+        raise(Error(funct.exp_loc, env,
+          Uncurried_arity_mismatch (t, arity, List.length sargs, false)));
+      let newT = if fully_applied then newT else mk_js_fn newarity newT in
+      (fully_applied, newT)
+    | _ -> (false, newT)
   in
   let rec type_unknown_args (args : lazy_args) omitted ty_fun (syntax_args : sargs)
      : targs * _ = 
@@ -3078,14 +3123,14 @@ and type_application env funct (sargs : sargs) : targs * Types.type_expr =
           Delayed_checks.add_delayed_check (fun () -> check_application_result env false exp)
       | _ -> ()
       end;
-      ([Nolabel, Some exp], ty_res)
+      ([Nolabel, Some exp], ty_res, false)
   | _ ->
+      if uncurried then force_uncurried_type funct;
       let ty = extract_uncurried_type funct.exp_type in
       let targs, ret_t = type_args [] [] ~ty_fun:ty (instance env ty) ~sargs in
-      let ret_t =
-        if funct.exp_type == ty then ret_t
-        else lower_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in
-      targs, ret_t
+      let fully_applied, ret_t =
+        update_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in
+      targs, ret_t, fully_applied
 
 and type_construct env loc lid sarg ty_expected attrs =
   let opath =
@@ -3821,6 +3866,16 @@ let report_error env ppf = function
       (String.concat ", " labels)  
   | Empty_record_literal ->
       fprintf ppf  "Empty record literal {} should be type annotated or used in a record context."
+  | Uncurried_arity_mismatch (typ, arity, args, false (* no partial application *)) ->
+    fprintf ppf "@[<v>@[<2>This uncurried function has type@ %a@]"
+    type_expr typ;
+    fprintf ppf "@ @[It is applied with @{<error>%d@} argument%s but it requires @{<info>%d@}.@]@]"
+      args (if args = 0 then "" else "s") arity
+  | Uncurried_arity_mismatch (typ, _, _, true (* partial application *)) ->
+    fprintf ppf "@[<v>@[<2>This uncurried function has type@ %a@]"
+    type_expr typ;
+    fprintf ppf "@ @[It is partially applied with too many arguments.@]@]"
+
 
 let super_report_error_no_wrap_printing_env = report_error
 

jscomp/ml/typecore.mli

@@ -109,6 +109,7 @@ type error =
   | Illegal_letrec_pat
   | Labels_omitted of string list
   | Empty_record_literal
+  | Uncurried_arity_mismatch of type_expr * int * int * bool
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 

jscomp/test/uncurried_cast.js

@@ -22,10 +22,9 @@ var Uncurried = {
 var E = /* @__PURE__ */Caml_exceptions.create("Uncurried_cast.E");
 
 function testRaise(param) {
-  throw {
-        RE_EXN_ID: E,
-        Error: new Error()
-      };
+  return raise({
+              RE_EXN_ID: E
+            });
 }
 
 var l = map({
@@ -50,9 +49,9 @@ function partial(param) {
   return map(partial_arg, param);
 }
 
-var ll = Curry._1(partial, (function (x) {
-        return x + 1 | 0;
-      }));
+var ll = partial(function (x) {
+      return x + 1 | 0;
+    });
 
 function withOpts(xOpt, y, zOpt, w) {
   var x = xOpt !== undefined ? xOpt : 3;