Add type constraint to binding_op (#2486)

lib/Ast.ml

@@ -641,6 +641,7 @@ module T = struct
     | Fp of function_param
     | Vc of value_constraint
     | Lb of value_binding
+    | Bo of binding_op
     | Mb of module_binding
     | Md of module_declaration
     | Cl of class_expr
@@ -663,6 +664,7 @@ module T = struct
     | Fp p -> Format.fprintf fs "Fp:@\n%a" Printast.function_param p
     | Vc c -> Format.fprintf fs "Vc:@\n%a" Printast.value_constraint c
     | Lb b -> Format.fprintf fs "Lb:@\n%a" Printast.value_binding b
+    | Bo b -> Format.fprintf fs "Bo:@\n%a" Printast.binding_op b
     | Mb m -> Format.fprintf fs "Mb:@\n%a" Printast.module_binding m
     | Md m -> Format.fprintf fs "Md:@\n%a" Printast.module_declaration m
     | Cl cl -> Format.fprintf fs "Cl:@\n%a" Printast.class_expr cl
@@ -697,6 +699,7 @@ let attributes = function
   | Fp _ -> []
   | Vc _ -> []
   | Lb x -> x.pvb_attributes
+  | Bo _ -> []
   | Mb x -> attrs_of_ext_attrs x.pmb_ext_attrs
   | Md x -> attrs_of_ext_attrs x.pmd_ext_attrs
   | Cl x -> x.pcl_attributes
@@ -720,6 +723,7 @@ let location = function
   | Fp x -> x.pparam_loc
   | Vc _ -> Location.none
   | Lb x -> x.pvb_loc
+  | Bo x -> x.pbop_loc
   | Mb x -> x.pmb_loc
   | Md x -> x.pmd_loc
   | Cl x -> x.pcl_loc
@@ -999,6 +1003,7 @@ end = struct
     | Fp _ -> assert false
     | Vc c -> assert (check_value_constraint c)
     | Lb _ -> assert false
+    | Bo _ -> assert false
     | Mb _ -> assert false
     | Md _ -> assert false
     | Cl {pcl_desc; _} ->
@@ -1108,6 +1113,7 @@ end = struct
     | Fp _ -> assert false
     | Vc _ -> assert false
     | Lb _ -> assert false
+    | Bo _ -> assert false
     | Mb _ -> assert false
     | Md _ -> assert false
     | Pld _ -> assert false
@@ -1177,6 +1183,7 @@ end = struct
     | Fp _ -> assert false
     | Vc _ -> assert false
     | Lb _ -> assert false
+    | Bo _ -> assert false
     | Mb _ -> assert false
     | Md _ -> assert false
     | Pld _ -> assert false
@@ -1303,6 +1310,7 @@ end = struct
     | Fp ctx -> assert (check_function_param ctx)
     | Vc _ -> assert false
     | Lb x -> assert (x.pvb_pat == pat)
+    | Bo x -> assert (x.pbop_pat == pat)
     | Mb _ -> assert false
     | Md _ -> assert false
     | Cl ctx ->
@@ -1434,6 +1442,7 @@ end = struct
     | Fp ctx -> assert (check_function_param ctx)
     | Vc _ -> assert false
     | Lb x -> assert (x.pvb_expr == exp)
+    | Bo x -> assert (x.pbop_exp == exp)
     | Mb _ -> assert false
     | Md _ -> assert false
     | Str str -> (
@@ -1689,6 +1698,8 @@ end = struct
      |{ctx= _; ast= Vc _}
      |{ctx= Lb _; ast= _}
      |{ctx= _; ast= Lb _}
+     |{ctx= Bo _; ast= _}
+     |{ctx= _; ast= Bo _}
      |{ctx= Td _; ast= _}
      |{ctx= _; ast= Td _}
      |{ ctx= Cl _
@@ -1773,6 +1784,7 @@ end = struct
     | Fp _ -> None
     | Vc _ -> None
     | Lb _ -> None
+    | Bo _ -> None
     | Cl c -> (
       match c.pcl_desc with
       | Pcl_apply _ -> Some Apply
@@ -1903,6 +1915,13 @@ end = struct
     | ( Exp {pexp_desc= Pexp_letop _; _}
       , Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _) ) ->
         false
+    | ( Bo {pbop_typ= None; _}
+      , ( Ppat_construct (_, Some _)
+        | Ppat_cons _
+        | Ppat_variant (_, Some _)
+        | Ppat_or _ | Ppat_alias _ ) ) ->
+        true
+    | Bo {pbop_typ= Some _; _}, (Ppat_any | Ppat_tuple _) -> true
     | _, Ppat_constraint _
      |_, Ppat_unpack _
      |( Pat
@@ -1938,7 +1957,7 @@ end = struct
      |Cl {pcl_desc= Pcl_fun _; _}, Ppat_construct _
      |Cl {pcl_desc= Pcl_fun _; _}, Ppat_alias _
      |Cl {pcl_desc= Pcl_fun _; _}, Ppat_lazy _
-     |Exp {pexp_desc= Pexp_letop _; _}, Ppat_exception _
+     |(Exp {pexp_desc= Pexp_letop _; _} | Bo _), Ppat_exception _
      |( Exp {pexp_desc= Pexp_fun _; _}
       , ( Ppat_construct _ | Ppat_cons _ | Ppat_lazy _ | Ppat_tuple _
         | Ppat_variant _ ) ) ->

lib/Ast.mli

@@ -113,6 +113,7 @@ type t =
   | Fp of function_param
   | Vc of value_constraint
   | Lb of value_binding
+  | Bo of binding_op
   | Mb of module_binding
   | Md of module_declaration
   | Cl of class_expr

lib/Fmt_ast.ml

@@ -2305,7 +2305,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 ~ctx (let_ :: ands) in
+      let bd = Sugar.Let_binding.of_binding_ops c.cmts (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

@@ -236,43 +236,6 @@ module Let_binding = struct
     | Pexp_constraint _, Ppat_constraint _ -> (xargs, None, xbody)
     | _ -> split_annot cmts xargs xbody
 
-  let type_cstr cmts ~ctx lb_pat lb_exp =
-    let ({ast= pat; _} as xpat) =
-      match (lb_pat.ppat_desc, lb_exp.pexp_desc) with
-      (* recognize and undo the pattern of code introduced by
-         ocaml/ocaml@fd0dc6a0fbf73323c37a73ea7e8ffc150059d6ff to fix
-         https://caml.inria.fr/mantis/view.php?id=7344 *)
-      | ( Ppat_constraint
-            ( ({ppat_desc= Ppat_var _; _} as pat)
-            , {ptyp_desc= Ptyp_poly ([], typ1); _} )
-        , Pexp_constraint (_, typ2) )
-        when equal_core_type typ1 typ2 ->
-          Cmts.relocate cmts ~src:lb_pat.ppat_loc ~before:pat.ppat_loc
-            ~after:pat.ppat_loc ;
-          sub_pat ~ctx:(Pat lb_pat) pat
-      | ( Ppat_constraint (_, {ptyp_desc= Ptyp_poly (_, typ1); _})
-        , Pexp_coerce (_, _, typ2) )
-        when equal_core_type typ1 typ2 ->
-          sub_pat ~ctx lb_pat
-      | _ -> sub_pat ~ctx lb_pat
-    in
-    let pat_is_extension {ppat_desc; _} =
-      match ppat_desc with Ppat_extension _ -> true | _ -> false
-    in
-    let xbody = sub_exp ~ctx lb_exp in
-    if
-      (not (List.is_empty xbody.ast.pexp_attributes)) || pat_is_extension pat
-    then (xpat, [], None, xbody)
-    else
-      let xpat =
-        match xpat.ast.ppat_desc with
-        | Ppat_constraint (p, {ptyp_desc= Ptyp_poly ([], _); _}) ->
-            sub_pat ~ctx:xpat.ctx p
-        | _ -> xpat
-      in
-      let xargs, typ, xbody = split_fun_args cmts xpat xbody in
-      (xpat, xargs, typ, xbody)
-
   let should_desugar_args pat typ =
     match (pat.ast, typ) with
     | {ppat_desc= Ppat_var _; ppat_attributes= []; _}, None -> true
@@ -301,16 +264,16 @@ 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 ~ctx bos =
+  let of_binding_ops cmts bos =
     List.map bos ~f:(fun bo ->
-        let lb_pat, lb_args, lb_typ, lb_exp =
-          type_cstr cmts ~ctx bo.pbop_pat bo.pbop_exp
-        in
+        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
-        ; lb_args
-        ; lb_typ
-        ; lb_exp
+        ; lb_pat= sub_pat ~ctx bo.pbop_pat
+        ; lb_args= xargs
+        ; lb_typ= bo.pbop_typ
+        ; lb_exp= xbody
         ; lb_pun= bo.pbop_is_pun
         ; lb_attrs= []
         ; lb_loc= bo.pbop_loc } )

lib/Sugar.mli

@@ -70,5 +70,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 -> ctx:Ast.t -> binding_op list -> t list
+  val of_binding_ops : Cmts.t -> binding_op list -> t list
 end

test/passing/tests/monadic_binding.ml

@@ -32,4 +32,6 @@ let _ =
   let* (args, _) : bar = () in
   let* (arg : bar) = () in
   let* (_ : foo) = () in
+  let* (_ as t) = xxx in
+  let+ (Ok x) = xxx in
   ()

vendor/parser-extended/ast_helper.ml

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

vendor/parser-extended/ast_mapper.ml

@@ -104,6 +104,16 @@ let map_arg_label sub = function
   | Labelled x -> Labelled (map_loc sub x)
   | Optional x -> Optional (map_loc sub x)
 
+let map_value_constraint sub = function
+  | Pvc_constraint {locally_abstract_univars=vars; typ} ->
+      let locally_abstract_univars = List.map (map_loc sub) vars in
+      let typ = sub.typ sub typ in
+      Pvc_constraint { locally_abstract_univars; typ }
+  | Pvc_coercion { ground; coercion } ->
+      let ground = Option.map (sub.typ sub) ground in
+      let coercion = sub.typ sub coercion in
+      Pvc_coercion { ground; coercion }
+
 module Flag = struct
   open Asttypes
 
@@ -605,13 +615,14 @@ 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_exp; pbop_is_pun; pbop_loc} =
+  let map_binding_op sub {pbop_op; pbop_pat; 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 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 exp pbop_is_pun loc
+    binding_op op pat typ exp pbop_is_pun loc
 
 end
 
@@ -859,22 +870,10 @@ let default_mapper =
 
     value_binding =
       (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_is_pun; pvb_attributes; pvb_loc} ->
-         let map_ct (ct:Parsetree.value_constraint) = match ct with
-           | Pvc_constraint {locally_abstract_univars=vars; typ} ->
-               Pvc_constraint
-                 { locally_abstract_univars = List.map (map_loc this) vars;
-                   typ = this.typ this typ
-                 }
-           | Pvc_coercion { ground; coercion } ->
-               Pvc_coercion {
-                 ground = Option.map (this.typ this) ground;
-                 coercion = this.typ this coercion
-               }
-         in
          Vb.mk
            (this.pat this pvb_pat)
            (this.expr this pvb_expr)
-           ?value_constraint:(Option.map map_ct pvb_constraint)
+           ?value_constraint:(Option.map (map_value_constraint this) pvb_constraint)
            ~is_pun:pvb_is_pun
            ~loc:(this.location this pvb_loc)
            ~attrs:(this.attributes this pvb_attributes)

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_exp, pbop_is_pun, rev_ands) = bindings in
+      { let (pbop_pat, 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_exp; pbop_is_pun; pbop_loc} in
+        let let_ = {pbop_op; pbop_pat; 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
@@ -2548,26 +2548,25 @@ and_let_binding:
 ;
 letop_binding_body:
     pat = let_ident exp = strict_binding
-      { (pat, exp, false) }
+      { (pat, None, exp, false) }
   | val_ident
       (* Let-punning *)
-      { (mkpatvar ~loc:$loc $1, 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
-      { let loc = ($startpos(pat), $endpos(typ)) in
-        (ghpat ~loc (Ppat_constraint(pat, typ)), exp, false) }
+      { (pat, Some (Pvc_constraint { locally_abstract_univars = []; typ }), exp, false) }
   | pat = pattern_no_exn EQUAL exp = seq_expr
-      { (pat, exp, false) }
+      { (pat, None, exp, false) }
 ;
 letop_bindings:
     body = letop_binding_body
-      { let let_pat, let_exp, let_is_pun = body in
-        let_pat, let_exp, let_is_pun, [] }
+      { let let_pat, let_typ, let_exp, let_is_pun = body in
+        let_pat, let_typ, let_exp, let_is_pun, [] }
   | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = letop_binding_body
-      { let let_pat, let_exp, let_is_pun, rev_ands = bindings in
-        let pbop_pat, pbop_exp, pbop_is_pun = body in
+      { 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 pbop_loc = make_loc $sloc in
-        let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_is_pun; pbop_loc} in
-        let_pat, let_exp, let_is_pun, and_ :: rev_ands }
+        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 }
 ;
 fun_binding:
     strict_binding

vendor/parser-extended/parsetree.mli

@@ -482,6 +482,7 @@ and binding_op =
   {
     pbop_op : string loc;
     pbop_pat : pattern;
+    pbop_typ : value_constraint option;
     pbop_exp : expression;
     pbop_is_pun: bool;
     pbop_loc : Location.t;

vendor/parser-extended/printast.ml

@@ -1233,3 +1233,5 @@ let signature_item ppf x = signature_item 0 ppf x
 let function_param ppf x = function_param 0 ppf x
 
 let value_constraint ppf x = value_constraint 0 ppf x
+
+let binding_op ppf x = binding_op 0 ppf x