packages feed

fourmolu 0.20.1.0 → 0.21.0.0

raw patch · 212 files changed

+3623/−1195 lines, 212 filesdep ~Diff

Dependency ranges changed: Diff

Files

CHANGELOG.md view
@@ -1,3 +1,90 @@+## Fourmolu 0.21.0.0++* Import lines separated by comments without blank lines are now considered one import group++### Upstream changes:++#### 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.+ ## Fourmolu 0.20.1.0  ### Upstream changes:
LICENSE.md view
@@ -12,7 +12,7 @@   notice, this list of conditions and the following disclaimer in the   documentation and/or other materials provided with the distribution. -* Neither the name Tweag I/O nor the names of contributors may be used to+* Neither the names Tweag I/O and Mark Karpov nor the names of contributors may be used to   endorse or promote products derived from this software without specific   prior written permission.
README.md view
@@ -22,24 +22,22 @@ * [Contributing](#contributing) * [License](#license) -Fourmolu is a formatter for Haskell source code. It is a fork of [Ormolu](https://github.com/mrkkrp/ormolu), with upstream improvements continually merged.+Fourmolu is a formatter for Haskell source code. It is a fork of [Ormolu](https://github.com/tweag/ormolu), with upstream improvements continually merged.  We share all bar one of Ormolu's goals: -* 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`](https://hackage.haskell.org/package/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.-* That 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.+* 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. * ~~Implementing one “true” formatting style which admits no configuration.~~ We allow configuration of various parameters, via CLI options or config files. We encourage any contributions which add further flexibility. @@ -78,13 +76,13 @@  ## Usage -The following will print the formatted output to the standard output.+The following prints the formatted output to the standard output:  ```console $ fourmolu Module.hs ``` -Add `-i` (or `--mode inplace`) to replace the contents of the input file with the formatted output.+Add `-i` (or `--mode inplace`) to replace the contents of the input file with the formatted output:  ```console $ fourmolu -i Module.hs@@ -104,7 +102,7 @@ $ git ls-files -z '*.hs' | xargs -P 12 -0 fourmolu --mode inplace ``` -To check if files are already formatted (useful on CI):+To check whether files are already formatted (useful on CI):  ```console $ fourmolu --mode check src@@ -126,19 +124,20 @@  Fourmolu can be integrated with your editor via the [Haskell Language Server](https://haskell-language-server.readthedocs.io/en/latest/index.html). Just set `haskell.formattingProvider` to `fourmolu` ([instructions](https://haskell-language-server.readthedocs.io/en/latest/configuration.html#language-specific-server-options)). -### GitHub actions+### GitHub Actions -[`run-fourmolu`](https://github.com/haskell-actions/run-fourmolu) is the recommended way to ensure that a project is formatted with Fourmolu.+[`run-fourmolu`](https://github.com/haskell-actions/run-fourmolu) is the recommended way to ensure that a project stays formatted with Fourmolu.  ### Language extensions, dependencies, and fixities  Fourmolu 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 the `fixities` configuration option in `fourmolu.yaml`. When the input comes from-stdin, one can pass `--stdin-input-file` which will give Fourmolu the location-that should be used as the starting point for searching for `.cabal` 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 the `fixities` configuration option in+`fourmolu.yaml`. When the input comes from stdin, you+can pass `--stdin-input-file` to tell Fourmolu which location to use as the+starting point when searching for `.cabal` files.  Here is an example of the `fixities` configuration: @@ -156,21 +155,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.  `fourmolu.yaml` can also contain instructions about-module re-exports that Fourmolu should be aware of. This might be desirable-because at the moment Fourmolu 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 Fourmolu. (You are welcome to open PRs to make Fourmolu aware of more-re-exports by default.) However, when the fixity of an operator is not-inferred correctly, making Fourmolu aware of a re-export may come in handy.-Here is an example:+module re-exports that Fourmolu should be aware of. This can be useful because+Fourmolu 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 Fourmolu. (You are welcome to open PRs upstream to Ormolu to make Fourmolu+aware of more re-exports by default.) However, when the fixity of an operator+is not inferred correctly, making Fourmolu aware of a re-export may help. Here+is an example:  ```yaml reexports:@@ -205,22 +203,22 @@ {- FOURMOLU_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-`{- FOURMOLU_DISABLE -}` at the very top. Note that for Fourmolu to work the-fragments where Fourmolu 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 `{- FOURMOLU_DISABLE -}` at the very top. Note that the fragments+where Fourmolu 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.  `{- ORMOLU_DISABLE -}` and `{- ORMOLU_ENABLE -}`, respectively, can be used to the same effect, and the two styles of magic comments can be mixed.  ### Regions -One can ask Fourmolu 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 Fourmolu 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. @@ -239,6 +237,7 @@ 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)@@ -246,10 +245,10 @@  ### Using as a library -The `fourmolu` 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.10.2.0. Rely on other modules at your own risk.+The `fourmolu` 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 @@ -264,25 +263,26 @@   specify the correct fixities in a `fourmolu.yaml` 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 `fourmolu.yaml` file.+  If either of these applies, make sure to specify the re-exports correctly+  in a `fourmolu.yaml` 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](https://github.com/mrkkrp/ormolu/blob/master/DESIGN.md#cpp) section in the design notes for a+  correctly, so Fourmolu 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. * Various minor idempotence issues, most of them are related to comments or column limits.
app/Main.hs view
@@ -220,7 +220,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@@ -284,7 +284,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)
+ data/examples/declaration/data/comment-in-empty-record-four-out.hs view
@@ -0,0 +1,6 @@+instance StateKey ExampleReq where+    data State ExampleReq = ExampleState+        {+        -- in here you can put any state that the+        -- run.+        }
+ data/examples/declaration/data/comment-in-empty-record-out.hs view
@@ -0,0 +1,6 @@+instance StateKey ExampleReq where+  data State ExampleReq = ExampleState+    {+    -- in here you can put any state that the+    -- run.+    }
+ data/examples/declaration/data/comment-in-empty-record.hs view
@@ -0,0 +1,5 @@+instance StateKey ExampleReq where+  data State ExampleReq = ExampleState {+        -- in here you can put any state that the+        -- run.+        }
+ data/examples/declaration/data/haddock-before-deriving-four-out.hs view
@@ -0,0 +1,5 @@+data A = A+    deriving+        ( -- | B+          Eq+        )
+ data/examples/declaration/data/haddock-before-deriving-out.hs view
@@ -0,0 +1,5 @@+data A = A+  deriving+    ( -- | B+      Eq+    )
+ data/examples/declaration/data/haddock-before-deriving.hs view
@@ -0,0 +1,3 @@+data A = A+  -- | B+  deriving (Eq)
+ data/examples/declaration/data/haddock-before-record-braces-four-out.hs view
@@ -0,0 +1,6 @@+module Example where++data Hello = Hello+    { hello :: String+    -- ^ hello world+    }
+ data/examples/declaration/data/haddock-before-record-braces-out.hs view
@@ -0,0 +1,6 @@+module Example where++data Hello = Hello+  { -- | hello world+    hello :: String+  }
+ data/examples/declaration/data/haddock-before-record-braces.hs view
@@ -0,0 +1,5 @@+module Example where++data Hello = Hello+  -- | hello world+  {hello :: String}
data/examples/declaration/data/infix-haddocks-out.hs view
@@ -24,8 +24,8 @@  data DocPartial   = Left -- ^ left docs-    -- on multiple-    -- lines+         -- on multiple+         -- lines       :*:       Right   | -- | op
+ data/examples/declaration/data/record-empty-haddock-four-out.hs view
@@ -0,0 +1,5 @@+data A = A+    { -- \|+      --+      a :: Int+    }
+ data/examples/declaration/data/record-empty-haddock-out.hs view
@@ -0,0 +1,5 @@+data A = A+  { -- \|+    --+    a :: Int+  }
+ data/examples/declaration/data/record-empty-haddock.hs view
@@ -0,0 +1,6 @@+data A = A+  {+    -- |+    -- +    a :: Int+  }
data/examples/declaration/data/unnamed-field-comment-3-out.hs view
@@ -1,5 +1,1 @@-data A-  = A-      -- | a number-      Int-      Bool+data A = A {- | a number -} Int Bool
+ data/examples/declaration/data/unpack-field-comment-0-four-out.hs view
@@ -0,0 +1,4 @@+data Buffer+    = Buffer+        {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array+        {-# UNPACK #-} !(Ptr Word8) -- beginning of slice
+ data/examples/declaration/data/unpack-field-comment-0-out.hs view
@@ -0,0 +1,4 @@+data Buffer+  = Buffer+      {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array+      {-# UNPACK #-} !(Ptr Word8) -- beginning of slice
+ data/examples/declaration/data/unpack-field-comment-0.hs view
@@ -0,0 +1,2 @@+data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array+                     {-# UNPACK #-} !(Ptr Word8)        -- beginning of slice
+ data/examples/declaration/data/unpack-field-comment-1-four-out.hs view
@@ -0,0 +1,4 @@+data P+    = P+        {-# UNPACK #-} !Word32 -- left word+        {-# UNPACK #-} !Word32 -- right word
+ data/examples/declaration/data/unpack-field-comment-1-out.hs view
@@ -0,0 +1,4 @@+data P+  = P+      {-# UNPACK #-} !Word32 -- left word+      {-# UNPACK #-} !Word32 -- right word
+ data/examples/declaration/data/unpack-field-comment-1.hs view
@@ -0,0 +1,2 @@+data P = P {-# UNPACK #-} !Word32 -- left word+           {-# UNPACK #-} !Word32 -- right word
+ data/examples/declaration/data/unpack-field-comment-2-four-out.hs view
@@ -0,0 +1,4 @@+data TBQueue a+    = TBQueue+        {-# UNPACK #-} !(TVar Natural) -- CR:  read capacity+        {-# UNPACK #-} !(TVar [a]) -- R:   elements waiting to be read
+ data/examples/declaration/data/unpack-field-comment-2-out.hs view
@@ -0,0 +1,4 @@+data TBQueue a+  = TBQueue+      {-# UNPACK #-} !(TVar Natural) -- CR:  read capacity+      {-# UNPACK #-} !(TVar [a]) -- R:   elements waiting to be read
+ data/examples/declaration/data/unpack-field-comment-2.hs view
@@ -0,0 +1,3 @@+data TBQueue a+   = TBQueue {-# UNPACK #-} !(TVar Natural) -- CR:  read capacity+             {-# UNPACK #-} !(TVar [a])     -- R:   elements waiting to be read
+ data/examples/declaration/data/unpack-field-comment-3-four-out.hs view
@@ -0,0 +1,4 @@+data Builder+    = Builder+        {-# UNPACK #-} !Int -- offset+        {-# UNPACK #-} !Int -- used units
+ data/examples/declaration/data/unpack-field-comment-3-out.hs view
@@ -0,0 +1,4 @@+data Builder+  = Builder+      {-# UNPACK #-} !Int -- offset+      {-# UNPACK #-} !Int -- used units
+ data/examples/declaration/data/unpack-field-comment-3.hs view
@@ -0,0 +1,3 @@+data Builder = Builder+     {-# UNPACK #-} !Int -- offset+     {-# UNPACK #-} !Int -- used units
data/examples/declaration/rewrite-rule/prelude4-four-out.hs view
@@ -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     #-}
data/examples/declaration/rewrite-rule/prelude4-out.hs view
@@ -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   #-}
data/examples/declaration/type-families/closed-type-family/multi-line-four-out.hs view
@@ -23,6 +23,5 @@     F a = String  type family F a where-    F a -- foo-        =+    F a = -- foo         a
data/examples/declaration/type-families/closed-type-family/multi-line-out.hs view
@@ -25,6 +25,5 @@   F a = String  type family F a where-  F a -- foo-    =+  F a = -- foo     a
data/examples/declaration/type-synonyms/multi-line-four-out.hs view
@@ -19,6 +19,5 @@         :<|> "route2" :> ApiRoute2 -- comment here         :<|> OmitDocs :> "i" :> ASomething API -type A -- foo-    =+type A = -- foo     B
data/examples/declaration/type-synonyms/multi-line-out.hs view
@@ -19,6 +19,5 @@     :<|> "route2" :> ApiRoute2 -- comment here     :<|> OmitDocs :> "i" :> ASomething API -type A -- foo-  =+type A = -- foo   B
data/examples/declaration/value/function/arrow/proc-do-complex-four-out.hs view
@@ -29,8 +29,7 @@                     Left                         ( z                             , w-                            ) -> \u ->-                            -- Procs can have lambdas+                            ) -> \u -> -- Procs can have lambdas                             let                                 v =                                     u -- Actually never used
data/examples/declaration/value/function/arrow/proc-do-complex-out.hs view
@@ -29,8 +29,7 @@           Left             ( z,               w-              ) -> \u ->-              -- Procs can have lambdas+              ) -> \u -> -- Procs can have lambdas               let v =                     u -- Actually never used                       ^ 2
data/examples/declaration/value/function/arrow/proc-lambdas-four-out.hs view
@@ -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
data/examples/declaration/value/function/arrow/proc-lambdas-out.hs view
@@ -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
data/examples/declaration/value/function/awkward-comment-0-four-out.hs view
@@ -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)
data/examples/declaration/value/function/awkward-comment-0-out.hs view
@@ -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)
data/examples/declaration/value/function/awkward-comment-1-four-out.hs view
@@ -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
data/examples/declaration/value/function/awkward-comment-1-out.hs view
@@ -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
+ data/examples/declaration/value/function/case-comment-after-pattern-four-out.hs view
@@ -0,0 +1,3 @@+foo = case a of+    b -> -- comment+        c
+ data/examples/declaration/value/function/case-comment-after-pattern-out.hs view
@@ -0,0 +1,3 @@+foo = case a of+  b -> -- comment+    c
+ data/examples/declaration/value/function/case-comment-after-pattern.hs view
@@ -0,0 +1,3 @@+foo = case a of+  b -- comment+    -> c
+ data/examples/declaration/value/function/case-comment-between-alt-and-where-four-out.hs view
@@ -0,0 +1,6 @@+foo =+    case x of+        _ -> 1+  -- comment+  where+    x = 1
+ data/examples/declaration/value/function/case-comment-between-alt-and-where-out.hs view
@@ -0,0 +1,6 @@+foo =+  case x of+    _ -> 1+  -- comment+  where+    x = 1
+ data/examples/declaration/value/function/case-comment-between-alt-and-where.hs view
@@ -0,0 +1,6 @@+foo =+  case x of+    _ -> 1+    -- comment+    where+      x = 1
data/examples/declaration/value/function/case-multi-line-four-out.hs view
@@ -21,7 +21,6 @@ quux x = case x of     x -> x -funnyComment =-    -- comment+funnyComment = -- comment     case () of         () -> ()
data/examples/declaration/value/function/case-multi-line-out.hs view
@@ -21,7 +21,6 @@ quux x = case x of   x -> x -funnyComment =-  -- comment+funnyComment = -- comment   case () of     () -> ()
+ data/examples/declaration/value/function/lambda-comment-after-arrow-four-out.hs view
@@ -0,0 +1,2 @@+f = \a -> -- foo+    a
+ data/examples/declaration/value/function/lambda-comment-after-arrow-out.hs view
@@ -0,0 +1,2 @@+f = \a -> -- foo+  a
+ data/examples/declaration/value/function/lambda-comment-after-arrow.hs view
@@ -0,0 +1,2 @@+f = \a -> -- foo+  a
data/examples/declaration/value/function/newline-single-line-body-four-out.hs view
@@ -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"
data/examples/declaration/value/function/newline-single-line-body-out.hs view
@@ -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"
+ data/examples/declaration/value/function/operator-comments-3-four-out.hs view
@@ -0,0 +1,5 @@+data X = X {x :: Int}++f =+    id+        . (\s -> s{x = 1}) -- Some comment
+ data/examples/declaration/value/function/operator-comments-3-out.hs view
@@ -0,0 +1,5 @@+data X = X {x :: Int}++f =+  id+    . (\s -> s {x = 1}) -- Some comment
+ data/examples/declaration/value/function/operator-comments-3.hs view
@@ -0,0 +1,5 @@+data X = X { x :: Int }++f = id+    . -- Some comment+    (\s -> s { x = 1 })
+ data/examples/declaration/value/function/operator-comments-4-four-out.hs view
@@ -0,0 +1,4 @@+foo = do+    bar+        -- txt+        $ baz
+ data/examples/declaration/value/function/operator-comments-4-out.hs view
@@ -0,0 +1,4 @@+foo = do+  bar+    -- txt+    $ baz
+ data/examples/declaration/value/function/operator-comments-4.hs view
@@ -0,0 +1,4 @@+foo = do+  bar+    -- txt+    $ baz
+ data/examples/declaration/value/function/record/wildcard-comments-0-four-out.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE RecordWildCards #-}++example =+    Record+        { -- A+          field = () -- B+          -- C+        , field = () -- D+        -- E+        -- F+        , ..+        } -- G
+ data/examples/declaration/value/function/record/wildcard-comments-0-out.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE RecordWildCards #-}++example =+  Record+    { -- A+      field = (), -- B+      -- C+      field = (), -- D+      -- E+      -- F+      ..+    } -- G
+ data/examples/declaration/value/function/record/wildcard-comments-0.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE RecordWildCards #-}++example =+  Record+    { -- A+      field = (), -- B+      -- C+      field = (), -- D+      -- E+      .. -- F+    } -- G
+ data/examples/declaration/value/function/record/wildcard-comments-1-four-out.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE RecordWildCards #-}++example =+    Record+        { -- A+          field = ()+        , -- C+          field = ()+          -- E+          -- F+        , ..+        } -- G
+ data/examples/declaration/value/function/record/wildcard-comments-1-out.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE RecordWildCards #-}++example =+  Record+    { -- A+      field = (),+      -- C+      field = (),+      -- E+      -- F+      ..+    } -- G
+ data/examples/declaration/value/function/record/wildcard-comments-1.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE RecordWildCards #-}++example =+  Record+    { -- A+      field = (),+      -- C+      field = (),+      -- E+      .. -- F+    } -- G
+ data/examples/import/comment-before-merged-import-lists-four-out.hs view
@@ -0,0 +1,7 @@+-- their own formatters.+import Test.Hspec.Core.Formatters.V1.Monad (+    FormatM,+    Formatter (..),+ )++import Test.Hspec.Core.Formatters.V1.Monad (Item (..), interpretWith)
+ data/examples/import/comment-before-merged-import-lists-out.hs view
@@ -0,0 +1,7 @@+-- their own formatters.+import Test.Hspec.Core.Formatters.V1.Monad+  ( FormatM,+    Formatter (..),+    Item (..),+    interpretWith,+  )
+ data/examples/import/comment-before-merged-import-lists.hs view
@@ -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)
+ data/examples/import/comment-before-merged-imports-four-out.hs view
@@ -0,0 +1,7 @@+-- Import stuff from Prelude explicitly+import Prelude (+    Eq (..),+    Int,+    ($),+    (.),+ )
+ data/examples/import/comment-before-merged-imports-out.hs view
@@ -0,0 +1,7 @@+-- Import stuff from Prelude explicitly+import Prelude+  ( Eq (..),+    Int,+    ($),+    (.),+  )
+ data/examples/import/comment-before-merged-imports.hs view
@@ -0,0 +1,3 @@+-- Import stuff from Prelude explicitly+import Prelude (Eq(..), Int)+import Prelude ((.), ($))
+ data/examples/import/comment-between-merged-imports-four-out.hs view
@@ -0,0 +1,6 @@+import HscMain (newHscEnv)+-- Implementations of the various modes+import LoadIface (showIface)++-- Imports for --abi-hash+import LoadIface (loadUserInterface)
+ data/examples/import/comment-between-merged-imports-out.hs view
@@ -0,0 +1,7 @@+import HscMain (newHscEnv)+-- Implementations of the various modes+import LoadIface+  ( -- Imports for --abi-hash+    loadUserInterface,+    showIface,+  )
+ data/examples/import/comment-between-merged-imports.hs view
@@ -0,0 +1,6 @@+-- Implementations of the various modes+import           LoadIface ( showIface )+import           HscMain ( newHscEnv )++-- Imports for --abi-hash+import           LoadIface ( loadUserInterface )
+ data/examples/import/comment-inside-empty-import-list-four-out.hs view
@@ -0,0 +1,6 @@+import Package1+import Package2+import Package3 (++    -- , import1+ )
+ data/examples/import/comment-inside-empty-import-list-out.hs view
@@ -0,0 +1,6 @@+import Package1+import Package2+import Package3+  (+  -- , import1+  )
+ data/examples/import/comment-inside-empty-import-list.hs view
@@ -0,0 +1,5 @@+import Package1+import Package3 (+ -- , import1+ )+import Package2
+ data/examples/import/comment-inside-sorted-import-list-four-out.hs view
@@ -0,0 +1,7 @@+import Package1+import Package2+import Package3 (+    hi,+    -- , import1+    test,+ )
+ data/examples/import/comment-inside-sorted-import-list-out.hs view
@@ -0,0 +1,7 @@+import Package1+import Package2+import Package3+  ( hi,+    -- , import1+    test,+  )
+ data/examples/import/comment-inside-sorted-import-list.hs view
@@ -0,0 +1,7 @@+import Package1+import Package3 (+ hi,+ -- , import1+ test,+ )+import Package2
data/examples/import/comments-inside-imports-out.hs view
@@ -1,7 +1,6 @@--- x- import qualified -- x   Bar import qualified -- x   Baz-import Foo+import -- x+  Foo
data/examples/import/comments-per-import-four-out.hs view
@@ -1,4 +1,3 @@--- (1) import Bar -- (2) import Baz -- (3)-import Foo+import Foo -- (1)
data/examples/import/comments-per-import-out.hs view
@@ -1,4 +1,3 @@--- (1) import Bar -- (2) import Baz -- (3)-import Foo+import Foo -- (1)
data/examples/import/data-four-out.hs view
@@ -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,+ )
data/examples/import/data-out.hs view
@@ -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,+  )
data/examples/import/explicit-imports-with-comments-four-out.hs view
@@ -1,7 +1,5 @@ import qualified MegaModule as M (-    -- (1)-    -- (2)     Either, -- (3)-    (<<<),-    (>>>),+    (<<<), -- (2)+    (>>>), -- (1)  )
data/examples/import/explicit-imports-with-comments-out.hs view
@@ -1,7 +1,5 @@ import qualified MegaModule as M-  ( -- (1)-    -- (2)-    Either, -- (3)-    (<<<),-    (>>>),+  ( Either, -- (3)+    (<<<), -- (2)+    (>>>), -- (1)   )
data/examples/import/explicit-level-imports-four-out.hs view
@@ -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)
data/examples/import/explicit-level-imports-out.hs view
@@ -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)
data/examples/import/merging-0-four-out.hs view
@@ -1,3 +1,6 @@ import Foo-import Foo (bar, foo)+import Foo (+    bar,+    foo,+ ) import Foo as F
data/examples/import/merging-0-out.hs view
@@ -1,3 +1,6 @@ import Foo-import Foo (bar, foo)+import Foo+  ( bar,+    foo,+  ) import Foo as F
data/examples/import/merging-1-four-out.hs view
@@ -1,2 +1,5 @@ import "bar" Foo (bar)-import "foo" Foo (baz, foo)+import "foo" Foo (+    baz,+    foo,+ )
data/examples/import/merging-1-out.hs view
@@ -1,2 +1,5 @@ import "bar" Foo (bar)-import "foo" Foo (baz, foo)+import "foo" Foo+  ( baz,+    foo,+  )
data/examples/import/merging-2-four-out.hs view
@@ -1,2 +1,8 @@-import Foo hiding (bar4, foo2)-import qualified Foo (bar3, foo1)+import Foo hiding (+    bar4,+    foo2,+ )+import qualified Foo (+    bar3,+    foo1,+ )
data/examples/import/merging-2-out.hs view
@@ -1,2 +1,8 @@-import Foo hiding (bar4, foo2)-import qualified Foo (bar3, foo1)+import Foo hiding+  ( bar4,+    foo2,+  )+import qualified Foo+  ( bar3,+    foo1,+  )
data/examples/import/simple-four-out.hs view
@@ -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
data/examples/import/simple-out.hs view
@@ -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
data/examples/module-header/block-haddock-in-export-list-out.hs view
@@ -1,5 +1,5 @@ module Foo-  ( -- | asdf+  ( {- | asdf -}     foo,   ) where
data/examples/module-header/empty-haddock-four-out.hs view
@@ -1,1 +1,3 @@+-- \|+-- module Test where
data/examples/module-header/empty-haddock-out.hs view
@@ -1,1 +1,3 @@+-- \|+-- module Test where
+ data/examples/other/block-comment-before-argument-four-out.hs view
@@ -0,0 +1,5 @@+checkPragma =+    ifM+        (anyM isBuiltin [builtinNat, builtinBool])+        {-then-} ok+        {-else-} notPostulate
+ data/examples/other/block-comment-before-argument-out.hs view
@@ -0,0 +1,5 @@+checkPragma =+  ifM+    (anyM isBuiltin [builtinNat, builtinBool])+    {-then-} ok+    {-else-} notPostulate
+ data/examples/other/block-comment-before-argument.hs view
@@ -0,0 +1,4 @@+checkPragma =+        ifM (anyM isBuiltin [builtinNat, builtinBool])+          {-then-} ok+          {-else-} notPostulate
+ data/examples/other/block-comment-before-element-four-out.hs view
@@ -0,0 +1,6 @@+eeExtensions =+    catMaybes+        [ {- 0x00 -} sniExt+        , {- 0x0a -} groupExt+        , {- 0x10 -} alpnExt+        ]
+ data/examples/other/block-comment-before-element-out.hs view
@@ -0,0 +1,6 @@+eeExtensions =+  catMaybes+    [ {- 0x00 -} sniExt,+      {- 0x0a -} groupExt,+      {- 0x10 -} alpnExt+    ]
+ data/examples/other/block-comment-before-element.hs view
@@ -0,0 +1,6 @@+eeExtensions =+    catMaybes+        [ {- 0x00 -} sniExt+        , {- 0x0a -} groupExt+        , {- 0x10 -} alpnExt+        ]
+ data/examples/other/comment-around-quasiquote-four-out.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE QuasiQuotes #-}++example =+    [ -- A+      [u||] -- B+      -- C+    , [u||] -- D+    -- E+    ] -- F
+ data/examples/other/comment-around-quasiquote-out.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE QuasiQuotes #-}++example =+  [ -- A+    [u||], -- B+    -- C+    [u||] -- D+    -- E+  ] -- F
+ data/examples/other/comment-around-quasiquote.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE QuasiQuotes #-}++example =+  [ -- A+    [u||], -- B+    -- C+    [u||] -- D+    -- E+  ] -- F
+ data/examples/other/comment-block-section-heading-four-out.hs view
@@ -0,0 +1,3 @@+{- ***+   aaa+-}
+ data/examples/other/comment-block-section-heading-out.hs view
@@ -0,0 +1,3 @@+{- ***+   aaa+-}
+ data/examples/other/comment-block-section-heading.hs view
@@ -0,0 +1,3 @@+{- ***+   aaa+-}
data/examples/other/comment-glued-together-out.hs view
@@ -1,6 +1,6 @@ module Main (main) where --- | Foo.+{- | Foo. -}  -- Bar main :: IO ()
+ data/examples/other/comment-in-empty-list-four-out.hs view
@@ -0,0 +1,9 @@+tests_Cli_Utils =+    testGroup+        "Utils"+        [++        --  testGroup "journalApplyValue" [+        --    testCase "time" $ do+        --  ]+        ]
+ data/examples/other/comment-in-empty-list-out.hs view
@@ -0,0 +1,9 @@+tests_Cli_Utils =+  testGroup+    "Utils"+    [++    --  testGroup "journalApplyValue" [+    --    testCase "time" $ do+    --  ]+    ]
+ data/examples/other/comment-in-empty-list.hs view
@@ -0,0 +1,6 @@+tests_Cli_Utils = testGroup "Utils" [++  --  testGroup "journalApplyValue" [+  --    testCase "time" $ do+  --  ]+  ]
+ data/examples/other/comment-opening-a-list-four-out.hs view
@@ -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+           ]
+ data/examples/other/comment-opening-a-list-out.hs view
@@ -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+       ]
+ data/examples/other/comment-opening-a-list.hs view
@@ -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+  ]
data/examples/other/comment-style-transform-out.hs view
@@ -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
+ data/examples/other/comment-trigger-escaping-four-out.hs view
@@ -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
+ data/examples/other/comment-trigger-escaping-out.hs view
@@ -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
+ data/examples/other/comment-trigger-escaping.hs view
@@ -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
data/examples/other/comment-two-blocks-four-out.hs view
@@ -2,7 +2,8 @@ newNames =     let (*) = flip (,)      in [ "Control" * "Monad"-    -- Foo -    -- Bar+        -- Foo++        -- Bar         ]
data/examples/other/comment-two-blocks-out.hs view
@@ -2,7 +2,8 @@ newNames =   let (*) = flip (,)    in [ "Control" * "Monad"-  -- Foo -  -- Bar+      -- Foo++      -- Bar       ]
data/examples/other/empty-haddock-four-out.hs view
@@ -1,9 +1,13 @@+-- \| module Test (+    -- \|     test, ) where +-- \| test ::+    -- \|     test -data T = T+data T = T {- \^ -}
data/examples/other/empty-haddock-out.hs view
@@ -1,9 +1,13 @@+-- \| module Test-  ( test,+  ( -- \|+    test,   ) where +-- \| test ::+  -- \|   test -data T = T+data T = T {- \^ -}
data/examples/other/invalid-haddock-weird-four-out.hs view
@@ -1,5 +1,3 @@ {-# LANGUAGE TemplateHaskell #-} -foo = foo---- \|# ${+foo = foo -- \|# ${
data/examples/other/invalid-haddock-weird-out.hs view
@@ -1,5 +1,3 @@ {-# LANGUAGE TemplateHaskell #-} -foo = foo---- \|# ${+foo = foo -- \|# ${
+ data/examples/other/pragma-below-header-four-out.hs view
@@ -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 = ()
+ data/examples/other/pragma-below-header-out.hs view
@@ -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 = ()
+ data/examples/other/pragma-below-header.hs view
@@ -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 = ()
+ data/examples/other/pragma-comment-multi-extension-four-out.hs view
@@ -0,0 +1,5 @@+-- comment+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Foo where
+ data/examples/other/pragma-comment-multi-extension-out.hs view
@@ -0,0 +1,5 @@+-- comment+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Foo where
+ data/examples/other/pragma-comment-multi-extension.hs view
@@ -0,0 +1,4 @@+-- comment+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}++module Foo where
+ data/fourmolu/haddock-style/output-auto-module=auto.hs view
@@ -0,0 +1,38 @@+-- | This is a test multiline+-- module haddock+module Foo where++-- | This is a singleline function haddock+single1 :: Int++{- | This is a singleline function haddock -}+single2 :: Int++-- | This is a multiline+-- function haddock+multi1 :: Int++{- |+This is a multiline+function haddock+-}+multi2 :: Int++{- | This is a multiline haddock+     with indentation+-}+multi_indentation :: Int++-- | This is a haddock+--+-- with two consecutive newlines+--+--+-- https://github.com/fourmolu/fourmolu/issues/172+foo :: Int+foo = 42++-- | This is a haddock containing another haddock+--+-- > {-# LANGUAGE ScopedTypeVariables #-}+haddock_in_haddock :: Int
+ data/fourmolu/haddock-style/output-auto-module=multi_line.hs view
@@ -0,0 +1,39 @@+{- | This is a test multiline+module haddock+-}+module Foo where++-- | This is a singleline function haddock+single1 :: Int++{- | This is a singleline function haddock -}+single2 :: Int++-- | This is a multiline+-- function haddock+multi1 :: Int++{- |+This is a multiline+function haddock+-}+multi2 :: Int++{- | This is a multiline haddock+     with indentation+-}+multi_indentation :: Int++-- | This is a haddock+--+-- with two consecutive newlines+--+--+-- https://github.com/fourmolu/fourmolu/issues/172+foo :: Int+foo = 42++-- | This is a haddock containing another haddock+--+-- > {-# LANGUAGE ScopedTypeVariables #-}+haddock_in_haddock :: Int
+ data/fourmolu/haddock-style/output-auto-module=multi_line_compact.hs view
@@ -0,0 +1,39 @@+{-| This is a test multiline+module haddock+-}+module Foo where++-- | This is a singleline function haddock+single1 :: Int++{- | This is a singleline function haddock -}+single2 :: Int++-- | This is a multiline+-- function haddock+multi1 :: Int++{- |+This is a multiline+function haddock+-}+multi2 :: Int++{- | This is a multiline haddock+     with indentation+-}+multi_indentation :: Int++-- | This is a haddock+--+-- with two consecutive newlines+--+--+-- https://github.com/fourmolu/fourmolu/issues/172+foo :: Int+foo = 42++-- | This is a haddock containing another haddock+--+-- > {-# LANGUAGE ScopedTypeVariables #-}+haddock_in_haddock :: Int
+ data/fourmolu/haddock-style/output-auto-module=single_line.hs view
@@ -0,0 +1,38 @@+-- | This is a test multiline+-- module haddock+module Foo where++-- | This is a singleline function haddock+single1 :: Int++{- | This is a singleline function haddock -}+single2 :: Int++-- | This is a multiline+-- function haddock+multi1 :: Int++{- |+This is a multiline+function haddock+-}+multi2 :: Int++{- | This is a multiline haddock+     with indentation+-}+multi_indentation :: Int++-- | This is a haddock+--+-- with two consecutive newlines+--+--+-- https://github.com/fourmolu/fourmolu/issues/172+foo :: Int+foo = 42++-- | This is a haddock containing another haddock+--+-- > {-# LANGUAGE ScopedTypeVariables #-}+haddock_in_haddock :: Int
+ data/fourmolu/haddock-style/output-auto.hs view
@@ -0,0 +1,38 @@+-- | This is a test multiline+-- module haddock+module Foo where++-- | This is a singleline function haddock+single1 :: Int++{- | This is a singleline function haddock -}+single2 :: Int++-- | This is a multiline+-- function haddock+multi1 :: Int++{- |+This is a multiline+function haddock+-}+multi2 :: Int++{- | This is a multiline haddock+     with indentation+-}+multi_indentation :: Int++-- | This is a haddock+--+-- with two consecutive newlines+--+--+-- https://github.com/fourmolu/fourmolu/issues/172+foo :: Int+foo = 42++-- | This is a haddock containing another haddock+--+-- > {-# LANGUAGE ScopedTypeVariables #-}+haddock_in_haddock :: Int
+ data/fourmolu/haddock-style/output-multi_line-module=auto.hs view
@@ -0,0 +1,41 @@+-- | This is a test multiline+-- module haddock+module Foo where++-- | This is a singleline function haddock+single1 :: Int++-- | This is a singleline function haddock+single2 :: Int++{- | This is a multiline+function haddock+-}+multi1 :: Int++{- |+This is a multiline+function haddock+-}+multi2 :: Int++{- | This is a multiline haddock+     with indentation+-}+multi_indentation :: Int++{- | This is a haddock++with two consecutive newlines+++https://github.com/fourmolu/fourmolu/issues/172+-}+foo :: Int+foo = 42++{- | This is a haddock containing another haddock++> {-# LANGUAGE ScopedTypeVariables #-}+-}+haddock_in_haddock :: Int
+ data/fourmolu/haddock-style/output-multi_line_compact-module=auto.hs view
@@ -0,0 +1,41 @@+-- | This is a test multiline+-- module haddock+module Foo where++-- | This is a singleline function haddock+single1 :: Int++-- | This is a singleline function haddock+single2 :: Int++{-| This is a multiline+function haddock+-}+multi1 :: Int++{-|+This is a multiline+function haddock+-}+multi2 :: Int++{-| This is a multiline haddock+     with indentation+-}+multi_indentation :: Int++{-| This is a haddock++with two consecutive newlines+++https://github.com/fourmolu/fourmolu/issues/172+-}+foo :: Int+foo = 42++{-| This is a haddock containing another haddock++> {-# LANGUAGE ScopedTypeVariables #-}+-}+haddock_in_haddock :: Int
+ data/fourmolu/haddock-style/output-single_line-module=auto.hs view
@@ -0,0 +1,36 @@+-- | This is a test multiline+-- module haddock+module Foo where++-- | This is a singleline function haddock+single1 :: Int++-- | This is a singleline function haddock+single2 :: Int++-- | This is a multiline+-- function haddock+multi1 :: Int++-- |+-- This is a multiline+-- function haddock+multi2 :: Int++-- | This is a multiline haddock+--      with indentation+multi_indentation :: Int++-- | This is a haddock+--+-- with two consecutive newlines+--+--+-- https://github.com/fourmolu/fourmolu/issues/172+foo :: Int+foo = 42++-- | This is a haddock containing another haddock+--+-- > {-# LANGUAGE ScopedTypeVariables #-}+haddock_in_haddock :: Int
data/fourmolu/import-grouping/input.hs view
@@ -14,3 +14,7 @@ import Text.Printf (printf) import qualified SomeModule import SomeInternal.Module2++import Foo+-- some comment+import Foo.Bar
data/fourmolu/import-grouping/output-by_qualified.hs view
@@ -5,6 +5,9 @@ import Data.Functor import Data.Maybe (maybe) import Data.Text (Text)+import Foo+-- some comment+import Foo.Bar import SomeInternal.Module1 (anotherDefinition, someDefinition) import SomeInternal.Module2 import Text.Printf (printf)
data/fourmolu/import-grouping/output-by_scope.hs view
@@ -6,6 +6,9 @@ import Data.Maybe (maybe) import Data.Text (Text) import qualified Data.Text+import Foo+-- some comment+import Foo.Bar import qualified SomeModule import qualified System.IO as SIO import Text.Printf (printf)
data/fourmolu/import-grouping/output-by_scope_then_qualified.hs view
@@ -5,6 +5,9 @@ import Data.Functor import Data.Maybe (maybe) import Data.Text (Text)+import Foo+-- some comment+import Foo.Bar import Text.Printf (printf)  import qualified Data.Text
data/fourmolu/import-grouping/output-custom.hs view
@@ -2,6 +2,9 @@  import Data.Either import Data.Functor+import Foo+-- some comment+import Foo.Bar import SomeInternal.Module2  import Data.Text (Text)
data/fourmolu/import-grouping/output-preserve.hs view
@@ -14,3 +14,7 @@ import qualified SomeModule import qualified System.IO as SIO import Text.Printf (printf)++import Foo+-- some comment+import Foo.Bar
data/fourmolu/import-grouping/output-single.hs view
@@ -6,6 +6,9 @@ import Data.Maybe (maybe) import Data.Text (Text) import qualified Data.Text+import Foo+-- some comment+import Foo.Bar import SomeInternal.Module1 (anotherDefinition, someDefinition) import SomeInternal.Module2 import qualified SomeInternal.Module2 as Mod2
data/fourmolu/sort-deriving-clauses/input.hs view
@@ -7,6 +7,6 @@   deriving (ToJSON)  data B -  -- A comment that will end up in an odd place+  -- A comment that will stay above Show   deriving stock (Show)   deriving (Eq)
data/fourmolu/sort-deriving-clauses/output-False.hs view
@@ -7,6 +7,6 @@     deriving (ToJSON)  data B-    -- A comment that will end up in an odd place+    -- A comment that will stay above Show     deriving stock (Show)     deriving (Eq)
data/fourmolu/sort-deriving-clauses/output-True.hs view
@@ -7,7 +7,6 @@     deriving newtype (Num)  data B-    -- A comment that will end up in an odd place-     deriving (Eq)+    -- A comment that will stay above Show     deriving stock (Show)
fourmolu.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: fourmolu-version: 0.20.1.0+version: 0.21.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer:@@ -8,8 +8,8 @@     George Thomas <georgefsthomas@gmail.com>     Brandon Chinn <brandonchinn178@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/fourmolu/fourmolu@@ -44,6 +44,9 @@ library   exposed-modules:     Ormolu+    Ormolu.Comments.Anchor+    Ormolu.Comments.Invariants+    Ormolu.Comments.Tree     Ormolu.Config     Ormolu.Diff.ParseResult     Ormolu.Diff.Text@@ -60,6 +63,7 @@     Ormolu.Parser.Result     Ormolu.Printer     Ormolu.Printer.Combinators+    Ormolu.Printer.CommentPlacement     Ormolu.Printer.Comments     Ormolu.Printer.Internal     Ormolu.Printer.Meat.Common@@ -86,7 +90,6 @@     Ormolu.Printer.Meat.Type     Ormolu.Printer.Meat.Type.Function     Ormolu.Printer.Operators-    Ormolu.Printer.SpanStream     Ormolu.Processing.Common     Ormolu.Processing.Cpp     Ormolu.Processing.Preprocess@@ -102,7 +105,7 @@   default-language: GHC2021   build-depends:     Cabal-syntax >=3.16 && <3.17,-    Diff >=0.4 && <2,+    Diff >=0.4 && <2.0 || >=2.0.1 && <2.1,     MemoTrie >=0.6 && <0.7,     ansi-terminal >=0.10 && <1.2,     array >=0.5 && <0.6,@@ -141,6 +144,8 @@       -Wredundant-constraints       -Wpartial-fields       -Wunused-packages+      -haddock+      -Winvalid-haddock   else     ghc-options:       -O2@@ -187,6 +192,8 @@       -Wpartial-fields       -Wunused-packages       -Wwarn=unused-packages+      -haddock+      -Winvalid-haddock   else     ghc-options:       -O2@@ -199,6 +206,7 @@   hs-source-dirs: tests   other-modules:     Ormolu.CabalInfoSpec+    Ormolu.Comments.AnchorSpec     Ormolu.Diff.TextSpec     Ormolu.Fixity.ParserSpec     Ormolu.Fixity.PrinterSpec@@ -208,6 +216,7 @@     Ormolu.Parser.ParseFailureSpec     Ormolu.Parser.PragmaSpec     Ormolu.PrinterSpec+    Ormolu.TestConfig    default-language: GHC2021   build-depends:@@ -253,6 +262,8 @@       -Wredundant-constraints       -Wpartial-fields       -Wunused-packages+      -haddock+      -Winvalid-haddock   else     ghc-options:       -O2
fourmolu.yaml view
@@ -11,7 +11,7 @@ indent-wheres: true record-brace-space: true newlines-between-decls: 1-haddock-style: single-line+haddock-style: auto haddock-style-module: null haddock-location-signature: auto let-style: inline
src/Ormolu.hs view
@@ -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,@@ -56,9 +56,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@@ -74,12 +76,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@@ -114,15 +116,44 @@         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 $ cfgPrinterOpts cfgWithIndices+  -- 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+          (cfgPrinterOpts cfgWithIndices)+          (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@@ -145,7 +176,11 @@     -- 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 $ cfgPrinterOpts cfgWithIndices+      let reformattedText =+            printSnippets+              (cfgPrinterOpts cfgWithIndices)+              (Choice.fromBool (cfgDebug cfg))+              result1        in case diffText formattedText reformattedText path of             Nothing -> return ()             Just diff -> throwIO (OrmoluNonIdempotentOutput diff)@@ -182,11 +217,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 ::
+ src/Ormolu/Comments/Anchor.hs view
@@ -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)
+ src/Ormolu/Comments/Invariants.hs view
@@ -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
+ src/Ormolu/Comments/Tree.hs view
@@ -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)
src/Ormolu/Config.hs view
@@ -113,7 +113,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),@@ -121,9 +122,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,
src/Ormolu/Config/Gen.hs view
@@ -1,5 +1,5 @@ {- FOURMOLU_DISABLE -}-{- ***** DO NOT EDIT: This module is autogenerated ***** -}+{- DO NOT EDIT: This module is autogenerated -}  {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-}@@ -240,7 +240,7 @@       "INT"     <*> f       "haddock-style"-      "How to print Haddock comments (choices: \"single-line\", \"multi-line\", or \"multi-line-compact\") (default: multi-line)"+      "How to print Haddock comments (choices: \"single-line\", \"multi-line\", \"multi-line-compact\", or \"auto\") (default: multi-line)"       "OPTION"     <*> f       "haddock-style-module"@@ -374,6 +374,7 @@   = HaddockSingleLine   | HaddockMultiLine   | HaddockMultiLineCompact+  | HaddockAuto   deriving (Eq, Show, Enum, Bounded)  data HaddockPrintStyleModule@@ -524,10 +525,11 @@       "single-line" -> Right HaddockSingleLine       "multi-line" -> Right HaddockMultiLine       "multi-line-compact" -> Right HaddockMultiLineCompact+      "auto" -> Right HaddockAuto       _ ->         Left . unlines $           [ "unknown value: " <> show s-          , "Valid values are: \"single-line\", \"multi-line\", or \"multi-line-compact\""+          , "Valid values are: \"single-line\", \"multi-line\", \"multi-line-compact\", or \"auto\""           ]  instance RenderPrinterOpt HaddockPrintStyle where@@ -535,6 +537,7 @@     HaddockSingleLine -> "single-line"     HaddockMultiLine -> "multi-line"     HaddockMultiLineCompact -> "multi-line-compact"+    HaddockAuto -> "auto"  instance Aeson.FromJSON HaddockPrintStyleModule where   parseJSON =@@ -833,7 +836,7 @@     , "# Number of spaces between top-level declarations"     , "newlines-between-decls: 1"     , ""-    , "# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact)"+    , "# How to print Haddock comments (choices: single-line, multi-line, multi-line-compact, or auto)"     , "haddock-style: multi-line"     , ""     , "# How to print module docstring"
src/Ormolu/Diff/ParseResult.hs view
@@ -11,6 +11,7 @@ module Ormolu.Diff.ParseResult   ( ParseResultDiff (..),     diffParseResult,+    diffCommentStream,   ) where @@ -20,7 +21,7 @@ import Data.Foldable import Data.Function import Data.Generics-import Data.List (sortOn)+import Data.List (sort, sortOn) import Data.Text qualified as T import GHC.Data.FastString (FastString) import GHC.Hs@@ -28,6 +29,7 @@ import GHC.Types.SrcLoc import Ormolu.Config.Gen (ImportGrouping (ImportGroupSingle)) import Ormolu.Imports (normalizeImports)+import Ormolu.Imports.Grouping (GroupImportsOpts (..)) import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import Ormolu.Utils@@ -49,7 +51,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 ->@@ -65,23 +72,50 @@     } =     diffCommentStream cstream0 cstream1       <> diffHsModule-        hs0 {hsmodImports = concat . normalizeImports' $ hsmodImports hs0}-        hs1 {hsmodImports = concat . normalizeImports' $ hsmodImports hs1}+        hs0 {hsmodImports = concat $ normalizeImports' hs0}+        hs1 {hsmodImports = concat $ normalizeImports' hs1}     where       -- The exact parameters here don't matter, it just needs to be consistent-      normalizeImports' =+      normalizeImports' hsmod =         normalizeImports-          (Without #implicitPrelude)-          False+          GroupImportsOpts+            { grouping = ImportGroupSingle,+              respectful = False,+              allComments = listify (const True) hsmod+            }           mempty-          ImportGroupSingle+          (Without #implicitPrelude)+          (hsmodImports hsmod) +-- | 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.@@ -190,8 +224,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` (map (T.dropWhile isSpace) . 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) =>
src/Ormolu/Diff/Text.hs view
@@ -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
src/Ormolu/Exception.hs view
@@ -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
src/Ormolu/Fixity.hs view
@@ -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")
src/Ormolu/Fixity/Imports.hs view
@@ -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
src/Ormolu/Fixity/Internal.hs view
@@ -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} =
src/Ormolu/Imports.hs view
@@ -29,8 +29,13 @@ import GHC.Types.PkgQual import GHC.Types.SourceText import GHC.Types.SrcLoc-import Ormolu.Config (ImportGrouping)-import Ormolu.Imports.Grouping (Import (..), ImportList (..), groupImports, prepareExistingGroups)+import Ormolu.Imports.Grouping+  ( GroupImportsOpts,+    Import (..),+    ImportList (..),+    groupImports,+    prepareExistingGroups,+  ) import Ormolu.Utils (notImplemented, showOutputable)  -- | Sort, group and normalize imports.@@ -39,21 +44,20 @@ -- sorted by source location, so this function should be called at most once on a -- given input list. normalizeImports ::-  Choice "implicitPrelude" ->-  Bool ->+  GroupImportsOpts ->   Set Cabal.ModuleName ->-  ImportGrouping ->+  Choice "implicitPrelude" ->   [LImportDecl GhcPs] ->   [[LImportDecl GhcPs]]-normalizeImports implicitPrelude respectful localModules importGrouping =+normalizeImports groupImportsOpts localModules implicitPrelude =   map (fmap snd)     . concatMap-      ( groupImports importGrouping localModules toImport+      ( groupImports groupImportsOpts localModules toImport           . M.toAscList           . M.fromListWith combineImports           . fmap (\x -> (importId implicitPrelude x, g x))       )-    . prepareExistingGroups importGrouping respectful+    . prepareExistingGroups groupImportsOpts   where     toImport :: (ImportId, x) -> Import     toImport (ImportId {..}, _) =@@ -81,20 +85,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,@@ -253,7 +278,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
src/Ormolu/Imports/Grouping.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}  module Ormolu.Imports.Grouping   ( Import (..),     ImportList (..),+    GroupImportsOpts (..),     prepareExistingGroups,     groupImports,   )@@ -15,14 +18,17 @@ import Data.List (groupBy, minimumBy, sortOn) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty+import Data.Map qualified as Map+import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Set qualified as Set import Distribution.ModuleName qualified as Cabal-import GHC.Hs (GhcPs, getLocA)+import GHC.Hs (GhcPs, LEpaComment, epaLocationRealSrcSpan, getLocA)+import GHC.Types.SrcLoc (getLoc, srcSpanEndLine, srcSpanStartLine, srcSpanToRealSrcSpan) import Language.Haskell.Syntax (LImportDecl, ModuleName, moduleNameString) import Ormolu.Config (ImportGroup (..), ImportGroupRule (..), ImportGrouping (..)) import Ormolu.Config qualified as Config-import Ormolu.Utils (ghcModuleNameToCabal, groupBy', separatedByBlank)+import Ormolu.Utils (ghcModuleNameToCabal, groupBy') import Ormolu.Utils.Glob (matchAllGlob, matchesGlob)  newtype ImportGroups = ImportGroups (NonEmpty ImportGroup)@@ -158,20 +164,53 @@             Config.MatchExternalModules -> not isLocalModule             Config.MatchLocalModules -> isLocalModule -prepareExistingGroups :: ImportGrouping -> Bool -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]]-prepareExistingGroups ig respectful =-  case ig of+data GroupImportsOpts = GroupImportsOpts+  { grouping :: ImportGrouping,+    respectful :: Bool,+    -- | All comments in the HsModule.+    --+    -- Can't retrieve comments from 'R', since 'R' runs the first time without+    -- comments.+    allComments :: [LEpaComment]+  }++prepareExistingGroups :: GroupImportsOpts -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]]+prepareExistingGroups opts =+  case opts.grouping of     ImportGroupPreserve -> preserveGroups-    ImportGroupLegacy | respectful -> preserveGroups+    ImportGroupLegacy | opts.respectful -> preserveGroups     _ -> flattenGroups   where-    preserveGroups = map toList . groupBy' (\x y -> not $ separatedByBlank getLocA x y)+    preserveGroups = map toList . groupBy' (\x y -> not $ separatedByBlank' x y)     flattenGroups = pure -groupImports :: forall x. ImportGrouping -> Set Cabal.ModuleName -> (x -> Import) -> [x] -> [[x]]-groupImports ig localModules fToImport = regroup . fmap (breakTies . matchRules)+    -- separatedByBlank only checks if the span lines are more than 1 apart.+    -- If there's a comment between two imports with no blank lines, we should+    -- still consider it one import group.+    separatedByBlank' a b =+      fromMaybe False $ do+        endA <- srcSpanEndLine <$> srcSpanToRealSrcSpan (getLocA a)+        startB <- srcSpanStartLine <$> srcSpanToRealSrcSpan (getLocA b)+        pure . any (not . hasComment) $ [endA + 1 .. startB - 1]++    -- Maps startLine -> endLine+    commentLineIntervals =+      Map.fromList+        [ (srcSpanStartLine spn, srcSpanEndLine spn)+        | comment <- opts.allComments,+          let spn = epaLocationRealSrcSpan $ getLoc comment+        ]+    hasComment lineNum =+      (not . Map.null)+        -- Find any comment where: startLine <= lineNum <= endLine+        . Map.filter (>= lineNum)+        . Map.takeWhileAntitone (<= lineNum)+        $ commentLineIntervals++groupImports :: forall x. GroupImportsOpts -> Set Cabal.ModuleName -> (x -> Import) -> [x] -> [[x]]+groupImports opts localModules fToImport = regroup . fmap (breakTies . matchRules)   where-    ImportGroups igs = groupsFromConfig ig+    ImportGroups igs = groupsFromConfig opts.grouping      indexedGroupRules :: [(Int, [ImportGroupRule])]     indexedGroupRules = zip [0 ..] (toList . igRules <$> toList igs)
src/Ormolu/Parser.hs view
@@ -152,20 +152,23 @@       parser = case cfgSourceType of         ModuleSource -> GHC.parseModule         SignatureSource -> GHC.parseSignature+      implicitPrelude =+        Choice.fromBool $+          EnumSet.member ImplicitPrelude (GHC.extensionFlags dynFlags)       r = case runParser parser dynFlags path input of         GHC.PFailed pstate ->           case pStateErrors pstate of             Just err -> Left err             Nothing -> error "PFailed does not have an error"-        GHC.POk pstate (L _ (normalizeModule config -> hsModule)) ->+        GHC.POk pstate (L _ (normalizeModule implicitPrelude config -> 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@@ -174,6 +177,7 @@                         prStackHeader = stackHeader,                         prPragmas = pragmas,                         prCommentStream = comments,+                        prHaddockText = haddockText,                         prExtensions = GHC.extensionFlags dynFlags,                         prModuleFixityMap = modFixityMap,                         prIndent = indent,@@ -184,13 +188,15 @@ -- | Normalize a 'HsModule' by sorting its export lists, dropping -- blank comments, etc. normalizeModule ::+  Choice "implicitPrelude" ->   Config RegionDeltas ->   HsModule GhcPs ->   HsModule GhcPs-normalizeModule Config {..} hsmod =+normalizeModule _ Config {..} hsmod =   everywhere     ( mkT dropBlankTypeHaddocks         `extT` dropBlankDataDeclHaddocks+        `extT` dropBlankConDeclFieldHaddocks         `extT` patchContext         `extT` patchExprContext     )@@ -220,6 +226,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 +241,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 _ inner))]@@ -257,7 +270,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@@ -275,11 +288,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
src/Ormolu/Parser/CommentStream.hs view
@@ -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
src/Ormolu/Parser/Pragma.hs view
@@ -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,
src/Ormolu/Parser/Result.hs view
@@ -1,16 +1,20 @@--- | 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.Set (Set) import Data.Text (Text) import Distribution.ModuleName (ModuleName) import GHC.Data.EnumSet (EnumSet) import GHC.Hs (GhcPs, HsModule) import GHC.LanguageExtensions.Type+import GHC.Types.SrcLoc (getLoc) import Ormolu.Config (SourceType) import Ormolu.Fixity (ModuleFixityMap) import Ormolu.Parser.CommentStream@@ -23,7 +27,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,@@ -31,12 +35,29 @@     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,     -- | Local modules     prLocalModules :: Set ModuleName   }++-- | 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
src/Ormolu/Printer.hs view
@@ -3,8 +3,14 @@ {-# 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,     PrinterOpts (..),   ) where@@ -12,39 +18,94 @@ 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.Config+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. printSnippets ::+  PrinterOptsTotal ->   -- | Whether to print out debug information during printing   Choice "debug" ->   -- | Result of parsing   [SourceSnippet] ->-  PrinterOptsTotal ->   -- | Resulting rendition   Text-printSnippets debug snippets printerOpts = T.concat . fmap printSnippet $ snippets+printSnippets printerOpts debug = T.concat . fmap fst . printSnippetsWithPlacements printerOpts 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 ::+  PrinterOptsTotal ->+  -- | 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 printerOpts debug = fmap (renderSnippet printerOpts debug)++-- | Render one snippet. A snippet that could not be parsed is passed+-- through as it was.+renderSnippet ::+  PrinterOptsTotal ->+  Choice "debug" ->+  SourceSnippet ->+  (Text, [CommentPlacement])+renderSnippet printerOpts debug = \case+  ParsedSnippet r -> render printerOpts 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 ::+  PrinterOptsTotal ->+  Choice "debug" ->+  ParseResult ->+  (Text, [CommentPlacement])+render printerOpts 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-            printerOpts-            prLocalModules-            prSourceType-            prExtensions-            prModuleFixityMap-            debug-      RawSnippet r -> r+    renderWith anchorMap =+      let (rendered, placements, visited) =+            runR+              ( p_hsModule+                  prStackHeader+                  prPragmas+                  prParsedSource+              )+              anchorMap+              printerOpts+              prLocalModules+              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
src/Ormolu/Printer/Combinators.hs view
@@ -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@@ -33,9 +33,10 @@     askModuleFixityMap,     askDebug,     located,-    encloseLocated,+    locatedEmpty,     located',     switchLayout,+    switchLayoutWithEnclosingComments,     switchLayoutNoLimit,     spansLayout,     enterLayout,@@ -72,7 +73,6 @@     comma,     commaDel,     commaDelImportExport,-    equals,     token'Larrowtail,     token'Rarrowtail,     token'darrow,@@ -90,12 +90,15 @@     token'lolly,      -- ** Stateful markers-    SpanMark (..),-    spanMarkSpan,+    LastEmitted (..),+    lastEmittedSpan,     HaddockStyle (..),-    setSpanMark,-    getSpanMark,+    setLastEmitted,+    getLastEmitted, +    -- ** Haddocks+    lookupHaddockText,+     -- ** Placement     Placement (..),     placeHanging,@@ -104,6 +107,7 @@  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.LanguageExtensions.Type@@ -112,6 +116,7 @@ import Ormolu.Config import Ormolu.Printer.Comments import Ormolu.Printer.Internal+import Ormolu.Utils (combineSrcSpans')  ---------------------------------------------------------------------------- -- Basic@@ -126,7 +131,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.@@ -134,59 +139,67 @@   (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 r = do-  layout <- spansLayout spans-  enterLayout layout r+switchLayout spans' m = do+  csSpans <- commentSpansIn (combineSrcSpans' <$> NE.nonEmpty spans')+  layout <- spansLayout (spans' <> csSpans)+  enterLayout layout m  -- | Same as 'switchLayout', except disregards the column limit. --@@ -195,7 +208,57 @@ switchLayoutNoLimit :: [SrcSpan] -> R () -> R () switchLayoutNoLimit spans = enterLayout (spansLayoutWithLimit NoLimit spans) --- | 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)+  layout <- spansLayout (spans' <> csSpans)+  enterLayout layout 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] -> R Layout spansLayout spans = do   colLimit <- getPrinterOpt poColumnLimit@@ -217,14 +280,14 @@            in spanLineLength > fromIntegral maxLineLength         _ -> False --- | 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@@ -234,7 +297,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 () ->@@ -245,9 +308,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")@@ -262,8 +325,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")@@ -302,7 +365,7 @@ ---------------------------------------------------------------------------- -- Wrapping --- | 'BracketStyle' controlling how closing bracket is rendered.+-- | 'BracketStyle' controlling how the closing bracket is rendered. data BracketStyle   = -- | Normal     N@@ -310,30 +373,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 token'oparenbar token'cparenbar --- | Surround given entity by curly braces @{@ and  @}@.+-- | Surround the given entity with curly braces @{@ and @}@. braces :: BracketStyle -> R () -> R () braces = brackets_ False (txt "{") (txt "}") --- | Surround given entity by square brackets @[@ and @]@.+-- | Surround the given entity with square brackets @[@ and @]@. brackets :: BracketStyle -> R () -> R () brackets = brackets_ False (txt "[") (txt "]") --- | Surround given entity by parentheses @(@ and @)@.+-- | Surround the given entity with parentheses @(@ and @)@. parens :: BracketStyle -> R () -> R () parens = brackets_ False (txt "(") (txt ")") --- | Surround given entity by @(# @ and @ #)@.+-- | Surround the given entity with @(# @ and @ #)@. parensHash :: BracketStyle -> R () -> R () parensHash = brackets_ True (txt "(#") (txt "#)") @@ -444,10 +508,6 @@   Leading -> breakpoint' >> comma >> space   Trailing -> comma >> breakpoint --- | Print @=@. Do not use @'txt' "="@.-equals :: R ()-equals = interferingTxt "="- ---------------------------------------------------------------------------- -- Token literals -- The names of the following literals are from GHC's@@ -527,13 +587,13 @@ -- 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
+ src/Ormolu/Printer/CommentPlacement.hs view
@@ -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)
src/Ormolu/Printer/Comments.hs view
@@ -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)
src/Ormolu/Printer/Internal.hs view
@@ -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.@@ -14,7 +14,6 @@     -- * Internal functions     txt,     txtStripIndent,-    interferingTxt,     atom,     space,     newline,@@ -44,22 +43,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,   )@@ -71,10 +75,9 @@ import Data.Bool (bool) import Data.Char (isSpace) import Data.Choice (Choice)-import Data.Coerce-import Data.Functor ((<&>)) import Data.Functor.Identity (runIdentity) import Data.List (find)+import Data.Map.Strict qualified as M import Data.Maybe (listToMaybe) import Data.Set (Set) import Data.Text (Text)@@ -87,17 +90,18 @@ import GHC.LanguageExtensions.Type import GHC.Types.SrcLoc import GHC.Utils.Outputable (Outputable)+import Ormolu.Comments.Anchor (AnchorMap, commentsAnchoredWithin, commentsBefore) import Ormolu.Config 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) @@ -109,7 +113,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,@@ -122,7 +126,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'.@@ -133,22 +139,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@@ -164,17 +174,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) @@ -182,10 +192,8 @@ runR ::   -- | Monad to run   R () ->-  -- | Span stream-  SpanStream ->-  -- | Comment stream-  CommentStream ->+  -- | Comments, attached to the elements they belong to+  AnchorMap ->   PrinterOptsTotal ->   Set ModuleName ->   -- | Whether the source is a signature or a regular module@@ -196,11 +204,18 @@   ModuleFixityMap ->   -- | Whether to print out debug information during printing   Choice "debug" ->-  -- | Resulting rendition-  Text-runR (R m) sstream cstream printerOpts localModules 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 printerOpts localModules 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,@@ -212,19 +227,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 = []         }  ----------------------------------------------------------------------------@@ -235,12 +252,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.@@ -269,17 +281,9 @@   let (leadingSpaces, s') = T.span isSpace s   txt $ T.drop indent leadingSpaces <> s' --- | 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 ->@@ -296,8 +300,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 ->@@ -334,12 +336,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@@ -378,18 +380,25 @@         scRequestedDelimiter = AfterNewline       } --- | 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@@ -439,9 +448,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@@ -512,16 +521,16 @@   let step = truncate $ fromIntegral indentStep * x   inciBy step m --- | 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 = inciByFrac 1 --- | 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@@ -542,7 +551,7 @@     Leading -> id x     Trailing -> sitcc x --- | 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@@ -551,7 +560,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 ->@@ -564,7 +573,7 @@     SingleLine -> sline     MultiLine -> mline --- | Get current 'Layout'.+-- | Get the current 'Layout'. getLayout :: R Layout getLayout = R (asks rcLayout) @@ -578,10 +587,10 @@ ---------------------------------------------------------------------------- -- 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 ->@@ -594,52 +603,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) ->@@ -647,7 +638,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@@ -663,23 +654,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@@ -690,19 +702,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
src/Ormolu/Printer/Meat/Common.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-}  -- | Rendering of commonly useful bits.@@ -12,20 +14,31 @@     p_qualName,     p_infixDefHelper,     p_hsDoc,-    p_hsDoc',+    p_hsDocInline,+    p_hsDocWith,+    multiLineIfDocumented,+    switchLayoutDocumented,+    hasLineHaddocks,+    p_hsDocName,     p_sourceText,     p_namespaceSpec,     p_hsMultAnn,     p_arrow,+    getIsFourmoluMultiHaddockPrintStyle,   ) where  import Control.Monad-import Data.Choice (Choice)+import Data.Choice (Choice, pattern Is, pattern Isn't) import Data.Choice qualified as Choice-import Data.Foldable (traverse_)+import Data.Data (Data)+import Data.Generics.Schemes (listify)+import Data.List.NonEmpty qualified as NE+import Data.Maybe (isJust)+import Data.Text (Text) import Data.Text qualified as T import GHC.Data.FastString+import GHC.Hs (ConDecl (..), LConDecl) import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Extension (GhcPs)@@ -39,6 +52,7 @@ import GHC.Types.SrcLoc import Language.Haskell.Syntax.Module.Name import Ormolu.Config+import Ormolu.Parser.CommentStream (Comment, isMultilineComment, unComment) import Ormolu.Printer.Combinators import Ormolu.Utils @@ -49,7 +63,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@@ -92,6 +107,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@@ -111,7 +131,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@@ -128,7 +148,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" ->@@ -164,6 +185,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 ->@@ -174,64 +200,168 @@   R () p_hsDoc hstyle needsNewline lstr = do   poHStyle <- getPrinterOpt poHaddockStyle-  p_hsDoc' poHStyle hstyle needsNewline lstr+  p_hsDocWith poHStyle hstyle needsNewline (Isn't #mayShareLine) lstr --- | Print a Haddock.-p_hsDoc' ::+-- | '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 -> Choice "endNewline" -> LHsDoc GhcPs -> R ()+p_hsDocInline hstyle needsNewline lstr = do+  poHStyle <- getPrinterOpt poHaddockStyle+  p_hsDocWith poHStyle hstyle needsNewline (Is #mayShareLine) lstr++-- | The worker behind 'p_hsDoc' and 'p_hsDocInline'.+p_hsDocWith ::   -- | 'haddock-style' configuration option   HaddockPrintStyle ->-  -- | Haddock style   HaddockStyle ->-  -- | Finish the doc string with a newline   Choice "endNewline" ->-  -- | The 'LHsDoc' to render+  Choice "mayShareLine" ->   LHsDoc GhcPs ->   R ()-p_hsDoc' poHStyle hstyle needsNewline (L l str) = do-  let isCommentSpan = \case-        HaddockSpan _ _ -> True-        CommentSpan _ -> True+p_hsDocWith poHStyle hstyle needsNewline mayShareLine ldoc = 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--  if poHStyle == HaddockSingleLine || length docStringLines <= 1-    then do+  poHStyle' <- resolveHaddockPrintStyle poHStyle hstyle ldoc+  case poHStyle' of+    HaddockPrint_AsWritten written -> do+      let lns = unComment written+      sitcc . sequence_ . NE.intersperse newline . fmap txt $ lns+    HaddockPrint_Single -> do       txt $ "-- " <> haddockDelim       space       sep (newline >> txt "--" >> space) txt docStringLines-    else do-      txt . T.concat $-        [ "{-",-          case (hstyle, poHStyle) of-            (Pipe, HaddockMultiLineCompact) -> ""-            _ -> " ",-          haddockDelim-        ]+    HaddockPrint_Multi delimSpace -> do+      txt $ "{-" <> delimSpace <> haddockDelim       space       sep multilineCommentNewline txtStripIndent docStringLines       newline       txt "-}"--  when (Choice.isTrue needsNewline) newline-  traverse_ (setSpanMark . HaddockSpan hstyle) =<< getSrcSpan l+  -- 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 && isMultilineHaddockPrintStyle poHStyle'+      then breakpoint+      else newline+  case getLoc ldoc 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 the+      -- nearest enclosing span.+      getEnclosingSpan >>= mapM_ (setLastEmitted . LastEmittedHaddock)+    RealSrcSpan spn _ -> setLastEmitted (LastEmittedHaddock spn)   where+    docStringLines = getDocStringLines ldoc     haddockDelim =       case hstyle of         Pipe -> "|"         Caret -> "^"         Asterisk n -> T.replicate n "*"         Named name -> "$" <> T.pack name-    getSrcSpan = \case-      -- 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-      -- nearest enclosing span.-      UnhelpfulSpan _ -> getEnclosingSpan-      RealSrcSpan spn _ -> pure $ Just spn +-- | 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 = do+      poHStyle <- getPrinterOpt poHaddockStyle+      not . isMultilineHaddockPrintStyle <$> resolveHaddockPrintStyle poHStyle 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 = 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   NoSourceText -> pure ()@@ -260,3 +390,57 @@     p_mult mult     space     token'rarrow++{----- Fourmolu: HaddockPrintStyle -----}++data HaddockPrintStyleResolved+  = HaddockPrint_AsWritten Comment+  | HaddockPrint_Single+  | HaddockPrint_Multi Text++resolveHaddockPrintStyle :: HaddockPrintStyle -> HaddockStyle -> LHsDoc GhcPs -> R HaddockPrintStyleResolved+resolveHaddockPrintStyle poHStyle hstyle ldoc =+  case poHStyle of+    HaddockSingleLine -> pure HaddockPrint_Single+    HaddockMultiLine -> resolveMulti " "+    HaddockMultiLineCompact -> resolveMulti $ case hstyle of Pipe -> ""; _ -> " "+    HaddockAuto -> do+      -- 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.+      --+      -- If we can't figure out what the author wrote, fallback to single-line haddocks+      asWritten <- haddockAsWritten hstyle ldoc+      pure $ maybe HaddockPrint_Single HaddockPrint_AsWritten asWritten+  where+    resolveMulti delimSpace =+      pure $+        if length (getDocStringLines ldoc) <= 1+          then HaddockPrint_Single+          else HaddockPrint_Multi delimSpace++isMultilineHaddockPrintStyle :: HaddockPrintStyleResolved -> Bool+isMultilineHaddockPrintStyle = \case+  HaddockPrint_AsWritten written -> isMultilineComment written+  HaddockPrint_Single -> False+  HaddockPrint_Multi _ -> True++getDocStringLines :: LHsDoc GhcPs -> [Text]+getDocStringLines = splitDocString . hsDocString . unLoc++-- Hack to workaround upstream bug+-- https://github.com/tweag/ormolu/issues/1225+getIsFourmoluMultiHaddockPrintStyle :: LConDecl GhcPs -> R Bool+getIsFourmoluMultiHaddockPrintStyle (L _ decl) = do+  poHStyle <- getPrinterOpt poHaddockStyle+  pure $ isJust doc && isMulti poHStyle+  where+    doc =+      case decl of+        ConDeclGADT {con_doc} -> con_doc+        ConDeclH98 {con_doc} -> con_doc+    isMulti = \case+      HaddockSingleLine -> False+      HaddockMultiLine -> True+      HaddockMultiLineCompact -> True+      HaddockAuto -> False
src/Ormolu/Printer/Meat/Declaration.hs view
@@ -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 ->           declNewline : 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,
src/Ormolu/Printer/Meat/Declaration/Class.hs view
@@ -75,7 +75,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 ()
src/Ormolu/Printer/Meat/Declaration/Data.hs view
@@ -10,7 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} --- | Renedring of data type declarations.+-- | Rendering of data type declarations. module Ormolu.Printer.Meat.Declaration.Data   ( p_dataDecl,   )@@ -22,7 +22,7 @@ import Data.List (sortOn) 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 Data.Text qualified as Text import GHC.Hs import GHC.Types.Fixity@@ -116,21 +116,26 @@               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+          fourmoluSitccFix <- getIsFourmoluMultiHaddockPrintStyle first_dd_cons           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 || fourmoluSitccFix                   then sitcc                   else id           sep s (sitcc' . located' (p_conDecl singleRecCon)) dd_cons'@@ -158,7 +163,7 @@ p_conDecl :: Choice "singleRecCon" -> ConDecl GhcPs -> R () p_conDecl _ decl@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@@ -166,6 +171,10 @@       sep commaDel p_rdrName cs     inci $ p_hsFun decl   where+    -- 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     conSigSpans =@@ -181,13 +190,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@@ -197,18 +204,19 @@         if recordStyle == RecordStyleKnr then space else 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@@ -268,26 +276,27 @@ p_hsDerivingClause ::   HsDerivingClause GhcPs ->   R ()-p_hsDerivingClause HsDerivingClause {..} = do+p_hsDerivingClause HsDerivingClause {..} = multiLineIfDocumented deriv_clause_tys $ do   singleDerivingParens <- getPrinterOpt poSingleDerivingParens    txt "deriving"-  let derivingWhat = located deriv_clause_tys $ \case-        DctSingle NoExtField sigTy-          | DerivingAlways <- singleDerivingParens -> parens N $ located sigTy p_hsSigType-          | otherwise -> located sigTy p_hsSigType-        DctMulti NoExtField sigTys-          | [sigTy] <- sigTys,-            DerivingNever <- singleDerivingParens ->-              located sigTy p_hsSigType-          | otherwise -> do-              sortDerivedClasses <- getPrinterOpt poSortDerivedClasses-              let sort = if sortDerivedClasses then sortOn showOutputable else id-              parens N $-                sep-                  commaDel-                  (sitcc . located' p_hsSigType)-                  (sort sigTys)+  let derivingWhat = located deriv_clause_tys $ \tys ->+        multiLineIfDocumented tys $ case tys of+          DctSingle NoExtField sigTy+            | DerivingAlways <- singleDerivingParens -> parens N $ located sigTy p_hsSigType+            | otherwise -> located sigTy p_hsSigType+          DctMulti NoExtField sigTys+            | [sigTy] <- sigTys,+              DerivingNever <- singleDerivingParens ->+                located sigTy p_hsSigType+            | otherwise -> do+                sortDerivedClasses <- getPrinterOpt poSortDerivedClasses+                let sort = if sortDerivedClasses then sortOn showOutputable else id+                parens N $+                  sep+                    commaDel+                    (sitcc . located' p_hsSigType)+                    (sort sigTys)   space   case deriv_clause_strategy of     Nothing -> do@@ -417,19 +426,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)
src/Ormolu/Printer/Meat/Declaration/Foreign.hs view
@@ -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 ()
src/Ormolu/Printer/Meat/Declaration/Instance.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/OpTree.hs view
@@ -23,6 +23,7 @@ import GHC.Types.Name.Reader (RdrName, rdrNameOcc) import GHC.Types.SrcLoc import Ormolu.Config (poIndentation, poTrailingSectionOperators)+import Ormolu.Parser.CommentStream (LComment) import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common (p_rdrName) import Ormolu.Printer.Meat.Declaration.Value@@ -47,20 +48,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))@@ -70,7 +71,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 =@@ -117,17 +118,18 @@       couldBeTrailing (prevExpr, opi) =         -- Enabled by config         trailingSectionOperators-          -- 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@@ -144,11 +146,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   indent <- getPrinterOpt poIndentation@@ -194,6 +204,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)@@ -233,14 +249,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)) =
src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs view
@@ -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,   )
src/Ormolu/Printer/Meat/Declaration/Rule.hs view
@@ -32,7 +32,7 @@   inci $ do     located lhs p_hsExpr     space-    equals+    txt "="     inci $ do       breakpoint       located rhs p_hsExpr
src/Ormolu/Printer/Meat/Declaration/Signature.hs view
@@ -169,9 +169,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 ::
src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs view
@@ -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
src/Ormolu/Printer/Meat/Declaration/Type.hs view
@@ -45,7 +45,7 @@       (map (located' p_hsTyVarBndr) hsq_explicit)   inci $ do     space-    equals+    txt "="     if hasDocStrings (unLoc t)       then newline       else breakpoint
src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs view
@@ -70,7 +70,7 @@   KindSig NoExtField k -> Just $ do     p_hsTypeAnnotation k   TyVarSig NoExtField bndr -> Just $ do-    equals+    txt "="     breakpoint     located bndr p_hsTyVarBndr @@ -104,7 +104,7 @@         (p_lhsTypeArg <$> feqn_pats)     inci $ do       space-      equals+      txt "="       breakpoint       located feqn_rhs p_hsType
src/Ormolu/Printer/Meat/Declaration/Value.hs view
@@ -102,7 +102,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@@ -124,12 +124,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 ->@@ -180,12 +180,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 ()@@ -244,8 +244,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)@@ -299,9 +300,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 >> token'rarrow     switchLayout [patGrhssSpan] $@@ -330,7 +331,7 @@       sitccIfTrailing (sep commaDel (sitcc . located' p_stmt) xs)       space       inci $ case style of-        EqualSign -> equals+        EqualSign -> txt "="         RightArrow -> token'rarrow       -- 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@@ -414,23 +415,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)@@ -463,13 +463,13 @@   BodyStmt _ body _ _ -> located body (render s)   LetStmt epAnnLet binds -> p_let' True epAnnLet binds Nothing   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@@ -522,7 +522,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@@ -535,8 +535,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)@@ -557,18 +557,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@@ -592,7 +592,7 @@   p_lhs hfbLHS   unless hfbPun $ do     space-    equals+    txt "="     let placement =           if onTheSameLine (getLocA hfbLHS) (getLocA hfbRHS)             then exprPlacement (unLoc hfbRHS)@@ -602,8 +602,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@@ -616,7 +617,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@@ -645,7 +646,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@@ -665,8 +666,7 @@         MultiLine -> 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         let indentArg =@@ -721,13 +721,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 (sitcc $ 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) (sitccIfTrailing . 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@@ -1138,7 +1137,12 @@   txt "if"   space   located if' p_hsExpr-  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@@ -1367,7 +1371,7 @@   located hfbLHS p_fieldOcc   unless hfbPun $ do     space-    equals+    txt "="     breakpoint     inci (located hfbRHS p_pat) @@ -1443,10 +1447,10 @@         breakpoint'         endQuote     -- 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@@ -1511,7 +1515,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)) ->@@ -1519,7 +1523,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@@ -1527,14 +1531,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)) _)])@@ -1552,7 +1556,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
src/Ormolu/Printer/Meat/ImportExport.hs view
@@ -16,7 +16,6 @@ import Data.Choice (pattern Without) import Data.Foldable (for_, traverse_) import Data.List (inits)-import Data.Text qualified as T import GHC.Hs import GHC.LanguageExtensions.Type import GHC.Types.PkgQual@@ -82,18 +81,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"         breakIfNotDiffFriendly         parens' True $ do           layout <- getLayout+          when (null xs) $ locatedEmpty (locA listLoc)           sep             breakpoint             (\(p, l) -> sitcc (located l (p_lie layout False p)))             (attachRelativePos xs)-    newline  p_declLevel :: ImportDeclLevel -> R () p_declLevel = \case@@ -146,7 +145,7 @@   IEDoc NoExtField str ->     indentDoc $       p_hsDoc Pipe (Without #endNewline) str-  IEDocNamed NoExtField str -> indentDoc $ txt $ "-- $" <> T.pack str+  IEDocNamed NoExtField str -> indentDoc $ p_hsDocName str   where     -- Add a comma to a import-export list element     withComma m =
src/Ormolu/Printer/Meat/Module.hs view
@@ -11,13 +11,15 @@ where  import Control.Monad-import Data.Choice (pattern With)+import Data.Choice (pattern Isn't, pattern With) import Data.Choice qualified as Choice+import Data.Generics.Schemes (listify) import GHC.Hs hiding (comment) import GHC.LanguageExtensions (Extension (ImplicitPrelude)) import GHC.Types.SrcLoc import Ormolu.Config import Ormolu.Imports (normalizeImports)+import Ormolu.Imports.Grouping (GroupImportsOpts (..)) import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma import Ormolu.Printer.Combinators@@ -28,7 +30,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@@ -45,7 +47,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@@ -54,7 +56,12 @@       newline       importGroups <- normalizeImportsR hsmodImports       forM_ importGroups $ \importGroup -> do-        forM_ importGroup (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_ importGroup $ \x -> do+          located' p_hsmodImport x+          newline         newline       declNewline       switchLayout (getLocA <$> hsmodDecls) $ do@@ -70,10 +77,13 @@       importGrouping <- getPrinterOpt poImportGrouping       pure $         normalizeImports-          implicitPrelude-          respectful+          GroupImportsOpts+            { grouping = importGrouping,+              respectful,+              allComments = listify (const True) hsmod+            }           localModules-          importGrouping+          implicitPrelude           imports  p_hsModuleHeader :: HsModule GhcPs -> LocatedA ModuleName -> R ()@@ -83,7 +93,7 @@       getPrinterOpt poHaddockStyleModule >>= \case         PrintStyleInherit -> getPrinterOpt poHaddockStyle         PrintStyleOverride style -> pure style-    forM_ hsmodHaddockModHeader (p_hsDoc' poHStyle Pipe (With #endNewline))+    forM_ hsmodHaddockModHeader (p_hsDocWith poHStyle Pipe (With #endNewline) (Isn't #mayShareLine))     p_hsmodName name    forM_ hsmodDeprecMessage $ \w -> do@@ -108,7 +118,8 @@     Nothing -> return ()     Just l -> do       breakpointBeforeExportList-      encloseLocated l $ \exports -> do+      located l $ \exports -> do+        when (null exports) $ locatedEmpty (locA l)         inci (p_hsmodExports exports)    breakpointBeforeWhere
src/Ormolu/Printer/Meat/Pragma.hs view
@@ -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
src/Ormolu/Printer/Meat/Type.hs view
@@ -70,7 +70,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@@ -110,10 +110,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 (sitcc $ located t p_hsType)   HsIParamTy _ n t -> sitcc $ do     located n atom@@ -197,7 +195,7 @@         next = parseFunRepr ty       } --- | 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@@ -212,7 +210,10 @@  p_hsConDeclRecFields :: [LHsConDeclRecField GhcPs] -> R () p_hsConDeclRecFields xs =-  recordBraces $ sep commaDel (sitcc . located' p_hsConDeclRecField) xs+  multiLineIfDocumented xs . recordBraces $ 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 field@HsConDeclRecField {..} = withFieldHaddocks $ do@@ -227,13 +228,13 @@       commaStyle <- getPrinterOpt poCommaStyle       let doc = cdf_doc cdrf_spec       when (commaStyle == Trailing) $-        mapM_ (p_hsDoc Pipe (With #endNewline)) doc+        mapM_ (p_hsDocInline Pipe (With #endNewline)) doc       action       when (commaStyle == Leading) $-        mapM_ (inciByFrac (-1) . (newline >>) . p_hsDoc Caret (Without #endNewline)) doc+        mapM_ (inciByFrac (-1) . (newline >>) . p_hsDocInline Caret (Without #endNewline)) doc --- | 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@@ -254,8 +255,8 @@ 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"
src/Ormolu/Printer/Meat/Type/Function.hs view
@@ -56,7 +56,7 @@ import GHC.Utils.Outputable (Outputable) import Ormolu.Config import Ormolu.Printer.Combinators-import Ormolu.Printer.Meat.Common (p_arrow, p_hsDoc, p_rdrName)+import Ormolu.Printer.Meat.Common (p_arrow, p_hsDocInline, p_rdrName) import Ormolu.Utils (showOutputable) import Prelude hiding (span) @@ -479,13 +479,13 @@    if Choice.isTrue isLeadingHaddock     then do-      traverse (liftR . p_hsDoc Pipe (With #endNewline)) doc *> m+      traverse (liftR . p_hsDocInline Pipe (With #endNewline)) doc *> m     else do       let (pre, endNewline) =             if Choice.isTrue isEnd               then (when (isJust doc) (liftR newline), Without #endNewline)               else (pure (), With #endNewline)-      m <* pre <* traverse (liftR . p_hsDoc Caret endNewline) doc+      m <* pre <* traverse (liftR . p_hsDocInline Caret endNewline) doc  interArgBreak :: PrintHsFun () interArgBreak = do
src/Ormolu/Printer/Operators.hs view
@@ -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)
− src/Ormolu/Printer/SpanStream.hs 
@@ -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
src/Ormolu/Processing/Common.hs view
@@ -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 ->
src/Ormolu/Processing/Preprocess.hs view
@@ -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@@ -173,7 +173,7 @@   | Just rest <- isMagicComment "FOURMOLU_DISABLE" s = Just $ "{- FOURMOLU_DISABLE -}" <> rest   | otherwise = Nothing --- | Construct a function for whitespace-insensitive matching of string.+-- | Construct a function for whitespace-insensitive matching of a string. isMagicComment ::   -- | What to expect   Text ->
src/Ormolu/Terminal.hs view
@@ -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, Enum, Bounded) --- | Run 'Term' monad.+-- | Run the 'Term' monad. runTerm ::   Term ->   -- | Color mode
src/Ormolu/Utils.hs view
@@ -8,6 +8,7 @@     combineSrcSpans',     notImplemented,     showOutputable,+    containsHaddocks,     splitDocString,     incSpanLine,     separatedByBlank,@@ -19,6 +20,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@@ -48,7 +51,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   [] -> []@@ -67,10 +70,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]@@ -86,8 +99,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@@ -118,7 +131,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 _ ->@@ -144,7 +157,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))@@ -165,7 +179,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
src/Ormolu/Utils/Fixity.hs view
@@ -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 ->
+ tests/Ormolu/Comments/AnchorSpec.hs view
@@ -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" :| []))
tests/Ormolu/FixitySpec.hs view
@@ -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
tests/Ormolu/PrinterSpec.hs view
@@ -7,16 +7,14 @@ 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 Data.Yaml qualified as Yaml import Ormolu import Ormolu.Config-import Ormolu.Fixity+import Ormolu.TestConfig import Path import Path.IO import System.Environment (lookupEnv)@@ -35,50 +33,20 @@       <$> [(ormoluPrinterOpts, "ormolu", "-out"), (defaultPrinterOpts, "fourmolu", "-four-out")]       <*> es --- | 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 :: (PrinterOptsTotal, String, String) -> Path Rel File -> Spec checkExample (printerOpts, label, suffix) srcPath' = it (fromRelFile srcPath' ++ " works (" ++ label ++ ")") . withNiceExceptions $ do   let srcPath = examplesDir </> srcPath'       inputPath = fromRelFile srcPath-      config =-        defaultConfig-          { cfgPrinterOpts = printerOpts,-            cfgSourceType = detectSourceType inputPath,-            cfgFixityOverrides = testsuiteOverrides,-            cfgDependencies =-              Set.fromList-                [ "base",-                  "esqueleto",-                  "hspec",-                  "lens",-                  "megaparsec",-                  "optics",-                  "relude",-                  "rio",-                  "servant"-                ]-          }+      config = (exampleConfig inputPath) {cfgPrinterOpts = printerOpts}   expectedOutputPath <- deriveOutput srcPath suffix-  -- 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@@ -88,20 +56,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 -> String -> IO (Path Rel File) deriveOutput path suffix =   parseRelFile $@@ -129,7 +97,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
+ tests/Ormolu/TestConfig.hs view
@@ -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)+        ]+    )