From 98cea4fe5dcb969564059a875ecc763b81a9b131 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 2 Nov 2022 13:29:59 +0100 Subject: [PATCH 1/3] Process uncurried types explicity. Produce directly `Js.Fn.arityn` instead of a `@bs` annotation. See https://github.com/rescript-lang/syntax/issues/716 --- src/res_core.ml | 29 +++- src/res_printer.ml | 149 +++++++++--------- .../other/expected/regionMissingComma.res.txt | 2 +- .../typexpr/expected/uncurried.res.txt | 32 ++-- tests/printer/typexpr/expected/arrow.res.txt | 2 +- 5 files changed, 122 insertions(+), 92 deletions(-) diff --git a/src/res_core.ml b/src/res_core.ml index e4048594..041182bc 100644 --- a/src/res_core.ml +++ b/src/res_core.ml @@ -4139,9 +4139,32 @@ 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 rec typeArity (t : Parsetree.core_type) = + match t.ptyp_desc with + | Ptyp_arrow (_, _, tRet) -> 1 + typeArity tRet + | _ -> 0 + in + let isUnit = + match typ.ptyp_desc with + | Ptyp_constr ({txt = Lident "unit"}, []) -> true + | _ -> false + in + let arity = 1 + typeArity t 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..04d8457e 100644 --- a/src/res_printer.ml +++ b/src/res_printer.ml @@ -1568,6 +1568,79 @@ 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 + let _uncurried, attrs = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not uncurried -> + 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 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 +1667,10 @@ 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 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 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" From fbacc51c71525bac395dfddcdac4b3a11902721a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 2 Nov 2022 14:13:10 +0100 Subject: [PATCH 2/3] Cleanup --- src/res_core.ml | 8 ++------ src/res_printer.ml | 3 ++- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/res_core.ml b/src/res_core.ml index 041182bc..e6ef0e24 100644 --- a/src/res_core.ml +++ b/src/res_core.ml @@ -4141,17 +4141,13 @@ and parseEs6ArrowType ~attrs p = List.fold_right (fun (uncurried, attrs, argLbl, (typ : Parsetree.core_type), startPos) t -> if uncurried then - let rec typeArity (t : Parsetree.core_type) = - match t.ptyp_desc with - | Ptyp_arrow (_, _, tRet) -> 1 + typeArity tRet - | _ -> 0 - in let isUnit = match typ.ptyp_desc with | Ptyp_constr ({txt = Lident "unit"}, []) -> true | _ -> false in - let arity = 1 + typeArity t 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 diff --git a/src/res_printer.ml b/src/res_printer.ml index 04d8457e..24a584de 100644 --- a/src/res_printer.ml +++ b/src/res_printer.ml @@ -1669,7 +1669,8 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = 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 arity 0 5 = "arity" -> + 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)}]) -> From a2e267fd9f02c5fd37f60d61a78d9f9afc51773e Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 2 Nov 2022 15:00:05 +0100 Subject: [PATCH 3/3] Remove unnecessary check for uncurried attributes in type printing. --- src/res_printer.ml | 19 +++++-------------- 1 file changed, 5 insertions(+), 14 deletions(-) diff --git a/src/res_printer.ml b/src/res_printer.ml index 24a584de..906cba38 100644 --- a/src/res_printer.ml +++ b/src/res_printer.ml @@ -1580,13 +1580,10 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in - let _uncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in match args with | [] -> Doc.nil | [([], Nolabel, n)] when not uncurried -> - let hasAttrsBefore = not (attrs = []) in + let hasAttrsBefore = not (attrsBefore = []) in let attrs = if hasAttrsBefore then printAttributes ~customLayout ~inline:true attrsBefore cmtTbl @@ -1616,7 +1613,9 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = else Doc.concat [typDoc; Doc.text " => "; returnDoc]); ]) | args -> - let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in + let attrs = + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl + in let renderedArgs = Doc.concat [ @@ -1918,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 @@ -1947,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