Merge branch 'MAIN' into pr/2737

Author: Julow

CHANGES.md

@@ -6,12 +6,65 @@ 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.
+  This also applies to `let%ext` bindings (#2747, @WardBrian).
+
 ### Fixed
 
+- Fix dropped comment in `(function _ -> x (* cmt *))` (#2739, @Julow)
+
+- \* `cases-matching-exp-indent=compact` does not impact `begin end` nodes that
+  don't have a match inside. (#2742, @EmileTrotignon)
+  ```ocaml
+  (* before *)
+  begin match () with
+  | () -> begin
+    f x
+  end
+  end
+  (* after *)
+  begin match () with
+  | () -> begin
+      f x
+    end
+  end
+  ```
+
 - `Ast_mapper` now iterates on *all* locations inside of Longident.t,
   instead of only some.
   (#2737, @v-gb)
 
+### Internal
+
+- Added information on writing tests to `CONTRIBUTING.md` (#2838, @WardBrian)
+
+### Changed
+
+- indentation of the `end` keyword in a match-case is now always at least 2. (#2742, @EmileTrotignon)
+  ```ocaml
+  (* before *)
+  begin match () with
+  | () -> begin
+    match () with
+    | () -> ()
+  end
+  end
+  (* after *)
+  begin match () with
+  | () -> begin
+    match () with
+    | () -> ()
+    end
+  end
+  ```
+
 ## 0.28.1
 
 ### Highlight
@@ -40,7 +93,7 @@ profile. This started with version 0.26.0.
 ### Added
 
 - Added option `module-indent` option (#2711, @HPRIOR) to control the indentation
-  of items within modules. This affects modules and signatures. For example, 
+  of items within modules. This affects modules and signatures. For example,
   module-indent=4:
   ```ocaml
   module type M = sig
@@ -148,7 +201,7 @@ profile. This started with version 0.26.0.
 - Fix a crash where `type%e nonrec t = t` was formatted as `type nonrec%e t = t`,
   which is invalid syntax. (#2712, @EmileTrotignon)
 
-- Fix commandline parsing being quadratic in the number of arguments 
+- Fix commandline parsing being quadratic in the number of arguments
   (#2724, @let-def)
 
 - \* Fix `;;` being added after a documentation comment (#2683, @EmileTrotignon)

CONTRIBUTING.md

@@ -19,8 +19,57 @@ We heartily welcome pull requests. To ensure an effective contribution, please a
 1. For significant, invasive, or output-affecting changes, consider opening an issue for discussion before committing substantial time and effort.
 2. If you're new to the project, starting with the [Good first issues](https://github.com/ocaml-ppx/ocamlformat/issues?utf8=%E2%9C%93&q=is%3Aissue+is%3Aopen+label%3A%22Good-first-issue+%3Agreen_heart%3A%22) can be beneficial.
 3. Fork the repository and create your branch from `main`.
-4. If you've added code that should be tested, supplement it with tests located in the `test/` directory.
-5. Ensure that the test suite passes (see [Running the tests](#running-the-tests) for instructions).
+4. Ensure that the test suite passes (see [Running the tests](#running-the-tests) for instructions). If there are changes in the tests,
+   verify that they are expected. If no existing test output changed, you likely need to add new tests (see [Adding a test](#adding-a-test)).
+
+### Adding a Test
+
+#### Golden Tests
+
+The majority of tests for `ocamlformat` are so called "golden" or "expect" tests. These
+tests all consist of running `ocamlformat` on `.ml` files and comparing the
+output to expected output stored in reference files. The `dune` configuration
+for this is automatically generated for you based on the files present in these
+directories the first time `dune runtest` is executed.
+
+These are separated into `test/failing` and `test/passing` directories.
+
+To add a test showing currently incorrect behavior, add a `.ml` file to
+`test/failing/tests`. If command line arguments are needed, create a
+corresponding `.ml.opts` file with the same name. The output of these tests
+will be stored in `.ml.broken-ref` files.
+
+To add a test showing correct behavior, add a `.ml` file to `test/passing/tests`
+or update an existing file there. These tests are similar to the failing tests,
+including the use of the `.ml.opts` files for command line arguments, however the
+same file will be tested against all of the built-in configurations (e.g.
+`default`, `janestreet`, etc.), with outputs appearing in sub folders named
+`refs.<configuration>`.
+
+In both cases, if multiple sets of options are desired, you can create multiple
+`.ml.opts` files with names provided after a `-`, for example `mytest.ml` can have
+`mytest-foo.ml.opts` and `mytest-bar.ml.opts`. This will create multiple test targets.
+
+The first time you [run the tests](#running-the-tests), the `dune.inc` file will
+be updated. Once you have promoted this, subsequent runs will show you any
+differences between the expected and actual outputs, which can be accepted with
+`dune promote`.
+
+#### cram-Style Tests
+
+The remaining tests are not designed to test the formatting output of
+`ocamlformat`, but rather the command line interface behavior, such as error
+messages and help text.
+
+These are found in `test/cli` and are written using
+[cram testing](https://dune.readthedocs.io/en/latest/reference/cram.html).
+Each test is a `.t` file that contains shell commands and their expected
+outputs. To add a new test, create a new `.t` file, or add new commands (lines
+beginning with ` $`) to an existing file.
+
+#### Unit Tests
+
+Unit tests are located in the `test/unit` directory and are written using [Alcotest](https://github.com/mirage/alcotest).
 
 ### Running the Tests
 

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 and let%ext
+           bindings. 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

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,30 @@ 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 and \
+       $(i,let%ext) bindings."
+    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 +1380,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

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

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

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,10 +233,54 @@ 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 -> (
+              b.pbop_is_pun
+              ||
+              match (b.pbop_pat.ppat_desc, b.pbop_exp.pexp_desc) with
+              | Ppat_var {txt; _}, Pexp_ident {txt= Lident e; _} ->
+                  String.equal txt 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
+    let value_bindings (m : Ast_mapper.mapper) vbs =
+      let punning is_extension vb =
+        let is_extension =
+          (* [and] nodes don't have extensions, so we need to track if the
+             earlier [let] did *)
+          is_extension || Option.is_some vb.pvb_attributes.attrs_extension
+        in
+        let pvb_is_pun =
+          is_extension
+          &&
+          match prefer_let_puns with
+          | None -> vb.pvb_is_pun
+          | Some false -> false
+          | Some true -> (
+              vb.pvb_is_pun
+              ||
+              match (vb.pvb_pat.ppat_desc, vb.pvb_body) with
+              | ( Ppat_var {txt; _}
+                , Pfunction_body {pexp_desc= Pexp_ident {txt= Lident e; _}; _}
+                ) ->
+                  String.equal txt e
+              | _ -> false )
+        in
+        (is_extension, {vb with pvb_is_pun})
+      in
+      let vbs' =
+        { vbs with
+          pvbs_bindings=
+            snd @@ List.fold_map ~init:false ~f:punning vbs.pvbs_bindings }
+      in
+      Ast_mapper.default_mapper.value_bindings m vbs'
+    in
     let pat m = function
       | {ppat_desc= Ppat_cons (_ :: _ :: _ :: _ as l); _} as p
         when match List.last_exn l with
@@ -305,11 +349,12 @@ module Parse = struct
           {p with pexp_desc= Pexp_tuple l}
       | e -> Ast_mapper.default_mapper.expr m e
     in
-    Ast_mapper.{default_mapper with expr; pat; binding_op}
+    Ast_mapper.{default_mapper with expr; pat; binding_op; value_bindings}
 
-  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 =

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

lib/Fmt_ast.ml

@@ -1633,6 +1633,7 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?pro ~wrap_intro
           in
           fmt_infix_ext_attrs c ~pro:function_ infix_ext_attrs
         in
+        let cmt_after_cases = Cmts.fmt_after c function_loc in
         let box_cases ~pro cases =
           let pro_inner, pro_outer, indent =
             (* Formatting of if-then-else relies on the ~box argument. *)
@@ -1653,8 +1654,9 @@ and fmt_function ?force_closing_paren ~ctx ~ctx0 ?pro ~wrap_intro
                   ( fmt_pattern c ~pro:(if_newline "| ") (sub_pat ~ctx pc_lhs)
                   $ space_break $ str "->" )
                 $ space_break
-                $ cbox 0 (fmt_expression c (sub_exp ~ctx pc_rhs)) )
-          | _ -> (box, fmt_cases c ctx cs)
+                $ cbox 0 (fmt_expression c (sub_exp ~ctx pc_rhs))
+                $ cmt_after_cases )
+          | _ -> (box, fmt_cases c ctx cs $ cmt_after_cases)
         in
         (fun_ $ function_, box_cases cases, box, 0)
   in
@@ -2570,14 +2572,16 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
              $ fmt_atrs ) )
   | Pexp_let (lbs, body, loc_in) ->
       let bindings =
-        Sugar.Let_binding.of_let_bindings ~ctx lbs.pvbs_bindings
+        Sugar.Let_binding.of_let_bindings ~ctx ~cmts:c.cmts lbs.pvbs_bindings
       in
       let fmt_expr = fmt_expression c (sub_exp ~ctx body) in
       pro
       $ fmt_let_bindings c ~ctx0:ctx ~parens ~fmt_atrs ~fmt_expr ~has_attr
           ~loc_in lbs.pvbs_rec bindings body
   | Pexp_letop {let_; ands; body; loc_in} ->
-      let bd = Sugar.Let_binding.of_binding_ops (let_ :: ands) in
+      let bd =
+        Sugar.Let_binding.of_binding_ops ~cmts:c.cmts (let_ :: ands)
+      in
       let fmt_expr = fmt_expression c (sub_exp ~ctx body) in
       pro
       $ fmt_let_bindings c ~ctx0:ctx ~parens ~fmt_atrs ~fmt_expr ~has_attr
@@ -3266,7 +3270,7 @@ and fmt_class_expr c ({ast= exp; ctx= ctx0} as xexp) =
         | _ -> c.conf.fmt_opts.indent_after_in.v
       in
       let bindings =
-        Sugar.Let_binding.of_let_bindings ~ctx lbs.pvbs_bindings
+        Sugar.Let_binding.of_let_bindings ~ctx ~cmts:c.cmts lbs.pvbs_bindings
       in
       let fmt_expr = fmt_class_expr c (sub_cl ~ctx body) in
       let has_attr = not (List.is_empty pcl_attributes) in
@@ -4694,7 +4698,9 @@ and fmt_structure_item c ~last:last_item ~semisemi {ctx= parent_ctx; ast= si}
       let fmt_item c ctx ~prev ~next b =
         let first = Option.is_none prev in
         let last = Option.is_none next in
-        let b = Sugar.Let_binding.of_let_binding ~ctx ~first b in
+        let b =
+          Sugar.Let_binding.of_let_binding ~ctx ~first ~cmts:c.cmts b
+        in
         let epi =
           match c.conf.fmt_opts.let_binding_spacing.v with
           | `Compact -> None