Fix arity of inner functions.

compiler/ml/ast_uncurried.ml

@@ -46,6 +46,11 @@ let expr_extract_uncurried_fun (expr : Parsetree.expression) =
     e
   | _ -> assert false
 
+let remove_fun (expr : Parsetree.expression) =
+  match expr.pexp_desc with
+  | Pexp_construct ({txt = Lident "Function$"}, Some e) -> e
+  | _ -> expr
+
 let core_type_is_uncurried_fun (typ : Parsetree.core_type) =
   match typ.ptyp_desc with
   | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow _}; _]) ->

compiler/syntax/src/res_core.ml

@@ -1596,8 +1596,8 @@ and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None)
             {attrs; label = lbl; expr = default_expr; pat; pos = start_pos} ->
           let loc = mk_loc start_pos end_pos in
           let fun_expr =
-            Ast_helper.Exp.fun_ ~loc ~attrs ~arity:(Some arity) lbl default_expr
-              pat expr
+            Ast_helper.Exp.fun_ ~loc ~attrs ~arity:None lbl default_expr pat
+              expr
           in
           if term_param_num = 1 then
             ( term_param_num - 1,

compiler/syntax/src/res_parens.ml

@@ -83,6 +83,7 @@ let unary_expr_operand expr =
   match opt_braces with
   | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc
   | None -> (
+    let expr = Ast_uncurried.remove_fun expr in
     match expr with
     | {Parsetree.pexp_attributes = attrs}
       when match ParsetreeViewer.filter_parsing_attrs attrs with
@@ -111,11 +112,6 @@ let unary_expr_operand expr =
       Parenthesized
     | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes ->
       Parenthesized
-    | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some expr)}
-      when ParsetreeViewer.is_underscore_apply_sugar expr ->
-      Nothing
-    | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some _)} ->
-      Parenthesized
     | _ -> Nothing)
 
 let binary_expr_operand ~is_lhs expr =
@@ -171,6 +167,7 @@ let rhs_binary_expr_operand parent_operator rhs =
   | _ -> false
 
 let flatten_operand_rhs parent_operator rhs =
+  let rhs = Ast_uncurried.remove_fun rhs in
   match rhs.Parsetree.pexp_desc with
   | Parsetree.Pexp_apply
       ( {
@@ -183,10 +180,8 @@ let flatten_operand_rhs parent_operator rhs =
     let prec_parent = ParsetreeViewer.operator_precedence parent_operator in
     let prec_child = ParsetreeViewer.operator_precedence operator in
     prec_parent >= prec_child || rhs.pexp_attributes <> []
-  | Pexp_construct ({txt = Lident "Function$"}, Some _) -> true
   | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) ->
     false
-  | Pexp_fun _ when ParsetreeViewer.is_underscore_apply_sugar rhs -> false
   | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true
   | _ when ParsetreeViewer.is_ternary_expr rhs -> true
   | _ -> false
@@ -246,6 +241,7 @@ let is_negative_constant constant =
   | _ -> false
 
 let field_expr expr =
+  let expr = Ast_uncurried.remove_fun expr in
   let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in
   match opt_braces with
   | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc
@@ -279,11 +275,6 @@ let field_expr expr =
       Parenthesized
     | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes ->
       Parenthesized
-    | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some expr)}
-      when ParsetreeViewer.is_underscore_apply_sugar expr ->
-      Nothing
-    | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some _)} ->
-      Parenthesized
     | _ -> Nothing)
 
 let set_field_expr_rhs expr =

compiler/syntax/src/res_printer.ml

@@ -2793,19 +2793,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl =
           None,
           {ppat_desc = Ppat_var {txt = "__x"}},
           {pexp_desc = Pexp_apply _},
-          _ )
-    | Pexp_construct
-        ( {txt = Lident "Function$"},
-          Some
-            {
-              pexp_desc =
-                Pexp_fun
-                  ( Nolabel,
-                    None,
-                    {ppat_desc = Ppat_var {txt = "__x"}},
-                    {pexp_desc = Pexp_apply _},
-                    _ );
-            } ) ->
+          _ ) ->
       (* (__x) => f(a, __x, c) -----> f(a, _, c)  *)
       print_expression_with_comments ~state
         (ParsetreeViewer.rewrite_underscore_apply e_fun)

tests/syntax_tests/data/parsing/errors/expressions/expected/arrow.res.txt

@@ -11,5 +11,4 @@
 ;;(Object.keys providers).reduce
     (Function$
        (fun [arity:2]elements ->
-          fun [arity:1]providerId -> ((let x = 1 in let b = 2 in x + b)
-            [@res.braces ])))
+          fun providerId -> ((let x = 1 in let b = 2 in x + b)[@res.braces ])))

tests/syntax_tests/data/parsing/errors/expressions/expected/block.res.txt

@@ -66,11 +66,11 @@
 let findThreadByIdLinearScan =
   Function$
     (fun [arity:2]~threads:((threads)[@res.namedArgLoc ]) ->
-       fun [arity:1]~id:((id)[@res.namedArgLoc ]) ->
+       fun ~id:((id)[@res.namedArgLoc ]) ->
          ((Js.Array2.findi ThreadsModel.threads
              (Function$
                 (fun [arity:2]thread ->
-                   fun [arity:1]i ->
+                   fun i ->
                      ((let thisId =
                          match thread with
                          | ServerData.OneToOne

tests/syntax_tests/data/parsing/errors/expressions/expected/consecutive.res.txt

@@ -44,9 +44,8 @@
 
   consecutive expressions on a line must be separated by ';' or a newline
 
-let f = Function$ (fun [arity:2]a -> fun [arity:1]b -> a + 3)
+let f = Function$ (fun [arity:2]a -> fun b -> a + 3)
 ;;b
-let f =
-  Function$ (fun [arity:2]g -> fun [arity:1]h -> ((a + 3; b)[@res.braces ]))
+let f = Function$ (fun [arity:2]g -> fun h -> ((a + 3; b)[@res.braces ]))
 let () = ((sideEffect1 (); sideEffect2 ())[@res.braces ])
 let () = ((let open Foo in let exception End  in x ())[@res.braces ])

tests/syntax_tests/data/parsing/errors/expressions/expected/emptyBlock.res.txt

@@ -1,2 +1,2 @@
 let x = {  }
-let f = Function$ (fun [arity:2]a -> fun [arity:1]b -> {  })
+let f = Function$ (fun [arity:2]a -> fun b -> {  })

tests/syntax_tests/data/parsing/errors/other/expected/labelledParameters.res.txt

@@ -31,12 +31,10 @@
 
   A labeled parameter starts with a `~`. Did you mean: `~x`?
 
-let f =
-  Function$
-    (fun [arity:3]x -> fun [arity:2]?(y= 2) -> fun [arity:1]z -> (x + y) + z)
+let f = Function$ (fun [arity:3]x -> fun ?(y= 2) -> fun z -> (x + y) + z)
 let g =
   Function$
     (fun [arity:3]~x:((x)[@res.namedArgLoc ]) ->
-       fun [arity:2]?y:(((y)[@res.namedArgLoc ])= 2) ->
-         fun [arity:1]~z:((z)[@res.namedArgLoc ]) -> (x + y) + z)
+       fun ?y:(((y)[@res.namedArgLoc ])= 2) ->
+         fun ~z:((z)[@res.namedArgLoc ]) -> (x + y) + z)
 type nonrec f = (x:int -> y:int -> int, [ `Has_arity2 ]) function$

tests/syntax_tests/data/parsing/errors/structure/expected/gh16B.res.txt

@@ -35,7 +35,7 @@ module ClientSet =
                                  let cmp =
                                    Function$
                                      (fun [arity:2]a ->
-                                        fun [arity:1]b ->
+                                        fun b ->
                                           ((compare
                                               (a |.u Client.getUniqueId)
                                               (b |.u Client.getUniqueId))

tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedAlways.res.txt

@@ -1,7 +1,7 @@
 [@@@uncurried ]
-let foo = Function$ (fun [arity:2]x -> fun [arity:1]y -> x + y)
+let foo = Function$ (fun [arity:2]x -> fun y -> x + y)
 let z = foo 3 4
-let bar = Function$ (fun [arity:2]x -> fun [arity:1]y -> x + y)
+let bar = Function$ (fun [arity:2]x -> fun y -> x + y)
 let b = bar 3 4
 let w = 3 |.u (foo 4)
 let a = 3 |.u (foo 4)

tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt

@@ -5,17 +5,15 @@ let uFun = Function$ (fun [arity:1]x -> 3)
 let mixFun =
   Function$
     (fun [arity:3]a ->
-       fun [arity:2]b ->
-         fun [arity:1]c ->
+       fun b ->
+         fun c ->
            Function$
              (fun [arity:3]d ->
-                fun [arity:2]e ->
-                  fun [arity:1]f ->
-                    Function$ (fun [arity:2]g -> fun [arity:1]h -> 4)))
+                fun e -> fun f -> Function$ (fun [arity:2]g -> fun h -> 4)))
 let bracesFun =
   Function$ (fun [arity:1]x -> Function$ (fun [arity:1]y -> x + y))
-let cFun2 = Function$ (fun [arity:2]x -> fun [arity:1]y -> 3)
-let uFun2 = Function$ (fun [arity:2]x -> fun [arity:1]y -> 3)
+let cFun2 = Function$ (fun [arity:2]x -> fun y -> 3)
+let uFun2 = Function$ (fun [arity:2]x -> fun y -> 3)
 type nonrec cTyp = (string -> int, [ `Has_arity1 ]) function$
 type nonrec uTyp = (string -> int, [ `Has_arity1 ]) function$
 type nonrec mixTyp =
@@ -77,19 +75,19 @@ let _ = Function$ ((fun [arity:1]x -> 34)[@res.async ][@att ])
 let _ = preserveAttr (Function$ ((fun [arity:1]x -> 34)[@att ]))
 let _ = preserveAttr (Function$ ((fun [arity:1]x -> 34)[@res.async ][@att ]))
 let t0 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 let t1 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 let t2 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 let t3 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 let t4 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 let t5 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 let t6 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 type nonrec arrowPath1 = (int -> string, [ `Has_arity1 ]) function$
 type nonrec arrowPath2 = (I.t -> string, [ `Has_arity1 ]) function$
 type nonrec arrowPath3 = (int -> string, [ `Has_arity1 ]) function$
@@ -109,18 +107,18 @@ let mixFun =
     (fun [arity:1]a ->
        Function$
          (fun [arity:2]b ->
-            fun [arity:1]c ->
+            fun c ->
               Function$
                 (fun [arity:3]d ->
-                   fun [arity:2]e ->
-                     fun [arity:1]f ->
+                   fun e ->
+                     fun f ->
                        Function$
                          (fun [arity:1]g -> Function$ (fun [arity:1]h -> 4)))))
 let bracesFun =
   Function$ (fun [arity:1]x -> Function$ (fun [arity:1]y -> x + y))
-let cFun2 = Function$ (fun [arity:2]x -> fun [arity:1]y -> 3)
-let uFun2 = Function$ (fun [arity:2]x -> fun [arity:1]y -> 3)
-let cFun2Dots = Function$ (fun [arity:2]x -> fun [arity:1]y -> 3)
+let cFun2 = Function$ (fun [arity:2]x -> fun y -> 3)
+let uFun2 = Function$ (fun [arity:2]x -> fun y -> 3)
+let cFun2Dots = Function$ (fun [arity:2]x -> fun y -> 3)
 type nonrec cTyp = (string -> int, [ `Has_arity1 ]) function$
 type nonrec uTyp = (string -> int, [ `Has_arity1 ]) function$
 type nonrec mixTyp =
@@ -184,13 +182,13 @@ let _ = Function$ ((fun [arity:1]x -> 34)[@res.async ][@att ])
 let _ = preserveAttr (Function$ ((fun [arity:1]x -> 34)[@att ]))
 let _ = preserveAttr (Function$ ((fun [arity:1]x -> 34)[@res.async ][@att ]))
 let t0 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 let t1 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 let t2 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 let t3 (type a) (type b) =
-  Function$ (fun [arity:2](l : a list) -> fun [arity:1](x : a) -> x :: l)
+  Function$ (fun [arity:2](l : a list) -> fun (x : a) -> x :: l)
 type nonrec arrowPath1 = (int -> string, [ `Has_arity1 ]) function$
 type nonrec arrowPath2 = (I.t -> string, [ `Has_arity1 ]) function$
 type nonrec arrowPath3 = (int -> string, [ `Has_arity1 ]) function$

tests/syntax_tests/data/parsing/grammar/expressions/expected/apply.res.txt

@@ -4,8 +4,7 @@
 ;;foo (Function$ (fun [arity:1]_ -> bla))
     (Function$ (fun [arity:1]_ -> blaz))
 ;;List.map (Function$ (fun [arity:1]x -> x + 1)) myList
-;;List.reduce
-    (Function$ (fun [arity:2]acc -> fun [arity:1]curr -> acc + curr)) 0
+;;List.reduce (Function$ (fun [arity:2]acc -> fun curr -> acc + curr)) 0
     myList
 let unitUncurried = apply ()
 ;;call ~a:(((((a)[@res.namedArgLoc ]) : int))[@res.namedArgLoc ])