Skip to content

Commit 295fe67

Browse files
WardBriangithub-actions[bot]
WardBrian
and
github-actions[bot]
authored
letop-punning for extension nodes (#2747)
* letop-punning for extension nodes * Update CHANGES.md Co-authored-by: github-actions[bot] <41898282+github-actions[bot]@users.noreply.github.com> * Fix comments getting dropped by letop-punning=always --------- Co-authored-by: github-actions[bot] <41898282+github-actions[bot]@users.noreply.github.com>
1 parent 7ec4b50 commit 295fe67

24 files changed

+321
-75
lines changed

‎CHANGES.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ profile. This started with version 0.26.0.
1414
`let+ x in ...` when `letop-punning=always`. With `letop-punning=never`, it
1515
becomes `let+ x = x in ...`. The default is `preserve`, which will
1616
only use punning when it exists in the source.
17+
This also applies to `let%ext` bindings (#2747, @WardBrian).
1718

1819
### Fixed
1920

‎doc/manpage_ocamlformat.mld‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -272,14 +272,14 @@ OPTIONS (CODE FORMATTING STYLE)
272272
a single line. The default value is compact.
273273

274274
--letop-punning={preserve|always|never}
275-
Name punning in bindings using extended let operators. preserve
276-
uses let-punning only when it exists in the source; the code "let*
277-
foo and* z = z in ..." will be left unchanged. always uses
278-
let-punning whenever possible; the code "let* foo and* z = z in
279-
..." will be rewritten to "let* foo and* z in ...". never never
280-
uses let-punning; the code "let* foo and* z = z in ..." will be
281-
rewritten to "let* foo = foo and* z = z in ...". The default value
282-
is preserve.
275+
Name punning in bindings using extended let operators and let%ext
276+
bindings. preserve uses let-punning only when it exists in the
277+
source; the code "let* foo and* z = z in ..." will be left
278+
unchanged. always uses let-punning whenever possible; the code
279+
"let* foo and* z = z in ..." will be rewritten to "let* foo and* z
280+
in ...". never never uses let-punning; the code "let* foo and* z =
281+
z in ..." will be rewritten to "let* foo = foo and* z = z in ...".
282+
The default value is preserve.
283283

284284
--line-endings={lf|crlf}
285285
Line endings used. lf uses Unix line endings. crlf uses Windows

‎lib/Conf.ml‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -998,7 +998,10 @@ module Formatting = struct
998998
(fun conf -> conf.fmt_opts.let_module)
999999

10001000
let letop_punning =
1001-
let doc = "Name punning in bindings using extended let operators." in
1001+
let doc =
1002+
"Name punning in bindings using extended let operators and \
1003+
$(i,let%ext) bindings."
1004+
in
10021005
let names = ["letop-punning"] in
10031006
let all =
10041007
[ Decl.Value.make ~name:"preserve" `Preserve

‎lib/Extended_ast.ml‎

Lines changed: 39 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -238,15 +238,49 @@ module Parse = struct
238238
| None -> b.pbop_is_pun
239239
| Some false -> false
240240
| Some true -> (
241-
match (b.pbop_pat.ppat_desc, b.pbop_exp.pexp_desc) with
242-
| Ppat_var {txt= v; _}, Pexp_ident {txt= Lident e; _} ->
243-
String.equal v e
244-
| _ -> false )
241+
b.pbop_is_pun
242+
||
243+
match (b.pbop_pat.ppat_desc, b.pbop_exp.pexp_desc) with
244+
| Ppat_var {txt; _}, Pexp_ident {txt= Lident e; _} ->
245+
String.equal txt e
246+
| _ -> false )
245247
in
246248
{b with pbop_loc= {b.pbop_loc with loc_start; loc_end}; pbop_is_pun}
247249
in
248250
Ast_mapper.default_mapper.binding_op m b'
249251
in
252+
let value_bindings (m : Ast_mapper.mapper) vbs =
253+
let punning is_extension vb =
254+
let is_extension =
255+
(* [and] nodes don't have extensions, so we need to track if the
256+
earlier [let] did *)
257+
is_extension || Option.is_some vb.pvb_attributes.attrs_extension
258+
in
259+
let pvb_is_pun =
260+
is_extension
261+
&&
262+
match prefer_let_puns with
263+
| None -> vb.pvb_is_pun
264+
| Some false -> false
265+
| Some true -> (
266+
vb.pvb_is_pun
267+
||
268+
match (vb.pvb_pat.ppat_desc, vb.pvb_body) with
269+
| ( Ppat_var {txt; _}
270+
, Pfunction_body {pexp_desc= Pexp_ident {txt= Lident e; _}; _}
271+
) ->
272+
String.equal txt e
273+
| _ -> false )
274+
in
275+
(is_extension, {vb with pvb_is_pun})
276+
in
277+
let vbs' =
278+
{ vbs with
279+
pvbs_bindings=
280+
snd @@ List.fold_map ~init:false ~f:punning vbs.pvbs_bindings }
281+
in
282+
Ast_mapper.default_mapper.value_bindings m vbs'
283+
in
250284
let pat m = function
251285
| {ppat_desc= Ppat_cons (_ :: _ :: _ :: _ as l); _} as p
252286
when match List.last_exn l with
@@ -315,7 +349,7 @@ module Parse = struct
315349
{p with pexp_desc= Pexp_tuple l}
316350
| e -> Ast_mapper.default_mapper.expr m e
317351
in
318-
Ast_mapper.{default_mapper with expr; pat; binding_op}
352+
Ast_mapper.{default_mapper with expr; pat; binding_op; value_bindings}
319353

320354
let ast (type a) (fg : a t) ~ocaml_version ~preserve_beginend
321355
~prefer_let_puns ~input_name str : a =

‎lib/Fmt_ast.ml‎

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -2572,14 +2572,16 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
25722572
$ fmt_atrs ) )
25732573
| Pexp_let (lbs, body, loc_in) ->
25742574
let bindings =
2575-
Sugar.Let_binding.of_let_bindings ~ctx lbs.pvbs_bindings
2575+
Sugar.Let_binding.of_let_bindings ~ctx ~cmts:c.cmts lbs.pvbs_bindings
25762576
in
25772577
let fmt_expr = fmt_expression c (sub_exp ~ctx body) in
25782578
pro
25792579
$ fmt_let_bindings c ~ctx0:ctx ~parens ~fmt_atrs ~fmt_expr ~has_attr
25802580
~loc_in lbs.pvbs_rec bindings body
25812581
| Pexp_letop {let_; ands; body; loc_in} ->
2582-
let bd = Sugar.Let_binding.of_binding_ops (let_ :: ands) in
2582+
let bd =
2583+
Sugar.Let_binding.of_binding_ops ~cmts:c.cmts (let_ :: ands)
2584+
in
25832585
let fmt_expr = fmt_expression c (sub_exp ~ctx body) in
25842586
pro
25852587
$ fmt_let_bindings c ~ctx0:ctx ~parens ~fmt_atrs ~fmt_expr ~has_attr
@@ -3268,7 +3270,7 @@ and fmt_class_expr c ({ast= exp; ctx= ctx0} as xexp) =
32683270
| _ -> c.conf.fmt_opts.indent_after_in.v
32693271
in
32703272
let bindings =
3271-
Sugar.Let_binding.of_let_bindings ~ctx lbs.pvbs_bindings
3273+
Sugar.Let_binding.of_let_bindings ~ctx ~cmts:c.cmts lbs.pvbs_bindings
32723274
in
32733275
let fmt_expr = fmt_class_expr c (sub_cl ~ctx body) in
32743276
let has_attr = not (List.is_empty pcl_attributes) in
@@ -4696,7 +4698,9 @@ and fmt_structure_item c ~last:last_item ~semisemi {ctx= parent_ctx; ast= si}
46964698
let fmt_item c ctx ~prev ~next b =
46974699
let first = Option.is_none prev in
46984700
let last = Option.is_none next in
4699-
let b = Sugar.Let_binding.of_let_binding ~ctx ~first b in
4701+
let b =
4702+
Sugar.Let_binding.of_let_binding ~ctx ~first ~cmts:c.cmts b
4703+
in
47004704
let epi =
47014705
match c.conf.fmt_opts.let_binding_spacing.v with
47024706
| `Compact -> None

‎lib/Sugar.ml‎

Lines changed: 18 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -123,7 +123,18 @@ module Let_binding = struct
123123
; lb_attrs: ext_attrs
124124
; lb_loc: Location.t }
125125

126-
let of_let_binding ~ctx ~first vb =
126+
let of_let_binding ~ctx ~first ~cmts vb =
127+
if vb.pvb_is_pun then
128+
(* this is a no-op if it was parsed as a pun, but if
129+
letop-punning=always was specified this is needed to move comments
130+
from the now-elided body *)
131+
Cmts.relocate cmts
132+
~src:
133+
( match vb.pvb_body with
134+
| Pfunction_body e -> e.pexp_loc
135+
| Pfunction_cases (_, l, _) ->
136+
(* NB: should be impossible for puns *) l )
137+
~before:vb.pvb_pat.ppat_loc ~after:vb.pvb_pat.ppat_loc ;
127138
{ lb_op= Location.{txt= (if first then "let" else "and"); loc= none}
128139
; lb_pat= sub_pat ~ctx vb.pvb_pat
129140
; lb_args= vb.pvb_args
@@ -133,11 +144,14 @@ module Let_binding = struct
133144
; lb_attrs= vb.pvb_attributes
134145
; lb_loc= vb.pvb_loc }
135146

136-
let of_let_bindings ~ctx =
137-
List.mapi ~f:(fun i -> of_let_binding ~ctx ~first:(i = 0))
147+
let of_let_bindings ~ctx ~cmts =
148+
List.mapi ~f:(fun i -> of_let_binding ~ctx ~first:(i = 0) ~cmts)
138149

139-
let of_binding_ops bos =
150+
let of_binding_ops ~cmts bos =
140151
List.map bos ~f:(fun bo ->
152+
if bo.pbop_is_pun then
153+
Cmts.relocate cmts ~src:bo.pbop_exp.pexp_loc
154+
~before:bo.pbop_pat.ppat_loc ~after:bo.pbop_pat.ppat_loc ;
141155
let ctx = Bo bo in
142156
{ lb_op= bo.pbop_op
143157
; lb_pat= sub_pat ~ctx bo.pbop_pat

‎lib/Sugar.mli‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -47,9 +47,11 @@ module Let_binding : sig
4747
; lb_attrs: ext_attrs
4848
; lb_loc: Location.t }
4949

50-
val of_let_binding : ctx:Ast.t -> first:bool -> value_binding -> t
50+
val of_let_binding :
51+
ctx:Ast.t -> first:bool -> cmts:Cmts.t -> value_binding -> t
5152

52-
val of_let_bindings : ctx:Ast.t -> value_binding list -> t list
53+
val of_let_bindings :
54+
ctx:Ast.t -> cmts:Cmts.t -> value_binding list -> t list
5355

54-
val of_binding_ops : binding_op list -> t list
56+
val of_binding_ops : cmts:Cmts.t -> binding_op list -> t list
5557
end

‎test/failing/dune.inc‎

Lines changed: 0 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -181,19 +181,6 @@
181181
(package ocamlformat)
182182
(action (diff tests/js_test.ml.broken-ref js_test.ml.output)))
183183

184-
(rule
185-
(deps tests/.ocamlformat )
186-
(package ocamlformat)
187-
(action
188-
(with-outputs-to letop_broken.ml.output
189-
(with-accepted-exit-codes 1
190-
(run %{bin:ocamlformat} --ocaml-version=4.14 --letop-punning=always %{dep:tests/letop_broken.ml})))))
191-
192-
(rule
193-
(alias runtest)
194-
(package ocamlformat)
195-
(action (diff tests/letop_broken.ml.broken-ref letop_broken.ml.output)))
196-
197184
(rule
198185
(deps tests/.ocamlformat )
199186
(package ocamlformat)

‎test/failing/tests/letop_broken.ml‎

Lines changed: 0 additions & 18 deletions
This file was deleted.

‎test/failing/tests/letop_broken.ml.broken-ref‎

Lines changed: 0 additions & 8 deletions
This file was deleted.

0 commit comments

Comments
 (0)