Add args to binding_ops (#2516)

lib/Fmt_ast.ml

@@ -2318,7 +2318,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
       $ fmt_let_bindings c ?ext ~parens ~fmt_atrs ~fmt_expr ~has_attr
           lbs.pvbs_rec bindings body
   | Pexp_letop {let_; ands; body} ->
-      let bd = Sugar.Let_binding.of_binding_ops c.cmts (let_ :: ands) in
+      let bd = Sugar.Let_binding.of_binding_ops (let_ :: ands) in
       let fmt_expr = fmt_expression c (sub_exp ~ctx body) in
       pro
       $ fmt_let_bindings c ?ext ~parens ~fmt_atrs ~fmt_expr ~has_attr

lib/Sugar.ml

@@ -226,16 +226,14 @@ module Let_binding = struct
   let of_let_bindings cmts ~ctx =
     List.mapi ~f:(fun i -> of_let_binding cmts ~ctx ~first:(i = 0))
 
-  let of_binding_ops cmts bos =
+  let of_binding_ops bos =
     List.map bos ~f:(fun bo ->
         let ctx = Bo bo in
-        let xbody = sub_exp ~ctx bo.pbop_exp in
-        let xargs, xbody = fun_ cmts ~will_keep_first_ast_node:false xbody in
         { lb_op= bo.pbop_op
         ; lb_pat= sub_pat ~ctx bo.pbop_pat
-        ; lb_args= xargs
+        ; lb_args= bo.pbop_args
         ; lb_typ= bo.pbop_typ
-        ; lb_exp= xbody
+        ; lb_exp= sub_exp ~ctx bo.pbop_exp
         ; lb_pun= bo.pbop_is_pun
         ; lb_attrs= []
         ; lb_loc= bo.pbop_loc } )

lib/Sugar.mli

@@ -61,5 +61,5 @@ module Let_binding : sig
 
   val of_let_bindings : Cmts.t -> ctx:Ast.t -> value_binding list -> t list
 
-  val of_binding_ops : Cmts.t -> binding_op list -> t list
+  val of_binding_ops : binding_op list -> t list
 end

vendor/parser-extended/ast_helper.ml

@@ -175,10 +175,11 @@ module Exp = struct
      pc_rhs = rhs;
     }
 
-  let binding_op op pat typ exp pun loc =
+  let binding_op op pat args typ exp pun loc =
     {
       pbop_op = op;
       pbop_pat = pat;
+      pbop_args = args;
       pbop_typ = typ;
       pbop_exp = exp;
       pbop_is_pun = pun;

vendor/parser-extended/ast_mapper.ml

@@ -620,14 +620,15 @@ module E = struct
     | Pexp_infix (op, e1, e2) ->
         infix ~loc ~attrs (map_loc sub op) (sub.expr sub e1) (sub.expr sub e2)
 
-  let map_binding_op sub {pbop_op; pbop_pat; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} =
+  let map_binding_op sub {pbop_op; pbop_pat; pbop_args; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} =
     let open Exp in
     let op = map_loc sub pbop_op in
     let pat = sub.pat sub pbop_pat in
+    let args = List.map (FP.map sub FP.map_expr) pbop_args in
     let typ = map_opt (map_value_constraint sub) pbop_typ in
     let exp = sub.expr sub pbop_exp in
     let loc = sub.location sub pbop_loc in
-    binding_op op pat typ exp pbop_is_pun loc
+    binding_op op pat args typ exp pbop_is_pun loc
 
 end
 

vendor/parser-extended/parser.mly

@@ -2231,10 +2231,10 @@ expr:
   | let_bindings(ext) IN seq_expr
       { expr_of_let_bindings ~loc:$sloc $1 $3 }
   | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr
-      { let (pbop_pat, pbop_typ, pbop_exp, pbop_is_pun, rev_ands) = bindings in
+      { let (pbop_pat, pbop_args, pbop_typ, pbop_exp, pbop_is_pun, rev_ands) = bindings in
         let ands = List.rev rev_ands in
         let pbop_loc = make_loc $sloc in
-        let let_ = {pbop_op; pbop_pat; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} in
+        let let_ = {pbop_op; pbop_pat; pbop_args; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} in
         mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) }
   | expr COLONCOLON e = expr
       { match e.pexp_desc, e.pexp_attributes with
@@ -2545,26 +2545,27 @@ and_let_binding:
     }
 ;
 letop_binding_body:
-    pat = let_ident exp = strict_binding
-      { (pat, None, exp, false) }
+    pat = let_ident args_typ_strict_binding
+      { let args, tc, exp = $2 in
+        (pat, args, tc, exp, false) }
   | val_ident
       (* Let-punning *)
-      { (mkpatvar ~loc:$loc $1, None, mkexpvar ~loc:$loc $1, true) }
+      { (mkpatvar ~loc:$loc $1, [], None, mkexpvar ~loc:$loc $1, true) }
   | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr
-      { (pat, Some (Pvc_constraint { locally_abstract_univars = []; typ }), exp, false) }
+      { (pat, [], Some (Pvc_constraint { locally_abstract_univars = []; typ }), exp, false) }
   | pat = pattern_no_exn EQUAL exp = seq_expr
-      { (pat, None, exp, false) }
+      { (pat, [], None, exp, false) }
 ;
 letop_bindings:
     body = letop_binding_body
-      { let let_pat, let_typ, let_exp, let_is_pun = body in
-        let_pat, let_typ, let_exp, let_is_pun, [] }
+      { let let_pat, let_args, let_typ, let_exp, let_is_pun = body in
+        let_pat, let_args, let_typ, let_exp, let_is_pun, [] }
   | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = letop_binding_body
-      { let let_pat, let_typ, let_exp, let_is_pun, rev_ands = bindings in
-        let pbop_pat, pbop_typ, pbop_exp, pbop_is_pun = body in
+      { let let_pat, let_args, let_typ, let_exp, let_is_pun, rev_ands = bindings in
+        let pbop_pat, pbop_args, pbop_typ, pbop_exp, pbop_is_pun = body in
         let pbop_loc = make_loc $sloc in
-        let and_ = {pbop_op; pbop_pat; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} in
-        let_pat, let_typ, let_exp, let_is_pun, and_ :: rev_ands }
+        let and_ = {pbop_op; pbop_args; pbop_pat; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} in
+        let_pat, let_args, let_typ, let_exp, let_is_pun, and_ :: rev_ands }
 ;
 fun_binding:
     strict_binding
@@ -2578,6 +2579,21 @@ strict_binding:
   | expr_fun_param fun_binding
       { ghexp ~loc:$sloc (Pexp_fun($1, $2)) }
 ;
+// [args_typ_strict_binding] will replace [strict_binding] when the lists of args are unfolded everywhere
+args_typ_strict_binding:
+    EQUAL seq_expr
+      { [], None, $2 }
+  | nonempty_llist(expr_fun_param) type_constraint? EQUAL seq_expr
+      { let tc =
+          match $2 with
+          | Some (Pconstraint typ) ->
+              Some (Pvc_constraint {locally_abstract_univars= []; typ})
+          | Some (Pcoerce (ground, coercion)) ->
+              Some (Pvc_coercion {ground; coercion} )
+          | None -> None
+        in
+        $1, tc, $4 }
+;
 %inline match_cases:
   xs = preceded_or_separated_nonempty_llist(BAR, match_case)
     { xs }

vendor/parser-extended/parsetree.mli

@@ -482,6 +482,7 @@ and binding_op =
   {
     pbop_op : string loc;
     pbop_pat : pattern;
+    pbop_args : expr_function_param list;
     pbop_typ : value_constraint option;
     pbop_exp : expression;
     pbop_is_pun: bool;