Fix issue in printing uncurried callbacks.

CHANGELOG.md

@@ -38,6 +38,7 @@ These are only breaking changes for unformatted code.
 
 - Fix issue where uncurried was not supported with pipe https://github.com/rescript-lang/rescript-compiler/pull/5803
 - Fix printing of nested types in uncurried mode https://github.com/rescript-lang/rescript-compiler/pull/5826
+- Fix issue in printing uncurried callbacks https://github.com/rescript-lang/rescript-compiler/pull/5828
 
 #### :nail_care: Polish
 

lib/4.06.1/unstable/js_compiler.ml

@@ -49434,7 +49434,7 @@ val processBsAttribute : Parsetree.attributes -> bool * Parsetree.attributes
 
 type functionAttributesInfo = {
   async: bool;
-  uncurried: bool;
+  bs: bool;
   attributes: Parsetree.attributes;
 }
 
@@ -49470,7 +49470,7 @@ type funParamKind =
 
 val funExpr :
   Parsetree.expression ->
-  Parsetree.attributes * funParamKind list * Parsetree.expression
+  bool * Parsetree.attributes * funParamKind list * Parsetree.expression
 
 (* example:
    *  `makeCoordinate({
@@ -49570,6 +49570,8 @@ val hasIfLetAttribute : Parsetree.attributes -> bool
 
 val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool
 
+val isFunNewtype : Parsetree.expression_desc -> bool
+
 end = struct
 #1 "res_parsetree_viewer.ml"
 open Parsetree
@@ -49633,18 +49635,17 @@ let processBsAttribute attrs =
 
 type functionAttributesInfo = {
   async: bool;
-  uncurried: bool;
+  bs: bool;
   attributes: Parsetree.attributes;
 }
 
 let processFunctionAttributes attrs =
-  let rec process async uncurried acc attrs =
+  let rec process async bs acc attrs =
     match attrs with
-    | [] -> {async; uncurried; attributes = List.rev acc}
+    | [] -> {async; bs; attributes = List.rev acc}
     | ({Location.txt = "bs"}, _) :: rest -> process async true acc rest
-    | ({Location.txt = "res.async"}, _) :: rest ->
-      process true uncurried acc rest
-    | attr :: rest -> process async uncurried (attr :: acc) rest
+    | ({Location.txt = "res.async"}, _) :: rest -> process true bs acc rest
+    | attr :: rest -> process async bs (attr :: acc) rest
   in
   process false false [] attrs
 
@@ -49711,7 +49712,7 @@ let funExpr expr =
       collectNewTypes (stringLoc :: acc) returnExpr
     | returnExpr -> (List.rev acc, returnExpr)
   in
-  let rec collect attrsBefore acc expr =
+  let rec collect ~uncurried attrsBefore acc expr =
     match expr with
     | {
      pexp_desc =
@@ -49721,29 +49722,33 @@ let funExpr expr =
            {ppat_desc = Ppat_var {txt = "__x"}},
            {pexp_desc = Pexp_apply _} );
     } ->
-      (attrsBefore, List.rev acc, rewriteUnderscoreApply expr)
+      (uncurried, attrsBefore, List.rev acc, rewriteUnderscoreApply expr)
     | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} ->
       let stringLocs, returnExpr = collectNewTypes [stringLoc] rest in
       let param = NewTypes {attrs; locs = stringLocs} in
-      collect attrsBefore (param :: acc) returnExpr
+      collect ~uncurried attrsBefore (param :: acc) returnExpr
     | {
      pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr);
      pexp_attributes = [];
     } ->
       let parameter = Parameter {attrs = []; lbl; defaultExpr; pat = pattern} in
-      collect attrsBefore (parameter :: acc) returnExpr
+      collect ~uncurried attrsBefore (parameter :: acc) returnExpr
     (* If a fun has an attribute, then it stops here and makes currying.
        i.e attributes outside of (...), uncurried `(.)` and `async` make currying *)
-    | {pexp_desc = Pexp_fun _} -> (attrsBefore, List.rev acc, expr)
-    | expr -> (attrsBefore, List.rev acc, expr)
+    | {pexp_desc = Pexp_fun _} -> (uncurried, attrsBefore, List.rev acc, expr)
+    | expr -> (uncurried, attrsBefore, List.rev acc, expr)
   in
   match expr with
+  | {pexp_desc = Pexp_fun _} ->
+    collect ~uncurried:false expr.pexp_attributes []
+      {expr with pexp_attributes = []}
   | {
-      pexp_desc = Pexp_fun (_, _defaultExpr, _pattern, _returnExpr);
-      pexp_attributes = attrs;
-    } as expr ->
-    collect attrs [] {expr with pexp_attributes = []}
-  | expr -> collect [] [] expr
+   pexp_desc =
+     Pexp_record ([({txt = Ldot (Ldot (Lident "Js", "Fn"), _)}, expr)], None);
+  } ->
+    collect ~uncurried:true expr.pexp_attributes []
+      {expr with pexp_attributes = []}
+  | _ -> collect ~uncurried:false [] [] expr
 
 let processBracesAttr expr =
   match expr.pexp_attributes with
@@ -50102,12 +50107,19 @@ let filterPrintableAttributes attrs = List.filter isPrintableAttribute attrs
 let partitionPrintableAttributes attrs =
   List.partition isPrintableAttribute attrs
 
+let isFunNewtype = function
+  | Pexp_fun _ | Pexp_newtype _ -> true
+  | Pexp_record ([({txt = Ldot (Ldot (Lident "Js", "Fn"), name)}, _)], None)
+    when String.length name >= 1 && name.[0] = 'I' ->
+    true
+  | _ -> false
+
 let requiresSpecialCallbackPrintingLastArg args =
   let rec loop args =
     match args with
     | [] -> false
-    | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true
-    | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false
+    | [(_, {pexp_desc})] when isFunNewtype pexp_desc -> true
+    | (_, {pexp_desc}) :: _ when isFunNewtype pexp_desc -> false
     | _ :: rest -> loop rest
   in
   loop args
@@ -50116,12 +50128,12 @@ let requiresSpecialCallbackPrintingFirstArg args =
   let rec loop args =
     match args with
     | [] -> true
-    | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false
+    | (_, {pexp_desc}) :: _ when isFunNewtype pexp_desc -> false
     | _ :: rest -> loop rest
   in
   match args with
-  | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false
-  | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: rest -> loop rest
+  | [(_, {pexp_desc})] when isFunNewtype pexp_desc -> false
+  | (_, {pexp_desc}) :: rest when isFunNewtype pexp_desc -> loop rest
   | _ -> false
 
 let modExprApply modExpr =
@@ -52489,8 +52501,8 @@ let ternaryOperand expr =
     } ->
       Nothing
     | {pexp_desc = Pexp_constraint _} -> Parenthesized
-    | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> (
-      let _attrsOnArrow, _parameters, returnExpr =
+    | {pexp_desc} when Res_parsetree_viewer.isFunNewtype pexp_desc -> (
+      let _uncurried, _attrsOnArrow, _parameters, returnExpr =
         ParsetreeViewer.funExpr expr
       in
       match returnExpr.pexp_desc with
@@ -54648,7 +54660,6 @@ and printLabelDeclaration ~state (ld : Parsetree.label_declaration) cmtTbl =
 
 and printTypExpr ~state (typExpr : Parsetree.core_type) cmtTbl =
   let printArrow ~uncurried ?(arity = max_int) typExpr =
-    (* XXX *)
     let attrsBefore, args, returnType =
       ParsetreeViewer.arrowType ~arity typExpr
     in
@@ -55065,7 +55076,9 @@ and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i =
      };
    pvb_expr = {pexp_desc = Pexp_newtype _} as expr;
   } -> (
-    let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in
+    let _uncurried, _attrs, parameters, returnExpr =
+      ParsetreeViewer.funExpr expr
+    in
     let abstractType =
       match parameters with
       | [NewTypes {locs = vars}] ->
@@ -55703,12 +55716,14 @@ and printIfChain ~state pexp_attributes ifs elseExpr cmtTbl =
   Doc.concat [printAttributes ~state attrs cmtTbl; ifDocs; elseDoc]
 
 and printExpression ~state (e : Parsetree.expression) cmtTbl =
-  let printArrow ~isUncurried e =
-    let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in
-    let ParsetreeViewer.{async; uncurried; attributes = attrs} =
+  let printArrow e =
+    let uncurried, attrsOnArrow, parameters, returnExpr =
+      ParsetreeViewer.funExpr e
+    in
+    let ParsetreeViewer.{async; bs; attributes = attrs} =
       ParsetreeViewer.processFunctionAttributes attrsOnArrow
     in
-    let uncurried = uncurried || isUncurried in
+    let uncurried = uncurried || bs in
     let returnExpr, typConstraint =
       match returnExpr.pexp_desc with
       | Pexp_constraint (expr, typ) ->
@@ -56033,11 +56048,15 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl =
       printExpressionWithComments ~state
         (ParsetreeViewer.rewriteUnderscoreApply e)
         cmtTbl
-    | Pexp_fun _ | Pexp_newtype _ -> printArrow ~isUncurried:false e
+    | Pexp_fun _
     | Pexp_record
-        ([({txt = Ldot (Ldot (Lident "Js", "Fn"), name)}, funExpr)], None)
-      when String.length name >= 1 && name.[0] = 'I' ->
-      printArrow ~isUncurried:true funExpr
+        ( [
+            ( {txt = Ldot (Ldot (Lident "Js", "Fn"), _)},
+              {pexp_desc = Pexp_fun _} );
+          ],
+          None )
+    | Pexp_newtype _ ->
+      printArrow e
     | Pexp_record (rows, spreadExpr) ->
       if rows = [] then
         Doc.concat
@@ -56411,10 +56430,13 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl =
   | _ -> exprWithAwait
 
 and printPexpFun ~state ~inCallback e cmtTbl =
-  let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in
-  let ParsetreeViewer.{async; uncurried; attributes = attrs} =
+  let uncurried, attrsOnArrow, parameters, returnExpr =
+    ParsetreeViewer.funExpr e
+  in
+  let ParsetreeViewer.{async; bs; attributes = attrs} =
     ParsetreeViewer.processFunctionAttributes attrsOnArrow
   in
+  let uncurried = bs || uncurried in
   let returnExpr, typConstraint =
     match returnExpr.pexp_desc with
     | Pexp_constraint (expr, typ) ->