ormolu 0.8.2.0 → 0.9.0.0

raw patch · 140 files changed

+2912/−1143 lines, 140 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +81/−0
• CONTRIBUTING.md +23/−23
• README.md +87/−81
• app/Main.hs +2/−2
• data/examples/declaration/data/comment-in-empty-record-out.hs +6/−0
• data/examples/declaration/data/comment-in-empty-record.hs +5/−0
• data/examples/declaration/data/haddock-before-deriving-out.hs +5/−0
• data/examples/declaration/data/haddock-before-deriving.hs +3/−0
• data/examples/declaration/data/haddock-before-record-braces-out.hs +6/−0
• data/examples/declaration/data/haddock-before-record-braces.hs +5/−0
• data/examples/declaration/data/infix-haddocks-out.hs +2/−2
• data/examples/declaration/data/record-empty-haddock-out.hs +5/−0
• data/examples/declaration/data/record-empty-haddock.hs +6/−0
• data/examples/declaration/data/unnamed-field-comment-3-out.hs +1/−5
• data/examples/declaration/data/unpack-field-comment-0-out.hs +4/−0
• data/examples/declaration/data/unpack-field-comment-0.hs +2/−0
• data/examples/declaration/data/unpack-field-comment-1-out.hs +4/−0
• data/examples/declaration/data/unpack-field-comment-1.hs +2/−0
• data/examples/declaration/data/unpack-field-comment-2-out.hs +4/−0
• data/examples/declaration/data/unpack-field-comment-2.hs +3/−0
• data/examples/declaration/data/unpack-field-comment-3-out.hs +4/−0
• data/examples/declaration/data/unpack-field-comment-3.hs +3/−0
• data/examples/declaration/rewrite-rule/prelude4-out.hs +1/−0
• data/examples/declaration/type-families/closed-type-family/multi-line-out.hs +1/−2
• data/examples/declaration/type-synonyms/multi-line-out.hs +1/−2
• data/examples/declaration/value/function/arrow/proc-do-complex-out.hs +1/−2
• data/examples/declaration/value/function/arrow/proc-lambdas-out.hs +1/−2
• data/examples/declaration/value/function/awkward-comment-0-out.hs +1/−2
• data/examples/declaration/value/function/awkward-comment-1-out.hs +1/−2
• data/examples/declaration/value/function/case-comment-after-pattern-out.hs +3/−0
• data/examples/declaration/value/function/case-comment-after-pattern.hs +3/−0
• data/examples/declaration/value/function/case-comment-between-alt-and-where-out.hs +6/−0
• data/examples/declaration/value/function/case-comment-between-alt-and-where.hs +6/−0
• data/examples/declaration/value/function/case-multi-line-out.hs +1/−2
• data/examples/declaration/value/function/lambda-comment-after-arrow-out.hs +2/−0
• data/examples/declaration/value/function/lambda-comment-after-arrow.hs +2/−0
• data/examples/declaration/value/function/newline-single-line-body-out.hs +1/−2
• data/examples/declaration/value/function/operator-comments-3-out.hs +5/−0
• data/examples/declaration/value/function/operator-comments-3.hs +5/−0
• data/examples/declaration/value/function/operator-comments-4-out.hs +4/−0
• data/examples/declaration/value/function/operator-comments-4.hs +4/−0
• data/examples/declaration/value/function/record/wildcard-comments-0-out.hs +12/−0
• data/examples/declaration/value/function/record/wildcard-comments-0.hs +11/−0
• data/examples/declaration/value/function/record/wildcard-comments-1-out.hs +12/−0
• data/examples/declaration/value/function/record/wildcard-comments-1.hs +11/−0
• data/examples/import/comment-before-merged-import-lists-out.hs +7/−0
• data/examples/import/comment-before-merged-import-lists.hs +7/−0
• data/examples/import/comment-before-merged-imports-out.hs +7/−0
• data/examples/import/comment-before-merged-imports.hs +3/−0
• data/examples/import/comment-between-merged-imports-out.hs +7/−0
• data/examples/import/comment-between-merged-imports.hs +6/−0
• data/examples/import/comment-inside-empty-import-list-out.hs +6/−0
• data/examples/import/comment-inside-empty-import-list.hs +5/−0
• data/examples/import/comment-inside-sorted-import-list-out.hs +7/−0
• data/examples/import/comment-inside-sorted-import-list.hs +7/−0
• data/examples/import/comments-inside-imports-out.hs +2/−3
• data/examples/import/comments-per-import-out.hs +1/−2
• data/examples/import/data-out.hs +5/−1
• data/examples/import/explicit-imports-with-comments-out.hs +3/−5
• data/examples/import/explicit-level-imports-out.hs +4/−1
• data/examples/import/merging-0-out.hs +4/−1
• data/examples/import/merging-1-out.hs +4/−1
• data/examples/import/merging-2-out.hs +8/−2
• data/examples/import/simple-out.hs +10/−2
• data/examples/module-header/block-haddock-in-export-list-out.hs +1/−1
• data/examples/module-header/empty-haddock-out.hs +2/−0
• data/examples/other/block-comment-before-argument-out.hs +5/−0
• data/examples/other/block-comment-before-argument.hs +4/−0
• data/examples/other/block-comment-before-element-out.hs +6/−0
• data/examples/other/block-comment-before-element.hs +6/−0
• data/examples/other/comment-around-quasiquote-out.hs +9/−0
• data/examples/other/comment-around-quasiquote.hs +9/−0
• data/examples/other/comment-block-section-heading-out.hs +3/−0
• data/examples/other/comment-block-section-heading.hs +3/−0
• data/examples/other/comment-glued-together-out.hs +1/−1
• data/examples/other/comment-in-empty-list-out.hs +9/−0
• data/examples/other/comment-in-empty-list.hs +6/−0
• data/examples/other/comment-opening-a-list-out.hs +11/−0
• data/examples/other/comment-opening-a-list.hs +11/−0
• data/examples/other/comment-style-transform-out.hs +17/−14
• data/examples/other/comment-trigger-escaping-out.hs +15/−0
• data/examples/other/comment-trigger-escaping.hs +15/−0
• data/examples/other/comment-two-blocks-out.hs +3/−2
• data/examples/other/empty-haddock-out.hs +6/−2
• data/examples/other/invalid-haddock-weird-out.hs +1/−3
• data/examples/other/pragma-below-header-out.hs +19/−0
• data/examples/other/pragma-below-header.hs +18/−0
• data/examples/other/pragma-comment-multi-extension-out.hs +5/−0
• data/examples/other/pragma-comment-multi-extension.hs +4/−0
• ormolu.cabal +15/−4
• src/Ormolu.hs +49/−20
• src/Ormolu/Comments/Anchor.hs +326/−0
• src/Ormolu/Comments/Invariants.hs +135/−0
• src/Ormolu/Comments/Tree.hs +74/−0
• src/Ormolu/Config.hs +4/−3
• src/Ormolu/Diff/ParseResult.hs +58/−3
• src/Ormolu/Diff/Text.hs +1/−1
• src/Ormolu/Exception.hs +25/−4
• src/Ormolu/Fixity.hs +1/−1
• src/Ormolu/Fixity/Imports.hs +1/−1
• src/Ormolu/Fixity/Internal.hs +5/−5
• src/Ormolu/Imports.hs +35/−14
• src/Ormolu/Parser.hs +18/−9
• src/Ormolu/Parser/CommentStream.hs +251/−105
• src/Ormolu/Parser/Pragma.hs +1/−1
• src/Ormolu/Parser/Result.hs +24/−3
• src/Ormolu/Printer.hs +76/−18
• src/Ormolu/Printer/Combinators.hs +120/−60
• src/Ormolu/Printer/CommentPlacement.hs +57/−0
• src/Ormolu/Printer/Comments.hs +110/−188
• src/Ormolu/Printer/Internal.hs +182/−151
• src/Ormolu/Printer/Meat/Common.hs +172/−26
• src/Ormolu/Printer/Meat/Declaration.hs +15/−13
• src/Ormolu/Printer/Meat/Declaration/Class.hs +1/−1
• src/Ormolu/Printer/Meat/Declaration/Data.hs +57/−50
• src/Ormolu/Printer/Meat/Declaration/Foreign.hs +6/−6
• src/Ormolu/Printer/Meat/Declaration/Instance.hs +1/−1
• src/Ormolu/Printer/Meat/Declaration/OpTree.hs +39/−23
• src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs +1/−1
• src/Ormolu/Printer/Meat/Declaration/Rule.hs +1/−1
• src/Ormolu/Printer/Meat/Declaration/Signature.hs +3/−3
• src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs +17/−17
• src/Ormolu/Printer/Meat/Declaration/Type.hs +1/−1
• src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +2/−2
• src/Ormolu/Printer/Meat/Declaration/Value.hs +75/−71
• src/Ormolu/Printer/Meat/ImportExport.hs +2/−2
• src/Ormolu/Printer/Meat/Module.hs +10/−4
• src/Ormolu/Printer/Meat/Pragma.hs +10/−3
• src/Ormolu/Printer/Meat/Type.hs +16/−15
• src/Ormolu/Printer/Operators.hs +29/−29
• src/Ormolu/Printer/SpanStream.hs +0/−49
• src/Ormolu/Processing/Common.hs +2/−2
• src/Ormolu/Processing/Preprocess.hs +4/−4
• src/Ormolu/Terminal.hs +2/−2
• src/Ormolu/Utils.hs +21/−7
• src/Ormolu/Utils/Fixity.hs +5/−5
• tests/Ormolu/Comments/AnchorSpec.hs +140/−0
• tests/Ormolu/FixitySpec.hs +1/−1
• tests/Ormolu/PrinterSpec.hs +12/−43
• tests/Ormolu/TestConfig.hs +49/−0

@@ -1,3 +1,84 @@+## Ormolu 0.9.0.0++* Comments are now attached to the syntax tree by position, before anything+  is printed, rather than by a cursor advanced as the printer walks the+  tree. Which element owns a comment no longer depends on the order in which+  the printer happens to visit things, so comments stop escaping the+  construct they were written in when Ormolu sorts or regroups it: a comment+  inside an import list stays there, a comment after a quasi-quote stops+  floating to the bottom of the file, and a comment attached to an import+  travels with that import when the imports are sorted. [Issue+  1074](https://github.com/tweag/ormolu/issues/1074) and [issue+  1076](https://github.com/tweag/ormolu/issues/1076).++* Haddock comments are now printed as they were written instead of being+  rebuilt from the documentation string GHC parsed out of them. A `{- | …+  -}` stays a block comment rather than becoming `--` lines, an empty `-- |`+  is no longer dropped, and a `{- *** … -}` section heading keeps its+  meaning. [Issue 641](https://github.com/tweag/ormolu/issues/641), [issue+  822](https://github.com/tweag/ormolu/issues/822), and [issue+  1159](https://github.com/tweag/ormolu/issues/1159).++  Ormolu still puts a space after a Haddock's trigger, re-indents a block+  Haddock to line up with the code it documents, and rewrites a trailing `--+  ^ X` as a leading `-- | X` when it moves the comment in front of what it+  documents.++* Backslashes are no longer added to lines in the middle of a comment block,+  where Haddock does not look for a trigger anyway. [Issue+  1131](https://github.com/tweag/ormolu/issues/1131).++* A comment written on its own line in front of an operator no longer+  strands the operator at the start of the next line. In a `do` block that+  changed what the code meant, because `$` at the beginning of a line is+  read as a new statement rather than as a continuation of the previous one.+  [Issue 1028](https://github.com/tweag/ormolu/issues/1028).++* A comment written after `=`, `->`, or a lambda arrow now stays on that+  line instead of being pushed onto the next one, and the result is+  idempotent. `f x = -- note` no longer becomes an `=` stranded on a line of+  its own. [Issue 786](https://github.com/tweag/ormolu/issues/786), [issue+  810](https://github.com/tweag/ormolu/issues/810), and [issue+  936](https://github.com/tweag/ormolu/issues/936).++* Layout decisions now take comments into account. A comment that falls+  inside a construct can no longer be squeezed into a single-line rendering+  of it.++* A comment block that trails a line of code and continues below it no+  longer drops to the start of the line, which could put the rest of the+  block outside the construct it was written in.++* A construct that brackets its contents is no longer put on one line when+  something inside it is documented with a `-- |` Haddock. Such a Haddock+  takes whole lines, so it used to swallow the closing bracket: a documented+  `deriving` clause came out as `deriving (-- | B`, and a documented field+  of a short record as `{-- | …`, which did not even parse. [Issue+  752](https://github.com/tweag/ormolu/issues/752) and [issue+  1164](https://github.com/tweag/ormolu/issues/1164).++  A `{- | … -}` Haddock is self-delimiting and does not force anything, so+  a declaration documented that way is left as it was written rather than+  being broken up: `data A = A {- | a number -} Int Bool` stays on one line+  where it used to be spread over five.++* Only pragmas in the file header are hoisted to the top of the module now.+  A `LANGUAGE` or `OPTIONS_GHC` pragma written after the first import or+  declaration stays where it is, and no longer drags the comments above it+  to the top of the file. GHC reads the header and stops, so such a pragma+  never affected compilation; moving it was giving it an effect it did not+  have. [Issue 1168](https://github.com/tweag/ormolu/issues/1168).++* A comment above a `{-# LANGUAGE A, B #-}` pragma is no longer duplicated+  when the pragma is split into one per extension; it stays with the first.+  [Issue 787](https://github.com/tweag/ormolu/issues/787).++* Ormolu now checks that the comments of the output correspond to the+  comments of the input—none dropped, duplicated, invented, or reordered—and+  refuses to format when they do not. This runs alongside the existing check+  that the AST is unchanged, is disabled by `--unsafe`, and costs nothing+  extra: the printer already records where it put each comment.+ ## Ormolu 0.8.2.0  * Overhaul how operator fixity information is collected. In addition to the

@@ -1,38 +1,38 @@ # Contributing -Issues (bugs, feature requests or otherwise feedback) may be reported in-[the GitHub issue tracker for this project][issues]. Pull requests are also+Issues (bugs, feature requests, or other feedback) may be reported in [the+GitHub issue tracker for this project][issues]. Pull requests are also welcome.  When contributing to this repository, please first discuss the change you wish to make via an issue, unless it's entirely trivial (typo fixes, etc.). If there is already an issue that describes the change you have in mind,-comment on it indicating that you're going to work on that. This way we can-avoid the situation when several people work on the same thing.+comment on it to indicate that you're going to work on it. This way we can+avoid situations where several people work on the same thing. -Please make sure that all non-trivial changes are described in commit+Please make sure that all non-trivial changes are described in the commit messages and PR descriptions.  ## Testing -Testing has been taken good care of and now it amounts to just adding-examples under `data/examples`. Each example is a pair of files:-`<example-name>.hs` for input and `<example-name>-out.hs` for corresponding-expected output.+Testing is well taken care of, so it usually amounts to just adding examples+under `data/examples`. Each example is a pair of files: `<example-name>.hs`+for the input and `<example-name>-out.hs` for the corresponding expected+output. -Testing is performed as following:+Testing is performed as follows: -* Given snippet of source code is parsed and pretty-printed.-* The result of printing is parsed back again and the AST is compared to the-  AST obtained from the original file. They should match.-* The output of printer is checked against the expected output.-* Idempotence property is verified: formatting already formatted code+* The given snippet of source code is parsed and pretty-printed.+* The result of printing is parsed again, and its AST is compared to the AST+  obtained from the original file. The two should match.+* The output of the printer is checked against the expected output.+* The idempotence property is verified: formatting already formatted code   results in exactly the same output. -Examples can be organized in sub-directories, see the existing ones for+Examples can be organized into sub-directories; see the existing ones for inspiration. -Please note that we try to keep individual files at most 25 lines long+Please note that we try to keep individual files at most 25 lines long, because otherwise it's hard to figure out what went wrong when a test fails.  To regenerate outputs that have changed, you can set the@@ -40,13 +40,13 @@  ## Formatting - - Use `nix run .#format` script to format Ormolu with the current version of-   Ormolu.+ - Use the `nix run .#format` script to format Ormolu with the current+   version of Ormolu. - - Additional formatters are configured via a pre-commit hook which is-   automatically installed when entering the Nix shell. You can also run it via-   `pre-commit run`/`pre-commit run -a`.+ - Additional formatters are configured via a pre-commit hook, which is+   installed automatically when you enter the Nix shell. You can also run it+   via `pre-commit run` or `pre-commit run -a`. -If Ormolu is not formatted like this, the CI will fail.+If Ormolu is not formatted this way, CI will fail.  [issues]: https://github.com/mrkkrp/ormolu/issues

@@ -6,13 +6,16 @@ [![Stackage LTS](http://stackage.org/package/ormolu/badge/lts)](http://stackage.org/lts/package/ormolu) [![CI](https://github.com/mrkkrp/ormolu/actions/workflows/ci.yml/badge.svg)](https://github.com/mrkkrp/ormolu/actions/workflows/ci.yml) +*Ormolu gratefully acknowledges the support and contributions of+[Tweag][tweag] during the period 2019–2026.*+ * [Installation](#installation) * [Building from source](#building-from-source) * [Usage](#usage)     * [Ormolu Live](#ormolu-live)     * [Editor integration](#editor-integration)     * [Haskell Language Server](#haskell-language-server)-    * [GitHub actions](#github-actions)+    * [GitHub Actions](#github-actions)     * [Language extensions, dependencies, and fixities](#language-extensions-dependencies-and-fixities)     * [Magic comments](#magic-comments)     * [Regions](#regions)@@ -29,21 +32,19 @@ Ormolu is a formatter for Haskell source code. The project was created with the following goals in mind: -* Using GHC's own parser to avoid parsing problems caused by+* Use GHC's own parser to avoid the parsing problems caused by   [`haskell-src-exts`][haskell-src-exts].-* Let some whitespace be programmable. The layout of the input influences-  the layout choices in the output. This means that the choices between-  single-line/multi-line layouts in certain situations are made by the user,-  not by an algorithm. This makes the implementation simpler and leaves some-  control to the user while still guaranteeing that the formatted code is-  stylistically consistent.-* Writing code in such a way so it's easy to modify and maintain.-* Implementing one “true” formatting style which admits no configuration.-* The formatting style aims to result in minimal diffs.+* Make some whitespace programmable. The layout of the input influences the+  layout choices in the output, so the choice between single-line and+  multi-line layouts is made by the user rather than by an algorithm. This+  keeps the implementation simpler and leaves some control to the user while+  still guaranteeing that the formatted code is stylistically consistent.+* Implement one “true” formatting style that admits no configuration.+* Produce minimal diffs. * Choose a style compatible with modern dialects of Haskell. As new Haskell-  extensions enter broad use, we may change the style to accommodate them.-* Idempotence: formatting already formatted code doesn't change it.-* Be well-tested and robust so that the formatter can be used in large+  extensions enter broad use, we may adjust the style to accommodate them.+* Guarantee idempotence: formatting already formatted code doesn't change it.+* Stay well-tested and robust, so that the formatter can be used in large   projects.  Try it out in your browser at <https://ormolu-live.markkarpov.com>!@@ -51,17 +52,17 @@  ## Installation -The [release page][releases] has binaries for Linux, macOS and Windows.+The [release page][releases] has binaries for Linux, macOS, and Windows. -You can also install using `cabal` or `stack`:+You can also install Ormolu with `cabal` or `stack`:  ```console $ cabal install ormolu $ stack install ormolu ``` -Ormolu is also included in several package repositories. E.g., on Arch Linux,-one can use [the package on AUR][aur]:+Ormolu is also included in several package repositories. For example, on Arch+Linux you can use [the package on AUR][aur]:  ```console $ yay -S ormolu@@ -78,7 +79,7 @@ Make sure to accept the offered Nix binary caches, otherwise building may take a very long time. The flake declares the relevant caches (the IOG cache and the project's own `ormolu.cachix.org`, which is populated by CI) via its-`nixConfig`, but Nix only uses them if you allow it to. The simplest way is+`nixConfig`, but Nix uses them only if you allow it to. The simplest way is to pass `--accept-flake-config`:  ```console@@ -93,14 +94,15 @@ extra-trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= ormolu.cachix.org-1:0L9Y4A+6dGpvfGtaeaq5w44pgX0AVRivKMfi2fiOzYE= ``` -Alternatively, `stack` could be used as follows:+Alternatively, you can use `stack`:  ```console $ stack build # to build $ stack install # to install ``` -To use Ormolu directly from GitHub with Nix flakes, this snippet may come in handy:+To use Ormolu directly from GitHub with Nix flakes, this snippet may come in+handy:  ```nix {@@ -113,14 +115,14 @@  ## Usage -The following will print the formatted output to the standard output.+The following prints the formatted output to the standard output:  ```console $ ormolu Module.hs ```  Add `--mode inplace` to replace the contents of the input file with the-formatted output.+formatted output:  ```console $ ormolu --mode inplace Module.hs@@ -138,7 +140,7 @@ $ ormolu --mode inplace $(git ls-files '*.hs') ``` -To check if files are are already formatted (useful on CI):+To check whether files are already formatted (useful on CI):  ```console $ ormolu --mode check $(find . -name '*.hs')@@ -156,7 +158,8 @@  On every new commit to `master`, [Ormolu Live](./ormolu-live) is deployed to https://ormolu-live.markkarpov.com. Older versions are available at-https://COMMITHASH--ormolu.netlify.app.+https://COMMITHASH--ormolu.netlify.app, where `COMMITHASH` is the hash of the+commit you want.  ### Editor integration @@ -171,25 +174,24 @@ [Haskell Language Server](https://haskell-language-server.readthedocs.io) has built-in support for using Ormolu as a formatter. -### GitHub actions+### GitHub Actions  [`run-ormolu`][run-ormolu] is the recommended way to ensure that a project-is formatted with Ormolu.+stays formatted with Ormolu.  ### Language extensions, dependencies, and fixities  Ormolu automatically locates the Cabal file that corresponds to a given-source code file. Cabal files are used to extract both default extensions-and dependencies. Default extensions directly affect behavior of the GHC-parser, while dependencies are used to figure out fixities of operators that-appear in the source code. Fixities can also be overridden via an `.ormolu`-file which should be located at a higher level in the file system hierarchy-than the source file that is being formatted. When the input comes from-stdin, one can pass `--stdin-input-file` which will give Ormolu the location-that should be used as the starting point for searching for `.cabal` and-`.ormolu` files.+source file. Cabal files are used to extract both default extensions and+dependencies. Default extensions directly affect the behavior of the GHC+parser, while dependencies are used to determine the fixities of operators+that appear in the source code. Fixities can also be overridden via an+`.ormolu` file, which should be located higher in the file system hierarchy+than the source file being formatted. When the input comes from stdin, you+can pass `--stdin-input-file` to tell Ormolu which location to use as the+starting point when searching for `.cabal` and `.ormolu` files. -Here is an example of `.ormolu` file:+Here is an example of an `.ormolu` file:  ```haskell infixr 9  .@@ -205,21 +207,20 @@ infixr 3.7 <~> ``` -It uses exactly the same syntax as usual Haskell fixity declarations to make-it easier for Haskellers to edit and maintain. Since Ormolu 0.7.8.0-fractional precedences are supported for more precise control over-formatting of complex operator chains.+It uses exactly the same syntax as ordinary Haskell fixity declarations,+which makes it easier for Haskellers to edit and maintain. Since Ormolu+0.7.8.0, fractional precedences are supported for more precise control over+the formatting of complex operator chains.  As of Ormolu 0.7.0.0, `.ormolu` files can also contain instructions about-module re-exports that Ormolu should be aware of. This might be desirable-because at the moment Ormolu cannot know about all possible module-re-exports in the ecosystem and only few of them are actually important when-it comes to fixity deduction. In 99% of cases the user won't have to do-anything, especially since most common re-exports are already programmed-into Ormolu. (You are welcome to open PRs to make Ormolu aware of more-re-exports by default.) However, when the fixity of an operator is not-inferred correctly, making Ormolu aware of a re-export may come in handy.-Here is an example:+module re-exports that Ormolu should be aware of. This can be useful because+Ormolu cannot know about every possible module re-export in the ecosystem,+and only a few of them actually matter for fixity deduction. In 99% of cases+you won't have to do anything, especially since the most common re-exports+are already built into Ormolu. (You are welcome to open PRs to make Ormolu+aware of more re-exports by default.) However, when the fixity of an operator+is not inferred correctly, making Ormolu aware of a re-export may help. Here+is an example:  ```haskell module Control.Lens exports Control.Lens.At@@ -255,19 +256,19 @@ {- ORMOLU_ENABLE -} ``` -This allows us to disable formatting selectively for code between these-markers or disable it for the entire file. To achieve the latter, just put-`{- ORMOLU_DISABLE -}` at the very top. Note that for Ormolu to work the-fragments where Ormolu is enabled must be parseable on their own. Because of-that the magic comments cannot be placed arbitrarily, but rather must-enclose independent top-level definitions.+These let you disable formatting selectively for the code between the two+markers, or for the entire file. To disable formatting for the whole file,+just put `{- ORMOLU_DISABLE -}` at the very top. Note that the fragments+where Ormolu is enabled must be parseable on their own. Because of this, the+magic comments cannot be placed arbitrarily; they must enclose independent+top-level definitions.  ### Regions -One can ask Ormolu to format a region of input and leave the rest-unformatted. This is accomplished by passing the `--start-line` and-`--end-line` command line options. `--start-line` defaults to the beginning-of the file, while `--end-line` defaults to the end.+You can ask Ormolu to format a region of the input and leave the rest+unformatted by passing the `--start-line` and `--end-line` command line+options. `--start-line` defaults to the beginning of the file, and+`--end-line` defaults to the end.  Note that the selected region needs to be parseable Haskell code on its own. @@ -286,16 +287,17 @@ 8         | Cabal file parsing failed 9         | Missing input file path when using stdin input and accounting for .cabal files 10        | Parse error while parsing fixity overrides+11        | Comments of original and formatted code differ 100       | In checking mode: unformatted files 101       | Inplace mode does not work with stdin 102       | Other issue (with multiple input files)  ### Using as a library -The `ormolu` package can also be depended upon from other Haskell programs.-For these purposes only the top `Ormolu` module should be considered stable.-It follows [PVP](https://pvp.haskell.org/) starting from the version-0.5.3.0. Rely on other modules at your own risk.+The `ormolu` package can also be used as a dependency from other Haskell+programs. For this purpose, only the top-level `Ormolu` module should be+considered stable. It follows the [PVP](https://pvp.haskell.org/) starting+from version 0.5.3.0. Rely on other modules at your own risk.  ## Troubleshooting @@ -310,40 +312,41 @@   specify the correct fixities in a `.ormolu` file.  * If this is a third-party operator (e.g. from `base` or some other package-  from Hackage), Ormolu probably doesn't recognize that the operator is the+  on Hackage), Ormolu probably doesn't recognize that the operator is the   same as the third-party one. -  Some reasons this might be the case:+  Some possible reasons for this: -    * You might have a custom Prelude that re-exports things from Prelude-    * You might have `-XNoImplicitPrelude` turned on+    * You have a custom Prelude that re-exports things from the standard+      Prelude.+    * You have `-XNoImplicitPrelude` turned on. -  If any of these are true, make sure to specify the reexports correctly in-  a `.ormolu` file.+  If either of these applies, make sure to specify the re-exports correctly+  in a `.ormolu` file. -You can see how Ormolu decides the fixity of operators if you use `--debug`.+You can see how Ormolu decides the fixity of operators by using `--debug`.  ## Limitations  * CPP support is experimental. CPP is virtually impossible to handle-  correctly, so we process them as a sort of unchangeable snippets. This-  works only in simple cases when CPP conditionals surround top-level-  declarations. See the [CPP][design-cpp] section in the design notes for a+  correctly, so Ormolu treats CPP sections as unchangeable snippets. This+  works only in simple cases, where CPP conditionals surround top-level+  declarations. See the [CPP][design-cpp] section of the design notes for a   discussion of the dangers.  ## Running on Hackage -It's possible to try Ormolu on arbitrary packages from Hackage. For that-execute (from the root of the cloned repo):+You can try Ormolu on arbitrary packages from Hackage. To do so, run the+following from the root of the cloned repo:  ```console $ nix build .#hackage.<package> ``` -Then inspect `result/log.txt` for possible problems. The derivation will-also contain formatted `.hs` files for inspection and original inputs with-`.hs-original` extension (those are with CPP dropped, exactly what is fed-into Ormolu).+Then inspect `result/log.txt` for possible problems. The derivation also+contains the formatted `.hs` files for inspection, along with the original+inputs under the `.hs-original` extension (these have CPP dropped and are+exactly what is fed into Ormolu).  ## Forks and modifications @@ -354,7 +357,9 @@  ## Contributing -See [CONTRIBUTING.md][contributing].+Contributions of all kinds are welcome, from bug reports and documentation+fixes to new features. Please see [CONTRIBUTING.md][contributing] to get+started.  ## License @@ -362,6 +367,7 @@  Copyright © 2018–2026 Tweag I/O, 2026–present Mark Karpov +[tweag]: https://tweag.io/ [aur]: https://aur.archlinux.org/packages/ormolu [design-cpp]: https://github.com/mrkkrp/ormolu/blob/master/DESIGN.md#cpp [emacs-package]: https://github.com/vyorkin/ormolu.el

@@ -134,7 +134,7 @@           InPlace -> do             hPutStrLn               stderr-              "In place editing is not supported when input comes from stdin."+              "In-place editing is not supported when the input comes from stdin."             -- 101 is different from all the other exit codes we already use.             return (ExitFailure 101)           Check -> do@@ -198,7 +198,7 @@         Nothing -> return ExitSuccess         Just diff -> do           runTerm (printTextDiff diff) (cfgColorMode rawConfig) stderr-          -- 100 is different to all the other exit code that are emitted+          -- 100 is different from all the other exit codes that are emitted           -- either from an 'OrmoluException' or from 'error' and           -- 'notImplemented'.           return (ExitFailure 100)

@@ -0,0 +1,6 @@+instance StateKey ExampleReq where+  data State ExampleReq = ExampleState+    {+    -- in here you can put any state that the+    -- run.+    }

@@ -0,0 +1,5 @@+instance StateKey ExampleReq where+  data State ExampleReq = ExampleState {+        -- in here you can put any state that the+        -- run.+        }

@@ -0,0 +1,5 @@+data A = A+  deriving+    ( -- | B+      Eq+    )

@@ -0,0 +1,3 @@+data A = A+  -- | B+  deriving (Eq)

@@ -0,0 +1,6 @@+module Example where++data Hello = Hello+  { -- | hello world+    hello :: String+  }

@@ -0,0 +1,5 @@+module Example where++data Hello = Hello+  -- | hello world+  {hello :: String}

@@ -24,8 +24,8 @@  data DocPartial   = Left -- ^ left docs-    -- on multiple-    -- lines+         -- on multiple+         -- lines       :*:       Right   | -- | op

@@ -0,0 +1,5 @@+data A = A+  { -- \|+    --+    a :: Int+  }

@@ -0,0 +1,6 @@+data A = A+  {+    -- |+    -- +    a :: Int+  }

@@ -1,5 +1,1 @@-data A-  = A-      -- | a number-      Int-      Bool+data A = A {- | a number -} Int Bool

@@ -0,0 +1,4 @@+data Buffer+  = Buffer+      {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array+      {-# UNPACK #-} !(Ptr Word8) -- beginning of slice

@@ -0,0 +1,2 @@+data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array+                     {-# UNPACK #-} !(Ptr Word8)        -- beginning of slice

@@ -0,0 +1,4 @@+data P+  = P+      {-# UNPACK #-} !Word32 -- left word+      {-# UNPACK #-} !Word32 -- right word

@@ -0,0 +1,2 @@+data P = P {-# UNPACK #-} !Word32 -- left word+           {-# UNPACK #-} !Word32 -- right word

@@ -0,0 +1,4 @@+data TBQueue a+  = TBQueue+      {-# UNPACK #-} !(TVar Natural) -- CR:  read capacity+      {-# UNPACK #-} !(TVar [a]) -- R:   elements waiting to be read

@@ -0,0 +1,3 @@+data TBQueue a+   = TBQueue {-# UNPACK #-} !(TVar Natural) -- CR:  read capacity+             {-# UNPACK #-} !(TVar [a])     -- R:   elements waiting to be read

@@ -0,0 +1,4 @@+data Builder+  = Builder+      {-# UNPACK #-} !Int -- offset+      {-# UNPACK #-} !Int -- used units

@@ -0,0 +1,3 @@+data Builder = Builder+     {-# UNPACK #-} !Int -- offset+     {-# UNPACK #-} !Int -- used units

@@ -2,6 +2,7 @@ "unpack" [~1] forall a. unpackCString # a = build (unpackFoldrCString # a) "unpack-list" [1] forall a. unpackFoldrCString # a (:) [] = unpackCString # a "unpack-append" forall a n. unpackFoldrCString # a (:) n = unpackAppendCString # a n+ -- There's a built-in rule (in PrelRules.lhs) for --      unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n   #-}

@@ -25,6 +25,5 @@   F a = String  type family F a where-  F a -- foo-    =+  F a = -- foo     a

@@ -19,6 +19,5 @@     :<|> "route2" :> ApiRoute2 -- comment here     :<|> OmitDocs :> "i" :> ASomething API -type A -- foo-  =+type A = -- foo   B

@@ -29,8 +29,7 @@           Left             ( z,               w-              ) -> \u ->-              -- Procs can have lambdas+              ) -> \u -> -- Procs can have lambdas               let v =                     u -- Actually never used                       ^ 2

@@ -5,6 +5,5 @@ bar =   proc x -> \f g h ->     \() ->-      \(Left (x, y)) ->-        -- Tuple value+      \(Left (x, y)) -> -- Tuple value         f (g (h x)) -< y

@@ -1,6 +1,5 @@ mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a-mergeErrorReply err1 reply -- XXX where to put it?-  =+mergeErrorReply err1 reply = -- XXX where to put it?   case reply of     Ok x state err2 -> Ok x state (mergeError err1 err2)     Error err2 -> Error (mergeError err1 err2)

@@ -1,8 +1,7 @@ doForeign :: Vars -> [Name] -> [Term] -> Idris LExp doForeign x = x   where-    splitArg tm | (_, [_, _, l, r]) <- unApply tm -- pair, two implicits-      =+    splitArg tm | (_, [_, _, l, r]) <- unApply tm = -- pair, two implicits       do         let l' = toFDesc l         r' <- irTerm (sMN 0 "__foreignCall") vs env r

@@ -0,0 +1,3 @@+foo = case a of+  b -> -- comment+    c

@@ -0,0 +1,3 @@+foo = case a of+  b -- comment+    -> c

@@ -0,0 +1,6 @@+foo =+  case x of+    _ -> 1+  -- comment+  where+    x = 1

@@ -0,0 +1,6 @@+foo =+  case x of+    _ -> 1+    -- comment+    where+      x = 1

@@ -21,7 +21,6 @@ quux x = case x of   x -> x -funnyComment =-  -- comment+funnyComment = -- comment   case () of     () -> ()

@@ -0,0 +1,2 @@+f = \a -> -- foo+  a

@@ -0,0 +1,2 @@+f = \a -> -- foo+  a

@@ -4,7 +4,6 @@  function' :: String -> String function' s = case s of-  "ThisString" ->-    -- And a comment here is okay+  "ThisString" -> -- And a comment here is okay     "Yay"   _ -> "Boo"

@@ -0,0 +1,5 @@+data X = X {x :: Int}++f =+  id+    . (\s -> s {x = 1}) -- Some comment

@@ -0,0 +1,5 @@+data X = X { x :: Int }++f = id+    . -- Some comment+    (\s -> s { x = 1 })

@@ -0,0 +1,4 @@+foo = do+  bar+    -- txt+    $ baz

@@ -0,0 +1,4 @@+foo = do+  bar+    -- txt+    $ baz

@@ -0,0 +1,12 @@+{-# LANGUAGE RecordWildCards #-}++example =+  Record+    { -- A+      field = (), -- B+      -- C+      field = (), -- D+      -- E+      -- F+      ..+    } -- G

@@ -0,0 +1,11 @@+{-# LANGUAGE RecordWildCards #-}++example =+  Record+    { -- A+      field = (), -- B+      -- C+      field = (), -- D+      -- E+      .. -- F+    } -- G

@@ -0,0 +1,12 @@+{-# LANGUAGE RecordWildCards #-}++example =+  Record+    { -- A+      field = (),+      -- C+      field = (),+      -- E+      -- F+      ..+    } -- G

@@ -0,0 +1,11 @@+{-# LANGUAGE RecordWildCards #-}++example =+  Record+    { -- A+      field = (),+      -- C+      field = (),+      -- E+      .. -- F+    } -- G

@@ -0,0 +1,7 @@+-- their own formatters.+import Test.Hspec.Core.Formatters.V1.Monad+  ( FormatM,+    Formatter (..),+    Item (..),+    interpretWith,+  )

@@ -0,0 +1,7 @@+-- their own formatters.+import Test.Hspec.Core.Formatters.V1.Monad (+    Formatter(..)+  , FormatM+  )++import Test.Hspec.Core.Formatters.V1.Monad (Item(..), interpretWith)

@@ -0,0 +1,7 @@+-- Import stuff from Prelude explicitly+import Prelude+  ( Eq (..),+    Int,+    ($),+    (.),+  )

@@ -0,0 +1,3 @@+-- Import stuff from Prelude explicitly+import Prelude (Eq(..), Int)+import Prelude ((.), ($))

@@ -0,0 +1,7 @@+import HscMain (newHscEnv)+-- Implementations of the various modes+import LoadIface+  ( -- Imports for --abi-hash+    loadUserInterface,+    showIface,+  )

@@ -0,0 +1,6 @@+-- Implementations of the various modes+import           LoadIface ( showIface )+import           HscMain ( newHscEnv )++-- Imports for --abi-hash+import           LoadIface ( loadUserInterface )

@@ -0,0 +1,6 @@+import Package1+import Package2+import Package3+  (+  -- , import1+  )

@@ -0,0 +1,5 @@+import Package1+import Package3 (+ -- , import1+ )+import Package2

@@ -0,0 +1,7 @@+import Package1+import Package2+import Package3+  ( hi,+    -- , import1+    test,+  )

@@ -0,0 +1,7 @@+import Package1+import Package3 (+ hi,+ -- , import1+ test,+ )+import Package2

@@ -1,7 +1,6 @@--- x- import qualified -- x   Bar import qualified -- x   Baz-import Foo+import -- x+  Foo

@@ -1,4 +1,3 @@--- (1) import Bar -- (2) import Baz -- (3)-import Foo+import Foo -- (1)

@@ -1,3 +1,7 @@ module Bar (data P, T (data P), data f) where -import N (T (data P), data P, data f)+import N+  ( T (data P),+    data P,+    data f,+  )

@@ -1,7 +1,5 @@ import qualified MegaModule as M-  ( -- (1)-    -- (2)-    Either, -- (3)-    (<<<),-    (>>>),+  ( Either, -- (3)+    (<<<), -- (2)+    (>>>), -- (1)   )

@@ -9,5 +9,8 @@ import Data.ByteString.Lazy quote (d) import splice Data.Text (a, b, c) import PyF ()-import splice PyF (fmt, tmf)+import splice PyF+  ( fmt,+    tmf,+  ) import quote PyF (abc)

@@ -1,3 +1,6 @@ import Foo-import Foo (bar, foo)+import Foo+  ( bar,+    foo,+  ) import Foo as F

@@ -1,2 +1,5 @@ import "bar" Foo (bar)-import "foo" Foo (baz, foo)+import "foo" Foo+  ( baz,+    foo,+  )

@@ -1,2 +1,8 @@-import Foo hiding (bar4, foo2)-import qualified Foo (bar3, foo1)+import Foo hiding+  ( bar4,+    foo2,+  )+import qualified Foo+  ( bar3,+    foo1,+  )

@@ -1,5 +1,13 @@ import Data.Text-import Data.Text (a, b, c)-import Data.Text hiding (a, b, c)+import Data.Text+  ( a,+    b,+    c,+  )+import Data.Text hiding+  ( a,+    b,+    c,+  ) import qualified Data.Text (a, b, c) import qualified Data.Text as T

@@ -1,5 +1,5 @@ module Foo-  ( -- | asdf+  ( {- | asdf -}     foo,   ) where

@@ -1,1 +1,3 @@+-- \|+-- module Test where

@@ -0,0 +1,5 @@+checkPragma =+  ifM+    (anyM isBuiltin [builtinNat, builtinBool])+    {-then-} ok+    {-else-} notPostulate

@@ -0,0 +1,4 @@+checkPragma =+        ifM (anyM isBuiltin [builtinNat, builtinBool])+          {-then-} ok+          {-else-} notPostulate

@@ -0,0 +1,6 @@+eeExtensions =+  catMaybes+    [ {- 0x00 -} sniExt,+      {- 0x0a -} groupExt,+      {- 0x10 -} alpnExt+    ]

@@ -0,0 +1,6 @@+eeExtensions =+    catMaybes+        [ {- 0x00 -} sniExt+        , {- 0x0a -} groupExt+        , {- 0x10 -} alpnExt+        ]

@@ -0,0 +1,9 @@+{-# LANGUAGE QuasiQuotes #-}++example =+  [ -- A+    [u||], -- B+    -- C+    [u||] -- D+    -- E+  ] -- F

@@ -0,0 +1,9 @@+{-# LANGUAGE QuasiQuotes #-}++example =+  [ -- A+    [u||], -- B+    -- C+    [u||] -- D+    -- E+  ] -- F

@@ -0,0 +1,3 @@+{- ***+   aaa+-}

@@ -0,0 +1,3 @@+{- ***+   aaa+-}

@@ -1,6 +1,6 @@ module Main (main) where --- | Foo.+{- | Foo. -}  -- Bar main :: IO ()

@@ -0,0 +1,9 @@+tests_Cli_Utils =+  testGroup+    "Utils"+    [++    --  testGroup "journalApplyValue" [+    --    testCase "time" $ do+    --  ]+    ]

@@ -0,0 +1,6 @@+tests_Cli_Utils = testGroup "Utils" [++  --  testGroup "journalApplyValue" [+  --    testCase "time" $ do+  --  ]+  ]

@@ -0,0 +1,11 @@+module Hledger.Cli.Commands where++commandsList :: String -> [String] -> [String]+commandsList progversion othercmds =+  map (bold' . accent) _banner_smslant+    ++ [ -- XXX not showing bold, why ?+         -- Keep the following synced with:+         --  commands.m4+         "----------",+         progversion+       ]

@@ -0,0 +1,11 @@+module Hledger.Cli.Commands where++commandsList :: String -> [String] -> [String]+commandsList progversion othercmds =+  map (bold' . accent) _banner_smslant ++   -- XXX not showing bold, why ?+  [+  -- Keep the following synced with:+  --  commands.m4+   "----------"+  ,progversion+  ]

@@ -1,17 +1,20 @@--- |--- Module:      Data.Aeson.TH--- Copyright:   (c) 2011-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Stability:   experimental--- Portability: portable+{-|+Module:      Data.Aeson.TH+Copyright:   (c) 2011-2016 Bryan O'Sullivan+             (c) 2011 MailRank, Inc.+License:     BSD3+Stability:   experimental+Portability: portable+-} module Main where --- |------ Here is a snippet:------ @--- x = y + 2--- @+{- |++Here is a snippet:++@+x = y + 2+@++-} x = y + 2

@@ -0,0 +1,15 @@+-- Excessive backslashes in multi line:+{-+*+|+-}++test = do+  -- Maybe excessive in single line:+  -- \* (if there's nothing after the * the line is completely dropped)+  line1+  -- Maybe excessive in multi line:+  {- \| is this excessive?+  * no excessive here at least+  -}+  line2

@@ -0,0 +1,15 @@+-- Excessive backslashes in multi line:+{-+*+|+-}++test = do+  -- Maybe excessive in single line:+  -- * (if there's nothing after the * the line is completely dropped)+  line1+  -- Maybe excessive in multi line:+  {- | is this excessive?+  * no excessive here at least+  -}+  line2

@@ -2,7 +2,8 @@ newNames =   let (*) = flip (,)    in [ "Control" * "Monad"-  -- Foo -  -- Bar+      -- Foo++      -- Bar       ]

@@ -1,9 +1,13 @@+-- \| module Test-  ( test,+  ( -- \|+    test,   ) where +-- \| test ::+  -- \|   test -data T = T+data T = T {- \^ -}

@@ -1,5 +1,3 @@ {-# LANGUAGE TemplateHaskell #-} -foo = foo---- \|# ${+foo = foo -- \|# ${

@@ -0,0 +1,19 @@+module Plugin.Data.Spec where++{-+foo bar boz+-}+monoConstructor :: Int+monoConstructor = 1++-- hello world++-- | A type of rose trees with empty leaves.+data EmptyRose = EmptyRose [EmptyRose]++-- This seems to cause issue+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++-- bob alice eve+f :: ()+f = ()

@@ -0,0 +1,18 @@+module Plugin.Data.Spec where++{-+foo bar boz+-}+monoConstructor :: Int+monoConstructor = 1++-- hello world+-- | A type of rose trees with empty leaves.+data EmptyRose = EmptyRose [EmptyRose]++-- This seems to cause issue+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++-- bob alice eve+f :: ()+f = ()

@@ -0,0 +1,5 @@+-- comment+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Foo where

@@ -0,0 +1,4 @@+-- comment+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}++module Foo where

@@ -1,12 +1,12 @@ cabal-version: 2.4 name: ormolu-version: 0.8.2.0+version: 0.9.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov <markkarpov92@gmail.com> tested-with:-  ghc ==9.10.2-  ghc ==9.12.2+  ghc ==9.10.3+  ghc ==9.12.4   ghc ==9.14.1  homepage: https://github.com/mrkkrp/ormolu@@ -39,6 +39,9 @@ library   exposed-modules:     Ormolu+    Ormolu.Comments.Anchor+    Ormolu.Comments.Invariants+    Ormolu.Comments.Tree     Ormolu.Config     Ormolu.Diff.ParseResult     Ormolu.Diff.Text@@ -55,6 +58,7 @@     Ormolu.Parser.Result     Ormolu.Printer     Ormolu.Printer.Combinators+    Ormolu.Printer.CommentPlacement     Ormolu.Printer.Comments     Ormolu.Printer.Internal     Ormolu.Printer.Meat.Common@@ -80,7 +84,6 @@     Ormolu.Printer.Meat.Pragma     Ormolu.Printer.Meat.Type     Ormolu.Printer.Operators-    Ormolu.Printer.SpanStream     Ormolu.Processing.Common     Ormolu.Processing.Cpp     Ormolu.Processing.Preprocess@@ -121,6 +124,8 @@       -Wredundant-constraints       -Wpartial-fields       -Wunused-packages+      -haddock+      -Winvalid-haddock   else     ghc-options:       -O2@@ -160,6 +165,8 @@       -Wpartial-fields       -Wunused-packages       -Wwarn=unused-packages+      -haddock+      -Winvalid-haddock   else     ghc-options:       -O2@@ -172,6 +179,7 @@   hs-source-dirs: tests   other-modules:     Ormolu.CabalInfoSpec+    Ormolu.Comments.AnchorSpec     Ormolu.Diff.TextSpec     Ormolu.Fixity.ParserSpec     Ormolu.Fixity.PrinterSpec@@ -181,6 +189,7 @@     Ormolu.Parser.ParseFailureSpec     Ormolu.Parser.PragmaSpec     Ormolu.PrinterSpec+    Ormolu.TestConfig    default-language: GHC2021   build-depends:@@ -208,6 +217,8 @@       -Wredundant-constraints       -Wpartial-fields       -Wunused-packages+      -haddock+      -Winvalid-haddock   else     ghc-options:       -O2

@@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-}  -- | A formatter for Haskell source code. This module exposes the official--- stable API, other modules may be not as reliable.+-- stable API; other modules may not be as reliable. module Ormolu   ( -- * Top-level formatting functions     ormolu,@@ -49,9 +49,11 @@ import Data.Text.IO.Utf8 qualified as T.Utf8 import Debug.Trace import GHC.Driver.Errors.Types+import GHC.Hs (HsModule (..), locA) import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Error+import Ormolu.Comments.Invariants import Ormolu.Config import Ormolu.Diff.ParseResult import Ormolu.Diff.Text@@ -68,12 +70,12 @@  -- | Format a 'Text'. ----- The function+-- The function: -----     * Needs 'IO' because some functions from GHC that are necessary to---       setup parsing context require 'IO'. There should be no visible---       side-effects though.---     * Takes file name just to use it in parse error messages.+--     * Needs 'IO' because some GHC functions that are necessary to set up+--       the parsing context require 'IO'. There should be no visible+--       side effects, though.+--     * Takes a file name only to use it in parse error messages. --     * Throws 'OrmoluException'. -- -- __NOTE__: The caller is responsible for setting the appropriate value in@@ -108,15 +110,41 @@         forM_ comments $ \(L loc comment) ->           traceM $ unwords ["*** COMMENT ***", showOutputable loc, show comment]       _ -> pure ()-  -- We're forcing 'formattedText' here because otherwise errors (such as-  -- messages about not-yet-supported functionality) will be thrown later-  -- when we try to parse the rendered code back, inside of GHC monad-  -- wrapper which will lead to error messages presenting the exceptions as-  -- GHC bugs.-  let !formattedText = printSnippets (Choice.fromBool (cfgDebug cfg)) result0+  -- We force 'formattedText' here because otherwise errors (such as+  -- messages about not-yet-supported functionality) would be thrown later,+  -- when we try to parse the rendered code back inside the GHC monad+  -- wrapper, which would lead to error messages presenting the exceptions+  -- as GHC bugs.+  let printed =+        printSnippetsWithPlacements (Choice.fromBool (cfgDebug cfg)) result0+      !formattedText = T.concat (fst <$> printed)+  -- Every comment of the input should come out exactly once, and in the+  -- order it went in. The AST check below does not cover this: it compares+  -- the comment streams as multisets, and the comments that travel with+  -- pragmas are not in the stream at all.+  unless (cfgUnsafe cfg) . liftIO $ do+    let violations =+          concat+            [ checkCommentInvariants+                (getLoc <$> inputComments r)+                (reorderableSpans (prParsedSource r))+                placements+            | (ParsedSnippet r, (_, placements)) <- result0 `zip` printed+            ]+        -- Imports are sorted and merged, so a comment attached to one of+        -- them may legitimately come out in a different order than it went+        -- in.+        reorderableSpans hsmod =+          [ spn+          | L l _ <- hsmodImports hsmod,+            Just spn <- [srcSpanToRealSrcSpan (locA l)]+          ]+    unless (null violations) $+      throwIO (OrmoluCommentInvariantsViolated path violations)   when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do-    -- Parse the result of pretty-printing again and make sure that AST-    -- is the same as AST of original snippet module span positions.+    -- Parse the result of pretty-printing again and make sure that its AST+    -- is the same as the AST of the original snippet, modulo span+    -- positions.     (_, result1) <-       parseModule'         cfg@@ -139,7 +167,8 @@     -- Try re-formatting the formatted result to check if we get exactly     -- the same output.     when (cfgCheckIdempotence cfg) . liftIO $-      let reformattedText = printSnippets (Choice.fromBool (cfgDebug cfg)) result1+      let reformattedText =+            printSnippets (Choice.fromBool (cfgDebug cfg)) result1        in case diffText formattedText reformattedText path of             Nothing -> return ()             Just diff -> throwIO (OrmoluNonIdempotentOutput diff)@@ -176,11 +205,11 @@ ormoluStdin cfg =   liftIO T.Utf8.getContents >>= ormolu cfg "<stdin>" --- | Refine a 'Config' by incorporating given 'SourceType', 'CabalInfo', and--- fixity overrides 'FixityMap'. You can use 'detectSourceType' to deduce--- 'SourceType' based on the file extension,--- 'CabalUtils.getCabalInfoForSourceFile' to obtain 'CabalInfo' and--- 'getFixityOverridesForSourceFile' for 'FixityMap'.+-- | Refine a 'Config' by incorporating the given 'SourceType', 'CabalInfo',+-- and fixity overrides 'FixityMap'. You can use 'detectSourceType' to deduce+-- the 'SourceType' from the file extension,+-- 'CabalUtils.getCabalInfoForSourceFile' to obtain the 'CabalInfo', and+-- 'getFixityOverridesForSourceFile' for the 'FixityMap'. -- -- @since 0.5.3.0 refineConfig ::

@@ -0,0 +1,326 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Positional comment attachment.+--+-- This module decides who owns a comment from where it sits in the source,+-- once, before anything is printed. The answer therefore does not depend on+-- the order in which the printer visits elements, which is what made+-- reordered imports and reassociated operator trees lose comments before.+--+-- The rule is short enough to state in full. Find the element that encloses+-- the comment most tightly. Within that element, find which gap between its+-- children the comment falls into. Then:+--+--   * a comment that starts on the line where the preceding sibling ends+--     trails that sibling;+--   * otherwise, if a sibling follows, the comment goes before it;+--   * otherwise the comment trails the last sibling;+--   * an element with no children at all owns the comment outright.+module Ormolu.Comments.Anchor+  ( CommentAnchor (..),+    attachComments,+    anchorFor,++    -- * Using the anchors while printing+    AnchorMap,+    mkAnchorMap,+    noComments,+    claimBefore,+    commentsBefore,+    claimTrailing,+    claimRemaining,+    pendingComments,+    commentsAnchoredWithin,+  )+where++import Data.List (find, sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (listToMaybe)+import Data.Set qualified as Set+import GHC.Types.SrcLoc+import Ormolu.Comments.Tree+import Ormolu.Parser.CommentStream++-- | Where a comment belongs.+data CommentAnchor+  = -- | On its own line(s) above the element+    AnchorBefore RealSrcSpan+  | -- | After the element, either on the same line or below it+    AnchorTrailing RealSrcSpan+  | -- | Inside the element, which has no children of its own+    AnchorInside RealSrcSpan+  | -- | Not inside anything: the comment belongs to the module+    AnchorModule+  deriving (Eq, Show)++-- | Attach every comment of a module.+attachComments ::+  -- | Comments, in source order+  [LComment] ->+  -- | Spans of all \"located\" elements of the module+  [RealSrcSpan] ->+  [(LComment, CommentAnchor)]+attachComments comments eltSpans =+  joinBlocks eltSpans [(c, anchorFor forest c) | c <- comments]+  where+    forest = mkSpanForest eltSpans++-- | Make a run of comment lines share one anchor.+--+-- Consecutive lines with nothing but comment between them are one block as+-- far as the reader is concerned, so splitting them across two elements+-- would tear the block apart. The first line decides where the whole block+-- goes.+joinBlocks ::+  -- | Spans of all elements, used to tell whether one stands between two+  -- comments+  [RealSrcSpan] ->+  [(LComment, CommentAnchor)] ->+  [(LComment, CommentAnchor)]+joinBlocks eltSpans = go Nothing+  where+    -- Only the start positions matter below, and only whether one of them+    -- falls in a range, so they are held as a set: this runs for every+    -- comment and scanning the module's spans each time is quadratic.+    eltStarts = Set.fromList (realSrcSpanStart <$> eltSpans)++    go _ [] = []+    go previous ((c@(L spn theComment), anchor) : rest) =+      let anchor' = case previous of+            Just (prevSpn, prevAnchor)+              | continues prevSpn -> prevAnchor+            _ -> anchor+          continues prevSpn =+            not (hasAtomsBefore theComment)+              && srcSpanEndLine prevSpn + 1 == srcSpanStartLine spn+              && not (elementBetween prevSpn spn)+       in (c, anchor') : go (Just (spn, anchor')) rest++    -- Consecutive lines are not one block if an element begins between+    -- them. @{- 0x00 -} sniExt@ followed by @{- 0x0a -} groupExt@ is two+    -- blocks, each leading its own element, not one block of two lines. It+    -- is enough for the element to *start* in the gap: in @f $ {-else-} do@+    -- the @do@ block opens on the first comment's line and runs well past+    -- the second, and the comment on the next line belongs inside it rather+    -- than to the block above.+    elementBetween from to =+      case Set.lookupGE (realSrcSpanEnd from) eltStarts of+        Just s -> s <= realSrcSpanStart to+        Nothing -> False++-- | Attach a single comment to the forest of element spans.+anchorFor :: [SpanTree] -> LComment -> CommentAnchor+anchorFor forest (L comment theComment) = go Nothing Nothing forest+  where+    go enclosing outerTrailing trees =+      case find (\t -> stSpan t `containsSpan` comment) trees of+        -- Descend into the element that encloses the comment, so that the+        -- anchor is always as tight as the source allows. Carry down the+        -- code this level has already put on the comment's line: an element+        -- that opens on that line, such as the right-hand side in @f x = --+        -- c@, has nothing of its own before the comment, but the comment+        -- still trails the @x@ one level up.+        --+        -- Only an element that wraps a single thing may carry it. One with+        -- several children is a list of items, and a comment written at the+        -- head of such a list introduces the items rather than trailing+        -- what stands before the bracket. In+        --+        -- > xs ++ [ -- why?+        -- >   a, b ]+        --+        -- the comment must stay inside the brackets; carrying it up would+        -- pull it, and the block of comment lines below it, out of the list.+        Just t+          | [_] <- stChildren t -> go (Just (stSpan t)) trailingHere (stChildren t)+          | otherwise -> go (Just (stSpan t)) Nothing (stChildren t)+        Nothing -> case (precedingSibling, followingSibling) of+          (Just p, _)+            | trailsCodeOn (stSpan p) -> AnchorTrailing (innermostEndingOnLine p)+          -- A comment with an element right after it on the same line and+          -- nothing of its own before it leads that element: a run of @{-+          -- 0x00 -} sniExt@ must not be read as trailing whatever comes+          -- before and pile up in one place. This outranks the code carried+          -- down from an outer level, so that the @{-a-}@ of @x = ({-a-} b,+          -- c)@ stays with @b@ rather than being pulled out to trail the+          -- @x@.+          (_, Just n)+            | startsOnCommentLine (stSpan n) -> AnchorBefore (stSpan n)+          -- Nothing at this level stands before the comment, but an outer+          -- level put code on its line: the comment trails that code. This+          -- is what keeps @f x = -- c@ on one line, the right-hand side+          -- having opened on that line with the comment as its first+          -- content.+          --+          -- Only a line comment may do this. It runs to the end of the line+          -- either way, so trailing an element one level up still renders+          -- it exactly where it was written. A block comment renders in+          -- place instead, and would end up ahead of the tokens that opened+          -- the element it was written inside: the pragma of @corebar = {-#+          -- CORE "bar baz" #-}@ would move before the @=@.+          (Nothing, _)+            | not (isMultilineComment theComment),+              Just p <- outerTrailing ->+                AnchorTrailing (innermostEndingOnLine p)+          (_, Just n) -> AnchorBefore (stSpan n)+          -- A comment after the last child of an element belongs to that+          -- element, but a comment after everything at the top level+          -- belongs to the module: there is nothing it can trail without+          -- being rendered before syntax that preceded it in the input,+          -- such as the @where@ of a module header.+          (Just p, Nothing)+            | Just _ <- enclosing -> AnchorTrailing (stSpan p)+            | otherwise -> AnchorModule+          (Nothing, Nothing) -> maybe AnchorModule AnchorInside enclosing+          where+            followingSibling =+              listToMaybe+                [ t+                | t <- trees,+                  realSrcSpanStart (stSpan t) >= realSrcSpanEnd comment+                ]+            startsOnCommentLine s =+              srcSpanStartLine s == srcSpanEndLine comment+      where+        precedingSibling =+          lastMaybe+            [ t+            | t <- trees,+              realSrcSpanEnd (stSpan t) <= realSrcSpanStart comment+            ]+        trailingHere = case precedingSibling of+          Just p | trailsCodeOn (stSpan p) -> Just p+          _ -> outerTrailing++    -- A comment only trails an element when it really does sit after code+    -- on that line. Checking the line alone is not enough, because the AST+    -- has zero-width spans that happen to share a line with a comment while+    -- standing before it.+    trailsCodeOn s =+      srcSpanEndLine s == srcSpanStartLine comment+        && hasAtomsBefore theComment++    -- A comment that trails a bracketed construct belongs to the innermost+    -- element that ends on its line, not to the bracket: @(x + y) -- c@+    -- attaches to @y@, so that the comment is rendered next to the+    -- expression it was written next to rather than after the closing+    -- bracket.+    innermostEndingOnLine t =+      case lastMaybe (filter (trailsCodeOn . stSpan) (stChildren t)) of+        Nothing -> stSpan t+        Just t' -> innermostEndingOnLine t'++    lastMaybe xs = if null xs then Nothing else Just (last xs)++----------------------------------------------------------------------------+-- Using the anchors while printing++-- | Anchored comments, arranged so that the printer can look them up by the+-- span of the element it is entering or leaving.+--+-- Comments are claimed rather than consumed: the first element with a given+-- span takes them, and every later element with the same span finds+-- nothing. Since several AST nodes routinely share a span, and the printer+-- enters them outermost first, this gives the comment to the outermost of+-- them, which is what one wants—a comment belongs outside the parentheses,+-- not inside them.+data AnchorMap = AnchorMap+  { amBefore :: Map RealSrcSpan [LComment],+    amTrailing :: Map RealSrcSpan [LComment],+    amModule :: [LComment]+  }++-- | An empty map, for the first of the two rendering passes: it collects+-- the spans of the elements the printer enters, and emits no comments.+noComments :: AnchorMap+noComments =+  AnchorMap {amBefore = Map.empty, amTrailing = Map.empty, amModule = []}++-- | Arrange anchored comments for lookup.+--+-- __NOTE__: 'AnchorInside' is currently folded into 'AnchorTrailing'. Doing+-- it properly needs a combinator for elements that can have no children at+-- all.+mkAnchorMap :: [(LComment, CommentAnchor)] -> AnchorMap+mkAnchorMap anchored =+  AnchorMap+    { amBefore = collect [(spn, c) | (c, AnchorBefore spn) <- anchored],+      amTrailing =+        collect $+          [(spn, c) | (c, AnchorTrailing spn) <- anchored]+            <> [(spn, c) | (c, AnchorInside spn) <- anchored],+      amModule = [c | (c, AnchorModule) <- anchored]+    }+  where+    collect = Map.fromListWith (flip (<>)) . fmap (fmap pure)++-- | The comments that go before the element with the given span, without+-- claiming them.+commentsBefore :: RealSrcSpan -> AnchorMap -> [LComment]+commentsBefore spn = Map.findWithDefault [] spn . amBefore++-- | Claim the comments that go before the element with the given span.+claimBefore :: RealSrcSpan -> AnchorMap -> ([LComment], AnchorMap)+claimBefore spn am =+  case Map.lookup spn (amBefore am) of+    Nothing -> ([], am)+    Just cs -> (cs, am {amBefore = Map.delete spn (amBefore am)})++-- | Claim the comments that go after the element with the given span.+claimTrailing :: RealSrcSpan -> AnchorMap -> ([LComment], AnchorMap)+claimTrailing spn am =+  case Map.lookup spn (amTrailing am) of+    Nothing -> ([], am)+    Just cs -> (cs, am {amTrailing = Map.delete spn (amTrailing am)})++-- | Claim everything that is left: the comments that belong to no element,+-- plus anything that was anchored to an element the printer never entered.+claimRemaining :: AnchorMap -> ([LComment], AnchorMap)+claimRemaining am =+  ( pendingComments am,+    AnchorMap {amBefore = Map.empty, amTrailing = Map.empty, amModule = []}+  )++-- | The comments anchored to the element at the given span, or to any+-- element inside it.+--+-- This is the question the layout decision needs to ask. "Which comments+-- are contained in this element" is a different and much coarser one: a+-- comment anywhere in a declaration is contained in it, but is attached to+-- one particular element, and only that element's layout should have to+-- account for it. This runs for every element the printer enters, so it+-- must not walk the whole map. Anchors are 'RealSrcSpan's ordered by start+-- position, and all of a module's spans share a file, so the anchors that+-- could be contained in the region are the contiguous run whose start lies+-- within it. Cutting the map down to that run first makes the cost+-- proportional to the size of the region rather than to the number of+-- comments in the module.+commentsAnchoredWithin :: RealSrcSpan -> AnchorMap -> [LComment]+commentsAnchoredWithin region AnchorMap {..} =+  sortOn getLoc . concat $+    within amBefore <> within amTrailing+  where+    within =+      Map.elems+        . Map.filterWithKey (\anchor _ -> region `containsSpan` anchor)+        . startingWithin++    -- Antitone in map order: as keys ascend their start position never+    -- decreases, so each predicate holds on a prefix and then stops.+    startingWithin =+      fst+        . Map.spanAntitone ((<= realSrcSpanEnd region) . realSrcSpanStart)+        . snd+        . Map.spanAntitone ((< realSrcSpanStart region) . realSrcSpanStart)++-- | Every comment that has not been emitted yet, in source order.+pendingComments :: AnchorMap -> [LComment]+pendingComments AnchorMap {..} =+  sortOn getLoc $+    amModule+      <> concat (Map.elems amBefore)+      <> concat (Map.elems amTrailing)

@@ -0,0 +1,135 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Properties that comment handling has to satisfy, and the check that+-- enforces them.+--+-- Every comment of the input should come out exactly once, and in the order+-- it went in. The check runs on every run of Ormolu, alongside the check+-- that the AST is unchanged, and is disabled by the same @--unsafe@ flag.+--+-- This is the half of comment checking that works on where the comments went+-- rather than on what they say. It compares the /spans/ of the comments a+-- module started with against the spans recorded as the printer emitted+-- them, so it can name the comment that was dropped, duplicated, invented+-- or moved.+--+-- It does /not/ look at the text of a comment at all: rendering one with+-- its contents mangled would pass. That is the other half, and it belongs+-- to 'Ormolu.Diff.ParseResult.diffCommentStream', which compares text and+-- ignores position. Neither check subsumes the other and both run by+-- default.+--+-- Haddocks are outside both halves. GHC's parser makes them part of the AST+-- rather than leaving them in the comment stream, so they are neither among+-- the comments a module started with nor in what the text check compares.+-- Losing or duplicating one changes the AST itself, and that is caught by+-- the third check, 'Ormolu.Diff.ParseResult.diffParseResult' comparing the+-- two syntax trees.+module Ormolu.Comments.Invariants+  ( InvariantViolation (..),+    checkCommentInvariants,+    renderInvariantViolation,+  )+where++import Data.List (sort)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Types.SrcLoc+import Ormolu.Printer.CommentPlacement++-- | A way in which the emitted comments failed to correspond to the+-- comments of the input.+data InvariantViolation+  = -- | A comment of the input was never emitted+    CommentDropped RealSrcSpan+  | -- | A comment was emitted more than once, the given number of times+    CommentDuplicated RealSrcSpan Int+  | -- | A comment was emitted that does not correspond to any comment of+    -- the input+    CommentInvented RealSrcSpan+  | -- | A comment was emitted after one that comes later in the input. The+    -- first span is the comment that was emitted too late, the second is+    -- the one it should have preceded.+    CommentReordered RealSrcSpan RealSrcSpan+  deriving (Eq, Show)++-- | Compare the comments of a snippet against the comments that were+-- emitted while rendering it.+checkCommentInvariants ::+  -- | Spans of all the comments the snippet started with+  [RealSrcSpan] ->+  -- | Spans of the elements the formatter is allowed to reorder, so that+  -- the comments travelling with them are exempt from the order check+  [RealSrcSpan] ->+  -- | Placements recorded while rendering it, in the order of emission+  [CommentPlacement] ->+  [InvariantViolation]+checkCommentInvariants inputSpans reorderable placements =+  dropped <> duplicated <> invented <> reordered+  where+    emitted = cpSpan <$> placements+    -- Pragmas and imports are deliberately sorted and the comments attached+    -- to them travel along, so the order they come out in says nothing.+    -- They are still expected to come out exactly once, which is what+    -- catches a comment being duplicated.+    ordered =+      [ spn+      | CommentPlacement {cpSpan = spn, cpSlot} <- placements,+        cpSlot /= SlotPragma,+        not (travelsWithAReorderedElement cpSlot)+      ]+    travelsWithAReorderedElement slot = case slotAnchor slot of+      Nothing -> False+      Just anchor -> any (`containsSpan` anchor) reorderable+    inputSet = Map.fromList ((,()) <$> inputSpans)+    counts = Map.fromListWith (+) ((,1 :: Int) <$> emitted)++    dropped =+      [CommentDropped spn | spn <- sort inputSpans, not (spn `Map.member` counts)]+    duplicated =+      [ CommentDuplicated spn n+      | (spn, n) <- Map.toAscList counts,+        n > 1+      ]+    invented =+      [ CommentInvented spn+      | spn <- Map.keys counts,+        not (spn `Map.member` inputSet)+      ]++    -- Only the first emission of each comment is considered, so that a+    -- comment reported as duplicated is not also reported as reordered.+    reordered = go [] (dedupe [] ordered)+      where+        dedupe _ [] = []+        dedupe seen (x : xs)+          | x `elem` seen = dedupe seen xs+          | otherwise = x : dedupe (x : seen) xs+        go _ [] = []+        go seen (x : xs) =+          [CommentReordered x y | y <- seen, x < y]+            <> go (x : seen) xs++-- | Render a violation as a single line.+renderInvariantViolation :: InvariantViolation -> Text+renderInvariantViolation = \case+  CommentDropped spn ->+    "dropped     " <> renderSpan spn+  CommentDuplicated spn n ->+    "duplicated  " <> renderSpan spn <> " (emitted " <> showT n <> " times)"+  CommentInvented spn ->+    "invented    " <> renderSpan spn+  CommentReordered spn before ->+    "reordered   " <> renderSpan spn <> " (emitted after " <> renderSpan before <> ")"++renderSpan :: RealSrcSpan -> Text+renderSpan spn =+  renderLoc (realSrcSpanStart spn) <> "-" <> renderLoc (realSrcSpanEnd spn)+  where+    renderLoc l = showT (srcLocLine l) <> ":" <> showT (srcLocCol l)++showT :: (Show a) => a -> Text+showT = T.pack . show

@@ -0,0 +1,74 @@+-- | The containment tree of AST element spans.+--+-- This is the structure "Ormolu.Comments.Anchor" reads to place a comment:+-- given a comment, which element encloses it most tightly, and which of+-- that element's children does it fall between. Arranging the spans by+-- containment is what makes those questions answerable from position alone,+-- without reference to the order in which the printer visits anything.+module Ormolu.Comments.Tree+  ( SpanTree (..),+    mkSpanForest,+    countNodes,+  )+where++import Data.List (sortOn)+import Data.Ord (Down (..))+import GHC.Types.SrcLoc++-- | An element span together with the element spans it encloses. Children+-- are in ascending order and do not overlap each other.+data SpanTree = SpanTree+  { stSpan :: RealSrcSpan,+    stChildren :: [SpanTree]+  }+  deriving (Eq, Show)++-- | Arrange spans into a forest by containment.+--+-- Duplicates are dropped: several AST nodes routinely share one span (a+-- wrapper and the thing it wraps, say), and for the purpose of owning a+-- comment they are one element. Spans that overlap another without being+-- contained in it are dropped too—the GHC AST does produce such spans+-- occasionally, and they cannot be placed in a tree.+--+-- Zero-width spans are kept. An empty bracketed construct—an export or+-- import list, @[]@, a record with no fields—contains no element at all, so+-- the printer enters a zero-width one at its opening bracket+-- ('Ormolu.Printer.Combinators.locatedEmpty') to give a comment written+-- between the brackets something to attach to.+mkSpanForest :: [RealSrcSpan] -> [SpanTree]+mkSpanForest = goForest . dedupe . sortOn nestingOrder+  where+    -- Outermost first, so that a span is always seen before the spans it+    -- contains.+    nestingOrder s = (realSrcSpanStart s, Down (realSrcSpanEnd s))++    dedupe (x : y : rest) | x == y = dedupe (y : rest)+    dedupe (x : rest) = x : dedupe rest+    dedupe [] = []++    goForest [] = []+    goForest (s : rest) =+      let (children, rest') = goChildren s rest+       in SpanTree s children : goForest rest'++    goChildren parent = go []+      where+        go acc [] = (reverse acc, [])+        go acc (s : rest)+          | parent `containsSpan` s =+              let (children, rest') = goChildren s rest+               in go (SpanTree s children : acc) rest'+          | realSrcSpanStart s < realSrcSpanEnd parent =+              -- Overlaps the parent without being contained in it; there is+              -- no correct place for it, so leave it out.+              go acc rest+          | otherwise = (reverse acc, s : rest)++-- | How many elements the forest holds. Used by the tests to check that+-- duplicate and overlapping spans are dropped.+countNodes :: [SpanTree] -> Int+countNodes = sum . fmap node+  where+    node t = 1 + countNodes (stChildren t)

@@ -39,7 +39,8 @@     cfgDynOptions :: ![DynOption],     -- | Fixity overrides     cfgFixityOverrides :: !FixityOverrides,-    -- | Module reexports to take into account when doing fixity resolution+    -- | Module re-exports to take into account when performing fixity+    -- resolution     cfgModuleReexports :: !ModuleReexports,     -- | Known dependencies, if any     cfgDependencies :: !(Set PackageName),@@ -47,9 +48,9 @@     cfgUnsafe :: !Bool,     -- | Output information useful for debugging     cfgDebug :: !Bool,-    -- | Checks if re-formatting the result is idempotent+    -- | Check that re-formatting the result is idempotent     cfgCheckIdempotence :: !Bool,-    -- | How to parse the input (regular haskell module or Backpack file)+    -- | How to parse the input (a regular Haskell module or a Backpack file)     cfgSourceType :: !SourceType,     -- | Whether to use colors and other features of ANSI terminals     cfgColorMode :: !ColorMode,

@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeepSubsumption #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -8,13 +9,17 @@ module Ormolu.Diff.ParseResult   ( ParseResultDiff (..),     diffParseResult,+    diffCommentStream,   ) where  import Data.ByteString (ByteString)+import Data.Char (isSpace) import Data.Foldable import Data.Function import Data.Generics+import Data.List (sort)+import Data.Text qualified as T import GHC.Data.FastString (FastString) import GHC.Hs import GHC.Types.SourceText@@ -40,7 +45,12 @@ instance Monoid ParseResultDiff where   mempty = Same --- | Return 'Diff' of two 'ParseResult's.+-- | Compare the parse result of the input against that of the output.+--+-- Two of Ormolu's three comment checks live here: 'diffCommentStream' for+-- the text of the comments, and the syntax tree comparison for the+-- Haddocks, which are part of the tree rather than of the comment stream.+-- The third, "Ormolu.Comments.Invariants", checks where the comments went. diffParseResult ::   ParseResult ->   ParseResult ->@@ -57,12 +67,35 @@     diffCommentStream cstream0 cstream1       <> diffHsModule hs0 hs1 +-- | Check that formatting did not change the /text/ of any comment.+--+-- This is the half of comment checking that works on what the comments say+-- rather than on where they went. Ormolu edits comment text on purpose—it+-- escapes Haddock triggers, re-indents block comments and normalizes the+-- spacing after a trigger—and both sides of this comparison have been+-- through 'Ormolu.Parser.CommentStream.mkCommentStream', so the intended+-- edits cancel out and only unintended ones show up.+--+-- What it deliberately does /not/ check:+--+--   * __order__, because Ormolu sorts imports, import lists and pragmas,+--     and a comment attached to one of those travels with it;+--   * __which comment is which__, since the lines are compared as a+--     multiset; a failure cannot say more than that the two sides differ,+--     which is why 'Different' is returned with no spans;+--   * __comments outside the stream__ — the Stack header and the comments+--     that travel with pragmas are lifted out of it during parsing, so+--     duplicating one of those is invisible here.+--+-- All three are covered by "Ormolu.Comments.Invariants", which compares+-- spans instead of text. Neither check subsumes the other and both run by+-- default. diffCommentStream :: CommentStream -> CommentStream -> ParseResultDiff diffCommentStream (CommentStream cs) (CommentStream cs')   | commentLines cs == commentLines cs' = Same   | otherwise = Different []   where-    commentLines = concatMap (toList . unComment . unLoc)+    commentLines = sort . concatMap (toList . unComment . unLoc)  -- | Compare two modules for equality disregarding certain semantically -- irrelevant features like exact print annotations.@@ -160,8 +193,30 @@         f QualifiedPost QualifiedPre = True         f x x' = x == x' +    -- Documentation is compared up to the normalizations Ormolu performs+    -- on it: the space it puts after a Haddock's trigger, the+    -- re-indentation it gives a @{- | … -}@ so that the comment lines up+    -- with the code it documents, and the collapsing of consecutive blank+    -- lines. All three change the doc string GHC parses back out, and all+    -- three are intended.     hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff-    hsDocStringEq = considerEqualVia' ((==) `on` splitDocString)+    hsDocStringEq =+      considerEqualVia' ((==) `on` (collapseBlanks . dedent . splitDocString))+      where+        -- The printer emits at most one blank line in a row, as it does for+        -- ordinary comments.+        collapseBlanks = \case+          (x : y : rest)+            | T.null x, T.null y -> collapseBlanks (y : rest)+          (x : rest) -> x : collapseBlanks rest+          [] -> []+        dedent = \case+          [] -> []+          (x : xs) ->+            let indentOf l = T.length (T.takeWhile (== ' ') l)+                indents = indentOf <$> filter (not . T.all isSpace) xs+                n = if null indents then 0 else minimum indents+             in x : fmap (T.drop n) xs      forLocated ::       (Data e0, Data e1) =>

@@ -256,7 +256,7 @@       hunkDiff = mapDiff (fmap third) xs   return Hunk {..} --- | Trim empty “both” lines from beginning and end of a 'DiffList''.+-- | Trim empty “both” lines from the beginning and end of a 'DiffList''. trimEmpty :: DiffList' -> DiffList' trimEmpty = go True id   where

@@ -19,6 +19,7 @@ import Data.Void (Void) import Distribution.Parsec.Error (PError, showPError) import GHC.Types.SrcLoc+import Ormolu.Comments.Invariants (InvariantViolation, renderInvariantViolation) import Ormolu.Diff.Text (TextDiff, printTextDiff) import Ormolu.Terminal import Ormolu.Terminal.QualifiedDo qualified as Term@@ -36,6 +37,9 @@     OrmoluASTDiffers TextDiff [RealSrcSpan]   | -- | Formatted source code is not idempotent     OrmoluNonIdempotentOutput TextDiff+  | -- | The comments that came out do not correspond to the comments that+    -- went in+    OrmoluCommentInvariantsViolated FilePath [InvariantViolation]   | -- | Some GHC options were not recognized     OrmoluUnrecognizedOpts (NonEmpty String)   | -- | Cabal file parsing failed@@ -91,6 +95,22 @@     newline     put "  Please, consider reporting the bug."     newline+  OrmoluCommentInvariantsViolated path violations -> Term.do+    put (T.pack path)+    newline+    for_ violations $ \violation -> Term.do+      put "  "+      put (renderInvariantViolation violation)+      newline+    newline+    put "  The comments of the output do not correspond to the comments of"+    newline+    put "  the input."+    newline+    put "  Please, consider reporting the bug."+    newline+    put "  To format anyway, use --unsafe."+    newline   OrmoluUnrecognizedOpts opts -> Term.do     put "The following GHC options were not recognized:"     newline@@ -106,13 +126,13 @@   OrmoluMissingStdinInputFile -> Term.do     put "The --stdin-input-file option is necessary when using input"     newline-    put "from stdin and accounting for .cabal files"+    put "from stdin and accounting for .cabal files."     newline   OrmoluFixityOverridesParseError errorBundle -> Term.do     put . T.pack . errorBundlePretty $ errorBundle     newline --- | Inside this wrapper 'OrmoluException' will be caught and displayed+-- | Inside this wrapper, 'OrmoluException' will be caught and displayed -- nicely. withPrettyOrmoluExceptions ::   -- | Color mode@@ -126,12 +146,13 @@       runTerm (printOrmoluException e) colorMode stderr       return . ExitFailure $         case e of-          -- Error code 1 is for 'error' or 'notImplemented'-          -- 2 used to be for erroring out on CPP+          -- Error code 1 is for 'error' or 'notImplemented'.+          -- 2 used to be for erroring out on CPP.           OrmoluParsingFailed {} -> 3           OrmoluOutputParsingFailed {} -> 4           OrmoluASTDiffers {} -> 5           OrmoluNonIdempotentOutput {} -> 6+          OrmoluCommentInvariantsViolated {} -> 11           OrmoluUnrecognizedOpts {} -> 7           OrmoluCabalFileParsingFailed {} -> 8           OrmoluMissingStdinInputFile {} -> 9

@@ -53,7 +53,7 @@   Binary.runGet Binary.get $     BL.fromStrict $(embedFile "extract-hackage-info/hackage-info.bin") --- | Default set of packages to assume as dependencies e.g. when no Cabal+-- | Default set of packages to assume as dependencies, e.g. when no Cabal -- file is found or taken into consideration. defaultDependencies :: Set PackageName defaultDependencies = Set.singleton (mkPackageName "base")

@@ -75,7 +75,7 @@   IEThingWith _ (L _ x) _ xs _ -> occName x : fmap (occName . unLoc) xs   _ -> [] --- | Apply given module re-exports.+-- | Apply the given module re-exports. applyModuleReexports :: ModuleReexports -> [FixityImport] -> [FixityImport] applyModuleReexports (ModuleReexports reexports) imports = imports >>= expand   where

@@ -74,7 +74,7 @@  {-# COMPLETE OpName #-} --- | Convert an 'OccName to an 'OpName'.+-- | Convert an 'OccName' to an 'OpName'. occOpName :: OccName -> OpName occOpName = MkOpName . fs_sbs . occNameFS @@ -125,10 +125,10 @@ data FixityApproximation = FixityApproximation   { -- | Fixity direction if it is known     faDirection :: Maybe FixityDirection,-    -- | Minimum precedence level found in the (maybe conflicting)+    -- | Minimum precedence level found in the (possibly conflicting)     -- definitions for the operator (inclusive)     faMinPrecedence :: Double,-    -- | Maximum precedence level found in the (maybe conflicting)+    -- | Maximum precedence level found in the (possibly conflicting)     -- definitions for the operator (inclusive)     faMaxPrecedence :: Double   }@@ -146,8 +146,8 @@     faMaxPrecedence <- Binary.getDoublele     pure FixityApproximation {..} --- | Gives the ability to merge two (maybe conflicting) definitions for an--- operator, keeping the higher level of compatible information from both.+-- | Gives the ability to merge two (possibly conflicting) definitions for+-- an operator, keeping the higher level of compatible information from both. instance Semigroup FixityApproximation where   FixityApproximation {faDirection = dir1, faMinPrecedence = min1, faMaxPrecedence = max1}     <> FixityApproximation {faDirection = dir2, faMinPrecedence = min2, faMaxPrecedence = max2} =

@@ -55,20 +55,41 @@   LImportDecl GhcPs ->   LImportDecl GhcPs ->   LImportDecl GhcPs-combineImports (L lx ImportDecl {..}) (L _ y) =-  L-    lx-    ImportDecl-      { ideclImportList = case (ideclImportList, GHC.ideclImportList y) of-          (Just (hiding, L l' xs), Just (_, L _ ys)) ->-            Just (hiding, (L l' (normalizeLies (xs ++ ys))))-          _ -> Nothing,-        ..-      }+combineImports x y =+  L widenedLoc earlier {ideclImportList = combinedImportList}+  where+    -- The merged declaration spans both of the ones it came from, so that+    -- it is laid out over several lines and a comment that was written+    -- between them has somewhere to go. Its own span would otherwise still+    -- describe a single line.+    widenedLoc =+      l {entry = EpaSpan (combineSrcSpans (locA (getLoc x)) (locA (getLoc y)))} --- | Import id, a collection of all things that justify having a separate--- import entry. This is used for merging of imports. If two imports have--- the same 'ImportId' they can be merged.+    -- Take the declaration that comes first in the source whole, rather+    -- than mixing the span of one with the contents of the other: a+    -- declaration whose span sits before its own module name or import+    -- list cannot be placed in a containment tree, which is what comment+    -- attachment needs.+    (L l earlier, L _ later)+      | startsFirst (locA (getLoc x)) (locA (getLoc y)) = (x, y)+      | otherwise = (y, x)+    combinedImportList =+      case (GHC.ideclImportList earlier, GHC.ideclImportList later) of+        (Just (hiding, L l' xs), Just (_, L _ ys)) ->+          Just (hiding, L l' (normalizeLies (xs ++ ys)))+        _ -> Nothing++-- | Does the first span start before the second? Spans without a real+-- location are treated as coming first, arbitrarily but consistently.+startsFirst :: SrcSpan -> SrcSpan -> Bool+startsFirst a b = case (srcSpanToRealSrcSpan a, srcSpanToRealSrcSpan b) of+  (Just a', Just b') -> realSrcSpanStart a' <= realSrcSpanStart b'+  (Nothing, _) -> True+  _ -> False++-- | An import id, a collection of all the things that justify having a+-- separate import entry. This is used for merging imports: if two imports+-- have the same 'ImportId', they can be merged. data ImportId = ImportId   { importIsPrelude :: Bool,     importPkgQual :: ImportPkgQual,@@ -227,7 +248,7 @@ compareLIewn :: LIEWrappedName GhcPs -> LIEWrappedName GhcPs -> Ordering compareLIewn = compareIewn `on` unLoc --- | Compare two @'IEWrapppedName' 'GhcPs'@ things.+-- | Compare two @'IEWrappedName' 'GhcPs'@ things. compareIewn :: IEWrappedName GhcPs -> IEWrappedName GhcPs -> Ordering compareIewn = (comparing fst <> (compareRdrName `on` unLoc . snd)) `on` classify   where

@@ -160,13 +160,13 @@             Nothing -> error "PFailed does not have an error"         GHC.POk pstate (L _ (normalizeModule implicitPrelude -> hsModule)) ->           case pStateErrors pstate of-            -- Some parse errors (pattern/arrow syntax in expr context)-            -- do not cause a parse error, but they are replaced with "_"-            -- by the parser and the modified AST is propagated to the-            -- later stages; but we fail in those cases.+            -- Some malformed inputs (pattern/arrow syntax in an+            -- expression context) do not cause a parse error; instead the+            -- parser replaces them with "_" and propagates the modified AST+            -- to the later stages. We fail in those cases.             Just err -> Left err             Nothing ->-              let (stackHeader, pragmas, comments) =+              let (stackHeader, pragmas, comments, haddockText) =                     mkCommentStream input hsModule                in Right                     ParseResult@@ -175,6 +175,7 @@                         prStackHeader = stackHeader,                         prPragmas = pragmas,                         prCommentStream = comments,+                        prHaddockText = haddockText,                         prExtensions = GHC.extensionFlags dynFlags,                         prModuleFixityMap = modFixityMap,                         prIndent = indent@@ -191,6 +192,7 @@   everywhere     ( mkT dropBlankTypeHaddocks         `extT` dropBlankDataDeclHaddocks+        `extT` dropBlankConDeclFieldHaddocks         `extT` patchContext         `extT` patchExprContext     )@@ -220,6 +222,13 @@       L _ (HsDocTy _ ty s) :: LHsType GhcPs         | isBlankDocString s -> ty       a -> a+    -- A Haddock on a field that holds nothing but whitespace is dropped,+    -- the same way one on a constructor is. Without this, whether it+    -- survives depends on whether it happened to end in a space.+    dropBlankConDeclFieldHaddocks = \case+      CDF {cdf_doc = Just s, ..} :: HsConDeclField GhcPs+        | isBlankDocString s -> CDF {cdf_doc = Nothing, ..}+      a -> a     dropBlankDataDeclHaddocks = \case       ConDeclGADT {con_doc = Just s, ..} :: ConDecl GhcPs         | isBlankDocString s -> ConDeclGADT {con_doc = Nothing, ..}@@ -228,7 +237,7 @@       a -> a      -- For constraint contexts (both in types and in expressions), normalize-    -- parenthesis as decided in https://github.com/tweag/ormolu/issues/264.+    -- parentheses as decided in https://github.com/tweag/ormolu/issues/264.     patchContext :: LHsContext GhcPs -> LHsContext GhcPs     patchContext = fmap $ \case       [x@(L _ (HsParTy _ _))] -> [x]@@ -249,7 +258,7 @@     allExts = [minBound .. maxBound]  -- | Extensions that are not enabled automatically and should be activated--- by user.+-- by the user. manualExts :: [Extension] manualExts =   [ Arrows, -- steals proc@@ -267,11 +276,11 @@     UnboxedSums,     UnicodeSyntax, -- gives special meanings to operators like (→)     TemplateHaskell, -- changes how $foo is parsed-    TemplateHaskellQuotes, -- enables TH subset of quasi-quotes, this+    TemplateHaskellQuotes, -- enables the TH subset of quasi-quotes, which     -- apparently interferes with QuasiQuotes in     -- weird ways     ImportQualifiedPost, -- affects how Ormolu renders imports, so the-    -- decision of enabling this style is left to the user+    -- decision to enable this style is left to the user     NegativeLiterals, -- with this, `- 1` and `-1` have differing AST     LexicalNegation, -- implies NegativeLiterals     LinearTypes, -- steals the (%) type operator in some cases

@@ -2,11 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} --- | Functions for working with comment stream.+-- | Functions for working with the comment stream. module Ormolu.Parser.CommentStream   ( -- * Comment stream     CommentStream (..),     mkCommentStream,+    HaddockText,      -- * Comment     LComment,@@ -17,10 +18,10 @@   ) where -import Control.Monad ((<=<)) import Data.Char (isSpace) import Data.Data (Data) import Data.Generics.Schemes+import Data.List qualified as L import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map.Lazy qualified as M@@ -29,7 +30,7 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.Data.Strict qualified as Strict-import GHC.Hs (HsModule)+import GHC.Hs (HsModule (..)) import GHC.Hs.Doc import GHC.Hs.Extension import GHC.Hs.ImpExp@@ -43,29 +44,63 @@ -- Comment stream  -- | A stream of 'RealLocated' 'Comment's in ascending order with respect to--- beginning of corresponding spans.+-- the beginning of the corresponding spans. newtype CommentStream = CommentStream [LComment]   deriving (Eq, Data, Semigroup, Monoid) --- | Create 'CommentStream' from 'HsModule'. The pragmas are--- removed from the 'CommentStream'.+-- | The source text of the Haddocks of a module, keyed by span.+--+-- Haddocks are printed from the text the author wrote rather than+-- reconstructed from the 'GHC.Hs.Doc.HsDocString' GHC parsed out of it.+-- Reconstruction cannot preserve everything — an empty @-- |@ vanishes, and+-- a @{- | … -}@ cannot come back as anything but @--@ lines — and what it+-- loses, it loses from the AST as well, which is why Ormolu refuses to+-- format some modules it should be able to.+type HaddockText = M.Map RealSrcSpan Comment++-- | Create a 'CommentStream' from an 'HsModule'. The pragmas are removed+-- from the 'CommentStream'. mkCommentStream ::   -- | Original input   Text ->   -- | Module to use for comment extraction   HsModule GhcPs ->-  -- | Stack header, pragmas, and comment stream+  -- | Stack header, pragmas, comment stream, and Haddock source text   ( Maybe LComment,     [([LComment], Pragma)],-    CommentStream+    CommentStream,+    HaddockText   ) mkCommentStream input hsModule =   ( mstackHeader,     pragmas,-    CommentStream comments+    CommentStream comments,+    haddockText   )   where-    (comments, pragmas) = extractPragmas input rawComments1+    -- The Haddocks are kept out of the comment stream, because they are+    -- printed from the AST, but their text is kept so that the printer can+    -- reproduce what the author wrote.+    haddockText =+      M.fromList+        [ (spn, mkHaddockComment (L spn (sliceSpan input spn)))+        | spn <- S.toList validHaddockCommentSpans+        ]++    (comments, pragmas) = extractPragmas input headerEnd rawComments1++    -- Where the file header stops and the module proper begins. Only+    -- pragmas before this point are hoisted and normalized; GHC reads the+    -- header and nothing else, so a pragma below it has no effect on+    -- compilation and moving it to the top would give it one.+    headerEnd =+      listToMaybe . L.sort $+        [ realSrcSpanStart spn+        | l <-+            (getLocA <$> hsmodImports hsModule)+              <> (getLocA <$> hsmodDecls hsModule),+          Just spn <- [srcSpanToRealSrcSpan l]+        ]     (rawComments1, mstackHeader) = extractStackHeader rawComments0      -- We want to extract all comments except _valid_ Haddock comments@@ -75,32 +110,33 @@         . flip M.withoutKeys validHaddockCommentSpans         . M.fromList         . fmap (\(L l a) -> (l, a))-        $ allComments+        $ allRawComments++    -- All comments, including valid and invalid Haddock comments+    allRawComments =+      mapMaybe (unAnnotationComment input) $+        epAnnCommentsToList =<< listify (only @EpAnnComments) hsModule       where-        -- All comments, including valid and invalid Haddock comments-        allComments =-          mapMaybe unAnnotationComment $-            epAnnCommentsToList =<< listify (only @EpAnnComments) hsModule-          where-            epAnnCommentsToList = \case-              EpaComments cs -> cs-              EpaCommentsBalanced pcs fcs -> pcs <> fcs-        -- All spans of valid Haddock comments-        validHaddockCommentSpans =-          S.fromList-            . mapMaybe srcSpanToRealSrcSpan-            . mconcat-              [ fmap getLoc . listify (only @(LHsDoc GhcPs)),-                fmap getLocA . listify isIEDocLike-              ]-            $ hsModule-          where-            isIEDocLike :: LIE GhcPs -> Bool-            isIEDocLike = \case-              L _ IEGroup {} -> True-              L _ IEDoc {} -> True-              L _ IEDocNamed {} -> True-              _ -> False+        epAnnCommentsToList = \case+          EpaComments cs -> cs+          EpaCommentsBalanced pcs fcs -> pcs <> fcs++    -- All spans of valid Haddock comments+    validHaddockCommentSpans =+      S.fromList+        . mapMaybe srcSpanToRealSrcSpan+        . mconcat+          [ fmap getLoc . listify (only @(LHsDoc GhcPs)),+            fmap getLocA . listify isIEDocLike+          ]+        $ hsModule+      where+        isIEDocLike :: LIE GhcPs -> Bool+        isIEDocLike = \case+          L _ IEGroup {} -> True+          L _ IEDoc {} -> True+          L _ IEDocNamed {} -> True+          _ -> False     only :: a -> Bool     only _ = True @@ -110,15 +146,15 @@ type LComment = RealLocated Comment  -- | A wrapper for a single comment. The 'Bool' indicates whether there were--- atoms before beginning of the comment in the original input. The--- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or--- just single item\/line otherwise.+-- atoms before the beginning of the comment in the original input. The+-- 'NonEmpty' list inside contains the lines of a multiline comment+-- @{- … -}@, or just a single item\/line otherwise. data Comment = Comment Bool (NonEmpty Text)   deriving (Eq, Show, Data) --- | Normalize comment string. Sometimes one multi-line comment is turned--- into several lines for subsequent outputting with correct indentation for--- each line.+-- | Normalize a comment string. Sometimes a single multi-line comment is+-- split into several lines so that it can later be output with correct+-- indentation on each line. mkComment ::   -- | Lines of original input with their indices   [(Int, Text)] ->@@ -138,27 +174,85 @@                     then startIndent                     else T.length (T.takeWhile isSpace y)                 n = minimum (startIndent : fmap getIndent xs)-                commentPrefix = if "{-" `T.isPrefixOf` s then "" else "-- "-             in x :| ((commentPrefix <>) . escapeHaddockTriggers . T.drop n <$> xs)+             in x :| (escapeOpeningTrigger . T.drop n <$> xs)     (atomsBefore, ls') =       case dropWhile ((< commentLine) . fst) ls of         [] -> (False, [])         ((_, i) : ls'') ->-          case T.take 2 (T.stripStart i) of-            "--" -> (False, ls'')-            "{-" -> (False, ls'')-            _ -> (True, ls'')-    startIndent-      -- srcSpanStartCol counts columns starting from 1, so we subtract 1-      | "{-" `T.isPrefixOf` s = srcSpanStartCol l - 1-      -- For single-line comments, the only case where xs != [] is when an-      -- invalid haddock comment composed of several single-line comments is-      -- encountered. In that case, each line of xs is prefixed with an-      -- extra space (not present in the original comment), so we set-      -- startIndent = 1 to remove this space.-      | otherwise = 1+          let lineStart = T.stripStart i+              -- A pragma is code, not a comment, even though it opens the+              -- same way. Without this a comment trailing @{-# UNPACK #-}+              -- !Int@ looks as though nothing preceded it on the line.+              startsWithComment =+                "--" `T.isPrefixOf` lineStart+                  || ( "{-" `T.isPrefixOf` lineStart+                         && not ("{-#" `T.isPrefixOf` lineStart)+                     )+           in (not startsWithComment, ls'')+    -- srcSpanStartCol counts columns starting from 1, so we subtract 1.+    -- A multi-line run of @--@ lines reaches us as the source wrote it, so+    -- it is dedented the same way a block comment is.+    startIndent = srcSpanStartCol l - 1     commentLine = srcSpanStartLine l +-- | Turn the source text of a Haddock into a 'Comment'.+--+-- Only the indentation of the continuation lines is touched, so that the+-- comment can be re-indented along with the code it documents. Nothing is+-- re-prefixed and no Haddock triggers are escaped: the whole point is that+-- what the author wrote comes back out.+mkHaddockComment :: RealLocated Text -> Comment+mkHaddockComment (L l s) =+  -- Blank lines are kept: inside a doc comment they are the author's+  -- paragraph breaks, not the incidental spacing that 'removeConseqBlanks'+  -- tidies up between ordinary comment lines.+  Comment False . fmap T.stripEnd . spaceAfterTrigger $+    case NE.nonEmpty (T.lines s) of+      Nothing -> s :| []+      Just (x :| xs) ->+        let startIndent = srcSpanStartCol l - 1+            getIndent y =+              if T.all isSpace y+                then startIndent+                else T.length (T.takeWhile isSpace y)+            n = minimum (startIndent : fmap getIndent xs)+         in x :| fmap (T.drop n) xs++-- | Put a space between a Haddock's trigger and what follows it, so that+-- @-- |Foo@ comes out as @-- | Foo@.+--+-- Named anchors are left alone: the name in @-- $section@ is part of the+-- anchor, and a space would make it a different one.+spaceAfterTrigger :: NonEmpty Text -> NonEmpty Text+spaceAfterTrigger (x :| xs) =+  case go x of+    Nothing -> x :| xs+    -- The whole comment shifts right by one, not just the first line.+    -- Haddock drops a leading space from every line of a doc string when+    -- the first line has one, so padding the first line alone would take a+    -- space away from all the others.+    Just x' -> x' :| fmap indentContinuation xs+  where+    go t = do+      (o, afterOpener) <- opener t+      let (spaces, rest) = T.span (== ' ') afterOpener+      (trg, body) <- trigger rest+      if T.null body || " " `T.isPrefixOf` body+        then Nothing+        else Just (o <> spaces <> trg <> " " <> body)+    indentContinuation t = case opener t of+      Just (o, rest) -> o <> " " <> rest+      Nothing -> " " <> t+    opener t+      | Just rest <- T.stripPrefix "--" t = Just ("--", rest)+      | Just rest <- T.stripPrefix "{-" t = Just ("{-", rest)+      | otherwise = Nothing+    trigger t+      | Just body <- T.stripPrefix "|" t = Just ("|", body)+      | Just body <- T.stripPrefix "^" t = Just ("^", body)+      | (stars, body) <- T.span (== '*') t, not (T.null stars) = Just (stars, body)+      | otherwise = Nothing+ -- | Get a collection of lines from a 'Comment'. unComment :: Comment -> NonEmpty Text unComment (Comment _ xs) = xs@@ -175,7 +269,7 @@ ---------------------------------------------------------------------------- -- Helpers --- | Detect and extract stack header if it is present.+-- | Detect and extract the stack header if it is present. extractStackHeader ::   -- | Comment stream to analyze   [RealLocated Text] ->@@ -195,71 +289,123 @@ extractPragmas ::   -- | Input   Text ->+  -- | Where the file header ends, if the module has anything after it+  Maybe RealSrcLoc ->   -- | Comment stream to analyze   [RealLocated Text] ->   ([LComment], [([LComment], Pragma)])-extractPragmas input = go initialLs id id+extractPragmas input headerEnd = go initialLs id id   where     initialLs = zip [1 ..] (T.lines input)++    -- A pragma below the header is not a pragma as far as GHC is+    -- concerned, so it stays in the comment stream and is printed where it+    -- was written. Hoisting it would both give it an effect it did not+    -- have and drag every comment above it to the top of the module.+    inHeader x = case headerEnd of+      Nothing -> True+      Just end -> realSrcSpanStart (getRealSrcSpan x) < end+     go ls csSoFar pragmasSoFar = \case       [] -> (csSoFar [], pragmasSoFar [])       (x : xs) ->         case parsePragma (unRealSrcSpan x) of-          Nothing ->+          Just pragma+            | inHeader x ->+                let combined ys = (csSoFar ys, pragma)+                    go' ls' ys rest = go ls' id (pragmasSoFar . (combined ys :)) rest+                 in case xs of+                      [] -> go' ls [] xs+                      (y : ys) ->+                        let (ls', y') = mkComment ls y+                         in if onTheSameLine+                              (RealSrcSpan (getRealSrcSpan x) Strict.Nothing)+                              (RealSrcSpan (getRealSrcSpan y) Strict.Nothing)+                              then go' ls' [y'] ys+                              else go' ls [] xs+          _ ->             let (ls', x') = mkComment ls x              in go ls' (csSoFar . (x' :)) pragmasSoFar xs-          Just pragma ->-            let combined ys = (csSoFar ys, pragma)-                go' ls' ys rest = go ls' id (pragmasSoFar . (combined ys :)) rest-             in case xs of-                  [] -> go' ls [] xs-                  (y : ys) ->-                    let (ls', y') = mkComment ls y-                     in if onTheSameLine-                          (RealSrcSpan (getRealSrcSpan x) Strict.Nothing)-                          (RealSrcSpan (getRealSrcSpan y) Strict.Nothing)-                          then go' ls' [y'] ys-                          else go' ls [] xs  -- | Extract @'RealLocated' 'Text'@ from 'GHC.LEpaComment'.-unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated Text)-unAnnotationComment (L epaLoc (GHC.EpaComment eck _)) =+unAnnotationComment :: Text -> GHC.LEpaComment -> Maybe (RealLocated Text)+unAnnotationComment input (L epaLoc (GHC.EpaComment eck _)) =   case eck of-    GHC.EpaDocComment s ->-      let trigger = case s of-            MultiLineDocString t _ -> Just t-            NestedDocString t _ -> Just t-            -- should not occur-            GeneratedDocString _ -> Nothing-       in haddock trigger (T.pack $ renderHsDocString s)+    -- A doc comment is taken from the source rather than rebuilt from the+    -- 'HsDocString' GHC parsed out of it: rebuilding cannot preserve a+    -- @{- | … -}@, nor an empty @-- |@, and losing either changes the AST.+    -- A comment that GHC lexed as a doc comment but that did not become+    -- part of the AST is not a Haddock at all. It still looks like one, so+    -- its trigger is escaped: Ormolu may move it somewhere a Haddock would+    -- be accepted, and it must not turn into one there.+    GHC.EpaDocComment _ ->+      withSpan $ \s ->+        Just (escapeOpeningTrigger (normalizeSpacing (sliceSpan input s)))     GHC.EpaDocOptions s -> mkL (T.pack s)-    GHC.EpaLineComment (T.pack -> s) -> mkL $-      case T.take 3 s of-        "-- " -> s-        "---" -> s-        _ -> insertAt " " s 3+    GHC.EpaLineComment (T.pack -> s) -> mkL (normalizeSpacing s)     GHC.EpaBlockComment s -> mkL (T.pack s)   where-    mkL = case epaLoc of-      GHC.EpaSpan (RealSrcSpan s _) -> Just . L s-      _ -> const Nothing-    insertAt x xs n = T.take (n - 1) xs <> x <> T.drop (n - 1) xs-    haddock mtrigger =-      mkL . dashPrefix . escapeHaddockTriggers . (trigger <>) <=< dropBlank-      where-        trigger = case mtrigger of-          Just HsDocStringNext -> "|"-          Just HsDocStringPrevious -> "^"-          Just (HsDocStringNamed n) -> "$" <> T.pack n-          Just (HsDocStringGroup k) -> T.replicate k "*"-          Nothing -> ""-        dashPrefix s = "--" <> spaceIfNecessary <> s-          where-            spaceIfNecessary = case T.uncons s of-              Just (c, _) | c /= ' ' -> " "-              _ -> ""-        dropBlank :: Text -> Maybe Text-        dropBlank s = if T.all isSpace s then Nothing else Just s+    realSpan = case epaLoc of+      GHC.EpaSpan (RealSrcSpan s _) -> Just s+      _ -> Nothing+    mkL = case realSpan of+      Just s -> Just . L s+      Nothing -> const Nothing+    withSpan f = do+      s <- realSpan+      L s <$> f s++-- | Put a space after the dashes of a line comment when there is none.+--+-- This is the one normalization that survives: @--foo@ becomes @-- foo@ and+-- @--|foo@ becomes @-- |foo@, which is what one expects of a formatter.+-- Everything else about a comment is left as it was written.+normalizeSpacing :: Text -> Text+normalizeSpacing s+  | not ("--" `T.isPrefixOf` s) = s+  | otherwise = case T.uncons (T.drop 2 s) of+      Nothing -> s+      Just (c, _)+        | c == ' ' || c == '-' -> s+        | otherwise -> "-- " <> T.drop 2 s++-- | Escape a Haddock trigger that opens a comment line, so that the line+-- cannot be read as a Haddock wherever it ends up.+--+-- A line that does not open a comment is left alone: a @*@ in the middle of+-- a @{- … -}@ block is just a character, and escaping it there only+-- disfigures the text.+escapeOpeningTrigger :: Text -> Text+escapeOpeningTrigger t =+  case T.stripPrefix "--" t of+    Just rest -> "--" <> escapeAfterSpaces rest+    Nothing -> case T.stripPrefix "{-" t of+      Just rest -> "{-" <> escapeAfterSpaces rest+      Nothing -> t+  where+    escapeAfterSpaces x =+      let (spaces, rest) = T.span (== ' ') x+       in spaces <> escapeHaddockTriggers rest++-- | Extract the source text a span covers.+sliceSpan :: Text -> RealSrcSpan -> Text+sliceSpan input spn =+  case spannedLines of+    [] -> ""+    [single] -> T.take (endCol - startCol) (T.drop (startCol - 1) single)+    (firstLine : rest) ->+      T.intercalate "\n" $+        T.drop (startCol - 1) firstLine : trimLast rest+  where+    startLine = srcSpanStartLine spn+    endLine = srcSpanEndLine spn+    startCol = srcSpanStartCol spn+    endCol = srcSpanEndCol spn+    spannedLines =+      take (endLine - startLine + 1) (drop (startLine - 1) (T.lines input))+    trimLast xs = case reverse xs of+      [] -> []+      (y : ys) -> reverse (T.take (endCol - 1) y : ys)  -- | Remove consecutive blank lines. removeConseqBlanks :: NonEmpty Text -> NonEmpty Text

@@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | A module for parsing of pragmas from comments.+-- | A module for parsing pragmas from comments. module Ormolu.Parser.Pragma   ( Pragma (..),     parsePragma,

@@ -1,14 +1,18 @@--- | A type for result of parsing.+-- | A type for the result of parsing. module Ormolu.Parser.Result   ( SourceSnippet (..),     ParseResult (..),+    inputComments,   ) where +import Data.List (sortOn)+import Data.Maybe (maybeToList) import Data.Text (Text) import GHC.Data.EnumSet (EnumSet) import GHC.Hs import GHC.LanguageExtensions.Type+import GHC.Types.SrcLoc (getLoc) import Ormolu.Config (SourceType) import Ormolu.Fixity (ModuleFixityMap) import Ormolu.Parser.CommentStream@@ -21,7 +25,7 @@ data ParseResult = ParseResult   { -- | Parsed module or signature     prParsedSource :: HsModule GhcPs,-    -- | Either regular module or signature file+    -- | Whether this is a regular module or a signature file     prSourceType :: SourceType,     -- | Stack header     prStackHeader :: Maybe LComment,@@ -29,10 +33,27 @@     prPragmas :: [([LComment], Pragma)],     -- | Comment stream     prCommentStream :: CommentStream,+    -- | Source text of the module's Haddocks, keyed by span+    prHaddockText :: HaddockText,     -- | Enabled extensions     prExtensions :: EnumSet Extension,     -- | Fixity map for operators     prModuleFixityMap :: ModuleFixityMap,-    -- | Indentation level, can be non-zero in case of region formatting+    -- | Indentation level; can be non-zero in the case of region formatting     prIndent :: Int   }++-- | All the comments a snippet started with, in source order.+--+-- This is not simply the comment stream: the Stack header and the comments+-- that precede pragmas are lifted out of the stream while parsing, and are+-- emitted separately. Haddocks, on the other hand, are not included at all,+-- because GHC's parser makes them part of the AST.+inputComments :: ParseResult -> [LComment]+inputComments ParseResult {prStackHeader, prPragmas, prCommentStream} =+  sortOn getLoc $+    maybeToList prStackHeader+      <> concatMap fst prPragmas+      <> streamComments+  where+    CommentStream streamComments = prCommentStream

@@ -3,18 +3,27 @@ {-# LANGUAGE RecordWildCards #-}  -- | Pretty-printer for Haskell AST.+--+-- Each snippet is rendered twice. Comments are attached to the elements the+-- printer enters, and the only way to know which elements those are is to+-- render once and see; the first pass therefore runs with no comments at+-- all and is kept only for the spans it visited. See 'render'. module Ormolu.Printer   ( printSnippets,+    printSnippetsWithPlacements,   ) where  import Data.Choice (Choice) import Data.Text (Text) import Data.Text qualified as T+import GHC.Types.SrcLoc (RealSrcSpan)+import Ormolu.Comments.Anchor+import Ormolu.Parser.CommentStream (CommentStream (..)) import Ormolu.Parser.Result import Ormolu.Printer.Combinators+import Ormolu.Printer.CommentPlacement import Ormolu.Printer.Meat.Module-import Ormolu.Printer.SpanStream import Ormolu.Processing.Common  -- | Render several source snippets.@@ -25,21 +34,70 @@   [SourceSnippet] ->   -- | Resulting rendition   Text-printSnippets debug = T.concat . fmap printSnippet+printSnippets debug = T.concat . fmap fst . printSnippetsWithPlacements debug++-- | Like 'printSnippets', but also return, for each snippet, the placement+-- of every comment it emitted.+--+-- Snippets are rendered separately and their spans are relative to+-- themselves, so the placements stay grouped by snippet: anything that+-- compares them against the input has to work one snippet at a time.+printSnippetsWithPlacements ::+  -- | Whether to print out debug information during printing+  Choice "debug" ->+  -- | Result of parsing+  [SourceSnippet] ->+  -- | For each snippet, its rendition and the comments it emitted+  [(Text, [CommentPlacement])]+printSnippetsWithPlacements debug = fmap (renderSnippet debug)++-- | Render one snippet. A snippet that could not be parsed is passed+-- through as it was.+renderSnippet ::+  Choice "debug" ->+  SourceSnippet ->+  (Text, [CommentPlacement])+renderSnippet debug = \case+  ParsedSnippet r -> render debug r+  RawSnippet r -> (r, [])++-- | Render one parsed snippet, along with the placement of every comment it+-- emitted.+--+-- This renders twice. Anchoring a comment to an element the printer never+-- enters would leave the comment stranded, and there is no way to know+-- which elements those are but to render once and see. The first pass is+-- given an empty 'AnchorMap', so it emits no comments and its output is+-- thrown away; what it is for is the spans it visited, which is what the+-- second pass attaches the comments to.+render ::+  Choice "debug" ->+  ParseResult ->+  (Text, [CommentPlacement])+render debug r@ParseResult {..} =+  let (_, _, visited) = renderWith noComments+      (rendered, placements, _) = renderWith (anchorMapFor r visited)+   in (rendered, placements)   where-    printSnippet = \case-      ParsedSnippet ParseResult {..} ->-        reindent prIndent $-          runR-            ( p_hsModule-                prStackHeader-                prPragmas-                prParsedSource-            )-            (mkSpanStream prParsedSource)-            prCommentStream-            prSourceType-            prExtensions-            prModuleFixityMap-            debug-      RawSnippet r -> r+    renderWith anchorMap =+      let (rendered, placements, visited) =+            runR+              ( p_hsModule+                  prStackHeader+                  prPragmas+                  prParsedSource+              )+              anchorMap+              prSourceType+              prExtensions+              prModuleFixityMap+              debug+              prHaddockText+       in (reindent prIndent rendered, placements, visited)++-- | Attach the comments of a snippet to the elements the printer enters.+anchorMapFor :: ParseResult -> [RealSrcSpan] -> AnchorMap+anchorMapFor ParseResult {..} visited =+  mkAnchorMap (attachComments comments visited)+  where+    CommentStream comments = prCommentStream

@@ -3,15 +3,15 @@ {-# LANGUAGE OverloadedStrings #-}  -- | Printing combinators. The definitions here are presented in such an--- order so you can just go through the Haddocks and by the end of the file--- you should have a pretty good idea how to program rendering logic.+-- order that you can just read through the Haddocks, and by the end of the+-- file you should have a pretty good idea of how to program rendering logic. module Ormolu.Printer.Combinators   ( -- * The 'R' monad     R,     runR,     getEnclosingSpan,-    getEnclosingSpanWhere,-    getEnclosingComments,+    getCommentsAnchoredWithin,+    getCommentsBefore,     isExtensionEnabled,      -- * Combinators@@ -28,9 +28,10 @@     askModuleFixityMap,     askDebug,     located,-    encloseLocated,+    locatedEmpty,     located',     switchLayout,+    switchLayoutWithEnclosingComments,     enterLayout,     Layout (..),     vlayout,@@ -61,15 +62,17 @@     -- ** Literals     comma,     commaDel,-    equals,      -- ** Stateful markers-    SpanMark (..),-    spanMarkSpan,+    LastEmitted (..),+    lastEmittedSpan,     HaddockStyle (..),-    setSpanMark,-    getSpanMark,+    setLastEmitted,+    getLastEmitted, +    -- ** Haddocks+    lookupHaddockText,+     -- ** Placement     Placement (..),     placeHanging,@@ -78,12 +81,14 @@  import Control.Monad import Data.List (intersperse)+import Data.List.NonEmpty qualified as NE import Data.Text (Text) import GHC.Data.Strict qualified as Strict import GHC.Parser.Annotation import GHC.Types.SrcLoc import Ormolu.Printer.Comments import Ormolu.Printer.Internal+import Ormolu.Utils (combineSrcSpans')  ---------------------------------------------------------------------------- -- Basic@@ -98,7 +103,7 @@ inciIf b m = if b then inci m else m  -- | Enter a 'GenLocated' entity. This combinator handles outputting comments--- and sets layout (single-line vs multi-line) for the inner computation.+-- and sets the layout (single-line vs multi-line) for the inner computation. -- Roughly, the rule for using 'located' is that every time there is a -- 'Located' wrapper, it should be “discharged” with a corresponding -- 'located' invocation.@@ -106,59 +111,117 @@   (HasLoc l) =>   -- | Thing to enter   GenLocated l a ->-  -- | How to render inner value+  -- | How to render the inner value   (a -> R ()) ->   R () located (L l' a) f = case locA l' of   UnhelpfulSpan _ -> f a   RealSrcSpan l _ -> do+    recordVisitedSpan l     spitPrecedingComments l     withEnclosingSpan l $       switchLayout [RealSrcSpan l Strict.Nothing] (f a)     spitFollowingComments l --- | Similar to 'located', but when the "payload" is an empty list, print--- virtual elements at the start and end of the source span to prevent comments--- from "floating out".-encloseLocated ::-  (HasLoc l) =>-  GenLocated l [a] ->-  ([a] -> R ()) ->+-- | Give an empty bracketed construct something for a comment written+-- inside it to attach to.+--+-- Brackets are rendered with 'txt', so an empty export or import list, an+-- empty @[]@ or a record with no fields contains no element at all. A+-- comment written between the brackets would be attached to whatever+-- encloses them and rendered outside them, so a zero-width element is+-- entered at the opening bracket instead.+locatedEmpty ::+  -- | Span of the empty construct+  SrcSpan ->   R ()-encloseLocated la f = located la $ \a -> do-  when (null a) $ located (L startSpan ()) pure-  f a-  when (null a) $ located (L endSpan ()) pure-  where-    l = locA la-    (startLoc, endLoc) = (srcSpanStart l, srcSpanEnd l)-    (startSpan, endSpan) = (mkSrcSpan startLoc startLoc, mkSrcSpan endLoc endLoc)+locatedEmpty l =+  let loc = srcSpanStart l+   in located (L (mkSrcSpan loc loc) ()) pure --- | A version of 'located' with arguments flipped.+-- | A version of 'located' with the arguments flipped. located' ::   (HasLoc l) =>-  -- | How to render inner value+  -- | How to render the inner value   (a -> R ()) ->   -- | Thing to enter   GenLocated l a ->   R () located' = flip located --- | Set layout according to combination of given 'SrcSpan's for a given.--- Use this only when you need to set layout based on e.g. combined span of--- several elements when there is no corresponding 'Located' wrapper--- provided by GHC AST. It is relatively rare that this one is needed.+-- | Set the layout according to the combination of the given 'SrcSpan's,+-- together with the spans of the comments that belong inside them. ----- Given empty list this function will set layout to single line.+-- Comments count towards the layout: a construct that would fit on one line+-- has to be broken up anyway if a comment was written inside it, or the+-- comment would swallow whatever follows it on the line.+--+-- 'located' calls this for you. Call it directly only when the layout has+-- to come from something the GHC AST has no 'Located' wrapper for, such as+-- the combined span of several elements; that is rare.+--+-- Given an empty list and no comments, this function will set the layout to+-- single-line. switchLayout ::   -- | Span that controls layout   [SrcSpan] ->   -- | Computation to run with changed layout   R () ->   R ()-switchLayout spans' = enterLayout (spansLayout spans')+switchLayout spans' m = do+  csSpans <- commentSpansIn (combineSrcSpans' <$> NE.nonEmpty spans')+  enterLayout (spansLayout (spans' <> csSpans)) m --- | Which layout combined spans result in?+-- | Like 'switchLayout', but the comments are looked for in the enclosing+-- element rather than in the given spans.+--+-- This is what a bracketed construct needs. In+--+-- > ( -- c+-- >   x+-- > )+--+-- the comment sits between the bracket and @x@, so it is inside neither of+-- them, and the parentheses would be put on one line despite it. Widening+-- the question to the enclosing element catches it. Do not reach for this+-- elsewhere: it is deliberately coarser than 'switchLayout', and applying+-- it where the enclosing element is large would let one comment break every+-- layout decision inside it.+switchLayoutWithEnclosingComments ::+  -- | Span that controls layout+  [SrcSpan] ->+  -- | Computation to run with changed layout+  R () ->+  R ()+switchLayoutWithEnclosingComments spans' m = do+  enclosing <- getEnclosingSpan+  csSpans <- commentSpansIn (flip RealSrcSpan Strict.Nothing <$> enclosing)+  enterLayout (spansLayout (spans' <> csSpans)) m++-- | The spans of the comments that belong inside the given region: both+-- attached to something in it and written inside it.+--+-- Both halves are needed. Without the first, a comment anywhere in a+-- declaration would force every layout decision inside that declaration to+-- multi-line. Without the second, a comment trailing an element would force+-- that element itself to be broken up.+--+-- Haddocks are not consulted here. They do not travel in the anchor map,+-- and their spans sit where the author wrote them rather than where they+-- will be printed, which is the wrong question; see+-- 'Ormolu.Printer.Meat.Common.multiLineIfDocumented'.+commentSpansIn :: Maybe SrcSpan -> R [SrcSpan]+commentSpansIn = \case+  Just (RealSrcSpan region _) -> do+    comments <- getCommentsAnchoredWithin region+    pure+      [ RealSrcSpan spn Strict.Nothing+      | L spn _ <- comments,+        region `containsSpan` spn+      ]+  _ -> pure []++-- | Which layout do the combined spans result in? spansLayout :: [SrcSpan] -> Layout spansLayout = \case   [] -> SingleLine@@ -167,14 +230,14 @@       then SingleLine       else MultiLine --- | Insert a space if enclosing layout is single-line, or newline if it's--- multiline.+-- | Insert a space if the enclosing layout is single-line, or a newline if+-- it is multi-line. -- -- > breakpoint = vlayout space newline breakpoint :: R () breakpoint = vlayout space newline --- | Similar to 'breakpoint' but outputs nothing in case of single-line+-- | Similar to 'breakpoint', but outputs nothing in the case of single-line -- layout. -- -- > breakpoint' = vlayout (return ()) newline@@ -184,7 +247,7 @@ ---------------------------------------------------------------------------- -- Formatting lists --- | Render a collection of elements inserting a separator between them.+-- | Render a collection of elements, inserting a separator between them. sep ::   -- | Separator   R () ->@@ -195,9 +258,9 @@   R () sep s f xs = sequence_ (intersperse s (f <$> xs)) --- | Render a collection of elements layout-sensitively using given printer,--- inserting semicolons if necessary and respecting 'useBraces' and--- 'dontUseBraces' combinators.+-- | Render a collection of elements layout-sensitively using the given+-- printer, inserting semicolons if necessary and respecting the 'useBraces'+-- and 'dontUseBraces' combinators. -- -- > useBraces $ sepSemi txt ["foo", "bar"] -- >   == vlayout (txt "{ foo; bar }") (txt "foo\nbar")@@ -212,8 +275,8 @@   R () sepSemi = sepSemi' False --- | A version of 'sepSemi' that allows to control whether semicolons should--- be inserted in multi-line layout.+-- | A version of 'sepSemi' that allows one to control whether semicolons+-- should be inserted in multi-line layout. -- -- > useBraces $ sepSemi' False txt ["foo", "bar"] -- >   == vlayout (txt "{ foo; bar }") (txt "foo\nbar")@@ -252,7 +315,7 @@ ---------------------------------------------------------------------------- -- Wrapping --- | 'BracketStyle' controlling how closing bracket is rendered.+-- | 'BracketStyle' controlling how the closing bracket is rendered. data BracketStyle   = -- | Normal     N@@ -260,30 +323,31 @@     S   deriving (Eq, Show) --- | Surround given entity by backticks.+-- | Surround the given entity with backticks. backticks :: R () -> R () backticks m = do   txt "`"   m   txt "`" --- | Surround given entity by banana brackets (i.e., from arrow notation.)+-- | Surround the given entity with banana brackets (i.e. from arrow+-- notation). banana :: BracketStyle -> R () -> R () banana = brackets_ True "(|" "|)" --- | Surround given entity by curly braces @{@ and  @}@.+-- | Surround the given entity with curly braces @{@ and @}@. braces :: BracketStyle -> R () -> R () braces = brackets_ False "{" "}" --- | Surround given entity by square brackets @[@ and @]@.+-- | Surround the given entity with square brackets @[@ and @]@. brackets :: BracketStyle -> R () -> R () brackets = brackets_ False "[" "]" --- | Surround given entity by parentheses @(@ and @)@.+-- | Surround the given entity with parentheses @(@ and @)@. parens :: BracketStyle -> R () -> R () parens = brackets_ False "(" ")" --- | Surround given entity by @(# @ and @ #)@.+-- | Surround the given entity with @(# @ and @ #)@. parensHash :: BracketStyle -> R () -> R () parensHash = brackets_ True "(#" "#)" @@ -348,21 +412,17 @@ commaDel :: R () commaDel = comma >> breakpoint --- | Print @=@. Do not use @'txt' "="@.-equals :: R ()-equals = interferingTxt "="- ---------------------------------------------------------------------------- -- Placement  -- | Expression placement. This marks the places where expressions that--- implement handing forms may use them.+-- support hanging forms may use them. data Placement   = -- | Multi-line layout should cause-    -- insertion of a newline and indentation-    -- bump+    -- insertion of a newline and an+    -- indentation bump     Normal-  | -- | Expressions that have hanging form+  | -- | Expressions that have a hanging form     -- should use it and avoid bumping one level     -- of indentation     Hanging

@@ -0,0 +1,57 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | A record of where each comment ended up in the rendered output.+--+-- The printer notes every comment as it emits it. Ormolu then checks that+-- record against the comments of the input, which is how it can promise+-- that formatting neither drops, duplicates, invents nor reorders a+-- comment; see "Ormolu.Comments.Invariants".+module Ormolu.Printer.CommentPlacement+  ( CommentPlacement (..),+    CommentSlot (..),+    slotAnchor,+  )+where++import GHC.Types.SrcLoc++----------------------------------------------------------------------------+-- Types++-- | Where a comment ended up relative to the AST element it was attached+-- to.+--+-- Only the distinctions a consumer can act on are kept: whether the comment+-- was attached to an element, and whether it rode along with a pragma. See+-- "Ormolu.Comments.Invariants", which is what reads this.+data CommentSlot+  = -- | Attached to the element at this span+    SlotAt RealSrcSpan+  | -- | Hoisted into the module header along with a pragma. Pragmas are+    -- sorted on purpose, so the order such a comment comes out in says+    -- nothing.+    SlotPragma+  | -- | Attached to nothing: the Stack header, or a leftover flushed at the+    -- end of the module by 'Ormolu.Printer.Comments.spitRemainingComments'+    SlotFloating+  deriving (Eq, Show)++-- | The span of the AST element that a comment was attached to, if the+-- comment was attached to an element at all.+slotAnchor :: CommentSlot -> Maybe RealSrcSpan+slotAnchor = \case+  SlotAt spn -> Just spn+  SlotPragma -> Nothing+  SlotFloating -> Nothing++-- | A single placement decision: one comment and the slot it was rendered+-- in.+data CommentPlacement = CommentPlacement+  { -- | Span of the comment in the input, which is what identifies it+    cpSpan :: RealSrcSpan,+    -- | Where the comment ended up+    cpSlot :: CommentSlot+  }+  deriving (Eq, Show)

@@ -1,6 +1,7 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | Helpers for formatting of comments. This is low-level code, use+-- | Helpers for formatting comments. This is low-level code; use -- "Ormolu.Printer.Combinators" unless you know what you are doing. module Ormolu.Printer.Comments   ( spitPrecedingComments,@@ -8,6 +9,7 @@     spitRemainingComments,     spitCommentNow,     spitCommentPending,+    CommentSlot (..),   ) where @@ -15,151 +17,130 @@ import Data.List.NonEmpty qualified as NE import Data.Maybe (listToMaybe) import GHC.Types.SrcLoc+import Ormolu.Comments.Anchor import Ormolu.Parser.CommentStream+import Ormolu.Printer.CommentPlacement import Ormolu.Printer.Internal  ---------------------------------------------------------------------------- -- Top-level --- | Output all preceding comments for an element at given location.+-- | Output all preceding comments for an element at the given location. spitPrecedingComments ::   -- | Span of the element to attach comments to   RealSrcSpan ->   R () spitPrecedingComments ref = do-  comments <- handleCommentSeries (spitPrecedingComment ref)-  when (not $ null comments) $ do-    lastMark <- getSpanMark+  comments <- withAnchorMap (claimBefore ref)+  forM_ comments (spitPrecedingComment ref)+  unless (null comments) $ do+    lastEmitted <- getLastEmitted     -- Insert a blank line between the preceding comments and the thing     -- after them if there was a blank line in the input.-    when (needsNewlineBefore ref lastMark) newline+    when (needsNewlineBefore ref lastEmitted) newline --- | Output all comments following an element at given location.+-- | Output all comments following an element at the given location. spitFollowingComments ::   -- | Span of the element to attach comments to   RealSrcSpan ->   R () spitFollowingComments ref = do-  trimSpanStream ref-  void $ handleCommentSeries (spitFollowingComment ref)+  comments <- withAnchorMap (claimTrailing ref)+  forM_ comments (spitFollowingComment ref) --- | Output all remaining comments in the comment stream.+-- | Output every comment that no element claimed.+--+-- This is the safety net that keeps a misattached comment from being lost+-- outright. It also means misattachment is silent, which is why+-- "Ormolu.Comments.Invariants" exists. spitRemainingComments :: R () spitRemainingComments = do-  -- Make sure we have a blank a line between the last definition and the+  -- Make sure we have a blank line between the last definition and the   -- trailing comments.   newline-  void $ handleCommentSeries spitRemainingComment+  comments <- withAnchorMap claimRemaining+  forM_ comments spitRemainingComment  ---------------------------------------------------------------------------- -- Single-comment functions --- | Output a single preceding comment for an element at given location.+-- | Output a single preceding comment for an element at the given location. spitPrecedingComment ::-  -- | Span of the element to attach comments to+  -- | Span of the element the comment is attached to   RealSrcSpan ->-  -- | The comment that was output, if any-  R (Maybe LComment)-spitPrecedingComment ref = do-  mlastMark <- getSpanMark-  let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref-  withPoppedComment p $ \l comment -> do-    lineSpans <- thisLineSpans-    let thisCommentLine = srcLocLine (realSrcSpanStart l)-        needsNewline =-          case listToMaybe lineSpans of-            Nothing -> False-            Just spn -> srcLocLine (realSrcSpanEnd spn) /= thisCommentLine-    when (needsNewline || needsNewlineBefore l mlastMark) newline-    spitCommentNow l comment-    if theSameLinePre l ref-      then space-      else newline+  -- | The comment to output+  LComment ->+  R ()+spitPrecedingComment ref (L l comment) = do+  lastEmitted <- getLastEmitted+  lineSpans <- thisLineSpans+  let thisCommentLine = srcLocLine (realSrcSpanStart l)+      needsNewline =+        case listToMaybe lineSpans of+          Nothing -> False+          Just spn -> srcLocLine (realSrcSpanEnd spn) /= thisCommentLine+      sameLine = theSameLinePre l ref+  when (needsNewline || needsNewlineBefore l lastEmitted) newline+  spitCommentNow (SlotAt ref) l comment+  if sameLine+    then space+    else newline --- | Output a comment that follows element at given location immediately on--- the same line, if there is any.+-- | Output a single comment that follows an element at the given location. spitFollowingComment ::-  -- | AST element to attach comments to+  -- | Span of the element the comment is attached to   RealSrcSpan ->-  -- | The comment that was output, if any-  R (Maybe LComment)-spitFollowingComment ref = do-  mlastMark <- getSpanMark-  mnSpn <- nextEltSpan-  -- Get first enclosing span that is not equal to reference span, i.e. it's-  -- truly something enclosing the AST element.-  meSpn <- getEnclosingSpanWhere (/= ref)-  withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastMark) $ \l comment ->-    if theSameLinePost l ref-      then-        if isMultilineComment comment-          then space >> spitCommentNow l comment-          else spitCommentPending OnTheSameLine l comment-      else do-        when (needsNewlineBefore l mlastMark) $-          registerPendingCommentLine OnNextLine ""-        spitCommentPending OnNextLine l comment+  -- | The comment to output+  LComment ->+  R ()+spitFollowingComment ref (L l comment) = do+  lastEmitted <- getLastEmitted+  if theSameLinePost l ref+    then+      if isMultilineComment comment+        then space >> spitCommentNow (SlotAt ref) l comment+        else spitCommentPending (SlotAt ref) OnTheSameLine l comment+    else do+      -- A comment keeps the blank line the input had in front of it. When+      -- nothing carrying a position has been emitted since, the element the+      -- comment is attached to is what that blank line separated it from.+      let lastEmitted' = case lastEmittedSpan lastEmitted of+            Just _ -> lastEmitted+            Nothing -> LastEmittedComment ref+      when (needsNewlineBefore l lastEmitted') $+        registerPendingCommentLine OnNextLine ""+      spitCommentPending (SlotAt ref) OnNextLine l comment --- | Output a single remaining comment from the comment stream.+-- | Output a single unclaimed comment. spitRemainingComment ::-  -- | The comment that was output, if any-  R (Maybe LComment)-spitRemainingComment = do-  mlastMark <- getSpanMark-  withPoppedComment (const True) $ \l comment -> do-    when (needsNewlineBefore l mlastMark) newline-    spitCommentNow l comment-    newline+  -- | The comment to output+  LComment ->+  R ()+spitRemainingComment (L l comment) = do+  lastEmitted <- getLastEmitted+  when (needsNewlineBefore l lastEmitted) newline+  spitCommentNow SlotFloating l comment+  newline  ---------------------------------------------------------------------------- -- Helpers --- | Output series of comments.-handleCommentSeries ::-  -- | Output and return the next comment, if any-  R (Maybe LComment) ->-  -- | The comments outputted-  R [LComment]-handleCommentSeries f = go-  where-    go = do-      mComment <- f-      case mComment of-        Nothing -> return []-        Just comment -> (comment :) <$> go---- | Try to pop a comment using given predicate and if there is a comment--- matching the predicate, print it out.-withPoppedComment ::-  -- | Comment predicate-  (LComment -> Bool) ->-  -- | Printing function-  (RealSrcSpan -> Comment -> R ()) ->-  -- | Are we done?-  R (Maybe LComment)-withPoppedComment p f = do-  r <- popComment p-  case r of-    Nothing -> return ()-    Just (L l comment) -> f l comment-  return r---- | Determine if we need to insert a newline between current comment and--- last printed comment.+-- | Determine whether we need to insert a newline between the current+-- comment and the last printed comment. needsNewlineBefore ::   -- | Current comment span   RealSrcSpan ->-  -- | Last printed comment span-  Maybe SpanMark ->+  -- | What was emitted last+  LastEmitted ->   Bool-needsNewlineBefore _ (Just (HaddockSpan _ _)) = True-needsNewlineBefore l mlastMark =-  case spanMarkSpan <$> mlastMark of+needsNewlineBefore _ (LastEmittedHaddock _) = True+needsNewlineBefore l lastEmitted =+  case lastEmittedSpan lastEmitted of     Nothing -> False-    Just lastMark ->-      srcSpanStartLine l > srcSpanEndLine lastMark + 1+    Just lastSpn ->+      srcSpanStartLine l > srcSpanEndLine lastSpn + 1 --- | Is the preceding comment and AST element are on the same line?+-- | Are the preceding comment and the AST element on the same line? theSameLinePre ::   -- | Current comment span   RealSrcSpan ->@@ -169,7 +150,7 @@ theSameLinePre l ref =   srcSpanEndLine l == srcSpanStartLine ref --- | Is the following comment and AST element are on the same line?+-- | Are the following comment and the AST element on the same line? theSameLinePost ::   -- | Current comment span   RealSrcSpan ->@@ -179,99 +160,40 @@ theSameLinePost l ref =   srcSpanStartLine l == srcSpanEndLine ref --- | Determine if given comment follows AST element.-commentFollowsElt ::-  -- | Location of AST element-  RealSrcSpan ->-  -- | Location of next AST element-  Maybe RealSrcSpan ->-  -- | Location of enclosing AST element-  Maybe RealSrcSpan ->-  -- | Location of last comment in the series-  Maybe SpanMark ->-  -- | Comment to test-  LComment ->-  Bool-commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =-  -- A comment follows a AST element if all 4 conditions are satisfied:-  goesAfter-    && logicallyFollows-    && noEltBetween-    && (continuation || lastInEnclosing || supersedesParentElt)-  where-    -- 1) The comment starts after end of the AST element:-    goesAfter =-      realSrcSpanStart l >= realSrcSpanEnd ref-    -- 2) The comment logically belongs to the element, four cases:-    logicallyFollows =-      theSameLinePost l ref -- a) it's on the same line-        || continuation -- b) it's a continuation of a comment block-        || lastInEnclosing -- c) it's the last element in the enclosing construct--    -- 3) There is no other AST element between this element and the comment:-    noEltBetween =-      case mnSpn of-        Nothing -> True-        Just nspn ->-          realSrcSpanStart nspn >= realSrcSpanEnd l-    -- 4) Less obvious: if column of comment is closer to the start of-    -- enclosing element, it probably related to that parent element, not to-    -- the current child element. This rule is important because otherwise-    -- all comments would end up assigned to closest inner elements, and-    -- parent elements won't have a chance to get any comments assigned to-    -- them. This is not OK because comments will get indented according to-    -- the AST elements they are attached to.-    ---    -- Skip this rule if the comment is a continuation of a comment block.-    supersedesParentElt =-      case meSpn of-        Nothing -> True-        Just espn ->-          let startColumn = srcLocCol . realSrcSpanStart-           in startColumn espn > startColumn ref-                || ( abs (startColumn espn - startColumn l)-                       >= abs (startColumn ref - startColumn l)-                   )-    continuation =-      -- A comment is a continuation when it doesn't have non-whitespace-      -- lexemes in front of it and goes right after the previous comment.-      not (hasAtomsBefore comment)-        && ( case mlastMark of-               Just (HaddockSpan _ _) -> False-               Just (CommentSpan spn) ->-                 srcSpanEndLine spn + 1 == srcSpanStartLine l-               _ -> False-           )-    lastInEnclosing =-      case meSpn of-        -- When there is no enclosing element, return false-        Nothing -> False-        -- When there is an enclosing element,-        Just espn ->-          let -- Make sure that the comment is inside the enclosing element-              insideParent = realSrcSpanEnd l <= realSrcSpanEnd espn-              -- And check if the next element is outside of the parent-              nextOutsideParent = case mnSpn of-                Nothing -> True-                Just nspn -> realSrcSpanEnd espn < realSrcSpanStart nspn-           in insideParent && nextOutsideParent- -- | Output a 'Comment' immediately. This is a low-level printing function.-spitCommentNow :: RealSrcSpan -> Comment -> R ()-spitCommentNow spn comment = do+--+-- Note that it records the placement as well as printing. Every path that+-- emits a comment has to go through this or 'spitCommentPending', or+-- "Ormolu.Comments.Invariants" will report the comment as dropped and+-- Ormolu will refuse to format the file.+spitCommentNow ::+  -- | The slot the comment is being rendered in+  CommentSlot ->+  RealSrcSpan ->+  Comment ->+  R ()+spitCommentNow slot spn comment = do+  recordCommentPlacement CommentPlacement {cpSpan = spn, cpSlot = slot}   sitcc     . sequence_     . NE.intersperse newline     . fmap txt     . unComment     $ comment-  setSpanMark (CommentSpan spn)+  setLastEmitted (LastEmittedComment spn) --- | Output a 'Comment' at the end of correct line or after it depending on--- 'CommentPosition'. Used for comments that may potentially follow on the--- same line as something we just rendered, but not immediately after it.-spitCommentPending :: CommentPosition -> RealSrcSpan -> Comment -> R ()-spitCommentPending position spn comment = do+-- | Output a 'Comment' at the end of the correct line, or after it,+-- depending on the 'CommentPosition'. Used for comments that may follow on+-- the same line as something we just rendered, but not immediately after it.+spitCommentPending ::+  -- | The slot the comment is being rendered in+  CommentSlot ->+  CommentPosition ->+  RealSrcSpan ->+  Comment ->+  R ()+spitCommentPending slot position spn comment = do+  recordCommentPlacement CommentPlacement {cpSpan = spn, cpSlot = slot}   let wrapper = case position of         OnTheSameLine -> sitcc         OnNextLine -> id@@ -281,4 +203,4 @@     . fmap (registerPendingCommentLine position)     . unComment     $ comment-  setSpanMark (CommentSpan spn)+  setLastEmitted (LastEmittedComment spn)

@@ -2,7 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | In most cases import "Ormolu.Printer.Combinators" instead, these+-- | In most cases, import "Ormolu.Printer.Combinators" instead; these -- functions are the low-level building blocks and should not be used on -- their own. The 'R' monad is re-exported from "Ormolu.Printer.Combinators" -- as well.@@ -13,7 +13,6 @@      -- * Internal functions     txt,-    interferingTxt,     atom,     space,     newline,@@ -36,22 +35,27 @@     -- * Special helpers for comment placement     CommentPosition (..),     registerPendingCommentLine,-    trimSpanStream,-    nextEltSpan,-    popComment,-    getEnclosingComments,+    withAnchorMap,+    getCommentsAnchoredWithin,+    getCommentsBefore,     getEnclosingSpan,-    getEnclosingSpanWhere,     withEnclosingSpan,     thisLineSpans,      -- * Stateful markers-    SpanMark (..),-    spanMarkSpan,+    LastEmitted (..),+    lastEmittedSpan,+    setLastEmitted,+    getLastEmitted,++    -- * Haddocks     HaddockStyle (..),-    setSpanMark,-    getSpanMark,+    lookupHaddockText, +    -- * Recording comment placement+    recordCommentPlacement,+    recordVisitedSpan,+     -- * Extensions     isExtensionEnabled,   )@@ -62,9 +66,8 @@ import Control.Monad.State.Strict import Data.Bool (bool) import Data.Choice (Choice)-import Data.Coerce-import Data.Functor ((<&>)) import Data.List (find)+import Data.Map.Strict qualified as M import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Text qualified as T@@ -75,17 +78,18 @@ import GHC.LanguageExtensions.Type import GHC.Types.SrcLoc import GHC.Utils.Outputable (Outputable)+import Ormolu.Comments.Anchor (AnchorMap, commentsAnchoredWithin, commentsBefore) import Ormolu.Config (SourceType (..)) import Ormolu.Fixity (ModuleFixityMap) import Ormolu.Parser.CommentStream-import Ormolu.Printer.SpanStream+import Ormolu.Printer.CommentPlacement import Ormolu.Utils (showOutputable)  ---------------------------------------------------------------------------- -- The 'R' monad  -- | The 'R' monad hosts combinators that allow us to describe how to render--- AST.+-- the AST. newtype R a = R (ReaderT RC (State SC) a)   deriving (Functor, Applicative, Monad) @@ -97,7 +101,7 @@     rcIndent :: !Int,     -- | Current layout     rcLayout :: Layout,-    -- | Spans of enclosing elements of AST+    -- | Spans of enclosing elements of the AST     rcEnclosingSpans :: [RealSrcSpan],     -- | Whether the last expression in the layout can use braces     rcCanUseBraces :: Bool,@@ -108,7 +112,9 @@     -- | Module fixity map     rcModuleFixityMap :: ModuleFixityMap,     -- | Whether to print out debug information during printing-    rcDebug :: !(Choice "debug")+    rcDebug :: !(Choice "debug"),+    -- | Source text of the module's Haddocks+    rcHaddockText :: HaddockText   }  -- | State context of 'R'.@@ -119,22 +125,26 @@     scIndent :: !Int,     -- | Rendered source code so far     scBuilder :: Builder,-    -- | Span stream-    scSpanStream :: SpanStream,     -- | Spans of atoms that have been printed on the current line so far     scThisLineSpans :: [RealSrcSpan],-    -- | Comment stream-    scCommentStream :: CommentStream,-    -- | Pending comment lines (in reverse order) to be inserted before next-    -- newline, 'Int' is the indentation level+    -- | Comments that have not been emitted yet, by the element they are+    -- attached to+    scAnchorMap :: AnchorMap,+    -- | Pending comment lines (in reverse order) to be inserted before the+    -- next newline     scPendingComments :: ![(CommentPosition, Text)],     -- | Whether to output a space before the next output     scRequestedDelimiter :: !RequestedDelimiter,-    -- | An auxiliary marker for keeping track of last output element-    scSpanMark :: !(Maybe SpanMark)+    -- | What was emitted last, used both for preserving blank lines from+    -- the input and for recognizing runs of comments+    scLastEmitted :: !LastEmitted,+    -- | Comment placement decisions made so far, in reverse order+    scCommentPlacements :: [CommentPlacement],+    -- | Spans of the elements the printer has entered, in reverse order+    scVisitedSpans :: [RealSrcSpan]   } --- | Make sure next output is delimited by one of the following.+-- | Make sure the next output is delimited by one of the following. data RequestedDelimiter   = -- | A space     RequestedSpace@@ -150,17 +160,17 @@  -- | 'Layout' options. data Layout-  = -- | Put everything on single line+  = -- | Put everything on a single line     SingleLine   | -- | Use multiple lines     MultiLine   deriving (Eq, Show) --- | Modes for rendering of pending comments.+-- | Modes for rendering pending comments. data CommentPosition   = -- | Put the comment on the same line     OnTheSameLine-  | -- | Put the comment on next line+  | -- | Put the comment on the next line     OnNextLine   deriving (Eq, Show) @@ -168,10 +178,8 @@ runR ::   -- | Monad to run   R () ->-  -- | Span stream-  SpanStream ->-  -- | Comment stream-  CommentStream ->+  -- | Comments, attached to the elements they belong to+  AnchorMap ->   -- | Whether the source is a signature or a regular module   SourceType ->   -- | Enabled extensions@@ -180,11 +188,18 @@   ModuleFixityMap ->   -- | Whether to print out debug information during printing   Choice "debug" ->-  -- | Resulting rendition-  Text-runR (R m) sstream cstream sourceType extensions moduleFixityMap debug =-  TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc+  -- | Source text of the module's Haddocks+  HaddockText ->+  -- | The rendition, the comment placement decisions that were made along+  -- the way, and the spans of the elements that were entered+  (Text, [CommentPlacement], [RealSrcSpan])+runR (R m) anchorMap sourceType extensions moduleFixityMap debug haddockText =+  ( TL.toStrict . toLazyText . scBuilder $ finalSc,+    reverse (scCommentPlacements finalSc),+    reverse (scVisitedSpans finalSc)+  )   where+    finalSc = execState (runReaderT m rc) sc     rc =       RC         { rcIndent = 0,@@ -194,19 +209,21 @@           rcExtensions = extensions,           rcSourceType = sourceType,           rcModuleFixityMap = moduleFixityMap,-          rcDebug = debug+          rcDebug = debug,+          rcHaddockText = haddockText         }     sc =       SC         { scColumn = 0,           scIndent = 0,           scBuilder = mempty,-          scSpanStream = sstream,           scThisLineSpans = [],-          scCommentStream = cstream,+          scAnchorMap = anchorMap,           scPendingComments = [],           scRequestedDelimiter = VeryBeginning,-          scSpanMark = Nothing+          scLastEmitted = LastEmittedOther,+          scCommentPlacements = [],+          scVisitedSpans = []         }  ----------------------------------------------------------------------------@@ -217,12 +234,7 @@ data SpitType   = -- | Simple opaque text that breaks comment series.     SimpleText-  | -- | Like 'SimpleText', but assume that when this text is inserted it-    -- will separate an 'Atom' and its pending comments, so insert an extra-    -- 'newline' in that case to force the pending comments and continue on-    -- a fresh line.-    InterferingText-  | -- | An atom that typically have span information in the AST and can+  | -- | An atom that typically has span information in the AST and can     -- have comments attached to it.     Atom   | -- | Used for rendering comment lines.@@ -242,17 +254,9 @@   R () txt = spit SimpleText --- | Similar to 'txt' but the text inserted this way is assumed to break the--- “link” between the preceding atom and its pending comments.-interferingTxt ::-  -- | 'Text' to output-  Text ->-  R ()-interferingTxt = spit InterferingText---- | Output 'Outputable' fragment of AST. This can be used to output numeric--- literals and similar. Everything that doesn't have inner structure but--- does have an 'Outputable' instance.+-- | Output an 'Outputable' fragment of the AST. This can be used to output+-- numeric literals and similar: anything that doesn't have inner structure+-- but does have an 'Outputable' instance. atom ::   (Outputable a) =>   a ->@@ -269,8 +273,6 @@ spit _ "" = return () spit stype text = do   requestedDel <- R (gets scRequestedDelimiter)-  pendingComments <- R (gets scPendingComments)-  when (stype == InterferingText && not (null pendingComments)) newline   case requestedDel of     RequestedNewline -> do       R . modify $ \sc ->@@ -307,12 +309,12 @@                     Just x -> x : xs                   _ -> xs,           scRequestedDelimiter = RequestedNothing,-          scSpanMark =+          scLastEmitted =             -- If there are pending comments, do not reset last comment             -- location.             if (stype == CommentPart) || (not . null . scPendingComments) sc-              then scSpanMark sc-              else Nothing+              then scLastEmitted sc+              else LastEmittedOther         }  -- | This primitive /does not/ necessarily output a space. It just ensures@@ -331,18 +333,25 @@         other -> other     } --- | Output a newline. First time 'newline' is used after some non-'newline'--- output it gets inserted immediately. Second use of 'newline' does not--- output anything but makes sure that the next non-white space output will--- be prefixed by a newline. Using 'newline' more than twice in a row has no--- effect. Also, using 'newline' at the very beginning has no effect, this--- is to avoid leading whitespace.+-- | Output a newline. The first time 'newline' is used after some+-- non-'newline' output, it gets inserted immediately. The second use of+-- 'newline' does not output anything but makes sure that the next+-- non-whitespace output will be prefixed by a newline. Using 'newline' more+-- than twice in a row has no effect. Also, using 'newline' at the very+-- beginning has no effect; this is to avoid leading whitespace. -- -- Similarly to 'space', this design prevents trailing newlines and makes it -- hard to output more than one blank newline in a row. newline :: R () newline = do-  indent <- R (gets scIndent)+  lineIndent <- R (gets scIndent)+  logicalIndent <- R (asks rcIndent)+  -- A trailing comment block spills onto the lines below the code it+  -- trails. Those lines take the indentation of the line the block started+  -- on, unless the construct being printed is indented further, in which+  -- case they follow it: dropping to the start of the line would put the+  -- rest of a block comment outside the declaration it was written in.+  let indent = max lineIndent logicalIndent   cs <- reverse <$> R (gets scPendingComments)   case cs of     [] -> newlineRaw@@ -387,9 +396,9 @@             _ -> AfterNewline         } --- | Insert a newline literal without modifying the internal state of the--- parser. This is to be used exceptionally, e.g. for printing multiline--- string literals.+-- | Insert a literal newline without modifying the internal state of the+-- printer. This is to be used in exceptional cases, e.g. for printing+-- multiline string literals. newlineLiteral :: R () newlineLiteral = R . modify $ \sc ->   sc@@ -421,16 +430,16 @@         { rcIndent = rcIndent rc + step         } --- | Increase indentation level by one indentation step for the inner--- computation. 'inci' should be used when a part of code must be more+-- | Increase the indentation level by one indentation step for the inner+-- computation. 'inci' should be used when a piece of code must be more -- indented relative to the parts outside of 'inci' in order for the output--- to be valid Haskell. When layout is single-line there is no obvious--- effect, but with multi-line layout correct indentation levels matter.+-- to be valid Haskell. With single-line layout there is no visible effect,+-- but with multi-line layout correct indentation levels matter. inci :: R () -> R () inci = inciBy indentStep --- | Set indentation level for the inner computation equal to current--- column. This makes sure that the entire inner block is uniformly+-- | Set the indentation level for the inner computation equal to the+-- current column. This makes sure that the entire inner block is uniformly -- \"shifted\" to the right. sitcc :: R () -> R () sitcc (R m) = do@@ -443,7 +452,7 @@           }   R (local modRC m) --- | Set 'Layout' for internal computation.+-- | Set the 'Layout' for the inner computation. enterLayout :: Layout -> R () -> R () enterLayout l (R m) = R (local modRC m)   where@@ -452,7 +461,7 @@         { rcLayout = l         } --- | Do one or another thing depending on current 'Layout'.+-- | Do one thing or another depending on the current 'Layout'. vlayout ::   -- | Single line   R a ->@@ -465,17 +474,17 @@     SingleLine -> sline     MultiLine -> mline --- | Get current 'Layout'.+-- | Get the current 'Layout'. getLayout :: R Layout getLayout = R (asks rcLayout)  ---------------------------------------------------------------------------- -- Special helpers for comment placement --- | Register a comment line for outputting. It will be inserted right--- before next newline. When the comment goes after something else on the--- same line, a space will be inserted between preceding text and the--- comment when necessary.+-- | Register a comment line for output. It will be inserted right before+-- the next newline. When the comment goes after something else on the same+-- line, a space will be inserted between the preceding text and the comment+-- when necessary. registerPendingCommentLine ::   -- | Comment position   CommentPosition ->@@ -488,52 +497,34 @@       { scPendingComments = (position, text) : scPendingComments sc       } --- | Drop elements that begin before or at the same place as given--- 'SrcSpan'.-trimSpanStream ::-  -- | Reference span-  RealSrcSpan ->-  R ()-trimSpanStream ref = do-  let leRef :: RealSrcSpan -> Bool-      leRef x = realSrcSpanStart x <= realSrcSpanStart ref-  R . modify $ \sc ->-    sc-      { scSpanStream = coerce (dropWhile leRef) (scSpanStream sc)-      }---- | Get location of next element in AST.-nextEltSpan :: R (Maybe RealSrcSpan)-nextEltSpan = listToMaybe . coerce <$> R (gets scSpanStream)+-- | Claim comments from the anchor map, storing what is left.+withAnchorMap :: (AnchorMap -> (a, AnchorMap)) -> R a+withAnchorMap f = R . state $ \sc ->+  let (a, am) = f (scAnchorMap sc)+   in (a, sc {scAnchorMap = am}) --- | Pop a 'Comment' from the 'CommentStream' if given predicate is--- satisfied and there are comments in the stream.-popComment ::-  (LComment -> Bool) ->-  R (Maybe LComment)-popComment f = R $ do-  CommentStream cstream <- gets scCommentStream-  case cstream of-    (x : xs) | f x -> do-      modify $ \sc -> sc {scCommentStream = CommentStream xs}-      return $ Just x-    _ -> return Nothing+-- | Get the comments that will be printed before the element at the given+-- span. Like 'getCommentsAnchoredWithin', this only looks; it does not+-- claim.+getCommentsBefore :: RealSrcSpan -> R [LComment]+getCommentsBefore spn = withAnchorMap (\am -> (commentsBefore spn am, am)) --- | Get the comments contained in the enclosing span.-getEnclosingComments :: R [LComment]-getEnclosingComments = do-  isEnclosed <--    getEnclosingSpan <&> \case-      Just enclSpan -> containsSpan enclSpan-      Nothing -> const False-  CommentStream cstream <- R $ gets scCommentStream-  pure $ takeWhile (isEnclosed . getLoc) cstream+-- | Get the comments attached to the element at the given span, or to+-- anything inside it.+--+-- This only looks; it does not claim. The layout decisions that ask this+-- run before the comments are emitted, and claiming here would leave+-- nothing for the printer to emit later.+getCommentsAnchoredWithin :: RealSrcSpan -> R [LComment]+getCommentsAnchoredWithin region =+  withAnchorMap (\am -> (commentsAnchoredWithin region am, am))  -- | Get the immediately enclosing 'RealSrcSpan'. getEnclosingSpan :: R (Maybe RealSrcSpan) getEnclosingSpan = getEnclosingSpanWhere (const True) --- | Get the first enclosing 'RealSrcSpan' that satisfies given predicate.+-- | Get the first enclosing 'RealSrcSpan' that satisfies the given+-- predicate. getEnclosingSpanWhere ::   -- | Predicate to use   (RealSrcSpan -> Bool) ->@@ -541,7 +532,7 @@ getEnclosingSpanWhere f =   find f <$> R (asks rcEnclosingSpans) --- | Set 'RealSrcSpan' of enclosing span for the given computation.+-- | Set the 'RealSrcSpan' of the enclosing span for the given computation. withEnclosingSpan :: RealSrcSpan -> R () -> R () withEnclosingSpan spn (R m) = R (local modRC m)   where@@ -557,23 +548,44 @@ ---------------------------------------------------------------------------- -- Stateful markers --- | An auxiliary marker for keeping track of last output element.-data SpanMark-  = -- | Haddock comment-    HaddockSpan HaddockStyle RealSrcSpan-  | -- | Non-haddock comment-    CommentSpan RealSrcSpan-  | -- | A statement in a do-block and such span-    StatementSpan RealSrcSpan+-- | What the printer emitted last, and where it came from in the input.+--+-- This is about spacing, not about attachment: it is what lets a blank line+-- in the input be preserved in the output, and what lets a run of comment+-- lines be recognized as one. Statements are tracked for the first of those+-- reasons, Haddocks for the second.+data LastEmitted+  = -- | Nothing yet, or ordinary code+    LastEmittedOther+  | -- | A comment occupying the given span of the input+    LastEmittedComment RealSrcSpan+  | -- | A Haddock occupying the given span of the input+    LastEmittedHaddock RealSrcSpan+  | -- | A statement of a layout block occupying the given span+    LastEmittedStatement RealSrcSpan+  deriving (Eq, Show) --- | Project 'RealSrcSpan' from 'SpanMark'.-spanMarkSpan :: SpanMark -> RealSrcSpan-spanMarkSpan = \case-  HaddockSpan _ s -> s-  CommentSpan s -> s-  StatementSpan s -> s+-- | Where the last emitted thing came from in the input, if it came from+-- anywhere in particular.+lastEmittedSpan :: LastEmitted -> Maybe RealSrcSpan+lastEmittedSpan = \case+  LastEmittedOther -> Nothing+  LastEmittedComment s -> Just s+  LastEmittedHaddock s -> Just s+  LastEmittedStatement s -> Just s --- | Haddock string style.+-- | Record what was emitted last.+setLastEmitted :: LastEmitted -> R ()+setLastEmitted lastEmitted = R . modify $ \sc ->+  sc+    { scLastEmitted = lastEmitted+    }++-- | Report what was emitted last.+getLastEmitted :: R LastEmitted+getLastEmitted = R (gets scLastEmitted)++-- | Haddock string style, i.e. the trigger a Haddock is rendered with. data HaddockStyle   = -- | @-- |@     Pipe@@ -584,19 +596,38 @@   | -- | @-- $@     Named String --- | Set span of last output comment.-setSpanMark ::-  -- | Span mark to set-  SpanMark ->-  R ()-setSpanMark spnMark = R . modify $ \sc ->+-- | The source text of the Haddock at the given span, if it is one of the+-- module's Haddocks. See 'Ormolu.Parser.CommentStream.HaddockText'.+lookupHaddockText :: RealSrcSpan -> R (Maybe Comment)+lookupHaddockText spn = R (asks (M.lookup spn . rcHaddockText))++----------------------------------------------------------------------------+-- Recording comment placement++-- | Record the fact that a comment was rendered in a particular slot.+--+-- Every code path that emits a comment has to call this. What is recorded+-- here is what "Ormolu.Comments.Invariants" checks the input's comments+-- against, so a comment emitted without being recorded is reported as+-- dropped and Ormolu refuses to format the file.+recordCommentPlacement :: CommentPlacement -> R ()+recordCommentPlacement placement = R . modify $ \sc ->   sc-    { scSpanMark = Just spnMark+    { scCommentPlacements = placement : scCommentPlacements sc     } --- | Get span of last output comment.-getSpanMark :: R (Maybe SpanMark)-getSpanMark = R (gets scSpanMark)+-- | Record that the printer entered the element with the given span.+--+-- Not every span in the AST is entered: the printer renders plenty of+-- syntax with 'txt' rather than through 'Ormolu.Printer.Combinators.located',+-- so a @where@ clause, for instance, has a span but is never entered. A+-- comment can only be attached to an element that is entered, because+-- entering it is the only moment at which the comment could be emitted.+recordVisitedSpan :: RealSrcSpan -> R ()+recordVisitedSpan spn = R . modify $ \sc ->+  sc+    { scVisitedSpans = spn : scVisitedSpans sc+    }  ---------------------------------------------------------------------------- -- Helpers for braces

@@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-}  -- | Rendering of commonly useful bits.@@ -12,6 +14,10 @@     p_qualName,     p_infixDefHelper,     p_hsDoc,+    p_hsDocInline,+    multiLineIfDocumented,+    switchLayoutDocumented,+    hasLineHaddocks,     p_hsDocName,     p_sourceText,     p_namespaceSpec,@@ -20,8 +26,12 @@ where  import Control.Monad-import Data.Choice (Choice)+import Data.Choice (Choice, pattern Is, pattern Isn't, pattern With) import Data.Choice qualified as Choice+import Data.Data (Data)+import Data.Generics.Schemes (listify)+import Data.List.NonEmpty qualified as NE+import Data.Text (Text) import Data.Text qualified as T import GHC.Data.FastString import GHC.Hs.Binds@@ -37,6 +47,7 @@ import GHC.Types.SrcLoc import Language.Haskell.Syntax.Module.Name import Ormolu.Config (SourceType (..))+import Ormolu.Parser.CommentStream (Comment, isMultilineComment, unComment) import Ormolu.Printer.Combinators import Ormolu.Utils @@ -47,7 +58,8 @@   | -- | Top-level declarations     Free --- | Outputs the name of the module-like entity, preceded by the correct prefix ("module" or "signature").+-- | Output the name of the module-like entity, preceded by the correct+-- prefix (@module@ or @signature@). p_hsmodName :: ModuleName -> R () p_hsmodName mname = do   sourceType <- askSourceType@@ -90,6 +102,11 @@         NameAnnRArrow {nann_mopen = Just _} -> parens N         -- special case for unboxed unit tuples         NameAnnOnly {nann_adornment = NameParensHash {}} -> const $ txt "(# #)"+        -- An empty list reaches the printer as a name, not as a list, so+        -- this is the only place a comment written between its brackets can+        -- be given something to attach to.+        NameAnnOnly {nann_adornment = NameSquare open _} ->+          const $ brackets N (locatedEmpty (getEpTokenSrcSpan open))         _ -> id        -- When UnboxedSums is enabled, `(#` is a single lexeme, so we have to@@ -109,7 +126,7 @@     Orig _ occName ->       -- This is used when GHC generates code that will be fed into       -- the renamer (e.g. from deriving clauses), but where we want-      -- to say that something comes from given module which is not+      -- to say that something comes from a given module that is not       -- specified in the source code, e.g. @Prelude.map@.       --       -- My current understanding is that the provided module name@@ -126,7 +143,8 @@   txt "."   atom occName --- | A helper for formatting infix constructions in lhs of definitions.+-- | A helper for formatting infix constructions on the left-hand side of+-- definitions. p_infixDefHelper ::   -- | Whether to format in infix style   Choice "infixStyle" ->@@ -162,6 +180,11 @@           sitcc (sep breakpoint sitcc args)  -- | Print a Haddock.+--+-- The author's own text is reused whenever it can be, so a @{- | … -}@+-- comes back as a block comment and an empty @-- |@ survives; see+-- 'haddockAsWritten' for when it cannot be. Otherwise the Haddock is+-- rebuilt from its 'HsDocString'. p_hsDoc ::   -- | Haddock style   HaddockStyle ->@@ -170,37 +193,160 @@   -- | The 'LHsDoc' to render   LHsDoc GhcPs ->   R ()-p_hsDoc hstyle needsNewline (L l str) = do-  let isCommentSpan = \case-        HaddockSpan _ _ -> True-        CommentSpan _ -> True+p_hsDoc hstyle needsNewline = p_hsDocWith hstyle needsNewline (Isn't #mayShareLine)++-- | 'p_hsDoc' for a Haddock inside a construct that may legitimately be laid+-- out on one line.+--+-- A Haddock that comes back out as @{- | … -}@ is self-delimiting, so it+-- ends with a 'breakpoint' rather than a newline and can share the line:+-- @data A = A {- | a number -} Int Bool@ stays as written. One rendered as+-- @--@ lines still ends the line, since it owns the rest of it.+p_hsDocInline :: HaddockStyle -> LHsDoc GhcPs -> R ()+p_hsDocInline hstyle = p_hsDocWith hstyle (With #endNewline) (Is #mayShareLine)++-- | The worker behind 'p_hsDoc' and 'p_hsDocInline'.+p_hsDocWith ::+  HaddockStyle ->+  Choice "endNewline" ->+  Choice "mayShareLine" ->+  LHsDoc GhcPs ->+  R ()+p_hsDocWith hstyle needsNewline mayShareLine (L l str) = do+  let goesAfterCommentOrHaddock = \case+        LastEmittedHaddock _ -> True+        LastEmittedComment _ -> True         _ -> False-  goesAfterComment <- maybe False isCommentSpan <$> getSpanMark+  goesAfterComment <- goesAfterCommentOrHaddock <$> getLastEmitted   -- Make sure the Haddock is separated by a newline from other comments.   when goesAfterComment newline-  let docStringLines = splitDocString $ hsDocString str-  forM_ (zip docStringLines (True : repeat False)) $ \(x, isFirst) -> do-    if isFirst-      then case hstyle of-        Pipe -> txt "-- |"-        Caret -> txt "-- ^"-        Asterisk n -> txt ("-- " <> T.replicate n "*")-        Named name -> p_hsDocName name-      else newline >> txt "--"-    space-    unless (T.null x) (txt x)-  when (Choice.isTrue needsNewline) newline+  -- Print what the author wrote when we still have it. Rebuilding the+  -- comment from the doc string cannot preserve a @{- | … -}@ or an empty+  -- @-- |@, and what it loses it loses from the AST too.+  asWritten <- haddockAsWritten hstyle (L l str)+  case asWritten of+    Just written -> do+      let lns = unComment written+      sitcc . sequence_ . NE.intersperse newline . fmap txt $ lns+    Nothing -> do+      let docStringLines = splitDocString $ hsDocString str+          docPrefix = case hstyle of+            Pipe -> "-- |"+            Caret -> "-- ^"+            Asterisk n -> "-- " <> T.replicate n "*"+            Named name -> hsDocNameText name+      forM_ (zip docStringLines (True : repeat False)) $ \(x, isFirst) -> do+        if isFirst+          then txt docPrefix+          else newline >> txt "--"+        space+        unless (T.null x) (txt x)+  -- A Haddock rendered as @--@ lines owns the rest of its line and has to+  -- end it. One rendered as @{- | … -}@ is self-delimiting, so a space will+  -- do when the surrounding layout is single-line.+  when (Choice.isTrue needsNewline) $+    if Choice.isTrue mayShareLine && maybe False isMultilineComment asWritten+      then breakpoint+      else newline   case l of     UnhelpfulSpan _ ->       -- It's often the case that the comment itself doesn't have a span-      -- attached to it and instead its location can be obtained from+      -- attached to it, and instead its location can be obtained from the       -- nearest enclosing span.-      getEnclosingSpan >>= mapM_ (setSpanMark . HaddockSpan hstyle)-    RealSrcSpan spn _ -> setSpanMark (HaddockSpan hstyle spn)+      getEnclosingSpan >>= mapM_ (setLastEmitted . LastEmittedHaddock)+    RealSrcSpan spn _ -> setLastEmitted (LastEmittedHaddock spn) --- | Print anchor of named doc section.+-- | Lay the computation out on several lines if rendering the given+-- fragment of the syntax tree will emit a Haddock as @--@ lines.+--+-- Such a Haddock takes whole lines: emitted inside a bracketed construct+-- that was put on one line, it swallows the rest of that line, closing+-- bracket and all. The author writes it in front of the construct, so its+-- span is outside the construct's and 'switchLayout' cannot see it; what+-- decides is where it will be /printed/, which is inside. Hence+-- @data A = A deriving (Eq)@ documented on the @Eq@ came out as+-- @deriving (-- \| B@, and a documented field of a one-line record as+-- @{-- \| …@, which does not parse at all.+--+-- A Haddock that comes back out as @{- | … -}@ is self-delimiting and does+-- not force anything, so @data A = A {- | a number -} Int Bool@ is left+-- alone rather than being exploded over five lines.+multiLineIfDocumented :: (Data a) => a -> R () -> R ()+multiLineIfDocumented x m = do+  breaks <- hasLineHaddocks x+  if breaks then enterLayout MultiLine m else m++-- | 'switchLayout', except that the layout is multi-line regardless of the+-- spans when rendering the given fragment will emit a Haddock as @--@+-- lines.+--+-- Use this rather than 'multiLineIfDocumented' around a 'switchLayout': the+-- override has to be applied after the spans have had their say, or it is+-- immediately discarded.+switchLayoutDocumented ::+  (Data a) =>+  -- | Fragment that decides whether documentation will be printed+  a ->+  -- | Span that controls layout otherwise+  [SrcSpan] ->+  -- | Computation to run with changed layout+  R () ->+  R ()+switchLayoutDocumented x spans' =+  switchLayout spans' . multiLineIfDocumented x++-- | Does rendering this fragment emit a Haddock as @--@ lines?+--+-- Every site this is asked about prints its Haddocks in 'Pipe' style, which+-- is what decides whether the author's own text can be reused.+hasLineHaddocks :: (Data a) => a -> R Bool+hasLineHaddocks x = case listify (const True :: LHsDoc GhcPs -> Bool) x of+  -- A doc string that is not reachable as an 'LHsDoc' cannot be inspected,+  -- so assume the worst and break.+  [] -> pure (containsHaddocks x)+  docs -> or <$> traverse rendersAsLines docs+  where+    rendersAsLines doc =+      maybe True (not . isMultilineComment) <$> haddockAsWritten Pipe doc++-- | The author's own text for a Haddock, when it can be reused.+--+-- 'Nothing' means the Haddock has to be rebuilt from its 'HsDocString' as+-- @--@ lines: either its text was not kept, or it is about to be rendered+-- in a different style than it was written in. Ormolu moves a trailing+-- @-- ^ X@ in front of what it documents and writes it as @-- | X@, and+-- keeping the author's text there would leave a @^@ pointing at the wrong+-- thing.+haddockAsWritten :: HaddockStyle -> LHsDoc GhcPs -> R (Maybe Comment)+haddockAsWritten hstyle (L l _) = do+  asWritten <- maybe (pure Nothing) lookupHaddockText (srcSpanToRealSrcSpan l)+  pure (mfilter (writtenAs hstyle . NE.head . unComment) asWritten)++-- | Was the Haddock written in the style it is about to be rendered in?+writtenAs :: HaddockStyle -> Text -> Bool+writtenAs hstyle firstLine =+  case T.stripPrefix "--" opener of+    Just rest -> hasTrigger (T.stripStart rest)+    Nothing -> maybe False (hasTrigger . T.stripStart) (T.stripPrefix "{-" opener)+  where+    opener = T.stripStart firstLine+    hasTrigger t = case hstyle of+      Pipe -> "|" `T.isPrefixOf` t+      Caret -> "^" `T.isPrefixOf` t+      Asterisk n ->+        T.replicate n "*" `T.isPrefixOf` t+          && not (T.replicate (n + 1) "*" `T.isPrefixOf` t)+      Named name -> ("$" <> T.pack name) `T.isPrefixOf` t++-- | Print the anchor of a named doc section. Unlike 'p_hsDoc' this is a+-- bare anchor with no doc string attached, so there is no span to report. p_hsDocName :: String -> R ()-p_hsDocName name = txt ("-- $" <> T.pack name)+p_hsDocName name = do+  txt (hsDocNameText name)++-- | Render the anchor of a named doc section.+hsDocNameText :: String -> Text+hsDocNameText name = "-- $" <> T.pack name  p_sourceText :: SourceText -> R () p_sourceText = \case

@@ -49,11 +49,12 @@ p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R () p_hsDecls = p_hsDecls' Disregard --- | Like 'p_hsDecls' but respects user choices regarding grouping. If the+-- | Like 'p_hsDecls', but respects user choices regarding grouping. If the -- user omits newlines between declarations, we also omit them in most--- cases, except when said declarations have associated Haddocks.+-- cases, except when the declarations in question have associated Haddocks. ----- Does some normalization (compress subsequent newlines into a single one)+-- Does some normalization (compresses consecutive newlines into a single+-- one). p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R () p_hsDeclsRespectGrouping = p_hsDecls' Respect @@ -70,7 +71,7 @@     renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)     renderGroupWithPrev prev curr =       -- We can omit a blank line when the user didn't add one, but we must-      -- ensure we always add blank lines around documented declarations+      -- ensure we always add blank lines around documented declarations.       case grouping of         Disregard ->           breakpoint : renderGroup curr@@ -98,8 +99,8 @@   [NonEmpty (LHsDecl GhcPs)] groupDecls _ [] = [] groupDecls isSig (l@(L _ DocNext) : xs) =-  -- If the first element is a doc string for next element, just include it-  -- in the next block:+  -- If the first element is a doc string for the next element, just include+  -- it in the next block:   case groupDecls isSig xs of     [] -> [l :| []]     (x : xs') -> (l <| x) : xs'@@ -165,7 +166,7 @@   TyFamInstD _ x -> p_tyFamInstDecl style x   DataFamInstD _ x -> p_dataFamInstDecl style x --- | Determine if these declarations should be grouped together.+-- | Determine whether these declarations should be grouped together. groupedDecls ::   LHsDecl GhcPs ->   LHsDecl GhcPs ->@@ -193,14 +194,15 @@     (KindSignature n, ClassDeclaration n') -> n == n'     (KindSignature n, FamilyDeclaration n') -> n == n'     (KindSignature n, TypeSynonym n') -> n == n'-    -- Special case for TH splices, we look at locations+    -- Special case for TH splices: we look at locations.     (Splice, Splice) -> not (separatedByBlank id l_x l_y)-    -- This looks only at Haddocks, normal comments are handled elsewhere+    -- This looks only at Haddocks; normal comments are handled elsewhere.     (DocNext, _) -> True     (_, DocPrev) -> True     _ -> False --- | Detect declaration series that should not have blanks between them.+-- | Detect a series of declarations that should not have blanks between+-- them. declSeries ::   LHsDecl GhcPs ->   LHsDecl GhcPs ->@@ -235,12 +237,12 @@   WarningPragma n -> Just n   _ -> Nothing --- Declarations that do not refer to names+-- Declarations that do not refer to names.  pattern Splice :: HsDecl GhcPs pattern Splice <- SpliceD _ (SpliceDecl _ _ _) --- Declarations referring to a single name+-- Declarations referring to a single name.  pattern   InlinePragma,@@ -273,7 +275,7 @@   SpecSigE _ _ (deconstructExprFromSpecSigE -> (L _ n, _, _)) _ -> Just n   _ -> Nothing --- Declarations which can refer to multiple names+-- Declarations that can refer to multiple names.  pattern   TypeSignature,

@@ -74,7 +74,7 @@         breakpoint         txt "where"   unless (null allDecls) $ do-    breakpoint -- Ensure whitespace is added after where clause.+    breakpoint -- Ensure whitespace is added after the where clause.     inci (p_hsDeclsRespectGrouping Associated allDecls)  p_classContext :: LHsContext GhcPs -> R ()

@@ -7,7 +7,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} --- | Renedring of data type declarations.+-- | Rendering of data type declarations. module Ormolu.Printer.Meat.Declaration.Data   ( p_dataDecl,   )@@ -18,7 +18,7 @@ import Data.Choice qualified as Choice import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE-import Data.Maybe (isJust, isNothing, maybeToList)+import Data.Maybe (isJust, isNothing, mapMaybe, maybeToList) import GHC.Hs import GHC.Types.Fixity import GHC.Types.ForeignCall@@ -110,21 +110,25 @@               conDeclConsSpans = \case                 ConDeclGADT {..} -> getLocA <$> con_names                 ConDeclH98 {..} -> getLocA con_name :| []-          if hasHaddocks dd_cons'+          -- A constructor documented with @--@ lines cannot share a line+          -- with anything. One documented with @{- | … -}@ can, so it is+          -- laid out as though it were undocumented.+          lineHaddocks <- consHaveLineHaddocks dd_cons'+          if lineHaddocks             then newline             else               if Choice.isTrue singleRecCon && compactLayoutAroundEquals                 then space                 else breakpoint-          equals+          txt "="           space           layout <- getLayout           let s =-                if layout == MultiLine || hasHaddocks dd_cons'+                if layout == MultiLine || lineHaddocks                   then newline >> txt "|" >> space                   else space >> txt "|" >> space               sitcc' =-                if hasHaddocks dd_cons' || Choice.isFalse singleRecCon+                if lineHaddocks || Choice.isFalse singleRecCon                   then sitcc                   else id           sep s (sitcc' . located' (p_conDecl singleRecCon)) dd_cons'@@ -134,7 +138,7 @@ p_conDecl :: Choice "singleRecCon" -> ConDecl GhcPs -> R () p_conDecl _ ConDeclGADT {..} = do   mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc-  switchLayout conDeclSpn $ do+  switchLayoutDocumented documented conDeclSpn $ do     let c :| cs = con_names     p_rdrName c     unless (null cs) . inci $ do@@ -142,21 +146,21 @@       sep commaDel p_rdrName cs     space     txt "::"-    delimiter-    inci . switchLayout conSigSpans $ do+    breakpoint+    inci . switchLayoutDocumented documented conSigSpans $ do       located con_outer_bndrs p_hsOuterTyVarBndrs       case unLoc con_outer_bndrs of         HsOuterImplicit {} -> pure ()-        HsOuterExplicit {} -> delimiter+        HsOuterExplicit {} -> breakpoint       forM_ con_inner_bndrs $ \tele -> do         p_hsForAllTelescope tele-        delimiter+        breakpoint       forM_ con_mb_cxt $ \qs -> do         located qs p_hsContext         space         txt "=>"-        delimiter-      switchLayout conArgResSpans $ do+        breakpoint+      switchLayoutDocumented documented conArgResSpans $ do         case con_g_args of           PrefixConGADT NoExtField xs ->             forM_ xs $ \x -> do@@ -165,19 +169,17 @@               p_hsMultAnn (located' p_hsType) (cdf_multiplicity x)               space               txt "->"-              delimiter+              breakpoint           RecConGADT _ x -> do             located x p_hsConDeclRecFields             space             txt "->"-            delimiter+            breakpoint         located con_res_ty p_hsType   where-    delimiter = if anyDocStrings then newline else breakpoint-    anyDocStrings =-      hasDocStrings (unLoc con_res_ty) || case con_g_args of-        PrefixConGADT _ xs -> conArgsHaveHaddocks xs-        RecConGADT _ (L _ xs) -> conArgsHaveHaddocks $ cdrf_spec . unLoc <$> xs+    -- Every part of the signature shares one layout decision, so any+    -- Haddock in any of them puts the whole of it on several lines.+    documented = (con_g_args, con_res_ty)      conDeclSpn =       fmap getLocA (NE.toList con_names) <> conSigSpans@@ -194,13 +196,11 @@     PrefixCon xs -> do       renderConDoc       renderContext-      switchLayout conDeclSpn $ do+      switchLayoutDocumented xs conDeclSpn $ do         p_rdrName con_name-        let argsHaveDocs = conArgsHaveHaddocks xs-            delimiter = if argsHaveDocs then newline else breakpoint-        unless (null xs) delimiter+        unless (null xs) breakpoint         inci . sitcc $-          sep delimiter (sitcc . p_hsConDeclFieldWithDoc) xs+          sep breakpoint (sitcc . p_hsConDeclFieldWithDoc) xs     RecCon l -> do       renderConDoc       renderContext@@ -209,18 +209,19 @@         breakpoint         inciIf (Choice.isFalse singleRecCon) (located l p_hsConDeclRecFields)     InfixCon l r -> do-      -- manually render these+      -- Render these manually.       let larg_doc = cdf_doc l           rarg_doc = cdf_doc r -      -- the constructor haddock can go on top of the entire constructor-      -- only if neither argument has haddocks+      -- The constructor Haddock can go on top of the entire constructor+      -- only if neither argument has Haddocks.       let putConDocOnTop = isNothing larg_doc && isNothing rarg_doc        when putConDocOnTop renderConDoc       renderContext       switchLayout conDeclSpn $ do-        -- the left arg haddock can use pipe only if the infix constructor has docs+        -- The left arg Haddock can use pipe style only if the infix+        -- constructor has docs.         if isJust con_doc           then do             mapM_ (p_hsDoc Pipe (With #endNewline)) larg_doc@@ -278,16 +279,17 @@ p_hsDerivingClause ::   HsDerivingClause GhcPs ->   R ()-p_hsDerivingClause HsDerivingClause {..} = do+p_hsDerivingClause HsDerivingClause {..} = multiLineIfDocumented deriv_clause_tys $ do   txt "deriving"-  let derivingWhat = located deriv_clause_tys $ \case-        DctSingle NoExtField sigTy -> parens N $ located sigTy p_hsSigType-        DctMulti NoExtField sigTys ->-          parens N $-            sep-              commaDel-              (sitcc . located' p_hsSigType)-              sigTys+  let derivingWhat = located deriv_clause_tys $ \tys ->+        multiLineIfDocumented tys $ case tys of+          DctSingle NoExtField sigTy -> parens N $ located sigTy p_hsSigType+          DctMulti NoExtField sigTys ->+            parens N $+              sep+                commaDel+                (sitcc . located' p_hsSigType)+                sigTys   space   case deriv_clause_strategy of     Nothing -> do@@ -318,19 +320,24 @@ ---------------------------------------------------------------------------- -- Helpers +-- | Do any of these constructors print a Haddock as @--@ lines where it+-- would share a line with the rest of the declaration?+--+-- Only the constructor's own Haddock and the docs on its prefix arguments+-- count. A record constructor lays its fields out over several lines+-- anyway, so documenting one of them says nothing about how the @=@ and the+-- constructor name should be arranged.+consHaveLineHaddocks :: [LConDecl GhcPs] -> R Bool+consHaveLineHaddocks = fmap or . traverse (f . unLoc)+  where+    f ConDeclH98 {..} =+      hasLineHaddocks $+        maybeToList con_doc <> case con_args of+          PrefixCon xs -> mapMaybe cdf_doc xs+          _ -> []+    f _ = pure False+ isInfix :: LexicalFixity -> Bool isInfix = \case   Infix -> True   Prefix -> False--hasHaddocks :: [LConDecl GhcPs] -> Bool-hasHaddocks = any (f . unLoc)-  where-    f ConDeclH98 {..} =-      isJust con_doc || case con_args of-        PrefixCon xs -> conArgsHaveHaddocks xs-        _ -> False-    f _ = False--conArgsHaveHaddocks :: [HsConDeclField GhcPs] -> Bool-conArgsHaveHaddocks = any (isJust . cdf_doc)

@@ -25,8 +25,8 @@     p_foreignExport fd_fe     p_foreignTypeSig fd --- | Printer for the last part of an import\/export, which is function name--- and type signature.+-- | Printer for the last part of an import\/export, which is the function+-- name and type signature. p_foreignTypeSig :: ForeignDecl GhcPs -> R () p_foreignTypeSig fd = do   breakpoint@@ -45,18 +45,18 @@ -- -- > foreign import callingConvention [safety] [identifier] ----- We need to check whether the safety has a good source, span, as it+-- We need to check whether the safety has a good source span, as it -- defaults to 'PlaySafe' if you don't have anything in the source. ----- We also layout the identifier using the 'SourceText', because printing--- with the other two fields of 'CImport' is very complicated. See the+-- We also lay out the identifier using the 'SourceText', because printing+-- it from the other two fields of 'CImport' is very complicated. See the -- 'Outputable' instance of 'ForeignImport' for details. p_foreignImport :: ForeignImport GhcPs -> R () p_foreignImport (CImport sourceText cCallConv safety _ _) = do   txt "foreign import"   space   located cCallConv atom-  -- Need to check for 'noLoc' for the 'safe' annotation+  -- Need to check for 'noLoc' for the 'safe' annotation.   when (isGoodSrcSpan $ getLocA safety) (space >> atom safety)   inci $ located sourceText $ \case     NoSourceText -> pure ()

@@ -89,7 +89,7 @@         breakpoint         txt "where"   unless (null allDecls) . inci $ do-    -- Ensure whitespace is added after where clause.+    -- Ensure whitespace is added after the where clause.     breakpoint     dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls 

@@ -22,6 +22,7 @@ import GHC.Types.Name (occNameString) import GHC.Types.Name.Reader (RdrName, rdrNameOcc) import GHC.Types.SrcLoc+import Ormolu.Parser.CommentStream (LComment) import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common (p_rdrName) import Ormolu.Printer.Meat.Declaration.Value@@ -46,20 +47,20 @@ getOpNameStr :: RdrName -> String getOpNameStr = occNameString . rdrNameOcc --- | Decide if the operands of an operator chain should be hanging.+-- | Decide whether the operands of an operator chain should be hanging. opBranchPlacement ::   (HasLoc l) =>   -- | Placer function for nodes   (ty -> Placement) ->-  -- | first expression of the chain+  -- | First expression of the chain   OpTree (GenLocated l ty) op ->-  -- | last expression of the chain+  -- | Last expression of the chain   OpTree (GenLocated l ty) op ->   Placement opBranchPlacement placer firstExpr lastExpr-  -- If the beginning of the first argument and the last argument starts on-  -- the same line, and the second argument has a hanging form, use hanging-  -- placement.+  -- If the start of the first argument and the start of the last argument+  -- are on the same line, and the last argument has a hanging form, use+  -- hanging placement.   | isOneLineSpan       ( mkSrcSpan           (srcSpanStart (opTreeLoc firstExpr))@@ -69,7 +70,7 @@       placer n   | otherwise = Normal --- | Decide whether to use braces or not based on the layout and placement+-- | Decide whether or not to use braces based on the layout and placement -- of an expression in an infix operator application. opBranchBraceStyle :: Placement -> R (R () -> R ()) opBranchBraceStyle placement =@@ -112,17 +113,18 @@       -- Whether we could place the operator in a trailing position,       -- followed by a breakpoint before the RHS       couldBeTrailing (prevExpr, opi) =-        -- An operator with fixity InfixR 0, like seq, $, and $ variants,-        -- is required+        -- An operator with fixity InfixR 0, like seq, $, and the $ variants,+        -- is required.         isHardSplitterOp (opiFixityApproximation opi)-          -- the LHS must be single-line+          -- The LHS must be single-line.           && isOneLineSpan (opTreeLoc prevExpr)-          -- can only happen when a breakpoint would have been added anyway+          -- This can only happen when a breakpoint would have been added+          -- anyway.           && placement == Normal-          -- if the node just on the left of the operator (so the rightmost-          -- node of the subtree prevExpr) is a do-block, then we cannot-          -- place the operator in a trailing position (because it would be-          -- read as being part of the do-block)+          -- If the node just to the left of the operator (that is, the+          -- rightmost node of the subtree prevExpr) is a do-block, then we+          -- cannot place the operator in a trailing position, because it+          -- would be read as being part of the do-block.           && not (isDoBlock $ rightMostNode prevExpr)       -- A staircase of two or more trailing operators is only worthwhile when       -- the operand at the very end of the chain has a hanging form (a do@@ -139,11 +141,19 @@       isSingleOperator = case ops of         [_] -> True         _ -> False-      -- If all operators at the current level match the conditions to be-      -- trailing, and the chain is either a single operator or ends in a-      -- hanging form, then put the operators in a trailing position.-      isTrailing =+  -- A comment written on its own line in front of an operator forces the+  -- operator onto a line of its own. In trailing position that line starts+  -- at the indentation of the statement, and @$@ at the start of a line in+  -- a @do@ block is read as a new statement rather than as a continuation.+  -- The leading layout indents instead, so it keeps the meaning.+  opsAreCommented <-+    or <$> traverse (fmap (not . null) . leadingComments . opiOp) ops+  -- If all operators at the current level match the conditions to be+  -- trailing, and the chain is either a single operator or ends in a+  -- hanging form, then put the operators in a trailing position.+  let isTrailing =         (isSingleOperator || chainEndsInHangingForm)+          && not opsAreCommented           && all couldBeTrailing (zip (NE.toList exprs) ops)   ub <- if isTrailing then return useBraces else opBranchBraceStyle placement   let p_x = ub $ p_exprOpTree s firstExpr@@ -178,6 +188,12 @@     p_x     putOpsExprs firstExpr ops otherExprs +-- | The comments that will be printed in front of a located thing.+leadingComments :: (HasLoc l) => GenLocated l a -> R [LComment]+leadingComments (L l _) = case locA l of+  RealSrcSpan spn _ -> getCommentsBefore spn+  _ -> pure []+ -- | Convert a 'LHsCmdTop' containing an operator tree to the 'OpTree' -- intermediate representation. cmdOpTree :: LHsCmdTop GhcPs -> OpTree (LHsCmdTop GhcPs) (LHsExpr GhcPs)@@ -217,14 +233,14 @@     p_x     putOpsExprs ops otherExprs --- | Check if given expression has a hanging form. Added for symmetry with--- exprPlacement and cmdTopPlacement, which are all used in p_xxxOpTree--- functions with opBranchPlacement.+-- | Check whether the given expression has a hanging form. Added for+-- symmetry with 'exprPlacement' and 'cmdTopPlacement', all of which are used+-- in the @p_xxxOpTree@ functions together with 'opBranchPlacement'. tyOpPlacement :: HsType GhcPs -> Placement tyOpPlacement = \case   _ -> Normal --- | Convert a LHsType containing an operator tree to the 'OpTree'+-- | Convert an 'LHsType' containing an operator tree to the 'OpTree' -- intermediate representation. tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName) tyOpTree (L _ (HsOpTy _ _ l op r)) =

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} --- | Rendering of Role annotation declarations.+-- | Rendering of role annotation declarations. module Ormolu.Printer.Meat.Declaration.RoleAnnotation   ( p_roleAnnot,   )

@@ -32,7 +32,7 @@   inci $ do     located lhs p_hsExpr     space-    equals+    txt "="     inci $ do       breakpoint       located rhs p_hsExpr

@@ -174,9 +174,9 @@   where     (_, specExpr, sigTy) = deconstructExprFromSpecSigE expr --- | The 'LHsExpr' in a 'SpecSigE' can only be of a very specific form, namely a--- variable applied to value/type-level arguments, optionally with a type--- signature.+-- | The 'LHsExpr' in a 'SpecSigE' can only be of a very specific form,+-- namely a variable applied to value/type-level arguments, optionally with a+-- type signature. -- -- https://github.com/ghc-proposals/ghc-proposals/blob/e2c683698323cec3e33625369ae2b5f585387c70/proposals/0493-specialise-expressions.rst#2proposed-change-specification deconstructExprFromSpecSigE ::

@@ -18,8 +18,8 @@ import Ormolu.Printer.Combinators import Ormolu.Utils --- | Print the source text of a string literal while indenting gaps and newlines--- correctly.+-- | Print the source text of a string literal while indenting gaps and+-- newlines correctly. p_stringLit :: FastString -> R () p_stringLit src = case parseStringLiteral $ T.pack $ unpackFS src of   Nothing -> error $ "Internal Ormolu error: couldn't parse string literal: " <> show src@@ -43,9 +43,9 @@         sep newlineLiteral txt segments     txt endMarker --- | The start/end marker of the literal, whether it is a regular or a multiline--- literal, and the segments of the literals (separated by gaps for a regular--- literal, and separated by newlines for a multiline literal).+-- | The start/end marker of the literal, whether it is a regular or a+-- multiline literal, and the segments of the literal (separated by gaps for+-- a regular literal, and separated by newlines for a multiline literal). data ParsedStringLiteral = ParsedStringLiteral   { startMarker, endMarker :: Text,     stringLiteralKind :: StringLiteralKind,@@ -57,9 +57,9 @@ data StringLiteralKind = RegularStringLiteral | MultilineStringLiteral   deriving stock (Show, Eq) --- | Turn a string literal (as it exists in the source) into a more structured--- form for printing. This should never return 'Nothing' for literals that the--- GHC parser accepted.+-- | Turn a string literal (as it exists in the source) into a more+-- structured form for printing. This should never return 'Nothing' for+-- literals that the GHC parser accepted. parseStringLiteral :: Text -> Maybe ParsedStringLiteral parseStringLiteral = \s -> do   psl <-@@ -83,7 +83,7 @@           <|> ((marker,) <$> T.stripSuffix marker suffix)       pure ParsedStringLiteral {segments = [infix_], ..} -    -- Split a string on gaps (backslash delimited whitespaces).+    -- Split a string on gaps (backslash-delimited whitespace).     --     -- > splitGaps "bar\\  \\fo\\&o" == ["bar", "fo\\&o"]     splitGaps :: Text -> [Text]@@ -93,14 +93,14 @@         go ((pre, suf) : bs) = case T.uncons suf of           Just ('\\', suf')             | (gap, T.uncons -> Just ('\\', rest)) <- T.span is_space suf',-              -- If there is a space after the backslash, this definitely is a+              -- If there is a space after the backslash, this is definitely a               -- string gap. Continue parsing gaps after the next backslash.               not $ T.null gap ->                 pre : splitGaps rest             | otherwise ->-                -- Check whether @suf@ starts with an escape sequence involving-                -- another backslash. If so, it can not be the start of a string-                -- gap, so we skip it.+                -- Check whether @suf@ starts with an escape sequence+                -- involving another backslash. If so, it cannot be the start+                -- of a string gap, so we skip it.                 let skipNextBackslash =                       any (`T.isPrefixOf` suf') escapesWithAnotherBackslash                  in go $ (if skipNextBackslash then drop 1 else id) bs@@ -111,14 +111,14 @@         -- https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6         escapesWithAnotherBackslash = ["\\", "^\\"] -    -- See the the MultilineStrings GHC proposal and 'lexMultilineString' from+    -- See the MultilineStrings GHC proposal and 'lexMultilineString' from     -- "GHC.Parser.String" for reference.     --     -- https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0569-multiline-strings.rst#proposed-change-specification     splitMultilineString :: Text -> [Text]     splitMultilineString =       splitGaps-        -- There is no reason to use gaps with multiline string literals just to+        -- There is no reason to use gaps in multiline string literals just to         -- emulate multi-line strings, so we replace them with "\\ \\".         >>> intercalateMinimalStringGaps         >>> splitNewlines@@ -144,8 +144,8 @@              in pre : T.replicate fill " " : go (col' + fill) suf           _ -> [s] -    -- Don't touch the first line, and remove common whitespace from all-    -- remaining lines as well as convert those consisting only of whitespace to+    -- Don't touch the first line; remove common whitespace from all+    -- remaining lines, and convert those consisting only of whitespace into     -- empty lines.     rmCommonWhitespacePrefixAndBlank :: [Text] -> [Text]     rmCommonWhitespacePrefixAndBlank = \case

@@ -45,7 +45,7 @@       (map (located' p_hsTyVarBndr) hsq_explicit)   inci $ do     space-    equals+    txt "="     if hasDocStrings (unLoc t)       then newline       else breakpoint

@@ -72,7 +72,7 @@     breakpoint     located k p_hsType   TyVarSig NoExtField bndr -> Just $ do-    equals+    txt "="     breakpoint     located bndr p_hsTyVarBndr @@ -106,7 +106,7 @@         (p_lhsTypeArg <$> feqn_pats)     inci $ do       space-      equals+      txt "="       breakpoint       located feqn_rhs p_hsType 

@@ -97,7 +97,7 @@   R () p_matchGroup' placer render style mg@MG {..} = do   -- Since we are forcing braces on 'sepSemi' based on 'ob', we have to-  -- restore the brace state inside the sepsemi.+  -- restore the brace state inside the 'sepSemi'.   ub <- bool dontUseBraces useBraces <$> canUseBraces   let ob = case style of         Case -> bracesIfNecessary@@ -119,12 +119,12 @@         (unLoc m_pats)         m_grhss --- | Function id obtained through pattern matching on 'FunBind' should not--- be used to print the actual equations because the different ‘RdrNames’--- used in the equations may have different “decorations” (such as backticks--- and parentheses) associated with them. It is necessary to use per-equation--- names obtained from 'm_ctxt' of 'Match'. This function replaces function--- name inside of 'Function' accordingly.+-- | The function id obtained through pattern matching on 'FunBind' should+-- not be used to print the actual equations, because the different+-- ‘RdrNames’ used in the equations may have different “decorations” (such as+-- backticks and parentheses) associated with them. It is necessary to use+-- the per-equation names obtained from the 'm_ctxt' of a 'Match'. This+-- function replaces the function name inside 'Function' accordingly. adjustMatchGroupStyle ::   Match GhcPs body ->   MatchGroupStyle ->@@ -175,12 +175,12 @@   R () p_match' placer render style isInfix multAnn strictness m_pats GRHSs {..} = do   -- Normally, since patterns may be placed in a multi-line layout, it is-  -- necessary to bump indentation for the pattern group so it's more-  -- indented than function name. This in turn means that indentation for+  -- necessary to bump indentation for the pattern group so that it's more+  -- indented than the function name. This in turn means that indentation for   -- the body should also be bumped. Normally this would mean that bodies   -- would start with two indentation steps applied, which is ugly, so we-  -- need to be a bit more clever here and bump indentation level only when-  -- pattern group is multiline.+  -- need to be a bit more clever here and bump the indentation level only+  -- when the pattern group is multiline.   p_hsMultAnn (located' p_hsType) multAnn   case multAnn of     HsUnannotated {} -> pure ()@@ -239,8 +239,9 @@               -- lines, we have to indent all but the first pattern.               inci $ sep breakpoint (located' p_pat) tail_pats       return indentBody-  let -- Calculate position of end of patterns. This is useful when we decide-      -- about putting certain constructions in hanging positions.+  let -- Calculate the position of the end of the patterns. This is useful+      -- when we decide whether to put certain constructions in hanging+      -- positions.       endOfPats = case NE.nonEmpty m_pats of         Nothing -> case style of           Function name -> Just (getLocA name)@@ -292,9 +293,9 @@     unless (length grhssGRHSs > 1) $       case style of         Function _ | hasGuards -> return ()-        Function _ -> space >> inci equals+        Function _ -> space >> inci (txt "=")         PatternBind | hasGuards -> return ()-        PatternBind -> space >> inci equals+        PatternBind -> space >> inci (txt "=")         s | isCase s && hasGuards -> return ()         _ -> space >> txt "->"     switchLayout [patGrhssSpan] $@@ -323,7 +324,7 @@       sitcc (sep commaDel (sitcc . located' p_stmt) xs)       space       inci $ case style of-        EqualSign -> equals+        EqualSign -> txt "="         RightArrow -> txt "->"       -- If we have a sequence of guards and it is placed in the normal way,       -- then we indent one level more for readability. Otherwise (all@@ -406,23 +407,22 @@   case getLocA l of     UnhelpfulSpan _ -> f x     RealSrcSpan currentSpn _ -> do-      getSpanMark >>= \case-        -- We deal with blank lines between statements here. The last mark-        -- may be a 'StatementSpan' (the usual case) or a comment span: the+      (lastEmittedSpan <$> getLastEmitted) >>= \case+        -- We deal with blank lines between statements here. The last thing+        -- emitted may be a statement (the usual case) or a comment: the         -- latter happens when the previous statement ended with a trailing         -- comment, in which case we still want to preserve a blank line that         -- followed that comment in the original input.-        Just lastMark ->-          let lastSpn = spanMarkSpan lastMark-           in when (srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1) newline+        Just lastSpn ->+          when (srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1) newline         Nothing -> return ()       f x-      -- In some cases the (f x) expression may insert a new mark. We want-      -- to be careful not to override comment marks.-      getSpanMark >>= \case-        Just (HaddockSpan _ _) -> return ()-        Just (CommentSpan _) -> return ()-        _ -> setSpanMark (StatementSpan currentSpn)+      -- In some cases the (f x) expression may record something else. We+      -- want to be careful not to override comments.+      getLastEmitted >>= \case+        LastEmittedHaddock _ -> return ()+        LastEmittedComment _ -> return ()+        _ -> setLastEmitted (LastEmittedStatement currentSpn)  p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R () p_stmt = p_stmt' N exprPlacement (p_hsExpr' NotApplicand)@@ -458,13 +458,13 @@     space     sitcc $ p_hsLocalBinds binds   ParStmt {} ->-    -- 'ParStmt' should always be eliminated in 'gatherStmts' already, such+    -- 'ParStmt' should always be eliminated in 'gatherStmts' already, so     -- that it never occurs in 'p_stmt''. Consequently, handling it here     -- would be redundant.     notImplemented "ParStmt"   TransStmt {..} ->-    -- 'TransStmt' only needs to account for render printing itself, since-    -- pretty printing of relevant statements (e.g., in 'trS_stmts') is+    -- 'TransStmt' only needs to account for printing itself, since+    -- pretty-printing of the relevant statements (e.g. in 'trS_stmts') is     -- handled through 'gatherStmts'.     case (trS_form, trS_by) of       (ThenForm, Nothing) -> do@@ -517,7 +517,7 @@         ub' $ withSpacing (p_stmt' s placer render) stmt         where           -- We need to set brace usage information for all but the last-          -- statement (e.g.in the case of nested do blocks).+          -- statement (e.g. in the case of nested do blocks).           ub' = case relPos of             FirstPos -> ub             MiddlePos -> ub@@ -530,8 +530,8 @@ p_hsLocalBinds = \case   HsValBinds epAnn (ValBinds _ binds lsigs) -> pseudoLocated epAnn $ do     -- When in a single-line layout, there is a chance that the inner-    -- elements will also contain semicolons and they will confuse the-    -- parser. so we request braces around every element except the last.+    -- elements will also contain semicolons that will confuse the parser,+    -- so we request braces around every element except the last.     br <- layoutToBraces <$> getLayout     let items =           let injectLeft (L l x) = L l (Left x)@@ -552,18 +552,18 @@     let p_ipBind (IPBind _ (L _ name) expr) = do           atom @HsIPName name           space-          equals+          txt "="           breakpoint           useBraces $ inci $ located expr p_hsExpr     sepSemi (located' p_ipBind) xs   EmptyLocalBinds _ -> return ()   where-    -- HsLocalBinds is no longer wrapped in a Located (see call sites-    -- of p_hsLocalBinds). Hence, we introduce a manual Located as we-    -- depend on the layout being correctly set.+    -- HsLocalBinds is no longer wrapped in a Located (see the call sites+    -- of p_hsLocalBinds). Hence, we introduce a manual Located, as we+    -- depend on the layout being set correctly.     pseudoLocated = \case       EpAnn {anns = AnnList {al_anchor}}-        | -- excluding cases where there are no bindings+        | -- Excluding cases where there are no bindings.           not $ isZeroWidthSpan (locA al_anchor) ->             located (L al_anchor ()) . const       _ -> id@@ -587,7 +587,7 @@   p_lhs hfbLHS   unless hfbPun $ do     space-    equals+    txt "="     let placement =           if onTheSameLine (getLocA hfbLHS) (getLocA hfbRHS)             then exprPlacement (unLoc hfbRHS)@@ -597,8 +597,9 @@ p_hsExpr :: HsExpr GhcPs -> R () p_hsExpr = p_hsExpr' NotApplicand N --- | An applicand is the left-hand side in a function application, i.e. @f@ in--- @f a@. We need to track this in order to add extra indentation in cases like+-- | An applicand is the left-hand side of a function application, i.e. @f@+-- in @f a@. We need to track this in order to add extra indentation in cases+-- like -- -- > foo = -- >   do@@ -611,7 +612,7 @@   Applicand -> inci . inci   NotApplicand -> inci --- | Adjust bracing as needed for certain cases e.g. involving case+-- | Adjust bracing as needed for certain cases, e.g. those involving case -- expressions and lambdas. adjustBracing :: IsApplicand -> BracketStyle -> R () -> R () adjustBracing isApp s p = do@@ -640,7 +641,7 @@     p_lam isApp s variant exprPlacement p_hsExpr mgroup   HsApp _ f x -> do     let -- In order to format function applications with multiple parameters-        -- nicer, traverse the AST to gather the function and all the+        -- more nicely, traverse the AST to gather the function and all the         -- parameters together.         gatherArgs f' knownArgs =           case f' of@@ -661,8 +662,7 @@             else Normal     -- If the last argument is not hanging, just separate every argument as     -- usual. If it is hanging, print the initial arguments and hang the-    -- last one. Also, use braces around the every argument except the last-    -- one.+    -- last one. Also, use braces around every argument except the last one.     case placement of       Normal -> do         ub <-@@ -704,13 +704,11 @@           _ -> False     txt "-"     -- If NegativeLiterals is enabled, we have to insert a space before-    -- negated literals, as `- 1` and `-1` have differing AST.+    -- negated literals, as `- 1` and `-1` have differing ASTs.     when (negativeLiterals && isLiteral) space     located e p_hsExpr-  HsPar _ e -> do-    csSpans <--      fmap (flip RealSrcSpan Strict.Nothing . getLoc) <$> getEnclosingComments-    switchLayout (locA e : csSpans) $+  HsPar _ e ->+    switchLayoutWithEnclosingComments [locA e] $       parens s (located e (dontUseBraces . p_hsExpr))   SectionL _ x op -> do     located x p_hsExpr@@ -891,7 +889,8 @@  -- | Print a list comprehension. ----- BracketStyle should be N except in a do-block, which must be S or else it's a parse error.+-- The 'BracketStyle' should be 'N' except in a do-block, where it must be 'S'+-- or else it's a parse error. p_listComp :: BracketStyle -> XRec GhcPs [ExprLStmt GhcPs] -> R () p_listComp s es = sitcc (vlayout singleLine multiLine)   where@@ -918,11 +917,11 @@       space       p_bodyParallels (gatherStmts stmts) -    -- print the list of list comprehension sections, e.g.+    -- Print the list of list comprehension sections, e.g.     -- [ "| x <- xs, y <- ys, let z = x <> y", "| a <- f z" ]     p_bodyParallels = sep (breakpoint >> txt "|" >> space) (sitcc . p_bodyParallelStmts) -    -- print a list comprehension section within a pipe, e.g.+    -- Print a list comprehension section within a pipe, e.g.     -- [ "x <- xs", "y <- ys", "let z = x <> y" ]     p_bodyParallelStmts = sep commaDel (located' (sitcc . p_stmt)) @@ -961,7 +960,7 @@ -- @ -- -- The final expression is parsed out in p_body, and the rest is passed--- to this function. This function takes the above tree as input and+-- to this function. This function takes the tree above as input and -- normalizes it into: -- -- @@@ -978,17 +977,17 @@ -- -- Notes: --   * The number of elements in the outer list is the number of pipes in---     the comprehension; i.e. 1 unless -XParallelListComp is enabled+--     the comprehension, i.e. 1 unless -XParallelListComp is enabled. gatherStmts :: [ExprLStmt GhcPs] -> [[ExprLStmt GhcPs]] gatherStmts = \case-  -- When -XParallelListComp is enabled + list comprehension has-  -- multiple pipes, input will have exactly 1 element, and it-  -- will be ParStmt.+  -- When -XParallelListComp is enabled and the list comprehension has+  -- multiple pipes, the input will have exactly 1 element, and it+  -- will be a ParStmt.   [L _ (ParStmt _ blocks _ _)] ->     [ concatMap collectNonParStmts stmts     | ParStmtBlock _ stmts _ _ <- NE.toList blocks     ]-  -- Otherwise, list will not contain any ParStmt+  -- Otherwise, the list will not contain any ParStmt.   stmts ->     [ concatMap collectNonParStmts stmts     ]@@ -1013,7 +1012,7 @@               located psb_def p_pat           ImplicitBidirectional ->             switchLayout pattern_def_spans $ do-              equals+              txt "="               breakpoint               located psb_def p_pat           ExplicitBidirectional mgroup -> do@@ -1132,7 +1131,12 @@   space   located if' p_hsExpr   breakpoint-  commentSpans <- fmap getLoc <$> getEnclosingComments+  -- A comment between the @then@ or @else@ keyword and its branch means the+  -- branch cannot hang; it has to start on its own line.+  commentSpans <-+    getEnclosingSpan >>= \case+      Nothing -> pure []+      Just enclosing -> fmap getLoc <$> getCommentsAnchoredWithin enclosing   let (thenSpan, elseSpan) = (locA aiThen, locA aiElse)         where           AnnsIf {aiThen, aiElse} = anns@@ -1268,7 +1272,7 @@   located hfbLHS p_fieldOcc   unless hfbPun $ do     space-    equals+    txt "="     breakpoint     inci (located hfbRHS p_pat) @@ -1342,10 +1346,10 @@         breakpoint'         txt "|]"     -- With StarIsType, type and declaration brackets might end with a *,-    -- so we have to insert a space in the end to prevent the (mis)parsing+    -- so we have to insert a space at the end to prevent the (mis)parsing     -- of an (*|) operator.     -- The detection is a bit overcautious, as it adds the spaces as soon as-    -- HsStarTy is anywhere in the type/declaration.+    -- an HsStarTy appears anywhere in the type/declaration.     handleStarIsType :: (Data a) => a -> R () -> R ()     handleStarIsType a p       | containsHsStarTy a = space *> p <* space@@ -1369,7 +1373,7 @@ getGRHSSpan (GRHS _ guards body) =   combineSrcSpans' $ getLocA body :| map getLocA guards --- | Determine placement of a given block.+-- | Determine the placement of a given block. blockPlacement ::   (body -> Placement) ->   NonEmpty (LGRHS GhcPs (LocatedA body)) ->@@ -1377,7 +1381,7 @@ blockPlacement placer (L _ (GRHS _ _ (L _ x)) :| []) = placer x blockPlacement _ _ = Normal --- | Determine placement of a given command.+-- | Determine the placement of a given command. cmdPlacement :: HsCmd GhcPs -> Placement cmdPlacement = \case   HsCmdLam {} -> Hanging@@ -1385,14 +1389,14 @@   HsCmdDo {} -> Hanging   _ -> Normal --- | Determine placement of a top level command.+-- | Determine the placement of a top-level command. cmdTopPlacement :: HsCmdTop GhcPs -> Placement cmdTopPlacement (HsCmdTop _ (L _ x)) = cmdPlacement x --- | Check if given expression has a hanging form.+-- | Check whether the given expression has a hanging form. exprPlacement :: HsExpr GhcPs -> Placement exprPlacement = \case-  -- Only hang lambdas with single line parameter lists+  -- Only hang lambdas with single-line parameter lists.   HsLam _ variant mg -> case variant of     LamSingle -> case mg of       MG _ (L _ [L _ (Match _ _ (L _ (x : xs)) _)])@@ -1410,7 +1414,7 @@       _ -> Normal   HsApp _ _ y -> exprPlacement (unLoc y)   HsProc _ p _ ->-    -- Indentation breaks if pattern is longer than one line and left+    -- Indentation breaks if the pattern is longer than one line and left     -- hanging. Consequently, only apply hanging when it is safe.     if isOneLineSpan (getLocA p)       then Hanging

@@ -79,18 +79,18 @@     space     case ideclImportList of       Nothing -> return ()-      Just (hiding, L _ xs) -> do+      Just (hiding, L listLoc xs) -> do         case hiding of           Exactly -> pure ()           EverythingBut -> txt "hiding"         breakpoint         parens N $ do           layout <- getLayout+          when (null xs) $ locatedEmpty (locA listLoc)           sep             breakpoint             (\(p, l) -> sitcc (located l (p_lie layout p)))             (attachRelativePos xs)-    newline  p_declLevel :: ImportDeclLevel -> R () p_declLevel = \case

@@ -23,7 +23,7 @@ import Ormolu.Printer.Meat.ImportExport import Ormolu.Printer.Meat.Pragma --- | Render a module-like entity (either a regular module or a backpack+-- | Render a module-like entity (either a regular module or a Backpack -- signature). p_hsModule ::   -- | Stack header@@ -40,7 +40,7 @@   switchLayout (deprecSpan <> exportSpans) $     enterMultilineLayoutIfContainsDocEntries (maybe [] unLoc hsmodExports) $ do       forM_ mstackHeader $ \(L spn comment) -> do-        spitCommentNow spn comment+        spitCommentNow SlotFloating spn comment         newline       newline       p_pragmas pragmas@@ -58,13 +58,19 @@           case hsmodExports of             Nothing -> return ()             Just l -> do-              encloseLocated l $ \exports -> do+              located l $ \exports -> do+                when (null exports) $ locatedEmpty (locA l)                 inci (p_hsmodExports exports)               breakpoint           txt "where"           newline       newline-      forM_ hsmodImports (located' p_hsmodImport)+      -- The newline goes here rather than at the end of 'p_hsmodImport' so+      -- that a comment trailing an import is emitted while the printer is+      -- still on the import's line.+      forM_ hsmodImports $ \x -> do+        located' p_hsmodImport x+        newline       newline       switchLayout (getLocA <$> hsmodDecls) $ do         p_hsDecls Free hsmodDecls

@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}  -- | Pretty-printing of language pragmas. module Ormolu.Printer.Meat.Pragma@@ -55,9 +56,15 @@ p_pragmas ps = do   let prepare = L.sortOn snd . L.nub . concatMap analyze       analyze = \case+        -- @{-# LANGUAGE A, B #-}@ becomes one pragma per extension, but the+        -- comment written above it was written once. It goes to the first+        -- extension only; giving it to each of them printed it as many+        -- times as there were extensions.         (cs, PragmaLanguage xs) ->-          let f x = (cs, (Language (classifyLanguagePragma x), x))-           in f <$> xs+          let f x = (Language (classifyLanguagePragma x), x)+           in case xs of+                [] -> []+                (y : ys) -> (cs, f y) : ((mempty,) . f <$> ys)         (cs, PragmaOptionsGHC x) -> [(cs, (OptionsGHC, x))]         (cs, PragmaOptionsHaddock x) -> [(cs, (OptionsHaddock, x))]   forM_ (prepare ps) $ \(cs, (pragmaTy, x)) ->@@ -66,7 +73,7 @@ p_pragma :: [LComment] -> PragmaTy -> Text -> R () p_pragma comments ty x = do   forM_ comments $ \(L l comment) -> do-    spitCommentNow l comment+    spitCommentNow SlotPragma l comment     newline   txt "{-# "   txt $ case ty of

@@ -25,7 +25,7 @@   ) where -import Data.Choice (pattern With)+import Control.Monad import GHC.Data.Strict qualified as Strict import GHC.Hs hiding (isPromoted) import GHC.Types.SourceText@@ -68,7 +68,7 @@     p_rdrName n   HsAppTy _ f x -> do     let -- In order to format type applications with multiple parameters-        -- nicer, traverse the AST to gather the function and all the+        -- more nicely, traverse the AST to gather the function and all the         -- parameters together.         gatherArgs f' knownArgs =           case f' of@@ -116,10 +116,8 @@     let opTree = BinaryOpBranches (tyOpTree x) op (tyOpTree y)     p_tyOpTree       (reassociateOpTree debug (Just . unLoc) modFixityMap opTree)-  HsParTy _ t -> do-    csSpans <--      fmap (flip RealSrcSpan Strict.Nothing . getLoc) <$> getEnclosingComments-    switchLayout (locA t : csSpans) $+  HsParTy _ t ->+    switchLayoutWithEnclosingComments [locA t] $       parens N (located t p_hsType)   HsIParamTy _ n t -> sitcc $ do     located n atom@@ -136,7 +134,7 @@     inci (located k p_hsType)   HsSpliceTy _ splice -> p_hsUntypedSplice DollarSplice splice   HsDocTy _ t str -> do-    p_hsDoc Pipe (With #endNewline) str+    p_hsDocInline Pipe str     located t p_hsType   HsExplicitListTy _ p xs -> do     case p of@@ -193,7 +191,7 @@         else breakpoint     p_hsTypeR = p_hsType' multilineArgs --- | Return 'True' if at least one argument in 'HsType' has a doc string+-- | Return 'True' if at least one argument in the 'HsType' has a doc string -- attached to it. hasDocStrings :: HsType GhcPs -> Bool hasDocStrings = \case@@ -274,11 +272,14 @@  p_hsConDeclRecFields :: [LHsConDeclRecField GhcPs] -> R () p_hsConDeclRecFields xs =-  braces N $ sep commaDel (sitcc . located' p_hsConDeclRecField) xs+  multiLineIfDocumented xs . braces N $ do+    when (null xs) $+      getEnclosingSpan >>= mapM_ (locatedEmpty . flip RealSrcSpan Strict.Nothing)+    sep commaDel (sitcc . located' p_hsConDeclRecField) xs  p_hsConDeclRecField :: HsConDeclRecField GhcPs -> R () p_hsConDeclRecField HsConDeclRecField {..} = do-  mapM_ (p_hsDoc Pipe (With #endNewline)) (cdf_doc cdrf_spec)+  mapM_ (p_hsDocInline Pipe) (cdf_doc cdrf_spec)   sitcc $     sep       commaDel@@ -291,8 +292,8 @@   breakpoint   sitcc . inci $ p_hsConDeclField cdrf_spec --- | This does not print 'cdf_doc' and 'cdf_multiplicity' as there is no single--- strategy for where to print them (see call sites).+-- | This does not print 'cdf_doc' and 'cdf_multiplicity', as there is no+-- single strategy for where to print them (see call sites). p_hsConDeclField :: HsConDeclField GhcPs -> R () p_hsConDeclField CDF {..} = do   case cdf_unpack of@@ -308,14 +309,14 @@  p_hsConDeclFieldWithDoc :: HsConDeclField GhcPs -> R () p_hsConDeclFieldWithDoc cdf = do-  mapM_ (p_hsDoc Pipe (With #endNewline)) (cdf_doc cdf)+  mapM_ (p_hsDocInline Pipe) (cdf_doc cdf)   p_hsConDeclField cdf  p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg = \case   HsValArg NoExtField ty -> located ty p_hsType-  -- first argument is the SrcSpan of the @,-  -- but the @ always has to be directly before the type argument+  -- The first argument is the SrcSpan of the @, but the @ always has to be+  -- directly before the type argument.   HsTypeArg _ ty -> txt "@" *> located ty p_hsType   -- NOTE(amesgen) is this unreachable or just not implemented?   HsArgPar _ -> notImplemented "HsArgPar"

@@ -24,8 +24,8 @@ import Ormolu.Utils  -- | Intermediate representation of operator trees, where a branching is not--- just a binary branching (with a left node, right node, and operator like--- in the GHC's AST), but rather a n-ary branching, with n + 1 nodes and n+-- just a binary branching (with a left node, a right node, and an operator,+-- as in the GHC AST), but rather an n-ary branching, with n + 1 nodes and n -- operators (n >= 1). -- -- This representation allows us to put all the operators with the same@@ -49,7 +49,7 @@   { -- | The actual operator     opiOp :: op,     -- | Its name, if available. We use 'Maybe RdrName' here instead of-    -- 'RdrName' because the name-fetching function received by+    -- 'RdrName' because the name-fetching function passed to     -- 'reassociateOpTree' returns a 'Maybe'     opiName :: Maybe RdrName,     -- | Information about the fixity direction and precedence level of the@@ -83,13 +83,14 @@         (Just n1, Just n2) -> n1 == n2         _ -> False --- | Return combined 'SrcSpan's of all elements in this 'OpTree'.+-- | Return the combined 'SrcSpan's of all elements in this 'OpTree'. opTreeLoc :: (HasLoc l) => OpTree (GenLocated l a) b -> SrcSpan opTreeLoc (OpNode n) = getHasLoc n opTreeLoc (OpBranches exprs _) =   combineSrcSpans' . fmap opTreeLoc $ exprs --- | Re-associate an 'OpTree' taking into account precedence of operators.+-- | Re-associate an 'OpTree' taking into account the precedence of+-- operators. -- Users are expected to first construct an initial 'OpTree', then -- re-associate it using this function before printing. reassociateOpTree ::@@ -134,7 +135,7 @@           Nothing -> defaultFixityApproximation           Just rdrName -> inferFixity debug rdrName modFixityMap --- | Given a 'OpTree' of any shape, produce a flat 'OpTree', where every+-- | Given an 'OpTree' of any shape, produce a flat 'OpTree' where every -- node and operator is directly connected to the root. makeFlatOpTree :: OpTree ty op -> OpTree ty op makeFlatOpTree (OpNode n) = OpNode n@@ -151,9 +152,9 @@     interleave [] ys = ys     interleave xs [] = xs --- | Starting from a flat 'OpTree' (i.e. a n-ary tree of depth 1,--- without regard for operator fixities), build an 'OpTree' with proper--- sub-trees (according to the fixity info carried by the nodes).+-- | Starting from a flat 'OpTree' (i.e. an n-ary tree of depth 1, without+-- regard for operator fixities), build an 'OpTree' with proper sub-trees+-- (according to the fixity info carried by the nodes). -- -- We have two complementary ways to build the proper sub-trees: --@@ -182,12 +183,11 @@ --   will become --     [[ex0 op0 ex1 op1 ex2] op2 ex3 op3 [ex4 op4 ex5] op5 ex6 op6 ex7] ----- We will also recursively apply the same logic on every sub-tree built--- during the process. The two principles are not overlapping and thus are--- required, because we are comparing precedence level ranges. In the case--- where we can't find a non-empty set {min,max}Ops with one logic or the--- other, we finally try to split the tree on “hard splitters” if there is--- any.+-- We also recursively apply the same logic to every sub-tree built during+-- the process. The two principles do not overlap, and both are required,+-- because we are comparing precedence level ranges. In the case where we+-- cannot find a non-empty set {min,max}Ops with one approach or the other,+-- we finally try to split the tree on “hard splitters”, if there are any. reassociateFlatOpTree ::   -- | Flat 'OpTree', with fixity info wrapped around each operator   OpTree ty (OpInfo op) ->@@ -276,10 +276,10 @@           OpTree ty (OpInfo op)         go [] _ _ _ subExprs subOps resExprs resOps =           -- No expr left to process.-          -- because we are in a "splitting" logic, there is at least one+          -- Because we are in a "splitting" logic, there is at least one           -- expr in the subExprs bag, so we build a subtree (if necessary)-          -- with sub-bags, add the node/subtree to the result bag, and then-          -- emit the result tree+          -- from the sub-bags, add the node/subtree to the result bag, and+          -- then emit the result tree.           let resExpr = buildFromSub (NE.fromList subExprs) subOps            in OpBranches (NE.reverse (resExpr :| resExprs)) (reverse resOps)         go (x : xs) (o : os) (idx : idxs) i subExprs subOps resExprs resOps@@ -287,13 +287,13 @@               -- The op we are looking at is one on which we need to split.               -- So we build a subtree from the sub-bags and the current               -- expr, append it to the result exprs, and continue with-              -- cleared sub-bags+              -- cleared sub-bags.               let resExpr = buildFromSub (x :| subExprs) subOps                in go xs os idxs (i + 1) [] [] (resExpr : resExprs) (o : resOps)         go (x : xs) ops idxs i subExprs subOps resExprs resOps =           -- Either there is no op left, or the op we are looking at is not           -- one on which we need to split. So we just add both the current-          -- expr and current op (if there is any) to the sub-bags+          -- expr and the current op (if there is any) to the sub-bags.           let (ops', subOps') = moveOneIfPossible ops subOps            in go xs ops' idxs (i + 1) (x : subExprs) subOps' resExprs resOps @@ -324,11 +324,11 @@           -- result tree           OpTree ty (OpInfo op)         go [] _ _ _ subExprs subOps resExprs resOps =-          -- no expr left to process-          -- because we are in a "grouping" logic, the subExprs bag might be-          -- empty. If it is not, we build a subtree (if necessary) with+          -- No expr left to process.+          -- Because we are in a "grouping" logic, the subExprs bag might be+          -- empty. If it is not, we build a subtree (if necessary) from the           -- sub-bags and add the resulting node/subtree to the result bag.-          -- In any case, we then emit the result tree+          -- In any case, we then emit the result tree.           let resExprs' = case NE.nonEmpty subExprs of                 Nothing -> NE.fromList resExprs                 Just subExprs' -> buildFromSub subExprs' subOps :| resExprs@@ -350,8 +350,8 @@         go (x : xs) ops idxs i [] subOps resExprs resOps =           -- Either there is no op left, or the op we are looking at is not           -- one on which we need to split, but the sub-bags are empty. So-          -- we just add both the current expr and current op (if there is-          -- any) to the result bags+          -- we just add both the current expr and the current op (if there+          -- is any) to the result bags.           let (ops', resOps') = moveOneIfPossible ops resOps            in go xs ops' idxs (i + 1) [] subOps (x : resExprs) resOps' @@ -364,9 +364,9 @@       x :| [] -> x       _ -> OpBranches (NE.reverse subExprs) (reverse subOps) --- | Indicate if an operator has @'InfixR' 0@ fixity. We special-case this--- class of operators because they often have, like ('$'), a specific--- “separator” use-case, and we sometimes format them differently than other+-- | Indicate whether an operator has @'InfixR' 0@ fixity. We special-case+-- this class of operators because, like ('$'), they often have a specific+-- “separator” use case, and we sometimes format them differently from other -- operators. isHardSplitterOp :: FixityApproximation -> Bool isHardSplitterOp = (== FixityApproximation (Just InfixR) 0 0)

@@ -1,49 +0,0 @@--- | Build span stream from AST.-module Ormolu.Printer.SpanStream-  ( SpanStream (..),-    mkSpanStream,-  )-where--import Data.Data (Data)-import Data.Foldable (toList)-import Data.Generics (everything, ext1Q, ext2Q)-import Data.List (sortOn)-import Data.Maybe (maybeToList)-import Data.Sequence (Seq)-import Data.Sequence qualified as Seq-import Data.Typeable (cast)-import GHC.Parser.Annotation-import GHC.Types.SrcLoc---- | A stream of 'RealSrcSpan's in ascending order. This allows us to tell--- e.g. whether there is another \"located\" element of AST between current--- element and comment we're considering for printing.-newtype SpanStream = SpanStream [RealSrcSpan]-  deriving (Eq, Show, Data, Semigroup, Monoid)---- | Create 'SpanStream' from a data structure containing \"located\"--- elements.-mkSpanStream ::-  (Data a) =>-  -- | Data structure to inspect (AST)-  a ->-  SpanStream-mkSpanStream a =-  SpanStream-    . sortOn realSrcSpanStart-    . toList-    $ everything mappend (const mempty `ext2Q` queryLocated `ext1Q` queryEpAnn) a-  where-    queryLocated ::-      (Data e0) =>-      GenLocated e0 e1 ->-      Seq RealSrcSpan-    queryLocated (L mspn _) =-      maybe mempty srcSpanToRealSrcSpanSeq (cast mspn :: Maybe SrcSpan)--    queryEpAnn :: EpAnn ann -> Seq RealSrcSpan-    queryEpAnn = srcSpanToRealSrcSpanSeq . locA--    srcSpanToRealSrcSpanSeq =-      Seq.fromList . maybeToList . srcSpanToRealSrcSpan

@@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} --- | Common definitions for pre- and post- processing.+-- | Common definitions for pre- and post-processing. module Ormolu.Processing.Common   ( removeIndentation,     reindent,@@ -40,7 +40,7 @@     (_, nonPrefix) = splitAt regionPrefixLength ls     middle = take (length nonPrefix - regionSuffixLength) nonPrefix --- | Convert a set of line indices into disjoint 'RegionDelta's+-- | Convert a set of line indices into disjoint 'RegionDeltas'. intSetToRegions ::   -- | Total number of lines   Int ->

@@ -61,8 +61,8 @@         & dropWhile isBlankRawSnippet         & L.dropWhileEnd isBlankRawSnippet     -- For every formattable region, we want to ensure that it is separated by-    -- a blank line from preceding/succeeding raw snippets if it starts/ends-    -- with a blank line.+    -- a blank line from the preceding/succeeding raw snippets if it+    -- starts/ends with a blank line.     -- Empty formattable regions are replaced by a blank line instead.     -- Extraneous raw snippets at the start/end are dropped afterwards.     patchSeparatingBlankLines = \case@@ -165,11 +165,11 @@ ormoluDisable :: Text ormoluDisable = "ORMOLU_DISABLE" --- | Creates a magic comment with the given inner text.+-- | Create a magic comment with the given inner text. magicComment :: Text -> Text magicComment t = "{- " <> t <> " -}" --- | Construct a function for whitespace-insensitive matching of string.+-- | Construct a function for whitespace-insensitive matching of a string. isMagicComment ::   -- | What to expect   Text ->

@@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | An abstraction for colorful output in terminal.+-- | An abstraction for colorful output in the terminal. module Ormolu.Terminal   ( -- * The 'Term' abstraction     Term,@@ -56,7 +56,7 @@ data ColorMode = Never | Always | Auto   deriving (Eq, Show) --- | Run 'Term' monad.+-- | Run the 'Term' monad. runTerm ::   Term ->   -- | Color mode

@@ -8,6 +8,7 @@     combineSrcSpans',     notImplemented,     showOutputable,+    containsHaddocks,     splitDocString,     incSpanLine,     separatedByBlank,@@ -18,6 +19,8 @@   ) where +import Data.Data (Data)+import Data.Generics.Schemes (listify) import Data.List (dropWhileEnd) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE@@ -47,7 +50,7 @@   | LastPos   deriving (Eq, Show) --- | Attach 'RelativePos'es to elements of a given list.+-- | Attach 'RelativePos'es to the elements of the given list. attachRelativePos :: [a] -> [(RelativePos, a)] attachRelativePos = \case   [] -> []@@ -66,10 +69,20 @@ notImplemented :: String -> a notImplemented msg = error $ "not implemented yet: " ++ msg --- | Pretty-print an 'GHC.Outputable' thing.+-- | Pretty-print a 'GHC.Outputable' thing. showOutputable :: (Outputable o) => o -> String showOutputable = showSDoc baseDynFlags . ppr +-- | Does this fragment of the syntax tree carry a Haddock anywhere inside+-- it?+--+-- Unlike the span of a Haddock, which sits wherever the author wrote it,+-- this answers the question the printer actually has: will rendering this+-- fragment emit documentation?+containsHaddocks :: (Data a) => a -> Bool+containsHaddocks =+  not . null . listify (const True :: HsDocString -> Bool)+ -- | Split and normalize a doc string. The result is a list of lines that -- make up the comment. splitDocString :: HsDocString -> [Text]@@ -85,8 +98,8 @@         . fmap (T.stripEnd . T.pack)         . lines         $ renderHsDocString docStr-    -- We cannot have the first character to be a dollar because in that-    -- case it'll be a parse error (apparently collides with named docs+    -- We cannot let the first character be a dollar, because in that case+    -- it would be a parse error (apparently it collides with the named docs     -- syntax @-- $name@ somehow).     escapeLeadingDollar txt =       case T.uncons txt of@@ -107,7 +120,7 @@                 then dropSpace <$> xs                 else xs --- | Increment line number in a 'SrcSpan'.+-- | Increment the line number in a 'SrcSpan'. incSpanLine :: Int -> SrcSpan -> SrcSpan incSpanLine i = \case   RealSrcSpan s _ ->@@ -133,7 +146,8 @@ separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b) --- | Return 'True' if one span ends on the same line the second one starts.+-- | Return 'True' if one span ends on the same line where the second one+-- starts. onTheSameLine :: SrcSpan -> SrcSpan -> Bool onTheSameLine a b =   isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))@@ -144,7 +158,7 @@   buf <- mallocPlainForeignPtrBytes (len + 3)   withForeignPtr buf $ \ptr -> do     TFFI.unsafeCopyToPtr txt ptr-    -- last three bytes have to be zero for easier decoding+    -- The last three bytes have to be zero for easier decoding.     pokeElemOff ptr len 0     pokeElemOff ptr (len + 1) 0     pokeElemOff ptr (len + 2) 0

@@ -24,9 +24,9 @@ import Text.Megaparsec (errorBundlePretty)  -- | Attempt to locate and parse an @.ormolu@ file. If it does not exist,--- default fixity map and module reexports are returned. This function--- maintains a cache of fixity overrides and module re-exports where cabal--- file paths act as keys.+-- the default fixity map and module re-exports are returned. This function+-- maintains a cache of fixity overrides and module re-exports keyed by+-- @.ormolu@ file path. getDotOrmoluForSourceFile ::   (MonadIO m) =>   -- | 'CabalInfo' already obtained for this source file@@ -69,8 +69,8 @@ parseFixityDeclarationStr =   first errorBundlePretty . parseFixityDeclaration . T.pack --- | A wrapper around 'parseModuleReexportDeclaration' for parsing--- a individual module reexport.+-- | A wrapper around 'parseModuleReexportDeclaration' for parsing an+-- individual module re-export. parseModuleReexportDeclarationStr ::   -- | Input to parse   String ->

@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Tests for the containment tree and the positional attachment rules.+module Ormolu.Comments.AnchorSpec (spec) where++import Data.List.NonEmpty (NonEmpty (..))+import GHC.Data.FastString (fsLit)+import GHC.Types.SrcLoc+import Ormolu.Comments.Anchor+import Ormolu.Comments.Tree+import Ormolu.Parser.CommentStream+import Test.Hspec++spec :: Spec+spec = do+  describe "mkSpanForest" $ do+    it "nests spans by containment" $+      mkSpanForest [spn 1 1 9 9, spn 2 1 3 9, spn 2 3 2 8]+        `shouldBe` [ SpanTree+                       (spn 1 1 9 9)+                       [SpanTree (spn 2 1 3 9) [SpanTree (spn 2 3 2 8) []]]+                   ]+    it "keeps siblings in ascending order" $+      fmap stSpan (mkSpanForest [spn 5 1 5 9, spn 1 1 1 9, spn 3 1 3 9])+        `shouldBe` [spn 1 1 1 9, spn 3 1 3 9, spn 5 1 5 9]+    it "treats a repeated span as one element" $+      -- Several AST nodes routinely share a span; the comment can only be+      -- owned once.+      countNodes (mkSpanForest [spn 1 1 9 9, spn 1 1 9 9, spn 1 1 9 9])+        `shouldBe` 1+    it "drops spans that overlap without being contained" $+      countNodes (mkSpanForest [spn 1 1 5 9, spn 3 1 7 9]) `shouldBe` 1+    it "keeps zero-width spans" $+      -- The printer enters a zero-width span at each end of an empty list,+      -- deliberately, so that a comment written inside the brackets has+      -- something to attach to.+      mkSpanForest [spn 1 1 1 1, spn 2 1 2 9]+        `shouldBe` [SpanTree (spn 1 1 1 1) [], SpanTree (spn 2 1 2 9) []]++  describe "anchorFor" $ do+    let forest = mkSpanForest [block, stmt1, stmt2]+        block = spn 1 1 5 10+        stmt1 = spn 2 3 2 9+        stmt2 = spn 4 3 4 9++    it "puts a comment between two elements before the later one" $+      anchorFor forest (ownLine 3 3 3 12) `shouldBe` AnchorBefore stmt2+    it "attaches a comment that trails code to the element it trails" $+      anchorFor forest (trailing 2 12 2 20) `shouldBe` AnchorTrailing stmt1+    it "does not treat a comment as trailing when no code precedes it" $+      -- Same line as the end of stmt1, but alone on its line, so it belongs+      -- to what comes after.+      anchorFor forest (ownLine 2 12 2 20) `shouldBe` AnchorBefore stmt2+    it "attaches a comment after the last element to that element" $+      anchorFor forest (ownLine 5 3 5 9) `shouldBe` AnchorTrailing stmt2+    it "gives a comment inside a childless element to that element" $+      anchorFor (mkSpanForest [spn 1 1 3 3]) (ownLine 2 3 2 9)+        `shouldBe` AnchorInside (spn 1 1 3 3)+    it "leaves a comment outside everything to the module" $+      -- Not trailing the last top-level element: there is nothing it could+      -- trail without being rendered before syntax that preceded it.+      anchorFor forest (ownLine 9 1 9 9) `shouldBe` AnchorModule+    it "leaves a comment to the module when there are no elements at all" $+      anchorFor [] (ownLine 1 1 1 9) `shouldBe` AnchorModule++    -- @f x = -- c@ re-parsed: the comment now falls inside the right-hand+    -- side, which opened on that line and has nothing of its own before the+    -- comment. Without looking one level up it would move onto its own+    -- line, and formatting would not be idempotent.+    it "attaches a comment inside an element that opened on its line to the code before it" $+      let rhs = spn 2 11 3 9+          body = spn 3 3 3 9+       in anchorFor+            (mkSpanForest [block, stmt1, rhs, body])+            (trailing 2 14 2 20)+            `shouldBe` AnchorTrailing stmt1+    it "still lets an element starting on the comment's line lead it" $+      -- The @{-a-}@ of @x = ({-a-} b, c)@ belongs to @b@, not to the @x@+      -- one level up.+      let tuple = spn 2 11 2 30+          b = spn 2 18 2 19+       in anchorFor+            (mkSpanForest [block, stmt1, tuple, b])+            (trailing 2 12 2 17)+            `shouldBe` AnchorBefore b+    it "does not carry a comment out of a list of items" $+      -- @xs ++ [ -- why?@: the comment introduces the items, so carrying it+      -- up to trail @xs@ would drag it out of the brackets.+      let list = spn 2 11 4 9+          itemA = spn 3 3 3 9+          itemB = spn 4 3 4 9+       in anchorFor+            (mkSpanForest [block, stmt1, list, itemA, itemB])+            (trailing 2 14 2 20)+            `shouldBe` AnchorBefore itemA+    it "does not carry a block comment up a level" $+      -- A block comment renders where it stands, so trailing an element one+      -- level up would push it ahead of the tokens that opened the element+      -- it was written inside.+      let rhs = spn 2 11 3 9+          body = spn 3 3 3 9+       in anchorFor+            (mkSpanForest [block, stmt1, rhs, body])+            (blockTrailing 2 14 2 20)+            `shouldBe` AnchorBefore body++    it "does not depend on the order the elements are given in" $+      -- This is the whole point: reordering imports or reassociating an+      -- operator tree must not change who owns a comment.+      anchorFor (mkSpanForest [stmt2, block, stmt1]) (ownLine 3 3 3 12)+        `shouldBe` AnchorBefore stmt2++  describe "attachComments" $+    it "attaches every comment exactly once" $ do+      let comments = [ownLine 3 3 3 12, trailing 4 12 4 20]+          anchors = attachComments comments [spn 1 1 5 10, spn 2 3 2 9, spn 4 3 4 9]+      length anchors `shouldBe` 2+      fmap snd anchors+        `shouldBe` [AnchorBefore (spn 4 3 4 9), AnchorTrailing (spn 4 3 4 9)]++----------------------------------------------------------------------------+-- Helpers++spn :: Int -> Int -> Int -> Int -> RealSrcSpan+spn l1 c1 l2 c2 =+  mkRealSrcSpan+    (mkRealSrcLoc (fsLit "<test>") l1 c1)+    (mkRealSrcLoc (fsLit "<test>") l2 c2)++-- | A comment with code in front of it on the same line.+trailing :: Int -> Int -> Int -> Int -> LComment+trailing l1 c1 l2 c2 = L (spn l1 c1 l2 c2) (Comment True ("-- x" :| []))++-- | A block comment with code in front of it on the same line.+blockTrailing :: Int -> Int -> Int -> Int -> LComment+blockTrailing l1 c1 l2 c2 = L (spn l1 c1 l2 c2) (Comment True ("{- x -}" :| []))++-- | A comment that is alone on its line.+ownLine :: Int -> Int -> Int -> Int -> LComment+ownLine l1 c1 l2 c2 = L (spn l1 c1 l2 c2) (Comment False ("-- x" :| []))

@@ -285,7 +285,7 @@       fimportList = Nothing     } --- | Adds an alias for an import.+-- | Add an alias for an import. as_ :: ModuleName -> FixityImport -> FixityImport as_ moduleName fixityImport =   fixityImport

@@ -6,14 +6,12 @@ import Control.Exception import Control.Monad import Data.List (isSuffixOf)-import Data.Map qualified as Map import Data.Maybe (isJust)-import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO.Utf8 qualified as T.Utf8 import Ormolu-import Ormolu.Fixity+import Ormolu.TestConfig import Path import Path.IO import System.Environment (lookupEnv)@@ -25,49 +23,20 @@   es <- runIO locateExamples   forM_ es checkExample --- | Fixity overrides that are to be used with the test examples.-testsuiteOverrides :: FixityOverrides-testsuiteOverrides =-  FixityOverrides-    ( Map.fromList-        [ (".=", FixityInfo InfixR 8),-          ("#", FixityInfo InfixR 5),-          (">~<", FixityInfo InfixR 3),-          ("|~|", FixityInfo InfixR 3.3),-          ("<~>", FixityInfo InfixR 3.7)-        ]-    )- -- | Check a single given example. checkExample :: Path Rel File -> Spec checkExample srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptions $ do   let srcPath = examplesDir </> srcPath'       inputPath = fromRelFile srcPath-      config =-        defaultConfig-          { cfgSourceType = detectSourceType inputPath,-            cfgFixityOverrides = testsuiteOverrides,-            cfgDependencies =-              Set.fromList-                [ "base",-                  "esqueleto",-                  "hspec",-                  "lens",-                  "megaparsec",-                  "optics",-                  "relude",-                  "rio",-                  "servant"-                ]-          }+      config = exampleConfig inputPath   expectedOutputPath <- deriveOutput srcPath-  -- 1. Given input snippet of source code parse it and pretty print it.-  -- 2. Parse the result of pretty-printing again and make sure that AST-  -- is the same as AST of the original snippet. (This happens in+  -- 1. Given an input snippet of source code, parse it and pretty-print it.+  -- 2. Parse the result of pretty-printing again and make sure that its AST+  -- is the same as the AST of the original snippet. (This happens in   -- 'ormoluFile' automatically.)   formatted0 <- ormoluFile config inputPath-  -- 3. Check the output against expected output. Thus all tests should-  -- include two files: input and expected output.+  -- 3. Check the output against the expected output. Thus all tests should+  -- include two files: the input and the expected output.   whenShouldRegenerateOutput $     T.Utf8.writeFile (fromRelFile expectedOutputPath) formatted0   expected <- T.Utf8.readFile $ fromRelFile expectedOutputPath@@ -77,20 +46,20 @@   formatted1 <- ormolu config "<formatted>" formatted0   shouldMatch True formatted1 formatted0 --- | Build list of examples for testing.+-- | Build a list of examples for testing. locateExamples :: IO [Path Rel File] locateExamples =   filter isInput . snd <$> listDirRecurRel examplesDir --- | Does given path look like input path (as opposed to expected output--- path)?+-- | Does the given path look like an input path (as opposed to an expected+-- output path)? isInput :: Path Rel File -> Bool isInput path =   let s = fromRelFile path       (s', exts) = F.splitExtensions s    in exts `elem` [".hs", ".hsig"] && not ("-out" `isSuffixOf` s') --- | For given path of input file return expected name of output.+-- | For the given input file path, return the expected output name. deriveOutput :: Path Rel File -> IO (Path Rel File) deriveOutput path =   parseRelFile $@@ -118,7 +87,7 @@ examplesDir :: Path Rel Dir examplesDir = $(mkRelDir "data/examples") --- | Inside this wrapper 'OrmoluException' will be caught and displayed+-- | Inside this wrapper, 'OrmoluException' will be caught and displayed -- nicely using 'displayException'. withNiceExceptions ::   -- | Action that may throw the exception

@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++-- | The 'Config' that all corpora of test inputs are formatted with.+--+-- Fixity information affects the shape of operator trees, and therefore+-- both the layout and which AST element claims a comment, so every spec+-- that formats an input file has to agree on it.+module Ormolu.TestConfig+  ( exampleConfig,+  )+where++import Data.Map qualified as Map+import Data.Set qualified as Set+import Ormolu+import Ormolu.Fixity++-- | The configuration to use for a test input at the given path.+exampleConfig :: FilePath -> Config RegionIndices+exampleConfig inputPath =+  defaultConfig+    { cfgSourceType = detectSourceType inputPath,+      cfgFixityOverrides = testsuiteOverrides,+      cfgDependencies =+        Set.fromList+          [ "base",+            "esqueleto",+            "hspec",+            "lens",+            "megaparsec",+            "optics",+            "relude",+            "rio",+            "servant"+          ]+    }++-- | Fixity overrides that are to be used with the test inputs.+testsuiteOverrides :: FixityOverrides+testsuiteOverrides =+  FixityOverrides+    ( Map.fromList+        [ (".=", FixityInfo InfixR 8),+          ("#", FixityInfo InfixR 5),+          (">~<", FixityInfo InfixR 3),+          ("|~|", FixityInfo InfixR 3.3),+          ("<~>", FixityInfo InfixR 3.7)+        ]+    )