diff --git a/src/res_core.ml b/src/res_core.ml index e4048594..e6ef0e24 100644 --- a/src/res_core.ml +++ b/src/res_core.ml @@ -4139,9 +4139,28 @@ and parseEs6ArrowType ~attrs p = let endPos = p.prevEndPos in let typ = List.fold_right - (fun (uncurried, attrs, argLbl, typ, startPos) t -> - let attrs = if uncurried then uncurryAttr :: attrs else attrs in - Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t) + (fun (uncurried, attrs, argLbl, (typ : Parsetree.core_type), startPos) t -> + if uncurried then + let isUnit = + match typ.ptyp_desc with + | Ptyp_constr ({txt = Lident "unit"}, []) -> true + | _ -> false + in + let _, args, _ = Res_parsetree_viewer.arrowType t in + let arity = 1 + List.length args in + let arity = if isUnit && arity = 1 then 0 else arity in + let loc = mkLoc startPos endPos in + let tArg = Ast_helper.Typ.arrow ~loc ~attrs argLbl typ t in + Ast_helper.Typ.constr ~loc + { + txt = + Ldot (Ldot (Lident "Js", "Fn"), "arity" ^ string_of_int arity); + loc; + } + [tArg] + else + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ + t) parameters returnType in { diff --git a/src/res_printer.ml b/src/res_printer.ml index 9793485f..906cba38 100644 --- a/src/res_printer.ml +++ b/src/res_printer.ml @@ -1568,6 +1568,78 @@ and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) ]) and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = + let printArrow ~uncurried typExpr = + let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in + let returnTypeNeedsParens = + match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr ~customLayout returnType cmtTbl in + if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not uncurried -> + let hasAttrsBefore = not (attrsBefore = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + else Doc.nil + in + let typDoc = + let doc = printTypExpr ~customLayout n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if hasAttrsBefore then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + ]) + | args -> + let attrs = + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if uncurried then Doc.concat [Doc.dot; Doc.space] + else Doc.nil); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> printTypeParameter ~customLayout tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc]) + in let renderedType = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" @@ -1594,6 +1666,11 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = (* object printings *) | Ptyp_object (fields, openFlag) -> printObject ~customLayout ~inline:false fields openFlag cmtTbl + | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr + | Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Fn"), arity)}, [tArg]) + when String.length arity >= 5 + && (String.sub [@doesNotRaise]) arity 0 5 = "arity" -> + printArrow ~uncurried:true tArg | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we @@ -1641,78 +1718,6 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = Doc.softLine; Doc.greaterThan; ])) - | Ptyp_arrow _ -> ( - let attrsBefore, args, returnType = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = - match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~customLayout n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ -> doc - in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); - ]) - | args -> - let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if isUncurried then Doc.concat [Doc.dot; Doc.space] - else Doc.nil); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun tp -> printTypeParameter ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) | Ptyp_tuple types -> printTupleType ~customLayout ~inline:false types cmtTbl | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl @@ -1912,10 +1917,6 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = * type t = (~foo: string, ~bar: float=?, unit) => unit * i.e. ~foo: string, ~bar: float *) and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = - let isUncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrs in - let uncurried = - if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil - in let attrs = printAttributes ~customLayout attrs cmtTbl in let label = match lbl with @@ -1941,11 +1942,7 @@ and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = Doc.group (Doc.concat [ - uncurried; - attrs; - label; - printTypExpr ~customLayout typ cmtTbl; - optionalIndicator; + attrs; label; printTypExpr ~customLayout typ cmtTbl; optionalIndicator; ]) in printComments doc cmtTbl loc diff --git a/tests/parsing/errors/other/expected/regionMissingComma.res.txt b/tests/parsing/errors/other/expected/regionMissingComma.res.txt index bb52d088..32b0e6ae 100644 --- a/tests/parsing/errors/other/expected/regionMissingComma.res.txt +++ b/tests/parsing/errors/other/expected/regionMissingComma.res.txt @@ -24,7 +24,7 @@ external make : ?style:((ReactDOMRe.Style.t)[@ns.namedArgLoc ]) -> - ((?image:((bool)[@ns.namedArgLoc ]) -> React.element)[@bs ]) = + (?image:((bool)[@ns.namedArgLoc ]) -> React.element) Js.Fn.arity1 = "ModalContent" type nonrec 'extraInfo student = { diff --git a/tests/parsing/grammar/typexpr/expected/uncurried.res.txt b/tests/parsing/grammar/typexpr/expected/uncurried.res.txt index d7c79b79..bf3909e3 100644 --- a/tests/parsing/grammar/typexpr/expected/uncurried.res.txt +++ b/tests/parsing/grammar/typexpr/expected/uncurried.res.txt @@ -1,20 +1,22 @@ type nonrec t = { - mutable field: ((float -> int -> bool -> unit)[@bs ]) } -type nonrec t = ((float -> int -> bool -> unit)[@bs ]) + mutable field: (float -> int -> bool -> unit) Js.Fn.arity3 } +type nonrec t = (float -> int -> bool -> unit) Js.Fn.arity3 type nonrec t = - ((((float)[@attr ]) -> - ((int)[@attr2 ]) -> - ((((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit)[@bs ]))[@bs ]) + (((float)[@attr ]) -> + ((int)[@attr2 ]) -> + (((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit) Js.Fn.arity2) + Js.Fn.arity2 type nonrec t = - ((float -> - ((int)[@attr2 ]) -> - ((bool -> ((string)[@attr4 ]) -> unit)[@bs ][@attr3 ]))[@bs ] - [@attr ]) + (((float -> + ((int)[@attr2 ]) -> + (((bool -> ((string)[@attr4 ]) -> unit) Js.Fn.arity2)[@attr3 ])) + Js.Fn.arity2)[@attr ]) type nonrec t = - ((((float)[@attr ]) -> - ((int)[@attr2 ]) -> - ((((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit)[@bs ]))[@bs ]) -external setTimeout : ((unit -> unit)[@bs ]) -> int -> timerId = "setTimeout" -[@@bs.val ] + (((float)[@attr ]) -> + ((int)[@attr2 ]) -> + (((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit) Js.Fn.arity2) + Js.Fn.arity2 external setTimeout : - (((unit -> unit) -> int -> timerId)[@bs ]) = "setTimeout" \ No newline at end of file + (unit -> unit) Js.Fn.arity0 -> int -> timerId = "setTimeout"[@@bs.val ] +external setTimeout : + ((unit -> unit) -> int -> timerId) Js.Fn.arity2 = "setTimeout" \ No newline at end of file diff --git a/tests/printer/typexpr/expected/arrow.res.txt b/tests/printer/typexpr/expected/arrow.res.txt index 4253ff51..2c29260a 100644 --- a/tests/printer/typexpr/expected/arrow.res.txt +++ b/tests/printer/typexpr/expected/arrow.res.txt @@ -211,7 +211,7 @@ type t = (. int, int) => (. int, int) => int type t = (. @attr int) => unit type t = (. @attr int) => (. @attr2 int) => unit type t = (. @attrOnInt int, @attrOnInt int) => (. @attrOnInt int, @attrOnInt int) => int -type t = (. @attr ~x: int, ~y: int, . @attr ~z: int, @attr ~omega: int) => unit +type t = (. @attr ~x: int, ~y: int) => (. @attr ~z: int, @attr ~omega: int) => unit @val external requestAnimationFrame: (float => unit) => unit = "requestAnimationFrame" @val external requestAnimationFrame: @attr ((float => unit) => unit) = "requestAnimationFrame"