Detect binding_op punning during parsing (#2474)

lib/Sugar.ml

@@ -311,11 +311,7 @@ module Let_binding = struct
         ; lb_args
         ; lb_typ
         ; lb_exp
-        ; lb_pun=
-            ( match (lb_pat.ast.ppat_desc, lb_exp.ast.pexp_desc) with
-            | Ppat_var {txt= v; _}, Pexp_ident {txt= Lident e; _} ->
-                String.equal v e
-            | _ -> false )
+        ; lb_pun= bo.pbop_is_pun
         ; lb_attrs= []
         ; lb_loc= bo.pbop_loc } )
 end

vendor/parser-extended/ast_helper.ml

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

vendor/parser-extended/ast_mapper.ml

@@ -605,13 +605,13 @@ 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_loc} =
+  let map_binding_op sub {pbop_op; pbop_pat; 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 exp = sub.expr sub pbop_exp in
     let loc = sub.location sub pbop_loc in
-    binding_op op pat exp loc
+    binding_op op pat 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_exp, rev_ands) = bindings in
+      { let (pbop_pat, 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_loc} in
+        let let_ = {pbop_op; pbop_pat; 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,26 @@ and_let_binding:
 ;
 letop_binding_body:
     pat = let_ident exp = strict_binding
-      { (pat, exp) }
+      { (pat, exp, false) }
   | val_ident
       (* Let-punning *)
-      { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1) }
+      { (mkpatvar ~loc:$loc $1, 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) }
+        (ghpat ~loc (Ppat_constraint(pat, typ)), exp, false) }
   | pat = pattern_no_exn EQUAL exp = seq_expr
-      { (pat, exp) }
+      { (pat, exp, false) }
 ;
 letop_bindings:
     body = letop_binding_body
-      { let let_pat, let_exp = body in
-        let_pat, let_exp, [] }
+      { let let_pat, let_exp, let_is_pun = body in
+        let_pat, let_exp, let_is_pun, [] }
   | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = letop_binding_body
-      { let let_pat, let_exp, rev_ands = bindings in
-        let pbop_pat, pbop_exp = body in
+      { let let_pat, let_exp, let_is_pun, rev_ands = bindings in
+        let pbop_pat, pbop_exp, pbop_is_pun = body in
         let pbop_loc = make_loc $sloc in
-        let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in
-        let_pat, let_exp, and_ :: rev_ands }
+        let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_is_pun; pbop_loc} in
+        let_pat, let_exp, let_is_pun, and_ :: rev_ands }
 ;
 fun_binding:
     strict_binding

vendor/parser-extended/parsetree.mli

@@ -483,6 +483,7 @@ and binding_op =
     pbop_op : string loc;
     pbop_pat : pattern;
     pbop_exp : expression;
+    pbop_is_pun: bool;
     pbop_loc : Location.t;
   }