wip remove Function$

Author: cristianoc

compiler/frontend/ast_derive_js_mapper.ml

@@ -169,7 +169,7 @@ let init () =
               in
               let to_js_body body =
                 Ast_comb.single_non_rec_value pat_to_js
-                  (Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1
+                  (Ast_uncurried.uncurried_fun ~arity:1
                      (Ast_compatible.fun_ ~arity:None
                         (Pat.constraint_ (Pat.var pat_param) core_type)
                         body))
@@ -214,7 +214,7 @@ let init () =
                 in
                 let from_js =
                   Ast_comb.single_non_rec_value pat_from_js
-                    (Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1
+                    (Ast_uncurried.uncurried_fun ~arity:1
                        (Ast_compatible.fun_ ~arity:(Some 1) (Pat.var pat_param)
                           (if create_type then
                              Exp.let_ Nonrecursive
@@ -260,7 +260,7 @@ let init () =
                            app2 unsafe_index_get_exp exp_map exp_param
                          else app1 erase_type_exp exp_param);
                       Ast_comb.single_non_rec_value pat_from_js
-                        (Ast_uncurried.uncurried_fun ~loc:Location.none ~arity:1
+                        (Ast_uncurried.uncurried_fun ~arity:1
                            (Ast_compatible.fun_ ~arity:(Some 1)
                               (Pat.var pat_param)
                               (let result =

compiler/frontend/ast_derive_projector.ml

@@ -20,9 +20,9 @@ let init () =
       {
         structure_gen =
           (fun (tdcls : tdcls) _explict_nonrec ->
-            let handle_uncurried_accessor_tranform ~loc ~arity accessor =
+            let handle_uncurried_accessor_tranform ~arity accessor =
               (* Accessors with no params (arity of 0) are simply values and not functions *)
-              if arity > 0 then Ast_uncurried.uncurried_fun ~loc ~arity accessor
+              if arity > 0 then Ast_uncurried.uncurried_fun ~arity accessor
               else accessor
             in
             let handle_tdcl tdcl =
@@ -52,7 +52,7 @@ let init () =
                             (Exp.ident {txt = Lident txt; loc})
                             {txt = Longident.Lident pld_label; loc})
                       (*arity will alwys be 1 since these are single param functions*)
-                      |> handle_uncurried_accessor_tranform ~arity:1 ~loc))
+                      |> handle_uncurried_accessor_tranform ~arity:1))
               | Ptype_variant constructor_declarations ->
                 Ext_list.map constructor_declarations
                   (fun
@@ -111,7 +111,7 @@ let init () =
                              Ast_compatible.fun_ ~arity:(Some 1)
                                (Pat.var {loc; txt = var})
                                b)
-                         |> handle_uncurried_accessor_tranform ~loc ~arity))
+                         |> handle_uncurried_accessor_tranform ~arity))
               | Ptype_abstract | Ptype_open ->
                 Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;
                 []

compiler/ml/ast_uncurried.ml

@@ -19,31 +19,23 @@ let uncurried_type ~loc ~arity t_arg =
   let t_arity = arity_type ~loc arity in
   Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg; t_arity]
 
-let uncurried_fun ~loc ~arity fun_expr =
+let uncurried_fun ~arity fun_expr =
   let fun_expr =
     match fun_expr.Parsetree.pexp_desc with
     | Pexp_fun (l, eo, p, e, _) ->
       {fun_expr with pexp_desc = Pexp_fun (l, eo, p, e, Some arity)}
     | _ -> assert false
   in
-  Ast_helper.Exp.construct ~loc
-    (Location.mknoloc (Longident.Lident "Function$"))
-    (Some fun_expr)
+  fun_expr
 
 let expr_is_uncurried_fun (expr : Parsetree.expression) =
   match expr.pexp_desc with
-  | Pexp_construct ({txt = Lident "Function$"}, Some _) -> true
+  | Pexp_fun (_, _, _, _, Some _) -> true
   | _ -> false
 
 let expr_extract_uncurried_fun (expr : Parsetree.expression) =
   match expr.pexp_desc with
-  | Pexp_construct ({txt = Lident "Function$"}, Some e) ->
-    let () =
-      match e.pexp_desc with
-      | Pexp_fun (_, _, _, _, Some _arity) -> ()
-      | _ -> assert false
-    in
-    e
+  | Pexp_fun (_, _, _, _, Some _) -> expr
   | _ -> assert false
 
 let remove_fun (expr : Parsetree.expression) =

compiler/ml/translcore.ml

@@ -674,7 +674,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
   | Texp_constant cst -> Lconst (Const_base cst)
   | Texp_let (rec_flag, pat_expr_list, body) ->
     transl_let rec_flag pat_expr_list (transl_exp body)
-  | Texp_function {arg_label = _; param; case; partial} ->
+  | Texp_function {arg_label = _; arity; param; case; partial} -> (
     let async = has_async_attribute e in
     let directive =
       match extract_directive_for_fn e with
@@ -695,7 +695,26 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
       }
     in
     let loc = e.exp_loc in
-    Lfunction {params; body; attr; loc}
+    let lambda = Lfunction {params; body; attr; loc} in
+    match arity with
+    | Some arity ->
+      let prim =
+        match
+          (Ast_uncurried.type_extract_uncurried_fun
+             (Ctype.expand_head e.exp_env e.exp_type))
+            .desc
+        with
+        | Tarrow (Nolabel, t, _, _) -> (
+          match (Ctype.expand_head e.exp_env t).desc with
+          | Tconstr (Pident {name = "unit"}, [], _) -> Pjs_fn_make_unit
+          | _ -> Pjs_fn_make arity)
+        | _ -> Pjs_fn_make arity
+      in
+      Lprim
+        ( prim (* could be replaced with Opaque in the future except arity 0*),
+          [lambda],
+          loc )
+    | None -> lambda)
   | Texp_apply
       ( ({
            exp_desc = Texp_ident (_, _, {val_kind = Val_prim p});
@@ -781,27 +800,6 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
     with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc))
   | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false
   | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true
-  | Texp_construct
-      ({txt = Lident "Function$"}, _, [({exp_desc = Texp_function _} as expr)])
-    ->
-    (* ReScript uncurried encoding *)
-    let loc = expr.exp_loc in
-    let lambda = transl_exp expr in
-    let arity =
-      Ast_uncurried.uncurried_type_get_arity ~env:e.exp_env e.exp_type
-    in
-    let prim =
-      match (Ctype.expand_head expr.exp_env expr.exp_type).desc with
-      | Tarrow (Nolabel, t, _, _) -> (
-        match (Ctype.expand_head expr.exp_env t).desc with
-        | Tconstr (Pident {name = "unit"}, [], _) -> Pjs_fn_make_unit
-        | _ -> Pjs_fn_make arity)
-      | _ -> Pjs_fn_make arity
-    in
-    Lprim
-      ( prim (* could be replaced with Opaque in the future except arity 0*),
-        [lambda],
-        loc )
   | Texp_construct (lid, cstr, args) -> (
     let ll = transl_list args in
     if cstr.cstr_inlined <> None then

compiler/ml/typecore.ml

@@ -1913,9 +1913,12 @@ let rec approx_type env sty =
 let rec type_approx env sexp =
   match sexp.pexp_desc with
   | Pexp_let (_, _, e) -> type_approx env e
-  | Pexp_fun (p, _, _, e, _arity) ->
+  | Pexp_fun (p, _, _, e, arity) -> (
     let ty = if is_optional p then type_option (newvar ()) else newvar () in
-    newty (Tarrow (p, ty, type_approx env e, Cok))
+    let t = newty (Tarrow (p, ty, type_approx env e, Cok)) in
+    match arity with
+    | None -> t
+    | Some arity -> Ast_uncurried.make_uncurried_type ~env ~arity t)
   | Pexp_match (_, {pc_rhs = e} :: _) -> type_approx env e
   | Pexp_try (e, _) -> type_approx env e
   | Pexp_tuple l -> newty (Ttuple (List.map (type_approx env) l))
@@ -2525,25 +2528,6 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
         exp_attributes = sexp.pexp_attributes;
         exp_env = env;
       }
-  | Pexp_construct
-      ( ({txt = Lident "Function$"} as lid),
-        (Some {pexp_desc = Pexp_fun (_, _, _, _, Some arity)} as sarg) ) ->
-    let state = Warnings.backup () in
-    let uncurried_typ =
-      Ast_uncurried.make_uncurried_type ~env ~arity (newvar ())
-    in
-    unify_exp_types loc env uncurried_typ ty_expected;
-    (* Disable Unerasable_optional_argument for uncurried functions *)
-    let unerasable_optional_argument =
-      Warnings.number Unerasable_optional_argument
-    in
-    Warnings.parse_options false
-      ("-" ^ string_of_int unerasable_optional_argument);
-    let exp =
-      type_construct env loc lid sarg uncurried_typ sexp.pexp_attributes
-    in
-    Warnings.restore state;
-    exp
   | Pexp_construct (lid, sarg) ->
     type_construct env loc lid sarg ty_expected sexp.pexp_attributes
   | Pexp_variant (l, sarg) -> (
@@ -3273,7 +3257,22 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
   | Pexp_extension ext ->
     raise (Error_forward (Builtin_attributes.error_of_extension ext))
 
-and type_function ?in_function ~arity loc attrs env ty_expected l caselist =
+and type_function ?in_function ~arity loc attrs env ty_expected_ l caselist =
+  let state = Warnings.backup () in
+  (* Disable Unerasable_optional_argument for uncurried functions *)
+  let unerasable_optional_argument =
+    Warnings.number Unerasable_optional_argument
+  in
+  Warnings.parse_options false ("-" ^ string_of_int unerasable_optional_argument);
+  let ty_expected =
+    match arity with
+    | None -> ty_expected_
+    | Some arity ->
+      let fun_t = newvar () in
+      let uncurried_typ = Ast_uncurried.make_uncurried_type ~env ~arity fun_t in
+      unify_exp_types loc env uncurried_typ ty_expected_;
+      fun_t
+  in
   let loc_fun, ty_fun =
     match in_function with
     | Some p -> p
@@ -3311,12 +3310,19 @@ and type_function ?in_function ~arity loc attrs env ty_expected l caselist =
     Location.prerr_warning case.c_lhs.pat_loc
       Warnings.Unerasable_optional_argument;
   let param = name_pattern "param" cases in
+  let exp_type = instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok))) in
+  let exp_type =
+    match arity with
+    | None -> exp_type
+    | Some arity -> Ast_uncurried.make_uncurried_type ~env ~arity exp_type
+  in
+  Warnings.restore state;
   re
     {
       exp_desc = Texp_function {arg_label = l; arity; param; case; partial};
       exp_loc = loc;
       exp_extra = [];
-      exp_type = instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok)));
+      exp_type;
       exp_attributes = attrs;
       exp_env = env;
     }

compiler/syntax/src/jsx_v4.ml

@@ -1028,8 +1028,7 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding =
     in
     let full_expression =
       full_expression
-      |> Ast_uncurried.uncurried_fun ~loc:full_expression.pexp_loc
-           ~arity:(if has_forward_ref then 2 else 1)
+      |> Ast_uncurried.uncurried_fun ~arity:(if has_forward_ref then 2 else 1)
     in
     let full_expression =
       match full_module_name with

compiler/syntax/src/res_comments_table.ml

@@ -1451,8 +1451,6 @@ and walk_expression expr t comments =
         attach t.leading expr.pexp_loc leading;
         walk_expression expr t inside;
         attach t.trailing expr.pexp_loc trailing
-    | Pexp_construct ({txt = Longident.Lident "Function$"}, Some return_expr) ->
-      walk_expression return_expr t comments
     | _ ->
       if is_block_expr return_expr then walk_expression return_expr t comments
       else

compiler/syntax/src/res_core.ml

@@ -528,7 +528,7 @@ let process_underscore_application args =
       let fun_expr =
         Ast_helper.Exp.fun_ ~loc ~arity:(Some 1) Nolabel None pattern exp_apply
       in
-      Ast_uncurried.uncurried_fun ~loc ~arity:1 fun_expr
+      Ast_uncurried.uncurried_fun ~arity:1 fun_expr
     | None -> exp_apply
   in
   (args, wrap)
@@ -1600,9 +1600,7 @@ and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None)
               expr
           in
           if term_param_num = 1 then
-            ( term_param_num - 1,
-              Ast_uncurried.uncurried_fun ~loc ~arity fun_expr,
-              1 )
+            (term_param_num - 1, Ast_uncurried.uncurried_fun ~arity fun_expr, 1)
           else (term_param_num - 1, fun_expr, arity + 1)
         | TypeParameter {attrs; locs = newtypes; pos = start_pos} ->
           ( term_param_num,