Use type function_param in Pcl_fun (#2498)

Author: gpetiot

lib/Ast.ml

@@ -302,7 +302,7 @@ module Cl = struct
     | Pcl_structure {pcstr_fields= _ :: _; _}
      |Pcl_let _ | Pcl_open _ | Pcl_extension _ ->
         false
-    | Pcl_apply (e, _) | Pcl_fun (_, _, _, e) -> is_simple e
+    | Pcl_apply (e, _) | Pcl_fun (_, e) -> is_simple e
     | Pcl_constraint (e, t) -> is_simple e && Cty.is_simple t
 
   (** [mem_cls cls cl] holds if [cl] is in the named class of expressions
@@ -1125,7 +1125,7 @@ end = struct
             List.exists l ~f:(fun {pci_expr; _} ->
                 let rec loop x =
                   match x.pcl_desc with
-                  | Pcl_fun (_, _, _, x) -> loop x
+                  | Pcl_fun (_, x) -> loop x
                   | Pcl_constraint (_, x) -> x == cty
                   | _ -> false
                 in
@@ -1151,7 +1151,7 @@ end = struct
     | Cl ctx ->
         assert (
           match ctx.pcl_desc with
-          | Pcl_fun (_, _, _, _) -> false
+          | Pcl_fun _ -> false
           | Pcl_constr _ -> false
           | Pcl_structure _ -> false
           | Pcl_apply _ -> false
@@ -1196,7 +1196,7 @@ end = struct
                   cl == x
                   ||
                   match x.pcl_desc with
-                  | Pcl_fun (_, _, _, x) -> loop x
+                  | Pcl_fun (_, x) -> loop x
                   | Pcl_constraint (x, _) -> loop x
                   | _ -> false
                 in
@@ -1213,7 +1213,7 @@ end = struct
         assert (
           match pcl_desc with
           | Pcl_structure _ -> false
-          | Pcl_fun (_, _, _, x) -> x == cl
+          | Pcl_fun (_, x) -> x == cl
           | Pcl_apply (x, _) -> x == cl
           | Pcl_let (_, x) -> x == cl
           | Pcl_constraint (x, _) -> x == cl
@@ -1316,7 +1316,7 @@ end = struct
     | Cl ctx ->
         assert (
           match ctx.pcl_desc with
-          | Pcl_fun (_, _, p, _) -> p == pat
+          | Pcl_fun (p, _) -> check_function_param p
           | Pcl_constr _ -> false
           | Pcl_structure {pcstr_self; _} ->
               Option.exists ~f:(fun self_ -> self_ == pat) pcstr_self
@@ -1462,8 +1462,7 @@ end = struct
     | Cl ctx ->
         let rec loop ctx =
           match ctx.pcl_desc with
-          | Pcl_fun (_, eopt, _, e) ->
-              Option.exists eopt ~f:(fun e -> e == exp) || loop e
+          | Pcl_fun (param, e) -> check_function_param param || loop e
           | Pcl_constr _ -> false
           | Pcl_structure _ -> false
           | Pcl_apply (_, l) -> List.exists l ~f:(fun (_, e) -> e == exp)
@@ -2068,7 +2067,7 @@ end = struct
             let exp = snd (List.last_exn args) in
             (not (parenze_exp (sub_exp ~ctx:(Cl cl) exp)))
             && exposed_right_exp cls exp
-        | Pcl_fun (_, _, _, e) ->
+        | Pcl_fun (_, e) ->
             (not (parenze_cl (sub_cl ~ctx:(Cl cl) e)))
             && exposed_right_cl cls e
         | _ -> false

lib/Sugar.ml

@@ -56,13 +56,12 @@ let cl_fun ?(will_keep_first_ast_node = true) cmts xexp =
     let {pcl_desc; pcl_loc; pcl_attributes; _} = exp in
     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
+      | Pcl_fun (p, body) ->
+          let before = p.pparam_loc and after = body.pcl_loc in
           if not will_keep_first_ast_node then
             Cmts.relocate cmts ~src:pcl_loc ~before ~after ;
           let xargs, xbody = fun_ (sub_cl ~ctx body) in
-          let param = Pparam_val (label, default, pattern) in
-          (mk_function_param before after param :: xargs, xbody)
+          (p :: xargs, xbody)
       | _ -> ([], xexp)
     else ([], xexp)
   in

vendor/parser-extended/ast_helper.ml

@@ -280,7 +280,7 @@ module Cl = struct
 
   let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b))
   let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a)
-  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d))
+  let fun_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_fun (a, b))
   let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b))
   let let_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_let (a, b))
   let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))

vendor/parser-extended/ast_mapper.ml

@@ -114,6 +114,20 @@ let map_value_constraint sub = function
       let coercion = sub.typ sub coercion in
       Pvc_coercion { ground; coercion }
 
+let map_function_param sub { pparam_loc = loc; pparam_desc = desc } =
+  let loc = sub.location sub loc in
+  let desc =
+    match desc with
+    | Pparam_val (lab, def, p) ->
+        Pparam_val
+          (sub.arg_label sub lab,
+          map_opt (sub.expr sub) def,
+          sub.pat sub p)
+    | Pparam_newtype ty ->
+        Pparam_newtype (List.map (map_loc sub) ty)
+  in
+  { pparam_loc = loc; pparam_desc = desc }
+
 module Flag = struct
   open Asttypes
 
@@ -477,20 +491,6 @@ end
 module E = struct
   (* Value expressions for the core language *)
 
-  let map_function_param sub { pparam_loc = loc; pparam_desc = desc } =
-    let loc = sub.location sub loc in
-    let desc =
-      match desc with
-      | Pparam_val (lab, def, p) ->
-          Pparam_val
-            (sub.arg_label sub lab,
-             map_opt (sub.expr sub) def,
-             sub.pat sub p)
-      | Pparam_newtype ty ->
-          Pparam_newtype (List.map (map_loc sub) ty)
-    in
-    { pparam_loc = loc; pparam_desc = desc }
-
   let map_constraint sub c =
     match c with
     | Pconstraint ty -> Pconstraint (sub.typ sub ty)
@@ -692,11 +692,9 @@ module CE = struct
         constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys)
     | Pcl_structure s ->
         structure ~loc ~attrs (sub.class_structure sub s)
-    | Pcl_fun (lab, e, p, ce) ->
+    | Pcl_fun (p, ce) ->
         fun_ ~loc ~attrs
-          (sub.arg_label sub lab)
-          (map_opt (sub.expr sub) e)
-          (sub.pat sub p)
+          (map_function_param sub p)
           (sub.class_expr sub ce)
     | Pcl_apply (ce, l) ->
         apply ~loc ~attrs (sub.class_expr sub ce)

vendor/parser-extended/parser.mly

@@ -1806,8 +1806,8 @@ class_fun_binding:
   | mkclass(
       COLON class_type EQUAL class_expr
         { Pcl_constraint($4, $2) }
-    | labeled_simple_pattern class_fun_binding
-      { let (l,o,p) = $1 in Pcl_fun(l, o, p, $2) }
+    | fun_param class_fun_binding
+      { Pcl_fun($1, $2) }
     ) { $1 }
 ;
 
@@ -1861,9 +1861,9 @@ class_simple_expr:
 
 class_fun_def:
   mkclass(
-    labeled_simple_pattern MINUSGREATER e = class_expr
-  | labeled_simple_pattern e = class_fun_def
-      { let (l,o,p) = $1 in Pcl_fun(l, o, p, e) }
+    fun_param MINUSGREATER e = class_expr
+  | fun_param e = class_fun_def
+      { Pcl_fun($1, e) }
   ) { $1 }
 ;
 %inline class_structure:

vendor/parser-extended/parsetree.mli

@@ -779,20 +779,12 @@ and class_expr_desc =
   | Pcl_constr of Longident.t loc * core_type list
       (** [c] and [['a1, ..., 'an] c] *)
   | Pcl_structure of class_structure  (** [object ... end] *)
-  | Pcl_fun of arg_label * expression option * pattern * class_expr
-      (** [Pcl_fun(lbl, exp0, P, CE)] represents:
+  | Pcl_fun of function_param * class_expr
+      (** [Pcl_fun(P, CE)] represents:
             - [fun P -> CE]
-                     when [lbl]  is {{!Asttypes.arg_label.Nolabel}[Nolabel]}
-                      and [exp0] is [None],
             - [fun ~l:P -> CE]
-                     when [lbl]  is {{!Asttypes.arg_label.Labelled}[Labelled l]}
-                      and [exp0] is [None],
             - [fun ?l:P -> CE]
-                     when [lbl]  is {{!Asttypes.arg_label.Optional}[Optional l]}
-                      and [exp0] is [None],
             - [fun ?l:(P = E0) -> CE]
-                     when [lbl]  is {{!Asttypes.arg_label.Optional}[Optional l]}
-                      and [exp0] is [Some E0].
         *)
   | Pcl_apply of class_expr * (arg_label * expression) list
       (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])]

vendor/parser-extended/printast.ml

@@ -727,11 +727,9 @@ and class_expr i ppf x =
   | Pcl_structure (cs) ->
       line i ppf "Pcl_structure\n";
       class_structure i ppf cs;
-  | Pcl_fun (l, eo, p, e) ->
+  | Pcl_fun (p, e) ->
       line i ppf "Pcl_fun\n";
-      arg_label i ppf l;
-      option i expression ppf eo;
-      pattern i ppf p;
+      function_param i ppf p;
       class_expr i ppf e;
   | Pcl_apply (ce, l) ->
       line i ppf "Pcl_apply\n";