Use type function_param in Pexp_fun

CHANGES.md

@@ -21,6 +21,7 @@ profile. This started with version 0.26.0.
 - Fix invalid syntax generated with `ocp-indent-compat` (#2445, @Julow)
 - Fixed bug with attributes on sub-expressions of infix operators (#2459, @tdelvecchio-jsc)
 - \* Fix cinaps comment formatting to not change multiline string contents (#2463, @tdelvecchio-jsc)
+- Fix position of comments around function parameters (#2471, @gpetiot)
 
 ## 0.26.1 (2023-09-15)
 

lib/Ast.ml

@@ -177,7 +177,7 @@ module Exp = struct
       , (Non_apply | Sequence | Then | ThenElse) )
      |( { pexp_desc=
             ( Pexp_function _ | Pexp_match _ | Pexp_try _
-            | Pexp_fun (_, _, _, {pexp_desc= Pexp_constraint _; _}) )
+            | Pexp_fun (_, {pexp_desc= Pexp_constraint _; _}) )
         ; _ }
       , (Match | Let_match | Non_apply) )
      |( { pexp_desc=
@@ -1072,7 +1072,7 @@ end = struct
               let rec loop = function
                 | {pexp_desc= Pexp_newtype (_, e); _} -> loop e
                 | {pexp_desc= Pexp_constraint (_, t); _} -> t == typ
-                | {pexp_desc= Pexp_fun (_, _, _, e); _} -> loop e
+                | {pexp_desc= Pexp_fun (_, e); _} -> loop e
                 | _ -> false
               in
               (match topt with None -> false | Some t -> typ == t)
@@ -1237,6 +1237,11 @@ end = struct
     let check_bindings l =
       List.exists l ~f:(fun {pvb_pat; _} -> check_subpat pvb_pat)
     in
+    let check_function_param param =
+      match param.pparam_desc with
+      | Pparam_val (_, _, p) -> p == pat
+      | Pparam_newtype _ -> false
+    in
     match ctx with
     | Pld (PPat (p1, _)) -> assert (p1 == pat)
     | Pld _ -> assert false
@@ -1293,13 +1298,9 @@ end = struct
             List.exists cases ~f:(function
               | {pc_lhs; _} when pc_lhs == pat -> true
               | _ -> false ) )
-      | Pexp_for (p, _, _, _, _) | Pexp_fun (_, _, p, _) -> assert (p == pat)
-      )
-    | Fp ctx ->
-        assert (
-          match ctx.pparam_desc with
-          | Pparam_val (_, _, p) -> p == pat
-          | Pparam_newtype _ -> false )
+      | Pexp_for (p, _, _, _, _) -> assert (p == pat)
+      | Pexp_fun (p, _) -> assert (check_function_param p) )
+    | Fp ctx -> assert (check_function_param ctx)
     | Lb x -> assert (x.pvb_pat == pat)
     | Mb _ -> assert false
     | Md _ -> assert false
@@ -1346,6 +1347,11 @@ end = struct
       | PStr [{pstr_desc= Pstr_eval (e, _); _}] -> e == exp
       | _ -> false
     in
+    let check_function_param param =
+      match param.pparam_desc with
+      | Pparam_val (_, e, _) -> Option.exists e ~f:(fun x -> x == exp)
+      | Pparam_newtype _ -> false
+    in
     match ctx with
     | Pld (PPat (_, Some e1)) -> assert (e1 == exp)
     | Pld _ -> assert false
@@ -1374,8 +1380,8 @@ end = struct
                 | {pc_guard= Some g; _} when g == exp -> true
                 | {pc_rhs; _} when pc_rhs == exp -> true
                 | _ -> false ) )
-        | Pexp_fun (_, default, _, body) ->
-            assert (Option.value_map default ~default:false ~f || body == exp)
+        | Pexp_fun (param, body) ->
+            assert (check_function_param param || body == exp)
         | Pexp_indexop_access {pia_lhs; pia_kind= Builtin idx; pia_rhs; _} ->
             assert (
               pia_lhs == exp || idx == exp
@@ -1424,11 +1430,7 @@ end = struct
         | Pexp_for (_, e1, e2, _, e3) ->
             assert (e1 == exp || e2 == exp || e3 == exp)
         | Pexp_override e1N -> assert (List.exists e1N ~f:snd_f) )
-    | Fp ctx ->
-        assert (
-          match ctx.pparam_desc with
-          | Pparam_val (_, e, _) -> Option.exists e ~f:(fun x -> x == exp)
-          | Pparam_newtype _ -> false )
+    | Fp ctx -> assert (check_function_param ctx)
     | Lb x -> assert (x.pvb_expr == exp)
     | Mb _ -> assert false
     | Md _ -> assert false
@@ -1487,7 +1489,7 @@ end = struct
                 match x with
                 | {pexp_desc= Pexp_newtype (_, e); _} -> loop e
                 | {pexp_desc= Pexp_constraint (e, _); _} -> loop e
-                | {pexp_desc= Pexp_fun (_, _, _, e); _} -> loop e
+                | {pexp_desc= Pexp_fun (_, e); _} -> loop e
                 | _ -> false
               in
               loop e
@@ -1983,7 +1985,7 @@ end = struct
         match exp.pexp_desc with
         | Pexp_assert e
          |Pexp_construct (_, Some e)
-         |Pexp_fun (_, _, _, e)
+         |Pexp_fun (_, e)
          |Pexp_ifthenelse (_, Some e)
          |Pexp_prefix (_, e)
          |Pexp_infix (_, _, e)
@@ -2066,7 +2068,7 @@ end = struct
        |Pexp_newtype (_, e)
        |Pexp_open (_, e)
        |Pexp_letopen (_, e)
-       |Pexp_fun (_, _, _, e)
+       |Pexp_fun (_, e)
        |Pexp_sequence (_, e)
        |Pexp_setfield (_, _, e)
        |Pexp_setinstvar (_, e)

lib/Fmt_ast.ml

@@ -708,7 +708,12 @@ and type_constr_and_body c xbody =
         ~after:exp.pexp_loc ;
       let typ_ctx = Exp body in
       let exp_ctx =
-        Exp Ast_helper.(Exp.fun_ Nolabel None (Pat.any ()) exp)
+        let pat = Ast_helper.Pat.any () in
+        let param =
+          { pparam_desc= Pparam_val (Nolabel, None, pat)
+          ; pparam_loc= pat.ppat_loc }
+        in
+        Exp Ast_helper.(Exp.fun_ param exp)
       in
       ( Some (fmt_type_cstr c ~constraint_ctx:`Fun (sub_typ ~ctx:typ_ctx typ))
       , sub_exp ~ctx:exp_ctx exp )
@@ -1236,6 +1241,8 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
 and fmt_fun_args c args =
   let fmt_fun_arg (a : function_param) =
     let ctx = Fp a in
+    Cmts.fmt c a.pparam_loc
+    @@
     match a.pparam_desc with
     | Pparam_val
         ( ((Labelled l | Optional l) as lbl)
@@ -1963,7 +1970,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
         if parens || not dock_fun_arg then (noop, pro) else (pro, noop)
       in
       match last_arg.pexp_desc with
-      | Pexp_fun (_, _, _, eN1_body)
+      | Pexp_fun (_, eN1_body)
         when List.for_all args_before ~f:(fun (_, eI) ->
                  is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) ->
           (* Last argument is a [fun _ ->]. *)

lib/Sugar.ml

@@ -14,61 +14,35 @@ open Asttypes
 open Ast
 open Extended_ast
 
-(* Temporary. Won't be necessary once the type [function_param] is used in
-   [Pexp_fun] and [Pcl_fun]. *)
-let mk_function_param pparam_desc =
-  let pparam_loc =
-    let init, locs =
-      match pparam_desc with
-      | Pparam_val (lbl, e, p) ->
-          let locs =
-            match lbl with
-            | Nolabel -> []
-            | Labelled x -> [x.loc]
-            | Optional x -> [x.loc]
-          in
-          let locs =
-            match e with Some e -> e.pexp_loc :: locs | None -> locs
-          in
-          (p.ppat_loc, locs)
-      | Pparam_newtype types -> (
-        match types with
-        | [] -> failwith "Pparam_newtype always contains at least one type"
-        | hd :: tl ->
-            let locs = List.map tl ~f:(fun x -> x.loc) in
-            (hd.loc, locs) )
-    in
-    let min acc x = if Location.compare_start acc x < 0 then acc else x in
-    let max acc x = if Location.compare_end acc x > 0 then acc else x in
-    let loc_start = (List.fold_left locs ~init ~f:min).loc_start in
-    let loc_end = (List.fold_left locs ~init ~f:max).loc_end in
-    {Location.loc_start; loc_end; loc_ghost= true}
-  in
-  {pparam_desc; pparam_loc}
+let mk_function_param {Location.loc_start; _} {Location.loc_end; _} p =
+  let pparam_loc = {Location.loc_start; loc_end; loc_ghost= true} in
+  {pparam_desc= p; pparam_loc}
 
 let fun_ cmts ?(will_keep_first_ast_node = true) xexp =
   let rec fun_ ?(will_keep_first_ast_node = false) ({ast= exp; _} as xexp) =
     let ctx = Exp exp in
     let {pexp_desc; pexp_loc; pexp_attributes; _} = exp in
     if will_keep_first_ast_node || List.is_empty pexp_attributes then
       match pexp_desc with
-      | Pexp_fun (label, default, pattern, body) ->
+      | Pexp_fun (p, body) ->
           if not will_keep_first_ast_node then
-            Cmts.relocate cmts ~src:pexp_loc ~before:pattern.ppat_loc
+            Cmts.relocate cmts ~src:pexp_loc ~before:p.pparam_loc
               ~after:body.pexp_loc ;
           let xargs, xbody = fun_ (sub_exp ~ctx body) in
-          ( mk_function_param (Pparam_val (label, default, pattern)) :: xargs
-          , xbody )
+          (p :: xargs, xbody)
       | Pexp_newtype (name, body) ->
           if not will_keep_first_ast_node then
             Cmts.relocate cmts ~src:pexp_loc ~before:body.pexp_loc
               ~after:body.pexp_loc ;
           let xargs, xbody = fun_ (sub_exp ~ctx body) in
           let xargs =
             match xargs with
-            | {pparam_desc= Pparam_newtype names; _} :: xargs ->
-                mk_function_param (Pparam_newtype (name :: names)) :: xargs
-            | xargs -> mk_function_param (Pparam_newtype [name]) :: xargs
+            | {pparam_desc= Pparam_newtype names; pparam_loc} :: xargs ->
+                let param = Pparam_newtype (name :: names) in
+                mk_function_param name.loc pparam_loc param :: xargs
+            | xargs ->
+                let param = Pparam_newtype [name] in
+                mk_function_param name.loc name.loc param :: xargs
           in
           (xargs, xbody)
       | _ -> ([], xexp)
@@ -83,12 +57,12 @@ let cl_fun ?(will_keep_first_ast_node = true) cmts xexp =
     if will_keep_first_ast_node || List.is_empty pcl_attributes then
       match pcl_desc with
       | Pcl_fun (label, default, pattern, body) ->
+          let before = pattern.ppat_loc and after = body.pcl_loc in
           if not will_keep_first_ast_node then
-            Cmts.relocate cmts ~src:pcl_loc ~before:pattern.ppat_loc
-              ~after:body.pcl_loc ;
+            Cmts.relocate cmts ~src:pcl_loc ~before ~after ;
           let xargs, xbody = fun_ (sub_cl ~ctx body) in
-          ( mk_function_param (Pparam_val (label, default, pattern)) :: xargs
-          , xbody )
+          let param = Pparam_val (label, default, pattern) in
+          (mk_function_param before after param :: xargs, xbody)
       | _ -> ([], xexp)
     else ([], xexp)
   in
@@ -230,7 +204,11 @@ module Let_binding = struct
              won't be necessary once the normalization is moved to
              [Extended_ast]. *)
           let pat = Ast_helper.Pat.any () in
-          Exp (Ast_helper.Exp.fun_ Nolabel None pat exp)
+          let param =
+            { pparam_desc= Pparam_val (Nolabel, None, pat)
+            ; pparam_loc= pat.ppat_loc }
+          in
+          Exp (Ast_helper.Exp.fun_ param exp)
         in
         (xargs, `Other (sub_typ ~ctx:typ_ctx typ), sub_exp ~ctx:exp_ctx exp)
     (* The type constraint is always printed before the declaration for

test/passing/tests/class_expr.ml

@@ -3,3 +3,5 @@ class c (`I i) = x
 class c `I = x
 
 class c i = x
+
+class c (* xx *) i (* yy *) = x