Fix printing of comments on Ptyp_arrow with labels.

Fixes #200

Author: Iwan

src/res_comments_table.ml

@@ -1279,13 +1279,12 @@ let rec walkStructure s t comments =
       attach t.trailing callExpr.pexp_loc afterExpr;
       walkList
         ~getLoc:(fun (_argLabel, expr) ->
-          let loc = match expr.Parsetree.pexp_attributes with
+          match expr.Parsetree.pexp_attributes with
           | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs ->
               {loc with loc_end = expr.pexp_loc.loc_end}
           | _ ->
              expr.pexp_loc
-          in
-          loc)
+          )
         ~walkNode:walkExprArgument
         arguments
         t
@@ -1840,7 +1839,13 @@ and walkExprArgument (_argLabel, expr) t comments =
 
   and walkTypeParameters typeParameters t comments =
     visitListButContinueWithRemainingComments
-      ~getLoc:(fun (_, _, typexpr) -> typexpr.Parsetree.ptyp_loc)
+      ~getLoc:(fun (_, _, typexpr) ->
+        match typexpr.Parsetree.ptyp_attributes with
+        | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs ->
+            {loc with loc_end = typexpr.ptyp_loc.loc_end}
+        | _ ->
+          typexpr.ptyp_loc
+      )
       ~walkNode:walkTypeParameter
       ~newlineDelimited:false
       typeParameters

src/res_core.ml

@@ -3828,9 +3828,13 @@ and parseTypeParameter p =
     match p.Parser.token with
     | Tilde ->
       Parser.next p;
-      let (name, _loc) = parseLident p in
+      let (name, loc) = parseLident p in
+      let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in
       Parser.expect ~grammar:Grammar.TypeExpression Colon p;
-      let typ = parseTypExpr p in
+      let typ =
+        let typ = parseTypExpr p in
+        {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes}
+      in
       begin match p.Parser.token with
       | Equal ->
         Parser.next p;
@@ -3899,9 +3903,13 @@ and parseEs6ArrowType ~attrs p =
   match p.Parser.token with
   | Tilde ->
     Parser.next p;
-    let (name, _loc) = parseLident p in
+    let (name, loc) = parseLident p in
+    let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in
     Parser.expect ~grammar:Grammar.TypeExpression Colon p;
-    let typ = parseTypExpr ~alias:false ~es6Arrow:false p in
+    let typ =
+      let typ = parseTypExpr ~alias:false ~es6Arrow:false p in
+      {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes}
+    in
     let arg = match p.Parser.token with
     | Equal ->
       Parser.next p;
@@ -3912,7 +3920,8 @@ and parseEs6ArrowType ~attrs p =
     in
     Parser.expect EqualGreater p;
     let returnType = parseTypExpr ~alias:false p in
-    Ast_helper.Typ.arrow ~attrs arg typ returnType
+    let loc = mkLoc startPos p.prevEndPos in
+    Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType
   | _ ->
     let parameters = parseTypeParameters p in
     Parser.expect EqualGreater p;

src/res_printer.ml

@@ -1612,7 +1612,9 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl =
             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 tp cmtTbl) args
+              List.map (fun tp ->
+                printTypeParameter tp cmtTbl
+              ) args
             )
           ]
         );
@@ -1812,6 +1814,11 @@ and printTypeParameter (attrs, lbl, typ) cmtTbl =
   | Labelled _ -> Doc.nil
   | Optional _lbl -> Doc.text "=?"
   in
+  let (loc, typ) = match typ.ptyp_attributes with
+  | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs ->
+    ({loc with loc_end = typ.ptyp_loc.loc_end}, {typ with ptyp_attributes = attrs})
+  | _ -> (typ.ptyp_loc, typ)
+  in
   let doc = Doc.group (
     Doc.concat [
       uncurried;
@@ -1821,7 +1828,7 @@ and printTypeParameter (attrs, lbl, typ) cmtTbl =
       optionalIndicator;
     ]
   ) in
-  printComments doc cmtTbl typ.ptyp_loc
+  printComments doc cmtTbl loc
 
 and printValueBinding ~recFlag vb cmtTbl i =
   let (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr vb.pvb_attributes in

tests/parsing/errors/other/__snapshots__/parse.spec.js.snap

@@ -95,7 +95,8 @@ exports[`patternMatching.js 1`] = `
 exports[`regionMissingComma.res 1`] = `
 "=====Parsetree==========================================
 external make :
-  ?style:ReactDOMRe.Style.t -> ((?image:bool -> React.element)[@bs ]) =
+  ?style:((ReactDOMRe.Style.t)[@ns.namedArgLoc ]) ->
+    ((?image:((bool)[@ns.namedArgLoc ]) -> React.element)[@bs ]) =
     \\"ModalContent\\"
 type nonrec 'extraInfo student =
   {

tests/parsing/errors/typexpr/__snapshots__/parse.spec.js.snap

@@ -8,14 +8,16 @@ module Error2 =
     type nonrec observation =
       {
       observed: int ;
-      onStep: currentValue:unit -> [%rescript.typehole ] }
+      onStep:
+        currentValue:((unit)[@ns.namedArgLoc ]) -> [%rescript.typehole ] }
   end
 module Error3 =
   struct
     type nonrec observation =
       {
       observed: int ;
-      onStep: currentValue:unit -> [%rescript.typehole ] }
+      onStep:
+        currentValue:((unit)[@ns.namedArgLoc ]) -> [%rescript.typehole ] }
   end
 =====Errors=============================================
 
@@ -206,8 +208,8 @@ type nonrec websocket = < id: [%rescript.typehole ]   >  Js.t
 
 exports[`garbage.res 1`] = `
 "=====Parsetree==========================================
-external printName : name:unit -> unit = \\"printName\\"[@@bs.module
-                                                      \\"moduleName\\"]
+external printName : name:((unit)[@ns.namedArgLoc ]) -> unit = \\"printName\\"
+[@@bs.module \\"moduleName\\"]
 =====Errors=============================================
 
   Syntax error!

tests/parsing/grammar/signature/__snapshots__/parse.spec.js.snap

@@ -22,7 +22,8 @@ exports[`external.js 1`] = `
 "module type Signature  =
   sig
     type nonrec t
-    external linkProgram : t -> program:webGlProgram -> unit = \\"linkProgram\\"
+    external linkProgram :
+      t -> program:((webGlProgram)[@ns.namedArgLoc ]) -> unit = \\"linkProgram\\"
     [@@bs.send ]
     external add_nat :
       nat -> int -> int -> int = \\"add_nat_bytecode\\" \\"add_nat_native\\"

tests/parsing/grammar/structure/__snapshots__/parse.spec.js.snap

@@ -35,7 +35,9 @@ exports[`externalDefinition.js 1`] = `
 "external clear : t -> int -> unit = \\"clear\\"
 external add_nat : nat -> int = \\"add_nat_bytecode\\" \\"add_nat_native\\"
 external attachShader :
-  t -> program:webGlProgram -> shader:webGlShader -> unit = \\"attachShader\\"
+  t ->
+    program:((webGlProgram)[@ns.namedArgLoc ]) ->
+      shader:((webGlShader)[@ns.namedArgLoc ]) -> unit = \\"attachShader\\"
 [@@bs.send ]
 external svg : unit -> React.element = \\"svg\\"
 external svg : unit -> React.element = \\"svg\\"

tests/parsing/grammar/typedefinition/__snapshots__/parse.spec.js.snap

@@ -166,7 +166,8 @@ type nonrec t = private int
 type nonrec t = private int -> int
 type nonrec t = private int -> int
 type nonrec t = private int -> int -> int
-type nonrec t = private int -> x:string -> float -> unit
+type nonrec t = private
+  int -> x:((string)[@ns.namedArgLoc ]) -> float -> unit
 type nonrec t = private string as 'x
 type nonrec t = private [%ext ]
 type nonrec t = private [%ext \\"console.log\\"]

tests/parsing/grammar/typexpr/__snapshots__/parse.spec.js.snap

@@ -54,33 +54,46 @@ exports[`es6Arrow.js 1`] = `
 "type nonrec t = x -> unit
 type nonrec t = x -> unit
 type nonrec t = int -> string -> unit
-type nonrec t = a:int -> b:int -> int
-type nonrec t = ?a:int -> ?b:int -> int
+type nonrec t =
+  a:((int)[@ns.namedArgLoc ]) -> b:((int)[@ns.namedArgLoc ]) -> int
+type nonrec t =
+  ?a:((int)[@ns.namedArgLoc ]) -> ?b:((int)[@ns.namedArgLoc ]) -> int
 type nonrec t = int -> int -> int -> int
-type nonrec t = a:int -> b:int -> c:int -> int
+type nonrec t =
+  a:((int)[@ns.namedArgLoc ]) ->
+    b:((int)[@ns.namedArgLoc ]) -> c:((int)[@ns.namedArgLoc ]) -> int
 let (f : x -> unit) = xf
 let (f : x -> unit) = xf
 let (f : int -> string -> unit) = xf
-let (t : a:int -> b:int -> int) = xf
-let (t : ?a:int -> ?b:int -> int) = xf
+let (t : a:((int)[@ns.namedArgLoc ]) -> b:((int)[@ns.namedArgLoc ]) -> int) =
+  xf
+let (t : ?a:((int)[@ns.namedArgLoc ]) -> ?b:((int)[@ns.namedArgLoc ]) -> int)
+  = xf
 let (t : int -> int -> int -> int) = xf
-let (t : a:int -> b:int -> c:int -> int) = xf
-type nonrec t = f:int -> string
-type nonrec t = ?f:int -> string
-let (f : f:int -> string) = fx
-let (f : ?f:int -> string) = fx
-type nonrec t = f:int -> string
-type nonrec t = f:int -> string
-type nonrec t = f:(int -> string) -> float
-type nonrec t = f:(int -> string) -> float
-type nonrec t = f:int -> string -> float
+let (t :
+  a:((int)[@ns.namedArgLoc ]) ->
+    b:((int)[@ns.namedArgLoc ]) -> c:((int)[@ns.namedArgLoc ]) -> int)
+  = xf
+type nonrec t = f:((int)[@ns.namedArgLoc ]) -> string
+type nonrec t = ?f:((int)[@ns.namedArgLoc ]) -> string
+let (f : f:((int)[@ns.namedArgLoc ]) -> string) = fx
+let (f : ?f:((int)[@ns.namedArgLoc ]) -> string) = fx
+type nonrec t = f:((int)[@ns.namedArgLoc ]) -> string
+type nonrec t = f:((int)[@ns.namedArgLoc ]) -> string
+type nonrec t = f:((int -> string)[@ns.namedArgLoc ]) -> float
+type nonrec t = f:((int -> string)[@ns.namedArgLoc ]) -> float
+type nonrec t = f:((int)[@ns.namedArgLoc ]) -> string -> float
 type nonrec t =
-  ((a:int -> ((b:int -> ((float)[@attr ]) -> unit)[@attrBeforeLblB ]))
+  ((a:((int)[@ns.namedArgLoc ]) ->
+      ((b:((int)[@ns.namedArgLoc ]) -> ((float)[@attr ]) -> unit)[@attrBeforeLblB
+                                                                   ]))
   [@attrBeforeLblA ])
 type nonrec t =
-  ((a:int -> ((b:int -> ((float)[@attr ]) -> unit)[@attrBeforeLblB ]))
+  ((a:((int)[@ns.namedArgLoc ]) ->
+      ((b:((int)[@ns.namedArgLoc ]) -> ((float)[@attr ]) -> unit)[@attrBeforeLblB
+                                                                   ]))
   [@attrBeforeLblA ])
-type nonrec t = ((a:int -> unit)[@attr ])
+type nonrec t = ((a:((int)[@ns.namedArgLoc ]) -> unit)[@attr ])
 type nonrec 'a getInitialPropsFn =
   < query: string Js.Dict.t  ;req: 'a Js.t Js.Nullable.t   >  Js.t ->
     'a Js.t Js.Promise.t"
@@ -106,7 +119,7 @@ type nonrec t = (module Console) ref
 let (devices : (string, (module DEVICE)) Hastbl.t) = Hashtbl.creat 17"
 `;
 
-exports[`parenthesized.js 1`] = `"type nonrec t = ((a:int -> unit)[@attr ])"`;
+exports[`parenthesized.js 1`] = `"type nonrec t = ((a:((int)[@ns.namedArgLoc ]) -> unit)[@attr ])"`;
 
 exports[`poly.js 1`] = `
 "external getLogger :

tests/printer/comments/__snapshots__/render.spec.js.snap

@@ -1808,16 +1808,36 @@ type add = /* before */ (
   /* c2 */ int /* c3 */,
 ) => /* before return */ int /* after */
 type add = /* before */ (
-  ~a: /* c0 */ int /* c1 */,
-  ~b: /* c2 */ int /* c3 */,
+  /* c0 */ ~a: int /* c1 */,
+  /* c2 */ ~b: int /* c3 */,
 ) => /* before return */ int /* after */
 type multiply = /* before */ (
-  ~fn: /* c0 */ (
+  /* c0 */ ~fn: (
     /* cinner0 */ int /* cinner1 */,
     /* cinner2 */ int /* cinner3 */,
   ) => /* cx */ int /* c1 */,
-  ~b: /* c2 */ int /* c3 */,
+  /* c2 */ ~b: int /* c3 */,
 ) => int /* after */
+type make = (
+  ~activity: ActivityFlow_Activity.t,
+  ~showExpert: (string, string) => unit,
+  ~showCognitiveAspect: string => unit,
+  ~next: (string, string, array<string>) => unit,
+  ~hapticFeedback: unit => unit,
+  ~participants: Belt.Set.String.t,
+  // here
+
+  // above
+  /* c0 */ ~openPhotoFeed: /* c1 */ (
+    /* c2 */ ~feedId: /* c3 */ option<string> /* c4 */,
+    /* c5 */ unit /* c6 */,
+  ) => /* c7 */ unit /* c8 */,
+  // only provide this when it shows a random activity
+  ~getAnother: unit => unit=?,
+) => React.element
+
+type f = /* c0 */ (~a: /* c1 */ int /* c2 */) => /* c3 */ int /* c4 */
+type f = (/* c0 */ ~a: /* c1 */ int /* c2 */) => /* c3 */ int /* c4 */
 
 // Ptyp_object
 type jsUser = /* before */ {