Syntax: process uncurried types explicitly in the parser/printer.

cristianoc · cristianoc · commit 032c86dc7e72 · 2022-11-08T07:43:22.000+01:00
Moved from rescript-lang/syntax#717
diff --git a/res_syntax/src/res_core.ml b/res_syntax/src/res_core.ml
@@ -4144,9 +4144,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/res_syntax/src/res_printer.ml b/res_syntax/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/res_syntax/tests/parsing/errors/other/expected/regionMissingComma.res.txt b/res_syntax/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/res_syntax/tests/parsing/grammar/typexpr/expected/uncurried.res.txt b/res_syntax/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"
+  (unit -> unit) Js.Fn.arity0 -> int -> timerId = "setTimeout"[@@bs.val ]
+external setTimeout :
+  ((unit -> unit) -> int -> timerId) Js.Fn.arity2 = "setTimeout"
diff --git a/res_syntax/tests/printer/typexpr/expected/arrow.res.txt b/res_syntax/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"

Original file line number	Diff line number	Diff line change
`@@ -24,7 +24,7 @@`
`24`	`24`
`25`	`25`	`external make :`
`26`	`26`	`?style:((ReactDOMRe.Style.t)[@ns.namedArgLoc ]) ->`
`27`		`- ((?image:((bool)[@ns.namedArgLoc ]) -> React.element)[@bs ]) =`
	`27`	`+ (?image:((bool)[@ns.namedArgLoc ]) -> React.element) Js.Fn.arity1 =`
`28`	`28`	`"ModalContent"`
`29`	`29`	`type nonrec 'extraInfo student =`
`30`	`30`	`{`