From 4d08217f0390a65ac99b8429e9d3588123430dd0 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 19 Nov 2022 08:14:40 +0100 Subject: [PATCH] Fix issue in printing uncurried callbacks. They did not print the same way as curried ones. --- CHANGELOG.md | 1 + lib/4.06.1/unstable/js_compiler.ml | 98 ++++++++++++------- lib/4.06.1/unstable/js_playground_compiler.ml | 98 ++++++++++++------- lib/4.06.1/whole_compiler.ml | 98 ++++++++++++------- res_syntax/src/res_parens.ml | 4 +- res_syntax/src/res_parsetree_viewer.ml | 54 +++++----- res_syntax/src/res_parsetree_viewer.mli | 6 +- res_syntax/src/res_printer.ml | 34 ++++--- .../tests/printer/expr/UncurriedByDefault.res | 16 +++ .../expr/expected/UncurriedByDefault.res.txt | 16 +++ .../printer/expr/expected/callback.res.txt | 6 +- 11 files changed, 277 insertions(+), 154 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b69c90cefd..79725ddf38 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index ca6072576a..ac890e7f44 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/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) -> diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 3b78c6b2be..41d8027dc3 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_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) -> diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 3d67e9a8c7..6ed555ffa2 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -104432,7 +104432,7 @@ val processBsAttribute : Parsetree.attributes -> bool * Parsetree.attributes type functionAttributesInfo = { async: bool; - uncurried: bool; + bs: bool; attributes: Parsetree.attributes; } @@ -104468,7 +104468,7 @@ type funParamKind = val funExpr : Parsetree.expression -> - Parsetree.attributes * funParamKind list * Parsetree.expression + bool * Parsetree.attributes * funParamKind list * Parsetree.expression (* example: * `makeCoordinate({ @@ -104568,6 +104568,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 @@ -104631,18 +104633,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 @@ -104709,7 +104710,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 = @@ -104719,29 +104720,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 @@ -105100,12 +105105,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 @@ -105114,12 +105126,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 = @@ -107487,8 +107499,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 @@ -109646,7 +109658,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 @@ -110063,7 +110074,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}] -> @@ -110701,12 +110714,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) -> @@ -111031,11 +111046,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 @@ -111409,10 +111428,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) -> diff --git a/res_syntax/src/res_parens.ml b/res_syntax/src/res_parens.ml index ad034b59bb..0e53e9720d 100644 --- a/res_syntax/src/res_parens.ml +++ b/res_syntax/src/res_parens.ml @@ -301,8 +301,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 diff --git a/res_syntax/src/res_parsetree_viewer.ml b/res_syntax/src/res_parsetree_viewer.ml index fd9a26df50..0cfbed1141 100644 --- a/res_syntax/src/res_parsetree_viewer.ml +++ b/res_syntax/src/res_parsetree_viewer.ml @@ -59,18 +59,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 @@ -137,7 +136,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 = @@ -147,29 +146,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 @@ -528,12 +531,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 @@ -542,12 +552,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 = diff --git a/res_syntax/src/res_parsetree_viewer.mli b/res_syntax/src/res_parsetree_viewer.mli index d13d21537e..7d513d8339 100644 --- a/res_syntax/src/res_parsetree_viewer.mli +++ b/res_syntax/src/res_parsetree_viewer.mli @@ -19,7 +19,7 @@ val processBsAttribute : Parsetree.attributes -> bool * Parsetree.attributes type functionAttributesInfo = { async: bool; - uncurried: bool; + bs: bool; attributes: Parsetree.attributes; } @@ -55,7 +55,7 @@ type funParamKind = val funExpr : Parsetree.expression -> - Parsetree.attributes * funParamKind list * Parsetree.expression + bool * Parsetree.attributes * funParamKind list * Parsetree.expression (* example: * `makeCoordinate({ @@ -154,3 +154,5 @@ val isUnderscoreApplySugar : Parsetree.expression -> bool val hasIfLetAttribute : Parsetree.attributes -> bool val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool + +val isFunNewtype : Parsetree.expression_desc -> bool diff --git a/res_syntax/src/res_printer.ml b/res_syntax/src/res_printer.ml index 4773840fac..54c246f2ab 100644 --- a/res_syntax/src/res_printer.ml +++ b/res_syntax/src/res_printer.ml @@ -1549,7 +1549,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 @@ -1966,7 +1965,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}] -> @@ -2604,12 +2605,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) -> @@ -2934,11 +2937,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 @@ -3312,10 +3319,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) -> diff --git a/res_syntax/tests/printer/expr/UncurriedByDefault.res b/res_syntax/tests/printer/expr/UncurriedByDefault.res index 8e7e19641d..57b68248e0 100644 --- a/res_syntax/tests/printer/expr/UncurriedByDefault.res +++ b/res_syntax/tests/printer/expr/UncurriedByDefault.res @@ -36,6 +36,14 @@ type unested = (. (. string) => unit) => unit let pipe = a->foo(. b, c) +let _ = setTimeout(. (. ()) => { + resolve(. 1) +}, 100) + +let _ = setTimeout(() => { + resolve(1) +}, 100) + @@uncurried let cApp = foo(. 3) @@ -76,3 +84,11 @@ type cnested = (. (. string) => unit) => unit type unested = (string => unit) => unit let pipe = a->foo(b, c) + +let _ = setTimeout(() => { + resolve(1) +}, 100) + +let _ = setTimeout(. (. ()) => { + resolve(. 1) +}, 100) diff --git a/res_syntax/tests/printer/expr/expected/UncurriedByDefault.res.txt b/res_syntax/tests/printer/expr/expected/UncurriedByDefault.res.txt index b23f25a1a4..289375f314 100644 --- a/res_syntax/tests/printer/expr/expected/UncurriedByDefault.res.txt +++ b/res_syntax/tests/printer/expr/expected/UncurriedByDefault.res.txt @@ -36,6 +36,14 @@ type unested = (. (. string) => unit) => unit let pipe = a->foo(. b, c) +let _ = setTimeout(. (. ()) => { + resolve(. 1) +}, 100) + +let _ = setTimeout(() => { + resolve(1) +}, 100) + @@uncurried let cApp = foo(. 3) @@ -76,3 +84,11 @@ type cnested = (. (. string) => unit) => unit type unested = (string => unit) => unit let pipe = a->foo(b, c) + +let _ = setTimeout(() => { + resolve(1) +}, 100) + +let _ = setTimeout(. (. ()) => { + resolve(. 1) +}, 100) diff --git a/res_syntax/tests/printer/expr/expected/callback.res.txt b/res_syntax/tests/printer/expr/expected/callback.res.txt index f6250dbbe4..50393c396b 100644 --- a/res_syntax/tests/printer/expr/expected/callback.res.txt +++ b/res_syntax/tests/printer/expr/expected/callback.res.txt @@ -62,7 +62,8 @@ let _ = { let trees = possibilities->Belt.Array.mapU((. combination) => - combination->Belt.Array.reduceU(Nil, (. tree, curr) => tree->insert(curr))) + combination->Belt.Array.reduceU(Nil, (. tree, curr) => tree->insert(curr)) + ) let set = mapThatHasAVeryLongName->Belt.Map.String.getExn(website)->Belt.Set.Int.add(user) @@ -83,7 +84,8 @@ let add2 = (y: coll, e: key) => let add2 = (y: coll, e: key) => if ( possibilities->Belt.Array.mapU((. combination) => - combination->Belt.Array.reduceU(Nil, (. tree, curr) => tree->insert(curr))) + combination->Belt.Array.reduceU(Nil, (. tree, curr) => tree->insert(curr)) + ) ) { y } else {