Add configuration to control whether let-punning is used (#2746)

WardBrian · web-flow · commit 1609f0474669 · 2025-10-30T16:27:19.000+01:00
* Add configuration to control whether let-punning is used

* Add tests for let punning configuration

* Update manpage in documentation

* CHANGES entry

* Rename to letop-punning

* More documentation with example

* Fix CHANGES
diff --git a/CHANGES.md b/CHANGES.md
@@ -6,6 +6,15 @@ profile. This started with version 0.26.0.
 
 ## unreleased
 
+### Added
+
+- Added option `letop-punning` (#2746, @WardBrian) to control whether
+  punning is used in extended binding operators.
+  For example, the code `let+ x = x in ...` can be formatted as
+  `let+ x in ...` when `letop-punning=always`. With `letop-punning=never`, it
+  becomes `let+ x = x in ...`. The default is `preserve`, which will
+  only use punning when it exists in the source.
+
 ### Fixed
 
 - Fix dropped comment in `(function _ -> x (* cmt *))` (#2739, @Julow)
diff --git a/doc/manpage_ocamlformat.mld b/doc/manpage_ocamlformat.mld
@@ -271,6 +271,16 @@ OPTIONS (CODE FORMATTING STYLE)
            ... = and before the in if the module declaration does not fit on
            a single line. The default value is compact.
 
+       --letop-punning={preserve|always|never}
+           Name punning in bindings using extended let operators. preserve
+           uses let-punning only when it exists in the source; the code "let*
+           foo and* z = z in ..." will be left unchanged. always uses
+           let-punning whenever possible; the code "let* foo and* z = z in
+           ..." will be rewritten to "let* foo and* z in ...". never never
+           uses let-punning; the code "let* foo and* z = z in ..." will be
+           rewritten to "let* foo = foo and* z = z in ...". The default value
+           is preserve.
+
        --line-endings={lf|crlf}
            Line endings used. lf uses Unix line endings. crlf uses Windows
            line endings. The default value is lf. Cannot be set in
diff --git a/lib/Conf.ml b/lib/Conf.ml
@@ -86,6 +86,7 @@ let conventional_profile from =
   ; let_binding_deindent_fun= elt true
   ; let_binding_spacing= elt `Compact
   ; let_module= elt `Compact
+  ; letop_punning= elt `Preserve
   ; line_endings= elt `Lf
   ; margin= elt 80
   ; match_indent= elt 0
@@ -156,6 +157,7 @@ let ocamlformat_profile from =
   ; let_binding_deindent_fun= elt true
   ; let_binding_spacing= elt `Compact
   ; let_module= elt `Compact
+  ; letop_punning= elt `Preserve
   ; line_endings= elt `Lf
   ; margin= elt 80
   ; match_indent= elt 0
@@ -225,6 +227,7 @@ let janestreet_profile from =
   ; let_binding_deindent_fun= elt false
   ; let_binding_spacing= elt `Double_semicolon
   ; let_module= elt `Sparse
+  ; letop_punning= elt `Preserve
   ; line_endings= elt `Lf
   ; margin= elt 90
   ; match_indent= elt 0
@@ -994,6 +997,27 @@ module Formatting = struct
       (fun conf elt -> update conf ~f:(fun f -> {f with let_module= elt}))
       (fun conf -> conf.fmt_opts.let_module)
 
+  let letop_punning =
+    let doc = "Name punning in bindings using extended let operators." in
+    let names = ["letop-punning"] in
+    let all =
+      [ Decl.Value.make ~name:"preserve" `Preserve
+          "$(b,preserve) uses let-punning only when it exists in the \
+           source; the code \"$(i,let* foo and* z = z in ...)\" will be \
+           left unchanged."
+      ; Decl.Value.make ~name:"always" `Always
+          "$(b,always) uses let-punning whenever possible; the code \
+           \"$(i,let* foo and* z = z in ...)\" will be rewritten to \
+           \"$(i,let* foo and* z in ...)\"."
+      ; Decl.Value.make ~name:"never" `Never
+          "$(b,never) never uses let-punning; the code \"$(i,let* foo and* \
+           z = z in ...)\" will be rewritten to \"$(i,let* foo = foo and* z \
+           = z in ...)\". " ]
+    in
+    Decl.choice ~names ~all ~default ~doc ~kind
+      (fun conf elt -> update conf ~f:(fun f -> {f with letop_punning= elt}))
+      (fun conf -> conf.fmt_opts.letop_punning)
+
   let let_open =
     let names = ["let-open"] in
     let msg = concrete_syntax_preserved_msg in
@@ -1353,6 +1377,7 @@ module Formatting = struct
       ; elt let_binding_deindent_fun
       ; elt let_binding_spacing
       ; elt let_module
+      ; elt letop_punning
       ; elt line_endings
       ; elt margin
       ; elt match_indent
diff --git a/lib/Conf_t.ml b/lib/Conf_t.ml
@@ -94,6 +94,7 @@ type fmt_opts =
   ; let_binding_deindent_fun: bool elt
   ; let_binding_spacing: [`Compact | `Sparse | `Double_semicolon] elt
   ; let_module: [`Compact | `Sparse] elt
+  ; letop_punning: [`Always | `Preserve | `Never] elt
   ; line_endings: [`Lf | `Crlf] elt
   ; margin: int elt
   ; match_indent: int elt
diff --git a/lib/Conf_t.mli b/lib/Conf_t.mli
@@ -92,6 +92,7 @@ type fmt_opts =
         (** De-indent the [fun] in a let-binding body. *)
   ; let_binding_spacing: [`Compact | `Sparse | `Double_semicolon] elt
   ; let_module: [`Compact | `Sparse] elt
+  ; letop_punning: [`Always | `Preserve | `Never] elt
   ; line_endings: [`Lf | `Crlf] elt
   ; margin: int elt  (** Format code to fit within [margin] columns. *)
   ; match_indent: int elt
diff --git a/lib/Extended_ast.ml b/lib/Extended_ast.ml
@@ -57,7 +57,7 @@ let map (type a) (x : a t) (m : Ast_mapper.mapper) : a -> a =
   | Documentation -> Fn.id
 
 module Parse = struct
-  let normalize_mapper ~ocaml_version ~preserve_beginend =
+  let normalize_mapper ~ocaml_version ~preserve_beginend ~prefer_let_puns =
     let open Asttypes in
     let open Ast_mapper in
     let enable_short_field_annot =
@@ -233,7 +233,17 @@ module Parse = struct
       let b' =
         let loc_start = b.pbop_op.loc.loc_start in
         let loc_end = b.pbop_exp.pexp_loc.loc_end in
-        {b with pbop_loc= {b.pbop_loc with loc_start; loc_end}}
+        let pbop_is_pun =
+          match prefer_let_puns with
+          | None -> b.pbop_is_pun
+          | Some false -> false
+          | Some true -> (
+            match (b.pbop_pat.ppat_desc, b.pbop_exp.pexp_desc) with
+            | Ppat_var {txt= v; _}, Pexp_ident {txt= Lident e; _} ->
+                String.equal v e
+            | _ -> false )
+        in
+        {b with pbop_loc= {b.pbop_loc with loc_start; loc_end}; pbop_is_pun}
       in
       Ast_mapper.default_mapper.binding_op m b'
     in
@@ -307,9 +317,10 @@ module Parse = struct
     in
     Ast_mapper.{default_mapper with expr; pat; binding_op}
 
-  let ast (type a) (fg : a t) ~ocaml_version ~preserve_beginend ~input_name
-      str : a =
-    map fg (normalize_mapper ~ocaml_version ~preserve_beginend)
+  let ast (type a) (fg : a t) ~ocaml_version ~preserve_beginend
+      ~prefer_let_puns ~input_name str : a =
+    map fg
+      (normalize_mapper ~ocaml_version ~preserve_beginend ~prefer_let_puns)
     @@
     let lexbuf = Lexing.from_string str in
     let ocaml_version =
diff --git a/lib/Extended_ast.mli b/lib/Extended_ast.mli
@@ -37,6 +37,7 @@ module Parse : sig
        'a t
     -> ocaml_version:Ocaml_version.t
     -> preserve_beginend:bool
+    -> prefer_let_puns:bool option
     -> input_name:string
     -> string
     -> 'a
diff --git a/lib/Parse_with_comments.ml b/lib/Parse_with_comments.ml
@@ -106,7 +106,14 @@ let parse ?(disable_w50 = false) ?(disable_deprecated = false) parse fragment
 
 let parse_ast (conf : Conf.t) fg ~ocaml_version ~input_name s =
   let preserve_beginend = Poly.(conf.fmt_opts.exp_grouping.v = `Preserve) in
-  Extended_ast.Parse.ast fg ~ocaml_version ~preserve_beginend ~input_name s
+  let prefer_let_puns =
+    match conf.fmt_opts.letop_punning.v with
+    | `Always -> Some true
+    | `Never -> Some false
+    | `Preserve -> None
+  in
+  Extended_ast.Parse.ast fg ~ocaml_version ~preserve_beginend
+    ~prefer_let_puns ~input_name s
 
 (** [is_repl_block x] returns whether [x] is a list of REPL phrases and
     outputs of the form:
diff --git a/test/cli/print_config.t b/test/cli/print_config.t
@@ -58,6 +58,7 @@ No redundant values:
   let-binding-deindent-fun=true (profile conventional (file .ocamlformat:1))
   let-binding-spacing=compact (profile conventional (file .ocamlformat:1))
   let-module=compact (profile conventional (file .ocamlformat:1))
+  letop-punning=preserve (profile conventional (file .ocamlformat:1))
   line-endings=lf (profile conventional (file .ocamlformat:1))
   margin=80 (profile conventional (file .ocamlformat:1))
   match-indent=0 (profile conventional (file .ocamlformat:1))
@@ -138,6 +139,7 @@ Redundant values from the conventional profile:
   let-binding-deindent-fun=true (profile conventional (file .ocamlformat:1))
   let-binding-spacing=compact (profile conventional (file .ocamlformat:1))
   let-module=compact (profile conventional (file .ocamlformat:1))
+  letop-punning=preserve (profile conventional (file .ocamlformat:1))
   line-endings=lf (profile conventional (file .ocamlformat:1))
   margin=80 (file .ocamlformat:3) -- Warning (redundant):  (profile conventional (file .ocamlformat:1))
   match-indent=0 (profile conventional (file .ocamlformat:1))
@@ -218,6 +220,7 @@ Redundant values from the ocamlformat profile:
   let-binding-deindent-fun=true (profile ocamlformat (file .ocamlformat:1))
   let-binding-spacing=compact (profile ocamlformat (file .ocamlformat:1))
   let-module=compact (profile ocamlformat (file .ocamlformat:1))
+  letop-punning=preserve (profile ocamlformat (file .ocamlformat:1))
   line-endings=lf (profile ocamlformat (file .ocamlformat:1))
   margin=80 (file .ocamlformat:3) -- Warning (redundant):  (profile ocamlformat (file .ocamlformat:1))
   match-indent=0 (profile ocamlformat (file .ocamlformat:1))
diff --git a/test/passing/gen/dune.inc b/test/passing/gen/dune.inc
@@ -3722,6 +3722,42 @@
  (package ocamlformat)
  (action (diff let_punning.ml.err let_punning.ml.stderr)))
 
+(rule
+ (deps .ocamlformat)
+ (package ocamlformat)
+ (action
+  (with-stdout-to let_punning_denied.ml.stdout
+   (with-stderr-to let_punning_denied.ml.stderr
+     (run %{bin:ocamlformat} --name let_punning_denied.ml --margin-check --letop-punning=never --ocaml-version=4.14.0 %{dep:../tests/let_punning_denied.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff let_punning_denied.ml.ref let_punning_denied.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff let_punning_denied.ml.err let_punning_denied.ml.stderr)))
+
+(rule
+ (deps .ocamlformat)
+ (package ocamlformat)
+ (action
+  (with-stdout-to let_punning_preferred.ml.stdout
+   (with-stderr-to let_punning_preferred.ml.stderr
+     (run %{bin:ocamlformat} --name let_punning_preferred.ml --margin-check --letop-punning=always --ocaml-version=4.14.0 %{dep:../tests/let_punning_preferred.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff let_punning_preferred.ml.ref let_punning_preferred.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff let_punning_preferred.ml.err let_punning_preferred.ml.stderr)))
+
 (rule
  (deps .ocamlformat)
  (package ocamlformat)
diff --git a/test/passing/refs.ahrefs/let_punning_denied.ml.ref b/test/passing/refs.ahrefs/let_punning_denied.ml.ref
@@ -0,0 +1,21 @@
+let ( let* ) x f = f x
+
+let ( and* ) a b = a, b
+
+let x = 1
+
+and y = 2
+
+and z = 3
+
+let p =
+  let* x = x
+  and* y = y
+  and* z = z in
+  x, y, z
+
+let q =
+  let%foo x = x
+  and y = y
+  and z = z in
+  x, y, z
diff --git a/test/passing/refs.ahrefs/let_punning_preferred.ml.ref b/test/passing/refs.ahrefs/let_punning_preferred.ml.ref
@@ -0,0 +1,21 @@
+let ( let* ) x f = f x
+
+let ( and* ) a b = a, b
+
+let x = 1
+
+and y = 2
+
+and z = 3
+
+let p =
+  let* x
+  and* y
+  and* z in
+  x, y, z
+
+let q =
+  let%foo x = x
+  and y = y
+  and z = z in
+  x, y, z
diff --git a/test/passing/refs.default/let_punning_denied.ml.ref b/test/passing/refs.default/let_punning_denied.ml.ref
@@ -0,0 +1,14 @@
+let ( let* ) x f = f x
+let ( and* ) a b = (a, b)
+
+let x = 1
+and y = 2
+and z = 3
+
+let p =
+  let* x = x and* y = y and* z = z in
+  (x, y, z)
+
+let q =
+  let%foo x = x and y = y and z = z in
+  (x, y, z)
diff --git a/test/passing/refs.default/let_punning_preferred.ml.ref b/test/passing/refs.default/let_punning_preferred.ml.ref
@@ -0,0 +1,14 @@
+let ( let* ) x f = f x
+let ( and* ) a b = (a, b)
+
+let x = 1
+and y = 2
+and z = 3
+
+let p =
+  let* x and* y and* z in
+  (x, y, z)
+
+let q =
+  let%foo x = x and y = y and z = z in
+  (x, y, z)
diff --git a/test/passing/refs.janestreet/let_punning_denied.ml.ref b/test/passing/refs.janestreet/let_punning_denied.ml.ref
@@ -0,0 +1,20 @@
+let ( let* ) x f = f x
+let ( and* ) a b = a, b
+
+let x = 1
+and y = 2
+and z = 3
+
+let p =
+  let* x = x
+  and* y = y
+  and* z = z in
+  x, y, z
+;;
+
+let q =
+  let%foo x = x
+  and y = y
+  and z = z in
+  x, y, z
+;;
diff --git a/test/passing/refs.janestreet/let_punning_preferred.ml.ref b/test/passing/refs.janestreet/let_punning_preferred.ml.ref
@@ -0,0 +1,20 @@
+let ( let* ) x f = f x
+let ( and* ) a b = a, b
+
+let x = 1
+and y = 2
+and z = 3
+
+let p =
+  let* x
+  and* y
+  and* z in
+  x, y, z
+;;
+
+let q =
+  let%foo x = x
+  and y = y
+  and z = z in
+  x, y, z
+;;
diff --git a/test/passing/refs.ocamlformat/let_punning_denied.ml.ref b/test/passing/refs.ocamlformat/let_punning_denied.ml.ref
@@ -0,0 +1,17 @@
+let ( let* ) x f = f x
+
+let ( and* ) a b = (a, b)
+
+let x = 1
+
+and y = 2
+
+and z = 3
+
+let p =
+  let* x = x and* y = y and* z = z in
+  (x, y, z)
+
+let q =
+  let%foo x = x and y = y and z = z in
+  (x, y, z)
diff --git a/test/passing/refs.ocamlformat/let_punning_preferred.ml.ref b/test/passing/refs.ocamlformat/let_punning_preferred.ml.ref
@@ -0,0 +1,17 @@
+let ( let* ) x f = f x
+
+let ( and* ) a b = (a, b)
+
+let x = 1
+
+and y = 2
+
+and z = 3
+
+let p =
+  let* x and* y and* z in
+  (x, y, z)
+
+let q =
+  let%foo x = x and y = y and z = z in
+  (x, y, z)
diff --git a/test/passing/tests/let_punning_denied.ml b/test/passing/tests/let_punning_denied.ml
diff --git a/test/passing/tests/let_punning_denied.ml.opts b/test/passing/tests/let_punning_denied.ml.opts
diff --git a/test/passing/tests/let_punning_preferred.ml b/test/passing/tests/let_punning_preferred.ml
diff --git a/test/passing/tests/let_punning_preferred.ml.opts b/test/passing/tests/let_punning_preferred.ml.opts
diff --git a/tools/printast/printast.ml b/tools/printast/printast.ml
