ea2d80e...master · ormolu

.buildkite/pipeline.yml+14−3

since splitsnapshots

unifiedsplit

@@ -1,7 +1,18 @@

1steps:

2− - label: Build and test

2+ - label: Build and test with GHC 8.6.5

3+ command: |

4+ nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc865

5+ timeout: 100

6+ - label: Build and test with GHC 8.8.4

7+ command: |

8+ nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc884

9+ timeout: 100

10+ - label: Build and test with GHC 8.10.1

11+ command: |

12+ nix-build --keep-going --no-out-link --argstr ormoluCompiler ghc8101

13+ timeout: 100

14+ - wait

15+ - label: Check formatting

3 command: |

16 command: |

4− nix-build --keep-going --no-out-link

5 ./format.sh

17 ./format.sh

6 git diff --exit-code --color=always

18 git diff --exit-code --color=always

7− timeout: 100

.github/workflows/binaries.ymlnew file+39

@@ -0,0 +1,39 @@

1+name: Build binaries

2+on:

3+ release:

4+ types: [published]

5+jobs:

6+ build:

7+ strategy:

8+ fail-fast: false

9+ matrix:

10+ os: [ubuntu-latest, macOS-latest, windows-latest]

11+ runs-on: ${{ matrix.os }}

12+ steps:

13+ - uses: actions/checkout@v2

14+ - uses: actions/setup-haskell@v1

15+ if: runner.os != 'Linux'

16+ with:

17+ ghc-version: '8.10.1'

18+ cabal-version: '3.2'

19+ - name: Build Linux binary

20+ if: runner.os == 'Linux'

21+ run: |

22+ docker run \

23+ -v $(pwd):/mnt -w /mnt \

24+ utdemir/ghc-musl:v14-ghc8101 \

25+ bash .github/workflows/build.sh

26+ - name: Build ${{ runner.os }} binary

27+ if: runner.os != 'Linux'

28+ shell: bash

29+ run: |

30+ cabal build exe:ormolu

31+ cp $(find dist-newstyle $ -name ormolu -o -name ormolu.exe $ -type f) ormolu

32+ - uses: actions/upload-release-asset@v1

33+ env:

34+ GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}

35+ with:

36+ upload_url: ${{ github.event.release.upload_url }}

37+ asset_path: ormolu

38+ asset_name: ormolu-${{ runner.os }}

39+ asset_content_type: application/octet-stream

.github/workflows/build.shnew file+7

@@ -0,0 +1,7 @@

1+set -e

2+

3+cabal update

4+cabal build exe:ormolu --enable-executable-static --ghc-options="-split-sections"

5+

6+cp $(find dist-newstyle -name ormolu -type f) .

7+strip -s ormolu

CHANGELOG.md+133−3

@@ -1,5 +1,126 @@

1## Unreleased

2

3+* Ormolu no longer overwrites already formatted files. [PR

4+ 649](https://github.com/tweag/ormolu/pull/649).

5+

6+## Ormolu 0.1.2.0

7+

8+* Fixed the bug when comments in different styles got glued together after

9+ formatting. [Issue 589](https://github.com/tweag/ormolu/issues/589).

10+

11+* Added `-i` as a shortcut for `--mode inplace`. [Issue

12+ 467](https://github.com/tweag/ormolu/issues/467).

13+

14+* Improved grouping of top-level declarations. [Issue

15+ 466](https://github.com/tweag/ormolu/issues/466).

16+

17+## Ormolu 0.1.1.0

18+

19+* Imports in a import lists are now normalized: duplicate imports are

20+ combined/eliminated intelligently.

21+

22+* Import declarations that can be merged are now automatically merged.

23+ [Issue 414](https://github.com/tweag/ormolu/issues/414).

24+

25+* The magic comments for disabling and enabling Ormolu now can encompass any

26+ fragment of code provided that the remaining code after exclusion of the

27+ disabled part is still syntactically correct. [Issue

28+ 601](https://github.com/tweag/ormolu/issues/601).

29+

30+* Improved sorting of operators in imports. [Issue

31+ 602](https://github.com/tweag/ormolu/issues/602).

32+

33+* Fixed a bug related to trailing space in multiline comments in certain

34+ cases. [Issue 603](https://github.com/tweag/ormolu/issues/602).

35+

36+* Added support for formatting linked lists with `(:)` as line terminator.

37+ [Issue 478](https://github.com/tweag/ormolu/issues/478).

38+

39+* Fixed rendering of function arguments in multiline layout. [Issue

40+ 609](https://github.com/tweag/ormolu/issues/609).

41+

42+* Blank lines between definitions in `let` and `while` bindings are now

43+ preserved. [Issue 554](https://github.com/tweag/ormolu/issues/554).

44+

45+* Fixed the bug when type applications stuck to the `$` of TH splices that

46+ followed them. [Issue 613](https://github.com/tweag/ormolu/issues/613).

47+

48+* Improved region formatting so that indented fragments—such as definitions

49+ inside of `where` clauses—can be formatted. [Issue

50+ 572](https://github.com/tweag/ormolu/issues/572).

51+

52+* Fixed the bug related to the de-association of pragma comments. [Issue

53+ 619](https://github.com/tweag/ormolu/issues/619).

54+

55+## Ormolu 0.1.0.0

56+

57+* Fixed rendering of type signatures concerning several identifiers. [Issue

58+ 566](https://github.com/tweag/ormolu/issues/566).

59+

60+* Fixed an idempotence issue with inline comments in tuples and parentheses.

61+ [Issue 450](https://github.com/tweag/ormolu/issues/450).

62+

63+* Fixed an idempotence issue when certain comments were picked up as

64+ “continuation” of a series of comments [Issue

65+ 449](https://github.com/tweag/ormolu/issues/449).

66+

67+* Fixed an idempotence issue related to different indentation levels in a

68+ comment series. [Issue 512](https://github.com/tweag/ormolu/issues/512).

69+

70+* Fixed an idempotence issue related to comments which may happen to be

71+ separated from the elements they are attached to by the equality sign.

72+ [Issue 340](https://github.com/tweag/ormolu/issues/340).

73+

74+* Fixed an idempotence issue with type synonym and data declarations where

75+ the type has a Haddock. [Issue

76+ 578](https://github.com/tweag/ormolu/issues/578).

77+

78+* Fix the false positive about AST differences in presence of comments with

79+ multiple blank lines in a row. [Issue

80+ 518](https://github.com/tweag/ormolu/issues/518).

81+

82+* Fixed rendering of comments around if expressions. [Issue

83+ 458](https://github.com/tweag/ormolu/issues/458).

84+

85+* Unnamed fields of data constructors are now documented using the `-- ^`

86+ syntax. [Issue 445](https://github.com/tweag/ormolu/issues/445) and [Issue

87+ 428](https://github.com/tweag/ormolu/issues/428).

88+

89+* Fixed non-idempotent transformation of partly documented data definition.

90+ [Issue 590](https://github.com/tweag/ormolu/issues/590).

91+

92+* Fixed an idempotence issue related to operators. [Issue

93+ 522](https://github.com/tweag/ormolu/issues/522).

94+

95+* Renamed the `--check-idempotency` flag to `--check-idempotence`.

96+ Apparently only the latter is correct.

97+

98+## Ormolu 0.0.5.0

99+

100+* Grouping of statements in `do`-blocks is now preserved. [Issue

101+ 74](https://github.com/tweag/ormolu/issues/74).

102+

103+* Grouping of TH splices is now preserved. [Issue

104+ 507](https://github.com/tweag/ormolu/issues/507).

105+

106+* Comments on pragmas are now preserved. [Issue

107+ 216](https://github.com/tweag/ormolu/issues/216).

108+

109+* Ormolu can now be enabled and disabled via special comments. [Issue

110+ 435](https://github.com/tweag/ormolu/issues/435).

111+

112+* Added experimental support for simple CPP. [Issue

113+ 415](https://github.com/tweag/ormolu/issues/415).

114+

115+* Added two new options `--start-line` and `--end-line` that allow us to

116+ select a region to format. [Issue

117+ 516](https://github.com/tweag/ormolu/issues/516).

118+

119+* Fixed rendering of module headers in the presence of preceding comments or

120+ Haddocks. [Issue 561](https://github.com/tweag/ormolu/issues/561).

121+

122+## Ormolu 0.0.4.0

123+

3* When given several files to format, Ormolu does not stop on the first

124* When given several files to format, Ormolu does not stop on the first

4 failure, but tries to format all the files. [Issue

125 failure, but tries to format all the files. [Issue

5 502](https://github.com/tweag/ormolu/issues/502).

126 502](https://github.com/tweag/ormolu/issues/502).

@@ -16,13 +137,22 @@

16 now put on its own line. [Issue

137 now put on its own line. [Issue

17 509](https://github.com/tweag/ormolu/issues/509).

138 509](https://github.com/tweag/ormolu/issues/509).

18

139

19−* Implemented support for the new language extension `ImportQualifiedPost`.

140+* Fixed the bug pertaining to rendering of arrow notation with multiline

141+ expressions. [Issue 513](https://github.com/tweag/ormolu/issues/513).

20

142

21−* Implemented support for the new language extension

143+* Made rendering of data type definitions, value-level applications, and

22− `StandaloneKindSignatures`.

144+ application of types use the same style. Moreover, existential now doesn't

145+ cause the data constructor be unconditionally rendered in multiline

146+ layout. [Issue 427](https://github.com/tweag/ormolu/issues/427).

147+

148+* Records with a single data constructor are now formatted more compactly.

149+ [Issue 425](https://github.com/tweag/ormolu/issues/425).

23

150

24* Switched to `ghc-lib-parser-8.10.1`.

151* Switched to `ghc-lib-parser-8.10.1`.

25

152

153+* Implemented support for the new language extensions `ImportQualifiedPost`

154+ and `StandaloneKindSignatures`.

155+

26## Ormolu 0.0.3.1

156## Ormolu 0.0.3.1

27

157

28* Fixed rendering of record updates with the record dot preprocessor syntax

158* Fixed rendering of record updates with the record dot preprocessor syntax

CONTRIBUTING.md+1−1

@@ -30,7 +30,7 @@ Testing is performed as following:

30* The result of printing is parsed back again and the AST is compared to the

31 AST obtained from the original file. They should match.

32* The output of printer is checked against the expected output.

33−* Idempotency property is verified: formatting already formatted code

33+* Idempotence property is verified: formatting already formatted code

34 results in exactly the same output.

35

36Examples can be organized in sub-directories, see the existing ones for

DESIGN.md+11−11

@@ -24,7 +24,7 @@ It also includes recommendations for future implementers.

24

25We set for the following goals (mostly taken from

26[brittany](https://github.com/lspitzner/brittany)):

27−* Preserve the meaning of the formatted functions;

27+* Preserve the meaning of the formatted functions when no CPP is used;

28* Make reasonable use of screen space;

29* Use linear space and computation time on the size of the input;

30* Preserve comments;

@@ -140,8 +140,10 @@ impossible to guess what they'll be called on.

140

141### CPP

142

143−Formatting a module which uses CPP directives won't be supported. Instead,

143+We allow CPP directives in the input, but we forgo the goal to preserve the

144+meaning of the formatted functions in that case.

145+Instead of supporting CPP better, we hope for a solution to replace CPP to

144−we hope for a solution to replace CPP to do conditional compilation.

146+do conditional compilation.

145

147

146There are the following challenges when formatting a module with CPP:

148There are the following challenges when formatting a module with CPP:

147

149

@@ -180,14 +182,15 @@ True

180```

182```

181

183

182At the time of this writing, formatting this program with Hindent

184At the time of this writing, formatting this program with Hindent

183−produces the same output we would get if the CPP directives were

185+or Ormolu produces the same output we would get if the CPP directives

184−considered comments:

186+were considered comments:

185

187

186```

188```

187−$ hindent --version

189+$ ormolu --version

188−hindent 5.2.7

190+ormolu 0.0.5.0 HEAD fc64eada5c4da7a5b07d2872e253671b48aec115

191+using ghc-lib-parser 8.10.1.20200412

189

192

190−$ hindent test.hs

193+$ ormolu --mode inplace test.hs

191

194

192$ cat test.hs

195$ cat test.hs

193{-# LANGUAGE CPP #-}

196{-# LANGUAGE CPP #-}

@@ -227,9 +230,6 @@ to parse Haskell modules. If CPP is replaced with some language

227extension or mechanism to do conditional compilation, all tools

230extension or mechanism to do conditional compilation, all tools

228will benefit from it.

231will benefit from it.

229

232

230−Therefore, CPP won't be supported. If the CPP extension

231−is enabled, we should signal an error right away.

232−

233### Printing

234

235Just pretty-printing code (following the approach of Hindent) seems sane. It

README.md+54−13

@@ -22,7 +22,7 @@ the following goals in mind:

22* That formatting style aims to result in minimal diffs while still

23 remaining very close to “conventional” Haskell formatting people use.

24* Choose a style compatible with modern dialects of Haskell. As new Haskell

25− extensions enter broad use, we may change the style to accomodate them.

25+ extensions enter broad use, we may change the style to accommodate them.

26* Idempotence: formatting already formatted code doesn't change it.

27* Be well-tested and robust to the point that it can be used in large

28 projects without exposing unfortunate, disappointing bugs here and there.

@@ -45,11 +45,12 @@ Alternatively, `stack` could be used with a `stack.yaml` file as follows.

45

46```console

47$ cat stack.yaml

48−resolver: lts-14.3

48+resolver: lts-16.0

49packages:

50- '.'

51

52−$ stack build

52+$ stack build # to build

53+$ stack install # to install

53```

54```

54

55

55To use Ormolu directly from GitHub with Nix, this snippet may come in handy:

56To use Ormolu directly from GitHub with Nix, this snippet may come in handy:

@@ -91,21 +92,44 @@ formatted output.

91$ ormolu --mode inplace Module.hs

92$ ormolu --mode inplace Module.hs

92```

93```

93

94

95+Use `find` to format a tree recursively:

96+

97+```console

98+$ ormolu --mode inplace $(find . -name '*.hs')

99+```

100+

101+## Magic comments

102+

103+Ormolu understands two magic comments:

104+

105+```haskell

106+{- ORMOLU_DISABLE -}

107+```

108+

109+and

110+

111+```haskell

112+{- ORMOLU_ENABLE -}

113+```

114+

115+This allows us to disable formatting selectively for code between these

116+markers or disable it for the entire file. To achieve the latter, just put

117+`{- ORMOLU_DISABLE -}` at the very top. Note that the source code should

118+still be parseable even without the “excluded” part. Because of that the

119+magic comments cannot be placed arbitrary, but should rather enclose

120+independent top-level definitions.

121+

94## Current limitations

122## Current limitations

95

123

96−* Does not handle CPP (wontfix, see [the design document][design]).

124+* CPP support is experimental. CPP is virtually impossible to handle

125+ correctly, so we process them as a sort of unchangeable snippets. This

126+ works only in simple cases when CPP conditionals surround top-level

127+ declarations. See the [CPP][design-cpp] section in the design notes for

128+ a discussion of the dangers.

97* Input modules should be parsable by Haddock, which is a bit stricter

129* Input modules should be parsable by Haddock, which is a bit stricter

98 criterion than just being valid Haskell modules.

130 criterion than just being valid Haskell modules.

99* Various minor idempotence issues, most of them are related to comments.

131* Various minor idempotence issues, most of them are related to comments.

100

132

101−## Editor integration

102−

103−We know of the following editor integrations:

104−

105−* [Emacs][emacs-package]

106−* [VS Code][vs-code-plugin]

107−* vim: [neoformat][neoformat], [vim-ormolu][vim-ormolu]

108−

109## Running on Hackage

133## Running on Hackage

110

134

111It's possible to try Ormolu on arbitrary packages from Hackage. For that

135It's possible to try Ormolu on arbitrary packages from Hackage. For that

@@ -120,6 +144,22 @@ also contain formatted `.hs` files for inspection and original inputs with

120`.hs-original` extension (those are with CPP dropped, exactly what is fed

144`.hs-original` extension (those are with CPP dropped, exactly what is fed

121into Ormolu).

145into Ormolu).

122

146

147+## Editor integration

148+

149+We know of the following editor integrations:

150+

151+* [Emacs][emacs-package]

152+* [VS Code][vs-code-plugin]

153+* vim: [neoformat][neoformat], [vim-ormolu][vim-ormolu]

154+

155+## Arch Linux

156+

157+To install Ormolu on Arch Linux, one can use [the package on AUR][aur]:

158+

159+```console

160+yay -S ormolu

161+```

162+

123## Contributing

163## Contributing

124

164

125See [CONTRIBUTING.md][contributing].

165See [CONTRIBUTING.md][contributing].

@@ -130,7 +170,7 @@ See [LICENSE.md][license].

130

170

132

172

133−[design]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp

173+[design-cpp]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp

134[contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md

174[contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md

135[license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md

175[license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md

136[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts

176[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts

138[vs-code-plugin]: https://marketplace.visualstudio.com/items?itemName=sjurmillidahl.ormolu-vscode

178[vs-code-plugin]: https://marketplace.visualstudio.com/items?itemName=sjurmillidahl.ormolu-vscode

139[vim-ormolu]: https://github.com/sdiehl/vim-ormolu

179[vim-ormolu]: https://github.com/sdiehl/vim-ormolu

140[neoformat]: https://github.com/sbdchd/neoformat

180[neoformat]: https://github.com/sbdchd/neoformat

181+[aur]: https://aur.archlinux.org/packages/ormolu

app/Main.hs+48−36

@@ -4,13 +4,11 @@

4{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE TypeApplications #-}

6

7−module Main

7+module Main (main) where

8− ( main,

9− )

10−where

11

8

12import Control.Exception (SomeException, displayException, try)

9import Control.Exception (SomeException, displayException, try)

13import Control.Monad

10import Control.Monad

11+import Data.Bool (bool)

14import Data.Either (lefts)

12import Data.Either (lefts)

15import Data.List (intercalate, sort)

13import Data.List (intercalate, sort)

16import qualified Data.Text.IO as TIO

14import qualified Data.Text.IO as TIO

@@ -37,9 +35,8 @@ main = withPrettyOrmoluExceptions $ do

37 -- It is possible to get IOException, error's and 'OrmoluException's

35 -- It is possible to get IOException, error's and 'OrmoluException's

38 -- from 'formatOne', so we just catch everything.

36 -- from 'formatOne', so we just catch everything.

39 errs <-

37 errs <-

40− lefts <$> mapM (try @SomeException . formatOne' . Just) xs

38+ lefts <$> mapM (try @SomeException . formatOne' . Just) (sort xs)

41 unless (null errs) $ do

39 unless (null errs) $ do

42− hPutStrLn stderr "Some files failed to format:\n"

43 mapM_ (hPutStrLn stderr . displayException) errs

40 mapM_ (hPutStrLn stderr . displayException) errs

44 exitWith (ExitFailure 102)

41 exitWith (ExitFailure 102)

45

42

@@ -48,7 +45,7 @@ formatOne ::

48 -- | Mode of operation

45 -- | Mode of operation

49 Mode ->

46 Mode ->

50 -- | Configuration

47 -- | Configuration

51− Config ->

48+ Config RegionIndices ->

52 -- | File to format or stdin as 'Nothing'

49 -- | File to format or stdin as 'Nothing'

53 Maybe FilePath ->

50 Maybe FilePath ->

54 IO ()

51 IO ()

@@ -64,15 +61,19 @@ formatOne mode config = \case

64 -- 101 is different from all the other exit codes we already use.

61 -- 101 is different from all the other exit codes we already use.

65 exitWith (ExitFailure 101)

62 exitWith (ExitFailure 101)

66 Just inputFile -> do

63 Just inputFile -> do

64+ originalInput <- TIO.readFile inputFile

67− r <- ormoluFile config inputFile

65+ formattedInput <- ormoluFile config inputFile

68 case mode of

66 case mode of

69 Stdout ->

67 Stdout ->

70− TIO.putStr r

68+ TIO.putStr formattedInput

71− InPlace ->

69+ InPlace -> do

70+ -- Only write when the contents have changed, in order to avoid

71+ -- updating the modified timestamp if the file was already correctly

72+ -- formatted.

73+ when (formattedInput /= originalInput) $

72− TIO.writeFile inputFile r

74+ TIO.writeFile inputFile formattedInput

73 Check -> do

75 Check -> do

74− r' <- TIO.readFile inputFile

76+ when (formattedInput /= originalInput) $

75− when (r /= r') $

76 -- 100 is different to all the other exit code that are emitted

77 -- 100 is different to all the other exit code that are emitted

77 -- either from an 'OrmoluException' or from 'error' and

78 -- either from an 'OrmoluException' or from 'error' and

78 -- 'notImplemented'.

79 -- 'notImplemented'.

@@ -81,15 +82,14 @@ formatOne mode config = \case

81----------------------------------------------------------------------------

82----------------------------------------------------------------------------

82-- Command line options parsing.

83-- Command line options parsing.

83

84

84−data Opts

85+data Opts = Opts

85− = Opts

86− { -- | Mode of operation

86+ { -- | Mode of operation

87− optMode :: !Mode,

87+ optMode :: !Mode,

88− -- | Ormolu 'Config'

88+ -- | Ormolu 'Config'

89− optConfig :: !Config,

89+ optConfig :: !(Config RegionIndices),

90− -- | Haskell source files to format or stdin (when the list is empty)

90+ -- | Haskell source files to format or stdin (when the list is empty)

91− optInputFiles :: ![FilePath]

91+ optInputFiles :: ![FilePath]

92− }

92+ }

93

94-- | Mode of operation.

95data Mode

@@ -139,20 +139,25 @@ optsParserInfo =

139optsParser :: Parser Opts

140optsParser =

141 Opts

142+ <$> ( (fmap (bool Stdout InPlace) . switch . mconcat)

143+ [ short 'i',

144+ help "A shortcut for --mode inplace"

145+ ]

142− <$> (option parseMode . mconcat)

146+ <|> (option parseMode . mconcat)

143− [ long "mode",

147+ [ long "mode",

144− short 'm',

148+ short 'm',

145− metavar "MODE",

149+ metavar "MODE",

146− value Stdout,

150+ value Stdout,

147− help "Mode of operation: 'stdout' (default), 'inplace', or 'check'"

151+ help "Mode of operation: 'stdout' (default), 'inplace', or 'check'"

148− ]

152+ ]

153+ )

149 <*> configParser

154 <*> configParser

150 <*> (many . strArgument . mconcat)

155 <*> (many . strArgument . mconcat)

151 [ metavar "FILE",

156 [ metavar "FILE",

152 help "Haskell source files to format or stdin (default)"

157 help "Haskell source files to format or stdin (default)"

153 ]

158 ]

154

159

155−configParser :: Parser Config

160+configParser :: Parser (Config RegionIndices)

156configParser =

161configParser =

157 Config

162 Config

158 <$> (fmap (fmap DynOption) . many . strOption . mconcat)

163 <$> (fmap (fmap DynOption) . many . strOption . mconcat)

@@ -172,15 +177,22 @@ configParser =

172 help "Output information useful for debugging"

177 help "Output information useful for debugging"

173 ]

178 ]

174 <*> (switch . mconcat)

179 <*> (switch . mconcat)

175− [ long "tolerate-cpp",

180+ [ long "check-idempotence",

176− short 'p',

177− help "Do not fail if CPP pragma is present"

178− ]

179− <*> (switch . mconcat)

180− [ long "check-idempotency",

181 short 'c',

182 help "Fail if formatting is not idempotent"

183 ]

184+ <*> ( RegionIndices

185+ <$> (optional . option auto . mconcat)

186+ [ long "start-line",

187+ metavar "START",

188+ help "Start line of the region to format (starts from 1)"

189+ ]

190+ <*> (optional . option auto . mconcat)

191+ [ long "end-line",

192+ metavar "END",

193+ help "End line of the region to format (inclusive)"

194+ ]

195+ )

184

196

185----------------------------------------------------------------------------

197----------------------------------------------------------------------------

186-- Helpers

198-- Helpers

data/examples/declaration/annotation/annotation-out.hs+1

@@ -18,4 +18,5 @@ foo = 5

18

19data Foo = Foo Int

20{-# ANN type Foo ("HLint: ignore") #-}

21+

21{- Comment -}

22{- Comment -}

data/examples/declaration/data/existential-multiline-out.hs+12

@@ -3,3 +3,15 @@

3data Foo

4 = forall a. MkFoo a (a -> Bool)

5 | forall a. Eq a => MkBar a

6+

7+data Bar

8+ = forall x y.

9+ Bar x y x y

10+

11+data Baz

12+ = forall x y.

13+ Baz

14+ x

15+ y

16+ x

17+ y

data/examples/declaration/data/existential-multiline.hs+7

@@ -3,3 +3,10 @@

3data Foo

4 = forall a. MkFoo a (a -> Bool)

5 | forall a. Eq a => MkBar a

6+

7+data Bar = forall x y.

8+ Bar x y x y

9+

10+data Baz = forall x y.

11+ Baz x y x

12+ y

data/examples/declaration/data/field-layout/gadt-out.hs+2−1

@@ -6,5 +6,6 @@ data Foo a b where

6 Foo :: Foo Int Int

7 -- | Something else

8 Bar ::

9+ Foo

9− Foo Char

10+ Char

10 Char

11 Char

data/examples/declaration/data/field-layout/record-out.hs+9−9

@@ -1,12 +1,12 @@

1module Main where

2

3-- | Foo.

4−data Foo

4+data Foo = Foo

5− = Foo

6− { -- | Something

5+ { -- | Something

7− foo :: Foo Int Int,

6+ foo :: Foo Int Int,

8− -- | Something else

7+ -- | Something else

9− bar ::

8+ bar ::

9+ Bar

10− Bar Char

10+ Char

11− Char

11+ Char

12− }

12+ }

data/examples/declaration/data/gadt/multiline-out.hs+1−1

@@ -8,7 +8,7 @@ data Foo a where

8 Foo ::

9 forall a b.

10 (Show a, Eq b) => -- foo

11− -- bar

11+ -- bar

12 a ->

13 b ->

14 Foo 'Int

data/examples/declaration/data/multiline-arg-parens-out.hs+1−1

@@ -5,6 +5,6 @@ data Foo

5 = Foo

6 Bar

7 (Set Baz) -- and here we go

8− -- and that's it

8+ -- and that's it

9 Text

10 deriving (Eq)

data/examples/declaration/data/partly-documented-out.hsnew file+5

@@ -0,0 +1,5 @@

1+data Optimisation

2+ = PETransform

3+ | -- | partial eval and associated transforms

4+ GeneralisedNatHack

5+ deriving (Show, Eq, Generic)

data/examples/declaration/data/partly-documented.hsnew file+2

@@ -0,0 +1,2 @@

1+data Optimisation = PETransform | GeneralisedNatHack -- ^ partial eval and associated transforms

2+ deriving (Show, Eq, Generic)

data/examples/declaration/data/record-multi-const-out.hsnew file+17

@@ -0,0 +1,17 @@

1+module Main where

2+

3+-- | Something.

4+data Foo

5+ = Foo

6+ { -- | X

7+ fooX :: Int,

8+ -- | Y

9+ fooY :: Int

10+ }

11+ | Bar

12+ { -- | X

13+ barX :: Int,

14+ -- | Y

15+ barY :: Int

16+ }

17+ deriving (Eq, Show)

data/examples/declaration/data/record-multi-const.hsnew file+13

@@ -0,0 +1,13 @@

1+module Main where

2+

3+-- | Something.

4+

5+data Foo = Foo

6+ { fooX :: Int -- ^ X

7+ , fooY :: Int -- ^ Y

8+ } |

9+ Bar

10+ { barX :: Int -- ^ X

11+ , barY :: Int -- ^ Y

12+ }

13+ deriving (Eq, Show)

data/examples/declaration/data/record-out.hs+19−20

@@ -1,24 +1,23 @@

1module Main where

2

3-- | Something.

4−data Foo

4+data Foo = Foo

5− = Foo

6− { -- | X

5+ { -- | X

7− fooX :: Int,

6+ fooX :: Int,

8− -- | Y

7+ -- | Y

9− fooY :: Int,

8+ fooY :: Int,

10− -- | BarBaz

9+ -- | BarBaz

11− fooBar, fooBaz :: NonEmpty (Identity Bool),

10+ fooBar, fooBaz :: NonEmpty (Identity Bool),

12− -- | GagGog

11+ -- | GagGog

13− fooGag,

12+ fooGag,

14− fooGog ::

13+ fooGog ::

15− NonEmpty

14+ NonEmpty

16− ( Indentity

15+ ( Indentity

17− Bool

16+ Bool

18− ),

17+ ),

19− -- | Huh!

18+ -- | Huh!

20− fooFoo,

19+ fooFoo,

21− barBar ::

20+ barBar ::

22− Int

21+ Int

23− }

22+ }

24 deriving (Eq, Show)

23 deriving (Eq, Show)

data/examples/declaration/data/simple-broken-out.hs+1−2

@@ -1,8 +1,7 @@

1module Main where

2

3-- | Here we go.

4−data Foo

5− = Foo {unFoo :: Int}

4+data Foo = Foo {unFoo :: Int}

6 deriving (Eq)

5 deriving (Eq)

7

6

8-- | And once again.

7-- | And once again.

data/examples/declaration/data/unnamed-field-comment-0-out.hsnew file+7

@@ -0,0 +1,7 @@

1+data Foo

2+ = -- | Bar

3+ Bar

4+ Field1

5+ -- ^ Field 1

6+ Field2

7+ -- ^ Field 2

data/examples/declaration/data/unnamed-field-comment-0.hsnew file+5

@@ -0,0 +1,5 @@

1+data Foo

2+ = -- | Bar

3+ Bar

4+ Field1 -- ^ Field 1

5+ Field2 -- ^ Field 2

data/examples/declaration/data/unnamed-field-comment-1-out.hsnew file+5

@@ -0,0 +1,5 @@

1+data X

2+ = B

3+ !Int

4+ -- ^ y

5+ C

data/examples/declaration/data/unnamed-field-comment-1.hsnew file+4

@@ -0,0 +1,4 @@

1+data X

2+ = B

3+ !Int -- ^ y

4+ C

data/examples/declaration/data/with-comment-out.hsnew file+4

@@ -0,0 +1,4 @@

1+data A

2+ = B -- C

3+ | -- D

4+ E

data/examples/declaration/data/with-comment.hsnew file+5

@@ -0,0 +1,5 @@

1+data A =

2+ B -- C

3+

4+ -- D

5+ | E

data/examples/declaration/data/with-weird-haddock-out.hsnew file+4

@@ -0,0 +1,4 @@

1+data PlusLevel' t

2+ = -- | @n + ℓ@.

3+ Plus Integer (LevelAtom' t)

4+ deriving (Show, Data)

data/examples/declaration/data/with-weird-haddock.hsnew file+2

@@ -0,0 +1,2 @@

1+data PlusLevel' t = Plus Integer (LevelAtom' t) -- ^ @n + ℓ@.

2+ deriving (Show, Data)

data/examples/declaration/instance/data-family-instances-gadt-out.hs+4−2

@@ -3,9 +3,11 @@

3

4data instance Bar Int a where

5 SameBar ::

6− Bar Int

6+ Bar

7+ Int

7 Int

8 Int

8 CloseBar :: Bar Int Double

9 CloseBar :: Bar Int Double

9 OtherBar ::

10 OtherBar ::

10− Bar Int

11+ Bar

12+ Int

11 a

13 a

data/examples/declaration/instance/data-family-instances-newtype-out.hs+3−4

@@ -1,7 +1,6 @@

1{-# LANGUAGE GADTSyntax #-}

2{-# LANGUAGE TypeFamilies #-}

3

4−newtype instance Foo [Double]

4+newtype instance Foo [Double] = DoubleListFoo

5− = DoubleListFoo

6− { unDoubleListFoo :: Double

5+ { unDoubleListFoo :: Double

7− }

6+ }

data/examples/declaration/signature/type/infix-promoted-type-constructor-out.hs−1

@@ -1,3 +1,2 @@

1fun1 :: Def ('[Ref s (Stored Uint32), IBool] 'T.:-> IBool)

2−

3fun2 :: Def ('[Ref s (Stored Uint32), IBool] ':-> IBool)

2fun2 :: Def ('[Ref s (Stored Uint32), IBool] ':-> IBool)

data/examples/declaration/signature/type/multi-value-out.hs+5

@@ -2,6 +2,11 @@ foo, bar :: Int

2foo = 1

3bar = 2

4

5+a, b, c :: Int

6+a = 1

7+b = 2

8+c = 3

9+

5foo,

10foo,

6 bar,

11 bar,

7 baz ::

12 baz ::

data/examples/declaration/signature/type/multi-value.hs+5

@@ -2,6 +2,11 @@ foo, bar :: Int

2foo = 1

3bar = 2

4

5+a, b, c :: Int

6+a = 1

7+b = 2

8+c = 3

9+

5foo,

10foo,

6 bar,

11 bar,

7 baz :: Int

12 baz :: Int

data/examples/declaration/signature/type/unrelated-out.hsnew file+4

@@ -0,0 +1,4 @@

1+clientFunc1 :: SomeType1

2+clientFunc2 :: SomeType2

3+clientFunc3 :: SomeType3

4+clientFunc1 :<|> clientFunc2 :<|> clientFunc3 = hoistClient foo bar baz

data/examples/declaration/signature/type/unrelated.hsnew file+4

@@ -0,0 +1,4 @@

1+clientFunc1 :: SomeType1

2+clientFunc2 :: SomeType2

3+clientFunc3 :: SomeType3

4+clientFunc1 :<|> clientFunc2 :<|> clientFunc3 = hoistClient foo bar baz

data/examples/declaration/splice/grouped-splices-out.hsnew file+3

@@ -0,0 +1,3 @@

1+$(deriveJSON fieldLabelMod ''A)

2+$(deriveJSON fieldLabelMod ''B)

3+$(deriveJSON fieldLabelMod ''C)

data/examples/declaration/splice/grouped-splices.hsnew file+3

@@ -0,0 +1,3 @@

1+$(deriveJSON fieldLabelMod ''A)

2+$(deriveJSON fieldLabelMod ''B)

3+$(deriveJSON fieldLabelMod ''C)

data/examples/declaration/splice/splice-decl.hs−1

@@ -15,4 +15,3 @@ foo bar

15-- TemplateHaskell allows Q () at the top level

16do

17 pure []

18−

data/examples/declaration/type-synonyms/with-weird-haddock-out.hsnew file+3

@@ -0,0 +1,3 @@

1+type Elims =

2+ -- | eliminations ordered left-to-right.

3+ [Elim]

data/examples/declaration/type-synonyms/with-weird-haddock.hsnew file+1

@@ -0,0 +1 @@

1+type Elims = [Elim] -- ^ eliminations ordered left-to-right.

data/examples/declaration/value/function/arg-breakpoints-out.hsnew file+3

@@ -0,0 +1,3 @@

1+foo

2+ bar =

3+ body

data/examples/declaration/value/function/arg-breakpoints.hsnew file+3

@@ -0,0 +1,3 @@

1+foo

2+ bar =

3+ body

data/examples/declaration/value/function/arrow/multiline-case-out.hsnew file+8

@@ -0,0 +1,8 @@

1+{-# LANGUAGE Arrows #-}

2+

3+f = proc x -> do

4+ x <-

5+ case x of X -> x

6+ -<

7+ y

8+ a -< b

data/examples/declaration/value/function/arrow/multiline-case.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# LANGUAGE Arrows #-}

2+

3+f = proc x -> do

4+ x

5+ <- case x of X -> x

6+ -< y

7+ a -< b

data/examples/declaration/value/function/arrow/proc-applications-out.hs+6−5

@@ -9,10 +9,11 @@ bar f x =

9 w

10 )

11 ->

12− f -< -- The value

12+ f -- The value

13+ -<

13− ( x, -- Foo

14+ ( x, -- Foo

14− w, -- Bar

15+ w, -- Bar

15− z -- Baz

16+ z -- Baz

16− )

17+ )

17

18

18baz x = proc a -> a -<< x

19baz x = proc a -> a -<< x

data/examples/declaration/value/function/arrow/proc-do-complex-out.hs+18−14

@@ -19,10 +19,11 @@ foo

19 )

20 ( b,

21 d

22− ) -<

23− ( b + 1, -- Funnel into arrow

24− d * b

25 )

22 )

23+ -<

24+ ( b + 1, -- Funnel into arrow

25+ d * b

26+ )

26 if x `mod` y == 0 -- Basic condition

27 if x `mod` y == 0 -- Basic condition

27 then case e of -- Only left case is relevant

28 then case e of -- Only left case is relevant

28 Left

29 Left

@@ -32,18 +33,20 @@ foo

32 let v =

33 let v =

33 u -- Actually never used

34 u -- Actually never used

34 ^ 2

35 ^ 2

35− in ( returnA -<

36+ in ( returnA

37+ -<

36− -- Just do the calculation

38+ -- Just do the calculation

37− (x + y * z)

39+ (x + y * z)

38 )

40 )

39 else do

41 else do

40 let u = x -- Let bindings bind expressions, not commands

42 let u = x -- Let bindings bind expressions, not commands

41− -- Could pattern match directly on x

43+ -- Could pattern match directly on x

42 i <- case u of

44 i <- case u of

43 0 -> (g . h -< u)

45 0 -> (g . h -< u)

44 n ->

46 n ->

45− ( ( h . g -<

47+ ( ( h . g

48+ -<

46− y -- First actual use of y

49+ y -- First actual use of y

47 )

50 )

48 )

51 )

49 returnA -< ()

52 returnA -< ()

@@ -51,8 +54,9 @@ foo

51 if i > 0

54 if i > 0

52 then ma -< ()

55 then ma -< ()

53 else returnA -< ()

56 else returnA -< ()

54− returnA -<

57+ returnA

58+ -<

55− ( i

59+ ( i

56− + x

60+ + x

57− * y -- Just do the calculation

61+ * y -- Just do the calculation

58− )

62+ )

data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs+3−2

@@ -13,5 +13,6 @@ barbaz f g = proc (a, b) -> do

13

14bazbar f = proc a -> do

15 a <-

16− f -<

16+ f

17+ -<

17− a

18+ a

data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs+9−7

@@ -11,10 +11,12 @@ bazbaz f g h = proc (a, b, c) -> do

11 z <-

12 h

13 x

14− y -<

14+ y

15+ -<

15− ( a,

16+ ( a,

16− b,

17+ b,

17− c

18+ c

18− )

19+ )

19− returnA -<

20+ returnA

21+ -<

20− (x, y, z)

22+ (x, y, z)

data/examples/declaration/value/function/arrow/proc-forms1-out.hs+8−6

@@ -7,13 +7,15 @@ foo1 f g h x =

7 (|

8 test

9 ( h f

10− . h g -<

10+ . h g

11+ -<

11− y x

12+ y x

12− . y z

13+ . y z

13 )

14 )

14 ( h g

15 ( h g

15− . h f -<

16+ . h f

17+ -<

16− y z

18+ y z

17− . y x

19+ . y x

18 )

20 )

19 |)

21 |)

data/examples/declaration/value/function/arrow/proc-forms2-out.hs+6−4

@@ -12,9 +12,11 @@ bar2 f g h x =

12

13bar3 f g h x =

14 proc (y, z) ->

15− ( (h f . h g) -<

15+ ( (h f . h g)

16+ -<

16− (y x) . y z

17+ (y x) . y z

17 ) |||

18 ) |||

18− ( (h g . h f) -<

19+ ( (h g . h f)

20+ -<

19− y z . (y x)

21+ y z . (y x)

20 )

22 )

data/examples/declaration/value/function/arrow/proc-ifs-out.hs+6−4

@@ -6,8 +6,10 @@ bar f g = proc a ->

6 if f a

7 then

8 f

9− . g -<

9+ . g

10+ -<

10− a

11+ a

11 else

12 else

12− g -<

13+ g

14+ -<

13− b

15+ b

data/examples/declaration/value/function/arrow/proc-parentheses-out.hs+5−4

@@ -6,13 +6,14 @@ bar f g = proc a ->

6 ( ( (f)

7 ( g

8 )

9+ )

9− ) -<

10+ -<

10− ( ( ( ( ( ( g

11+ ( ( ( ( ( ( g

11− a

12+ a

13+ )

12 )

14 )

13 )

15 )

14 )

16 )

15 )

17 )

16 )

18 )

17− )

18 )

19 )

data/examples/declaration/value/function/arrow/recursive-procs-out.hs+14−10

@@ -3,17 +3,21 @@

3foo f g = proc (x, y) -> do

4 rec a <- f y -< x

5 b <-

6− g x -<

6+ g x

7+ -<

7− y

8+ y

8− bar -<

9+ bar

10+ -<

9− ( a,

11+ ( a,

10− b

12+ b

11− )

13+ )

12 rec p <-

14 rec p <-

13 f

15 f

14− p -<

16+ p

17+ -<

15− a

18+ a

16 rec q <-

19 rec q <-

17 g

20 g

18− q -<

21+ q

22+ -<

19− b

23+ b

data/examples/declaration/value/function/awkward-comment-0-out.hsnew file+6

@@ -0,0 +1,6 @@

1+mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a

2+mergeErrorReply err1 reply -- XXX where to put it?

3+ =

4+ case reply of

5+ Ok x state err2 -> Ok x state (mergeError err1 err2)

6+ Error err2 -> Error (mergeError err1 err2)

data/examples/declaration/value/function/awkward-comment-0.hsnew file+5

@@ -0,0 +1,5 @@

1+mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a

2+mergeErrorReply err1 reply -- XXX where to put it?

3+ = case reply of

4+ Ok x state err2 -> Ok x state (mergeError err1 err2)

5+ Error err2 -> Error (mergeError err1 err2)

data/examples/declaration/value/function/awkward-comment-1-out.hsnew file+9

@@ -0,0 +1,9 @@

1+doForeign :: Vars -> [Name] -> [Term] -> Idris LExp

2+doForeign x = x

3+ where

4+ splitArg tm | (_, [_, _, l, r]) <- unApply tm -- pair, two implicits

5+ =

6+ do

7+ let l' = toFDesc l

8+ r' <- irTerm (sMN 0 "__foreignCall") vs env r

9+ return (l', r')

data/examples/declaration/value/function/awkward-comment-1.hsnew file+7

@@ -0,0 +1,7 @@

1+doForeign :: Vars -> [Name] -> [Term] -> Idris LExp

2+doForeign x = x

3+ where

4+ splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits

5+ = do let l' = toFDesc l

6+ r' <- irTerm (sMN 0 "__foreignCall") vs env r

7+ return (l', r')

data/examples/declaration/value/function/blank-lines-let-out.hsnew file+6

@@ -0,0 +1,6 @@

1+foo =

2+ let x = 10

3+

4+ y = 11

5+ z = 12

6+ in x + y + z

data/examples/declaration/value/function/blank-lines-let.hsnew file+9

@@ -0,0 +1,9 @@

1+foo =

2+ let

3+

4+ x = 10

5+

6+ y = 11

7+ z = 12

8+

9+ in x + y + z

data/examples/declaration/value/function/blank-lines-where-out.hsnew file+6

@@ -0,0 +1,6 @@

1+foo = x + y + z

2+ where

3+ x = 10

4+

5+ y = 11

6+ z = 12

data/examples/declaration/value/function/blank-lines-where.hsnew file+7

@@ -0,0 +1,7 @@

1+foo = x + y + z

2+ where

3+

4+ x = 10

5+

6+ y = 11

7+ z = 12

data/examples/declaration/value/function/do/blocks-out.hs+1

@@ -15,4 +15,5 @@ readInClause = do

15 <|> do

16 optional g_Semi

17 void allspacing

18+

18 return things

19 return things

data/examples/declaration/value/function/do/comment-alignment-out.hsnew file+9

@@ -0,0 +1,9 @@

1+main = do

2+ case blah of

3+ Nothing -> return ()

4+ Just xs -> do

5+ forM_ xs foo

6+ bar

7+ -- and here it goes

8+ unless bobla $

9+ quux

data/examples/declaration/value/function/do/comment-alignment.hsnew file+9

@@ -0,0 +1,9 @@

1+main = do

2+ case blah of

3+ Nothing -> return ()

4+ Just xs -> do

5+ forM_ xs foo

6+ bar

7+ -- and here it goes

8+ unless bobla $

9+ quux

data/examples/declaration/value/function/do/comment-spacing-out.hsnew file+7

@@ -0,0 +1,7 @@

1+foo = do

2+ bar

3+ -- foo

4+ baz

5+

6+ -- foo

7+ quux

data/examples/declaration/value/function/do/comment-spacing.hsnew file+7

@@ -0,0 +1,7 @@

1+foo = do

2+ bar

3+ -- foo

4+ baz

5+

6+ -- foo

7+ quux

data/examples/declaration/value/function/do/recursive-do-rec-out.hs+5

@@ -2,13 +2,18 @@

2

3foo = do

4 rec a <- b + 5

5+

5 let d = c

6 let d = c

7+

6 b <- a * 5

8 b <- a * 5

9+

7 something

10 something

11+

8 c <- a + b

12 c <- a + b

9 print c

13 print c

10 rec something $ do

14 rec something $ do

11 x <- a

15 x <- a

12 print x

16 print x

17+

13 y <- c

18 y <- c

14 print y

19 print y

data/examples/declaration/value/function/if-with-comment-out.hsnew file+8

@@ -0,0 +1,8 @@

1+foo =

2+ if undefined

3+ then -- then comment

4+ undefined

5+ else -- else comment

6+

7+ do

8+ undefined

data/examples/declaration/value/function/if-with-comment.hsnew file+8

@@ -0,0 +1,8 @@

1+foo =

2+ if undefined

3+ -- then comment

4+ then undefined

5+ -- else comment

6+ else

7+ do

8+ undefined

data/examples/declaration/value/function/implicit-params-out.hs+1

@@ -1,6 +1,7 @@

1{-# LANGUAGE ImplicitParams #-}

2

3sortBy :: (a -> a -> Bool) -> [a] -> [a]

4+sortBy = undefined

4

5

5sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]

6sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]

6sort = sortBy ?cmp

7sort = sortBy ?cmp

data/examples/declaration/value/function/implicit-params.hs+2

@@ -1,6 +1,8 @@

1{-# LANGUAGE ImplicitParams #-}

2sortBy :: (a -> a -> Bool) -> [a] -> [a]

3

4+sortBy = undefined

5+

4sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]

6sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]

5sort = sortBy ?cmp

7sort = sortBy ?cmp

6

8

data/examples/declaration/value/function/infix/dollar-chains-out.hs+3−3

@@ -13,9 +13,9 @@ foo =

13 throwIO (OrmoluCppEnabled path)

14

15foo =

16− bar

16+ bar $

17− $ baz

17+ baz $

18− $ quux

18+ quux

19

20x =

21 case l of { A -> B } $

data/examples/declaration/value/function/infix/hanging-out.hs+4−3

@@ -17,6 +17,7 @@ update =

17 `catch` \case

18 a -> a

19

20−foo = bar

20+foo =

21+ bar

21− ++ case foo of

22+ ++ case foo of

22− a -> a

23+ a -> a

data/examples/declaration/value/function/infix/lenses-out.hs+8−7

@@ -1,11 +1,12 @@

1lenses =

2+ Just $

2− Just $ M.fromList $

3+ M.fromList $

3− "type" .= ("user.connection" :: Text)

4+ "type" .= ("user.connection" :: Text)

4− # "connection" .= uc

5+ # "connection" .= uc

5− # "user" .= case name of

6+ # "user" .= case name of

6− Just n -> Just $ object ["name" .= n]

7+ Just n -> Just $ object ["name" .= n]

7− Nothing -> Nothing

8+ Nothing -> Nothing

8− # []

9+ # []

9

10

10foo =

11foo =

11 a

12 a

data/examples/declaration/value/function/let-single-line-out.hs−1

@@ -5,7 +5,6 @@ foo x = let x = z where { z = 2 }; a = 3 in x

5foo x = let g :: Int -> Int; g = id in ()

6

7let a = b; c = do { foo; bar }; d = baz in b

8−

9let a = case True of { True -> foo; False -> bar }; b = foo a in b

8let a = case True of { True -> foo; False -> bar }; b = foo a in b

10

9

11foo x = let ?g = id; ?f = g in x

10foo x = let ?g = id; ?f = g in x

data/examples/declaration/value/function/list-notation-0-out.hsnew file+5

@@ -0,0 +1,5 @@

1+foo =

2+ testCase "Foo" testFoo :

3+ testCase "Bar" testBar :

4+ testCase "Baz" testBaz :

5+ []

data/examples/declaration/value/function/list-notation-0.hsnew file+5

@@ -0,0 +1,5 @@

1+foo =

2+ testCase "Foo" testFoo :

3+ testCase "Bar" testBar :

4+ testCase "Baz" testBaz :

5+ []

data/examples/declaration/value/function/list-notation-1-out.hsnew file+8

@@ -0,0 +1,8 @@

1+instance A.ToJSON UpdateTable where

2+ toJSON a =

3+ A.object $

4+ "TableName" .= updateTableName a :

5+ "ProvisionedThroughput" .= updateProvisionedThroughput a :

6+ case updateGlobalSecondaryIndexUpdates a of

7+ [] -> []

8+ l -> ["GlobalSecondaryIndexUpdates" .= l]

data/examples/declaration/value/function/list-notation-1.hsnew file+7

@@ -0,0 +1,7 @@

1+instance A.ToJSON UpdateTable where

2+ toJSON a = A.object

3+ $ "TableName" .= updateTableName a

4+ : "ProvisionedThroughput" .= updateProvisionedThroughput a

5+ : case updateGlobalSecondaryIndexUpdates a of

6+ [] -> []

7+ l -> [ "GlobalSecondaryIndexUpdates" .= l ]

data/examples/declaration/value/function/list-notation-2-out.hsnew file+6

@@ -0,0 +1,6 @@

1+-- A list of the element and all its parents up to the root node.

2+getPath tree t =

3+ t :

4+ case Map.lookup (getId t) tree of

5+ Nothing -> []

6+ Just parent -> getPath tree parent

data/examples/declaration/value/function/list-notation-2.hsnew file+5

@@ -0,0 +1,5 @@

1+-- A list of the element and all its parents up to the root node.

2+getPath tree t = t :

3+ case Map.lookup (getId t) tree of

4+ Nothing -> []

5+ Just parent -> getPath tree parent

data/examples/declaration/value/function/list-notation-3-out.hsnew file+12

@@ -0,0 +1,12 @@

1+foo =

2+ reportSDoc "tc.cc" 30 $

3+ sep $ do

4+ (prettyTCM q <+> " before compilation") : do

5+ map (prettyTCM . map unArg . clPats) cls

6+

7+foo =

8+ reportSDoc "tc.cc" 30 $

9+ sep $ do

10+ (prettyTCM q <+> " before compilation") :

11+ do

12+ map (prettyTCM . map unArg . clPats) cls

data/examples/declaration/value/function/list-notation-3.hsnew file+10

@@ -0,0 +1,10 @@

1+foo =

2+ reportSDoc "tc.cc" 30 $ sep $ do

3+ (prettyTCM q <+> " before compilation") : do

4+ map (prettyTCM . map unArg . clPats) cls

5+

6+foo =

7+ reportSDoc "tc.cc" 30 $ sep $ do

8+ (prettyTCM q <+> " before compilation") :

9+ do

10+ map (prettyTCM . map unArg . clPats) cls

data/examples/declaration/value/function/multi-way-if-out.hs+4−2

@@ -3,12 +3,14 @@

3foo x = if | x == 5 -> 5

4

5bar x y =

6+ if

6− if | x > y -> x

7+ | x > y -> x

7 | x < y ->

8 | x < y ->

8 y

9 y

9 | otherwise -> x

10 | otherwise -> x

10

11

11baz =

12baz =

12− if | p -> f

13+ if

14+ | p -> f

13 | otherwise -> g

15 | otherwise -> g

14 x

16 x

data/examples/declaration/value/function/operator-comments-2-out.hsnew file+5

@@ -0,0 +1,5 @@

1+x =

2+ y

3+ ++ f g -- commentA

4+ -- commentB

5+ -- commentC

data/examples/declaration/value/function/operator-comments-2.hsnew file+4

@@ -0,0 +1,4 @@

1+x =

2+ y ++ -- commentA

3+-- commentB

4+ f g -- commentC

data/examples/declaration/value/function/operators-out.hs → data/examples/declaration/value/function/operators-0-out.hsrenamed

The content is the same.

data/examples/declaration/value/function/operators.hs → data/examples/declaration/value/function/operators-0.hsrenamed

The content is the same.

data/examples/declaration/value/function/operators-1-out.hsnew file+4

@@ -0,0 +1,4 @@

1+foo =

2+ f

3+ . g

4+ =<< h . i

data/examples/declaration/value/function/operators-1.hsnew file+3

@@ -0,0 +1,3 @@

1+foo = f

2+ . g

3+ =<< h . i

data/examples/declaration/value/function/operators-2-out.hsnew file+4

@@ -0,0 +1,4 @@

1+foo n

2+ | x || y && z || n ** x

3+ || x && n =

4+ 42

data/examples/declaration/value/function/operators-2.hsnew file+4

@@ -0,0 +1,4 @@

1+foo n

2+ | x || y && z || n ** x

3+ || x && n =

4+ 42

data/examples/declaration/value/function/operators-3-out.hsnew file+3

@@ -0,0 +1,3 @@

1+foo =

2+ op <> n <+> colon <+> prettySe <+> text "="

3+ <+> prettySe <> text sc

data/examples/declaration/value/function/operators-3.hsnew file+3

@@ -0,0 +1,3 @@

1+foo =

2+ op <> n <+> colon <+> prettySe <+> text "=" <+>

3+ prettySe <> text sc

data/examples/declaration/value/function/operators-4-out.hsnew file+3

@@ -0,0 +1,3 @@

1+foo =

2+ line <> bindingOf <+> text "=" <+> tPretty <+> colon

3+ <+> align <> prettyPs

data/examples/declaration/value/function/operators-4.hsnew file+3

@@ -0,0 +1,3 @@

1+foo =

2+ line <> bindingOf <+> text "=" <+> tPretty <+> colon <+>

3+ align <> prettyPs

data/examples/declaration/value/function/operators-5-out.hsnew file+5

@@ -0,0 +1,5 @@

1+foo =

2+ map bar $

3+ [ baz

4+ ]

5+ ++ quux

data/examples/declaration/value/function/operators-5.hsnew file+4

@@ -0,0 +1,4 @@

1+foo =

2+ map bar $

3+ [ baz

4+ ] ++ quux

data/examples/declaration/value/function/operators-6-out.hsnew file+9

@@ -0,0 +1,9 @@

1+type PermuteRef =

2+ "a"

3+ :> ( "b" :> "c" :> End

4+ :<|> "c" :> "b" :> End

5+ )

6+ :<|> "b"

7+ :> ( "a" :> "c" :> End

8+ :<|> "c" :> "a" :> End

9+ )

data/examples/declaration/value/function/operators-6.hsnew file+7

@@ -0,0 +1,7 @@

1+type PermuteRef =

2+ "a" :> ( "b" :> "c" :> End

3+ :<|> "c" :> "b" :> End

4+ )

5+ :<|> "b" :> ( "a" :> "c" :> End

6+ :<|> "c" :> "a" :> End

7+ )

data/examples/declaration/value/function/record-constructors-out.hs → data/examples/declaration/value/function/record/constructors-out.hsrenamed

The content is the same.

data/examples/declaration/value/function/record-constructors.hs → data/examples/declaration/value/function/record/constructors.hsrenamed

The content is the same.

data/examples/declaration/value/function/record-dot-out.hs → data/examples/declaration/value/function/record/dot-out.hsrenamed

The content is the same.

data/examples/declaration/value/function/record-dot.hs → data/examples/declaration/value/function/record/dot.hsrenamed

The content is the same.

data/examples/declaration/value/function/record/hanging-after-equal-con-out.hsnew file+8

@@ -0,0 +1,8 @@

1+foo =

2+ Foo

3+ { foo =

4+ -- Blah blah

5+ case x of

6+ Blah -> 1

7+ Blim -> 2

8+ }

data/examples/declaration/value/function/record/hanging-after-equal-con.hsnew file+7

@@ -0,0 +1,7 @@

1+foo = Foo

2+ { foo =

3+ -- Blah blah

4+ case x of

5+ Blah -> 1

6+ Blim -> 2

7+ }

data/examples/declaration/value/function/record/hanging-after-equal-update-out.hsnew file+8

@@ -0,0 +1,8 @@

1+foo =

2+ foo

3+ { foo =

4+ -- Blah blah

5+ case x of

6+ Blah -> 1

7+ Blim -> 2

8+ }

data/examples/declaration/value/function/record/hanging-after-equal-update.hsnew file+7

@@ -0,0 +1,7 @@

1+foo = foo

2+ { foo =

3+ -- Blah blah

4+ case x of

5+ Blah -> 1

6+ Blim -> 2

7+ }

data/examples/declaration/value/function/record-inter-comments-out.hs → data/examples/declaration/value/function/record/inter-comments-out.hsrenamed

The content is the same.

data/examples/declaration/value/function/record-inter-comments.hs → data/examples/declaration/value/function/record/inter-comments.hsrenamed

The content is the same.

data/examples/declaration/value/function/record-updaters-out.hs → data/examples/declaration/value/function/record/updaters-out.hsrenamed

The content is the same.

data/examples/declaration/value/function/record-updaters.hs → data/examples/declaration/value/function/record/updaters.hsrenamed

The content is the same.

data/examples/declaration/value/function/record-wildcards-out.hs → data/examples/declaration/value/function/record/wildcards-out.hsrenamed

The content is the same.

data/examples/declaration/value/function/record-wildcards.hs → data/examples/declaration/value/function/record/wildcards.hsrenamed

The content is the same.

data/examples/declaration/value/function/type-applications-and-splice-out.hsnew file+4

@@ -0,0 +1,4 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE TypeApplications #-}

3+

4+staticKey name = [|sing @ $(symFQN name)|]

data/examples/declaration/value/function/type-applications-and-splice.hsnew file+4

@@ -0,0 +1,4 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE TypeApplications #-}

3+

4+staticKey name = [| sing @ $(symFQN name) |]

data/examples/import/deduplication-bug-out.hsnew file+6

@@ -0,0 +1,6 @@

1+import Foo1 (Bar1 (..), Baz1)

2+import Foo2 (Bar2 (..), Baz2)

3+import Foo3 (Bar3 (x1, x2, x3))

4+import Foo4 (Bar4 (x1, x2))

5+import Foo5 (Bar5 (x1))

6+import Foo6 (Bar6 (..))

data/examples/import/deduplication-bug.hsnew file+6

@@ -0,0 +1,6 @@

1+import Foo1 (Bar1, Baz1, Bar1(..))

2+import Foo2 (Bar2(..), Baz2, Bar2)

3+import Foo3 (Bar3(x1,x3), Bar3(x1, x2))

4+import Foo4 (Bar4(x1), Bar4(x2))

5+import Foo5 (Bar5, Bar5(x1))

6+import Foo6 (Bar6(x1), Bar6(..))

data/examples/import/explicit-imports-out.hs+4−4

@@ -1,12 +1,12 @@

1import qualified MegaModule as M

2− ( (<<<),

3− (>>>),

4− Either,

2+ ( Either,

5 Maybe (Just, Nothing),

3 Maybe (Just, Nothing),

6 MaybeT (..),

4 MaybeT (..),

7− Monad ((>>), (>>=), return),

5+ Monad (return, (>>), (>>=)),

8 MonadBaseControl,

6 MonadBaseControl,

9 join,

7 join,

10 liftIO,

8 liftIO,

11 void,

9 void,

10+ (<<<),

11+ (>>>),

12 )

data/examples/import/explicit-imports-with-comments-out.hs+3−2

@@ -1,6 +1,7 @@

1import qualified MegaModule as M

2 ( -- (1)

3− (<<<), -- (2)

3+ -- (2)

4− (>>>),

5 Either, -- (3)

4 Either, -- (3)

5+ (<<<),

6+ (>>>),

6 )

7 )

data/examples/import/merging-0-out.hsnew file+3

@@ -0,0 +1,3 @@

1+import Foo

2+import Foo (bar, foo)

3+import Foo as F

data/examples/import/merging-0.hsnew file+4

@@ -0,0 +1,4 @@

1+import Foo

2+import Foo (foo)

3+import Foo (bar)

4+import Foo as F

data/examples/import/merging-1-out.hsnew file+2

@@ -0,0 +1,2 @@

1+import "bar" Foo (bar)

2+import "foo" Foo (baz, foo)

data/examples/import/merging-1.hsnew file+3

@@ -0,0 +1,3 @@

1+import "foo" Foo (foo)

2+import "bar" Foo (bar)

3+import "foo" Foo (baz)

data/examples/import/merging-2-out.hsnew file+2

@@ -0,0 +1,2 @@

1+import Foo hiding (bar4, foo2)

2+import qualified Foo (bar3, foo1)

data/examples/import/merging-2.hsnew file+4

@@ -0,0 +1,4 @@

1+import qualified Foo (foo1)

2+import Foo hiding (foo2)

3+import qualified Foo (bar3)

4+import Foo hiding (bar4)

data/examples/import/misc-out.hs−6

@@ -1,11 +1,5 @@

1import A hiding

2 ( foobarbazqux,

3− foobarbazqux,

4− foobarbazqux,

5− foobarbazqux,

6− foobarbazqux,

7− foobarbazqux,

8− foobarbazqux,

9 )

3 )

10import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f)

4import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f)

11import Name hiding ()

5import Name hiding ()

data/examples/import/nested-explicit-imports-out.hs+6−6

@@ -1,10 +1,10 @@

1import qualified MegaModule as M

2− ( (<<<),

3− (>>>),

4− Either,

2+ ( Either,

5 Monad

3 Monad

4+ ( return,

6− ( (>>),

5+ (>>),

7− (>>=),

6+ (>>=)

8− return

9 ),

7 ),

8+ (<<<),

9+ (>>>),

10 )

data/examples/import/qualified-post-out.hs+1−1

@@ -1,5 +1,5 @@

1{-# LANGUAGE ImportQualifiedPost #-}

2

3−import Data.Text qualified as T

4import Data.Text qualified (a, b, c)

3import Data.Text qualified (a, b, c)

5import Data.Text qualified hiding (a, b, c)

4import Data.Text qualified hiding (a, b, c)

5+import Data.Text qualified as T

data/examples/import/qualified-prelude-out.hs+1−1

@@ -1,4 +1,4 @@

1module P where

2

3+import Prelude hiding (id, (.))

3import qualified Prelude

4import qualified Prelude

4−import Prelude hiding ((.), id)

data/examples/import/simple-out.hs+2−3

@@ -1,6 +1,5 @@

1import Data.Text

2−import Data.Text

3−import qualified Data.Text as T

4−import qualified Data.Text (a, b, c)

5import Data.Text (a, b, c)

2import Data.Text (a, b, c)

6import Data.Text hiding (a, b, c)

3import Data.Text hiding (a, b, c)

4+import qualified Data.Text (a, b, c)

5+import qualified Data.Text as T

data/examples/import/simple.hs+2

@@ -4,3 +4,5 @@ import qualified Data.Text as T

4import qualified Data.Text (a, c, b)

5import Data.Text (a, b, c)

6import Data.Text hiding (c, b, a)

7+import Data.Text (a, b, c, b, a)

8+import Data.Text hiding (c, b, a, b, c)

data/examples/import/sorted-export-list-out.hsnew file+1

@@ -0,0 +1 @@

1+import Linear.Vector (Additive (..), (*^), (^*))

data/examples/import/sorted-export-list.hsnew file+1

@@ -0,0 +1 @@

1+import Linear.Vector (Additive (..), (*^), (^*))

data/examples/module-header/double-dot-with-names-out.hs+1−6

@@ -1,11 +1,6 @@

1{-# LANGUAGE PatternSynonyms #-}

2

3−module ExportSyntax

3+module ExportSyntax (A (.., NoA), Q (F, ..), G (T, .., U)) where

4− ( A (.., NoA),

5− Q (F, ..),

6− G (T, .., U),

7− )

8−where

9

4

10data A = A | B

5data A = A | B

11

6

data/examples/module-header/multiline2.hs+2−2

@@ -1,2 +1,2 @@

1−module Foo

1+module Foo (

2− (foo, bar, baz) where

2+ foo, bar, baz) where

data/examples/module-header/preceding-comment-with-haddock-out.hs+1−4

@@ -3,9 +3,6 @@

3-}

4

5-- | This is the module's Haddock.

6−module Main

6+module Main (main) where

7− ( main,

8− )

9−where

10

7

11main = return ()

8main = return ()

data/examples/module-header/singleline-empty-out.hs+1−4

@@ -1,5 +1,2 @@

1-- | This demonstrates a BUG.

2−module Foo

2+module Foo () where

3− (

4− )

5−where

data/examples/module-header/stack-header-0-out.hs+1

@@ -3,4 +3,5 @@

3{-# LANGUAGE OverloadedStrings #-}

4

5main = return ()

6+

6-- stack runhaskell

7-- stack runhaskell

data/examples/module-header/stack-header-1-out.hs+1

@@ -4,4 +4,5 @@

4{-# LANGUAGE OverloadedStrings #-}

5

6main = return ()

7+

7-- stack runhaskell

8-- stack runhaskell

data/examples/module-header/warning-pragma-multiline-out.hs+1−4

@@ -1,9 +1,6 @@

1module Test

2 {-# DEPRECATED "This module is unstable" #-}

3− ( foo,

3+ (foo, bar, baz)

4− bar,

5− baz,

6− )

7where

4where

8

5

9import Blah

6import Blah

data/examples/module-header/warning-pragma-out.hs+3−1

@@ -1,3 +1,5 @@

1module Test

2+ {-# WARNING

2− {-# WARNING "This module is very internal" #-}

3+ "This module is very internal"

4+ #-}

3where

5where

data/examples/other/argument-comment-out.hs−1

@@ -9,7 +9,6 @@ foo ::

9 -- | Foo

10 Int ->

11 Int

12−

13foo ::

12foo ::

14 Foo a =>

13 Foo a =>

15 -- | Foo

14 -- | Foo

data/examples/other/comment-glued-together-out.hsnew file+7

@@ -0,0 +1,7 @@

1+module Main (main) where

2+

3+-- | Foo.

4+

5+-- Bar

6+main :: IO ()

7+main = return ()

data/examples/other/comment-glued-together.hsnew file+6

@@ -0,0 +1,6 @@

1+module Main (main) where

2+

3+{- | Foo. -}

4+-- Bar

5+main :: IO ()

6+main = return ()

data/examples/other/comment-trailing-space-out.hsnew file+9

@@ -0,0 +1,9 @@

1+data T

2+ = {-

3+

4+ some multi-line comment

5+

6+ with empty lines

7+

8+ -}

9+ A

data/examples/other/comment-trailing-space.hsnew file+9

@@ -0,0 +1,9 @@

1+data T

2+ = {-

3+

4+ some multi-line comment

5+

6+ with empty lines

7+

8+ -}

9+ A

data/examples/other/comment-two-blocks-out.hs+2−2

@@ -2,7 +2,7 @@ newNames :: [(String, String)]

2newNames =

3 let (*) = flip (,)

4 in [ "Control" * "Monad"

5− -- Foo

5+ -- Foo

6

7− -- Bar

7+ -- Bar

8 ]

data/examples/other/cpp/continuation-out.hsnew file+8

@@ -0,0 +1,8 @@

1+foo :: Int

2+foo = 5

3+

4+#define message_for(a, b) \

5+ printf(#a " and " #b ": We love you!\n")

6+

7+bar :: Int

8+bar = 6

data/examples/other/cpp/continuation.hsnew file+8

@@ -0,0 +1,8 @@

1+foo :: Int

2+foo = 5

3+

4+#define message_for(a, b) \

5+ printf(#a " and " #b ": We love you!\n")

6+

7+bar :: Int

8+bar = 6

data/examples/other/cpp/lonely-hash-out.hsnew file+14

@@ -0,0 +1,14 @@

1+module Main (main) where

2+

3+import Data.Void

4+import Test.Hspec

5+import Test.Hspec.Megaparsec

6+import Text.Megaparsec

7+import Text.Megaparsec.Char

8+

9+# if !MIN_VERSION_base(4,13,0)

10+import Data.Semigroup ((<>))

11+# endif

12+

13+main :: IO ()

14+main = return ()

data/examples/other/cpp/lonely-hash.hsnew file+14

@@ -0,0 +1,14 @@

1+module Main (main) where

2+

3+import Data.Void

4+import Test.Hspec

5+import Test.Hspec.Megaparsec

6+import Text.Megaparsec

7+import Text.Megaparsec.Char

8+

9+# if !MIN_VERSION_base(4,13,0)

10+import Data.Semigroup ((<>))

11+# endif

12+

13+main :: IO ()

14+main = return ()

data/examples/other/cpp/separation-0a-out.hsnew file+7

@@ -0,0 +1,7 @@

1+instance Stream s => Monad (ParsecT e s m) where

2+ return = pure

3+ (>>=) = pBind

4+

5+#if !(MIN_VERSION_base(4,13,0))

6+ fail = Fail.fail

7+#endif

data/examples/other/cpp/separation-0a.hsnew file+6

@@ -0,0 +1,6 @@

1+instance Stream s => Monad (ParsecT e s m) where

2+ return = pure

3+ (>>=) = pBind

4+#if !(MIN_VERSION_base(4,13,0))

5+ fail = Fail.fail

6+#endif

data/examples/other/cpp/separation-0b-out.hsnew file+10

@@ -0,0 +1,10 @@

1+instance Stream s => Monad (ParsecT e s m) where

2+ return = pure

3+ (>>=) = pBind

4+

5+#if !(MIN_VERSION_base(4,13,0))

6+ fail = Fail.fail

7+#endif

8+

9+foo :: Int

10+foo = undefined

data/examples/other/cpp/separation-0b.hsnew file+9

@@ -0,0 +1,9 @@

1+instance Stream s => Monad (ParsecT e s m) where

2+ return = pure

3+ (>>=) = pBind

4+#if !(MIN_VERSION_base(4,13,0))

5+ fail = Fail.fail

6+#endif

7+

8+foo :: Int

9+foo = undefined

data/examples/other/cpp/separation-1a-out.hsnew file+12

@@ -0,0 +1,12 @@

1+decompressingPipe ::

2+ (PrimMonad m, MonadThrow m, MonadResource m) =>

3+ CompressionMethod ->

4+ ConduitT ByteString ByteString m ()

5+decompressingPipe Store = C.awaitForever C.yield

6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)

7+

8+#ifdef ENABLE_BZIP2

9+decompressingPipe BZip2 = BZ.bunzip2

10+#else

11+decompressingPipe BZip2 = throwM BZip2Unsupported

12+#endif

data/examples/other/cpp/separation-1a.hsnew file+11

@@ -0,0 +1,11 @@

1+decompressingPipe

2+ :: (PrimMonad m, MonadThrow m, MonadResource m)

3+ => CompressionMethod

4+ -> ConduitT ByteString ByteString m ()

5+decompressingPipe Store = C.awaitForever C.yield

6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)

7+#ifdef ENABLE_BZIP2

8+decompressingPipe BZip2 = BZ.bunzip2

9+#else

10+decompressingPipe BZip2 = throwM BZip2Unsupported

11+#endif

data/examples/other/cpp/separation-1b-out.hsnew file+15

@@ -0,0 +1,15 @@

1+decompressingPipe ::

2+ (PrimMonad m, MonadThrow m, MonadResource m) =>

3+ CompressionMethod ->

4+ ConduitT ByteString ByteString m ()

5+decompressingPipe Store = C.awaitForever C.yield

6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)

7+

8+#ifdef ENABLE_BZIP2

9+decompressingPipe BZip2 = BZ.bunzip2

10+#else

11+decompressingPipe BZip2 = throwM BZip2Unsupported

12+#endif

13+

14+foo :: Int

15+foo = undefined

data/examples/other/cpp/separation-1b.hsnew file+14

@@ -0,0 +1,14 @@

1+decompressingPipe

2+ :: (PrimMonad m, MonadThrow m, MonadResource m)

3+ => CompressionMethod

4+ -> ConduitT ByteString ByteString m ()

5+decompressingPipe Store = C.awaitForever C.yield

6+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)

7+#ifdef ENABLE_BZIP2

8+decompressingPipe BZip2 = BZ.bunzip2

9+#else

10+decompressingPipe BZip2 = throwM BZip2Unsupported

11+#endif

12+

13+foo :: Int

14+foo = undefined

data/examples/other/cpp/separation-2a-out.hsnew file+9

@@ -0,0 +1,9 @@

1+ffff, ffffffff :: Natural

2+

3+#ifdef HASKELL_ZIP_DEV_MODE

4+ffff = 200

5+ffffffff = 5000

6+#else

7+ffff = 0xffff

8+ffffffff = 0xffffffff

9+#endif

data/examples/other/cpp/separation-2a.hsnew file+8

@@ -0,0 +1,8 @@

1+ffff, ffffffff :: Natural

2+#ifdef HASKELL_ZIP_DEV_MODE

3+ffff = 200

4+ffffffff = 5000

5+#else

6+ffff = 0xffff

7+ffffffff = 0xffffffff

8+#endif

data/examples/other/cpp/separation-2b-out.hsnew file+11

@@ -0,0 +1,11 @@

1+ffff, ffffffff :: Natural

2+#ifdef HASKELL_ZIP_DEV_MODE

3+ffff = 200

4+ffffffff = 5000

5+#else

6+ffff = 0xffff

7+ffffffff = 0xffffffff

8+#endif

9+

10+foo :: Int

11+foo = undefined

data/examples/other/cpp/separation-2b.hsnew file+11

@@ -0,0 +1,11 @@

1+ffff, ffffffff :: Natural

2+#ifdef HASKELL_ZIP_DEV_MODE

3+ffff = 200

4+ffffffff = 5000

5+#else

6+ffff = 0xffff

7+ffffffff = 0xffffffff

8+#endif

9+

10+foo :: Int

11+foo = undefined

data/examples/other/cpp/shifted-out.hsnew file+21

@@ -0,0 +1,21 @@

1+sinkData h compression = do

2+ (uncompressedSize, crc32, compressedSize) <-

3+ case compression of

4+ Store ->

5+ withCompression

6+ dataSink

7+ Deflate ->

8+ withCompression $

9+ Z.compress 9 (Z.WindowBits (-15)) .| dataSink

10+#ifdef ENABLE_BZIP2

11+ BZip2 -> withCompression $

12+ BZ.bzip2 .| dataSink

13+#else

14+ BZip2 -> throwM BZip2Unsupported

15+#endif

16+ return

17+ DataDescriptor

18+ { ddCRC32 = fromIntegral crc32,

19+ ddCompressedSize = compressedSize,

20+ ddUncompressedSize = uncompressedSize

21+ }

data/examples/other/cpp/shifted.hsnew file+17

@@ -0,0 +1,17 @@

1+sinkData h compression = do

2+ (uncompressedSize, crc32, compressedSize) <-

3+ case compression of

4+ Store -> withCompression

5+ dataSink

6+ Deflate -> withCompression $

7+ Z.compress 9 (Z.WindowBits (-15)) .| dataSink

8+#ifdef ENABLE_BZIP2

9+ BZip2 -> withCompression $

10+ BZ.bzip2 .| dataSink

11+#else

12+ BZip2 -> throwM BZip2Unsupported

13+#endif

14+ return DataDescriptor

15+ { ddCRC32 = fromIntegral crc32

16+ , ddCompressedSize = compressedSize

17+ , ddUncompressedSize = uncompressedSize }

data/examples/other/cpp/simple-import-out.hsnew file+14

@@ -0,0 +1,14 @@

1+module Main (main) where

2+

3+import Data.Void

4+import Test.Hspec

5+import Test.Hspec.Megaparsec

6+import Text.Megaparsec

7+import Text.Megaparsec.Char

8+

9+#if !MIN_VERSION_base(4,13,0)

10+import Data.Semigroup ((<>))

11+#endif

12+

13+main :: IO ()

14+main = return ()

data/examples/other/cpp/simple-import.hsnew file+14

@@ -0,0 +1,14 @@

1+module Main (main) where

2+

3+import Data.Void

4+import Test.Hspec

5+import Test.Hspec.Megaparsec

6+import Text.Megaparsec

7+import Text.Megaparsec.Char

8+

9+#if !MIN_VERSION_base(4,13,0)

10+import Data.Semigroup ((<>))

11+#endif

12+

13+main :: IO ()

14+main = return ()

data/examples/other/disabling/indented-fragment-out.hsnew file+7

@@ -0,0 +1,7 @@

1+foo =

2+ {- ORMOLU_DISABLE -}

3+ testCase "Foo" testFoo :

4+ testCase "Bar" testBar :

5+ testCase "Baz" testBaz :

6+ {- ORMOLU_ENABLE -}

7+ []

data/examples/other/disabling/indented-fragment.hsnew file+7

@@ -0,0 +1,7 @@

1+foo =

2+ {- ORMOLU_DISABLE -}

3+ testCase "Foo" testFoo :

4+ testCase "Bar" testBar :

5+ testCase "Baz" testBaz :

6+ {- ORMOLU_ENABLE -}

7+ []

data/examples/other/disabling/single-definition-out.hsnew file+10

@@ -0,0 +1,10 @@

1+module Foo (foo, bar) where

2+

3+{- ORMOLU_DISABLE -}

4+foo :: Int -> Int

5+foo = (+5)

6+{- ORMOLU_ENABLE -}

7+

8+bar :: Bool -> Bool

9+bar True = True

10+bar False = True

data/examples/other/disabling/single-definition.hsnew file+10

@@ -0,0 +1,10 @@

1+module Foo (foo,bar) where

2+

3+{- ORMOLU_DISABLE -}

4+foo :: Int -> Int

5+foo = (+5)

6+{- ORMOLU_ENABLE -}

7+

8+bar :: Bool -> Bool

9+bar True = True

10+bar False = True

data/examples/other/disabling/whole-file-out.hsnew file+10

@@ -0,0 +1,10 @@

1+{- ORMOLU_DISABLE -}

2+

3+module Foo (foo,bar) where

4+

5+foo :: Int -> Int

6+foo = (+5)

7+

8+bar :: Bool -> Bool

9+bar True = True

10+bar False = True

data/examples/other/disabling/whole-file.hsnew file+10

@@ -0,0 +1,10 @@

1+{- ORMOLU_DISABLE -}

2+

3+module Foo (foo,bar) where

4+

5+foo :: Int -> Int

6+foo = (+5)

7+

8+bar :: Bool -> Bool

9+bar True = True

10+bar False = True

data/examples/other/inline-comment-0-out.hsnew file+3

@@ -0,0 +1,3 @@

1+x = ({-a-} b, c)

2+

3+y = ({-a-} b)

data/examples/other/inline-comment-0.hsnew file+3

@@ -0,0 +1,3 @@

1+x = ({-a-}b, c)

2+

3+y = ({-a-}b)

data/examples/other/inline-comment-1-out.hsnew file+12

@@ -0,0 +1,12 @@

1+showPs env ((n, _, Let _ t v) : bs) =

2+ " " ++ show n ++ " : "

3+ ++ showEnv env ({- normalise ctxt env -} t)

4+ ++ " = "

5+ ++ showEnv env ({- normalise ctxt env -} v)

6+ ++ "\n"

7+ ++ showPs env bs

8+showPs env ((n, _, b) : bs) =

9+ " " ++ show n ++ " : "

10+ ++ showEnv env ({- normalise ctxt env -} (binderTy b))

11+ ++ "\n"

12+ ++ showPs env bs

data/examples/other/inline-comment-1.hsnew file+9

@@ -0,0 +1,9 @@

1+showPs env ((n, _, Let _ t v):bs)

2+ = " " ++ show n ++ " : " ++

3+ showEnv env ({- normalise ctxt env -} t) ++ " = " ++

4+ showEnv env ({- normalise ctxt env -} v) ++

5+ "\n" ++ showPs env bs

6+showPs env ((n, _, b):bs)

7+ = " " ++ show n ++ " : " ++

8+ showEnv env ({- normalise ctxt env -} (binderTy b)) ++

9+ "\n" ++ showPs env bs

data/examples/other/multiline-forall-out.hs+1−2

@@ -12,8 +12,7 @@ data D

12 )

13 (x :: *)

14 (y :: *).

15− D

16− (f x y)

15+ D (f x y)

17

16

18data G where

17data G where

19 G ::

18 G ::

data/examples/other/multiple-blank-line-comment-out.hsnew file+9

@@ -0,0 +1,9 @@

1+module A where

2+

3+a =

4+ b

5+ [ f

6+ {-,

7+

8+ -}

9+ ]

data/examples/other/multiple-blank-line-comment.hsnew file+10

@@ -0,0 +1,10 @@

1+module A where

2+

3+a =

4+ b

5+ [ f

6+ {-,

7+

8+

9+ -}

10+ ]

data/examples/other/pragma-comments-after-out.hsnew file+4

@@ -0,0 +1,4 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+-- TODO: Fix and delete this pragma

4+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

data/examples/other/pragma-comments-after.hsnew file+3

@@ -0,0 +1,3 @@

1+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- TODO: Fix and delete this pragma

2+{-# LANGUAGE AllowAmbiguousTypes #-}

3+{-# LANGUAGE ConstraintKinds #-}

data/examples/other/pragma-comments-out.hsnew file+8

@@ -0,0 +1,8 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+-- TODO This extension is probably too dangerous, remove it.

3+{-# LANGUAGE RecordWildCards #-}

4+-- Avoid warning produced by TH.

5+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

6+

7+-- | Header comment.

8+module Foo () where

data/examples/other/pragma-comments.hsnew file+11

@@ -0,0 +1,11 @@

1+-- | Header comment.

2+

3+{-# LANGUAGE OverloadedStrings #-}

4+

5+-- Avoid warning produced by TH.

6+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

7+

8+-- TODO This extension is probably too dangerous, remove it.

9+{-# LANGUAGE RecordWildCards #-}

10+

11+module Foo () where

data/examples/other/pragma-out.hs+1−4

@@ -9,7 +9,4 @@

9{-# OPTIONS_HADDOCK prune, show-extensions #-}

10

11-- | Header comment.

12−module Foo

12+module Foo () where

13− (

14− )

15−where

data/examples/other/pragma-sorting-out.hs+1−2

@@ -1,10 +1,9 @@

1{-# LANGUAGE NondecreasingIndentation #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE NoMonoLocalBinds #-}

5−

6-- This gap is necessary for stylish Haskell not to re-arrange

4-- This gap is necessary for stylish Haskell not to re-arrange

7-- NoMonoLocalBinds before TypeFamilies

5-- NoMonoLocalBinds before TypeFamilies

6+{-# LANGUAGE NoMonoLocalBinds #-}

8

7

9module Foo

8module Foo

10 ( bar,

9 ( bar,

default.nix+108−61

@@ -1,7 +1,9 @@

1−{ pkgs ? (import ./nix/nixpkgs) }:

1+{ pkgs ? (import ./nix/nixpkgs { inherit system; })

2+, system ? builtins.currentSystem

3+, ormoluCompiler ? "ghc884" # the shell doesn't work with ghc8101 yet

4+}:

2

5

3let

6let

4− ormoluCompiler = "ghc865";

5 source = pkgs.lib.sourceByRegex ./. [

7 source = pkgs.lib.sourceByRegex ./. [

6 "^.*\.md$"

8 "^.*\.md$"

7 "^app.*$"

9 "^app.*$"

@@ -14,67 +16,71 @@ let

14 overrides = ormoluOverlay;

16 overrides = ormoluOverlay;

15 };

17 };

16 ormoluOverlay = self: super: {

18 ormoluOverlay = self: super: {

17− "ormolu" = pkgs.haskell.lib.enableCabalFlag

18− (super.callCabal2nix "ormolu" source { }) "dev";

19+ "ormolu" = super.callCabal2nixWithOptions "ormolu" source "-fdev" { };

19− # Nixpkgs provides ghc-lib-parser-8.8.0.20190424, but we want

20− # ghc-lib-parser-8.10.1. We disable Haddock generation because it's way

21− # too slow.

22− "ghc-lib-parser" = pkgs.haskell.lib.dontHaddock

23− (super.callHackageDirect {

24− pkg = "ghc-lib-parser";

25− ver = "8.10.1.20200324";

26− sha256 = "0f2c68fzdj2lw6da2zpx7a0cx631im3kylwd85dzx1npsm1vzlbg";

27− } {});

28 };

20 };

29 ormolize = import ./nix/ormolize {

21 ormolize = import ./nix/ormolize {

30 inherit pkgs;

22 inherit pkgs;

31 inherit haskellPackages;

23 inherit haskellPackages;

32 };

24 };

33− # NOTE We have to exclude some directories for some packages because

25+ expectedFailures = [

34− # Ormolu needs files to be parsable by Haddock which is not always the

26+ "Agda"

35− # case. For example some tests and examples do not parse.

36− excludedHackageDirs = {

37− "aws" = ["Examples"];

27+ "aws"

38− "distributed-process" = ["benchmarks"];

28+ "distributed-process"

39− "esqueleto" = ["test"];

29+ "esqueleto"

40− "fay" = ["examples"];

30+ "fay"

31+ "hlint"

32+ "idris"

33+ "intero"

34+ "leksah"

35+ "pandoc"

36+ "pipes"

41− "postgrest" = ["test"];

37+ "postgrest"

42− };

38+ "purescript"

39+ "tensorflow"

40+ ] ++ (if ormoluCompiler == "ghc8101" then [] else ["lens"]);

43 ormolizedPackages = doCheck:

41 ormolizedPackages = doCheck:

44 pkgs.lib.mapAttrs (name: p: ormolize {

42 pkgs.lib.mapAttrs (name: p: ormolize {

45 package = p;

43 package = p;

46 inherit doCheck;

44 inherit doCheck;

47− excludedDirs =

45+ expectedFailures =

48− if builtins.hasAttr name excludedHackageDirs

46+ if pkgs.lib.lists.any (x: x == name) expectedFailures

49− then excludedHackageDirs.${name}

47+ then ./expected-failures + "/${name}.txt"

50− else [];

48+ else null;

51 }) haskellPackages;

49 }) haskellPackages;

52in {

50in {

53 ormolu = haskellPackages.ormolu;

51 ormolu = haskellPackages.ormolu;

52+ # We put the derivations in another attribute set to avoid building them

53+ # when nix-build is run.

54+ dev = {

55+ ormoluShell =

54− ormoluShell = haskellPackages.shellFor {

56+ haskellPackages.shellFor {

55− packages = ps: [

57+ packages = ps: [

56− ps.ormolu

58+ ps.ormolu

57− ];

59+ ];

58− buildInputs = [

60+ buildInputs = [

59− haskellPackages.cabal-install

61+ haskellPackages.cabal-install

60− haskellPackages.ghcid

62+ haskellPackages.ghcid

61− ];

63+ ];

62− };

64+ };

63− withOrmolu = haskellPackages.shellFor {

65+ withOrmolu = haskellPackages.shellFor {

64− packages = ps: [];

66+ packages = ps: [];

65− buildInputs = [

67+ buildInputs = [

66− haskellPackages.ormolu

68+ haskellPackages.cabal-install

69+ haskellPackages.ormolu

67− ];

70+ ];

71+ };

68 };

72 };

69 inherit ormoluOverlay ormoluCompiler;

73 inherit ormoluOverlay ormoluCompiler;

70 hackage = ormolizedPackages false;

74 hackage = ormolizedPackages false;

71 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (

75 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (

72 let ps = [

76 let ps = [

77+ "Agda"

73 "QuickCheck"

78 "QuickCheck"

74 "ShellCheck"

79 "ShellCheck"

75 "aeson"

80 "aeson"

76 "attoparsec"

81 "attoparsec"

77 "aws"

82 "aws"

83+ "brick"

78 "capability"

84 "capability"

79 "cassava"

85 "cassava"

80 "conduit"

86 "conduit"

@@ -86,37 +92,78 @@ in {

86 "hakyll"

92 "hakyll"

87 "haxl"

93 "haxl"

88 "hedgehog"

94 "hedgehog"

95+ "hledger"

89 "hlint"

96 "hlint"

97+ "http-client"

98+ "idris"

99+ "intero"

100+ "leksah"

101+ "lens"

90 "megaparsec"

102 "megaparsec"

91− "ormolu"

92 "optics"

103 "optics"

104+ "ormolu"

105+ "pandoc"

106+ "parsec3"

107+ "pipes"

93 "postgrest"

108 "postgrest"

109+ "purescript"

94 "servant"

110 "servant"

95 "servant-server"

111 "servant-server"

112+ "stack"

96 "tensorflow"

113 "tensorflow"

97 "text_1_2_4_0"

114 "text_1_2_4_0"

98 "tls"

115 "tls"

99 "yesod-core"

116 "yesod-core"

100−

101− # Comment idempotence issue

102−

103− # "Agda"

104− # "brick"

105− # "hledger"

106− # "http-client"

107− # "idris"

108− # "intero"

109− # "leksah"

110− # "pandoc"

111− # "pipes"

112− # "stack"

113−

114− # Missing language extension

115−

116− # "lens" #fixed in master

117− # "purescript"

118−

119 ];

117 ];

120 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)

118 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)

121 );

119 );

120+ regionTests = pkgs.stdenv.mkDerivation {

121+ name = "ormolu-region-tests";

122+ src = ./region-tests;

123+ buildInputs = [

124+ haskellPackages.ormolu

125+ pkgs.diffutils

126+ ];

127+ doCheck = true;

128+ buildPhase = ''

129+ cp src.hs result-all-implicit.hs

130+ ormolu --check-idempotence --mode inplace result-all-implicit.hs

131+ cp src.hs result-all-explicit.hs

132+ ormolu --check-idempotence --mode inplace --start-line 1 --end-line 18 result-all-explicit.hs

133+ cp src.hs result-only-start.hs

134+ ormolu --check-idempotence --mode inplace --start-line 1 result-only-start.hs

135+ cp src.hs result-only-end.hs

136+ ormolu --check-idempotence --mode inplace --end-line 18 result-only-end.hs

137+ cp src.hs result-6-7.hs

138+ ormolu --check-idempotence --mode inplace --start-line 6 --end-line 7 result-6-7.hs

139+ cp src.hs result-6-8.hs

140+ ormolu --check-idempotence --mode inplace --start-line 6 --end-line 8 result-6-8.hs

141+ cp src.hs result-9-12.hs

142+ ormolu --check-idempotence --mode inplace --start-line 9 --end-line 12 result-9-12.hs

143+ cp src.hs result-17-18.hs

144+ ormolu --check-idempotence --mode inplace --start-line 17 --end-line 18 result-17-18.hs

145+ '';

146+ checkPhase = ''

147+ echo result-all-implicit.hs

148+ diff --color=always expected-result-all.hs result-all-implicit.hs

149+ echo result-all-explicit.hs

150+ diff --color=always expected-result-all.hs result-all-explicit.hs

151+ echo result-only-start.hs

152+ diff --color=always expected-result-all.hs result-only-start.hs

153+ echo result-only-end.hs

154+ diff --color=always expected-result-all.hs result-only-end.hs

155+ echo result-6-7.hs

156+ diff --color=always expected-result-6-7.hs result-6-7.hs

157+ echo result-6-8.hs

158+ diff --color=always expected-result-6-8.hs result-6-8.hs

159+ echo result-9-12.hs

160+ diff --color=always expected-result-9-12.hs result-9-12.hs

161+ echo result-17-18.hs

162+ diff --color=always expected-result-17-18.hs result-17-18.hs

163+ '';

164+ installPhase = ''

165+ mkdir "$out"

166+ find . -name '*.hs' -exec cp --parents {} $out \;

167+ '';

168+ };

122}

169}

expected-failures/Agda.txtnew file+11

@@ -0,0 +1,11 @@

1+Formatting is not idempotent:

2+ dist/build/Agda/Syntax/Parser/Lexer.hs<rendered>:1602:17

3+ before: " = (check_ac"

4+ after: " =\n "

5+Please, consider reporting the bug.

6+

7+Formatting is not idempotent:

8+ src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:769:4

9+ before: " nes\n\n "

10+ after: " nes\n\n -- Andreas"

11+Please, consider reporting the bug.

expected-failures/aws.txtnew file+9

@@ -0,0 +1,9 @@

1+The GHC parser (in Haddock mode) failed:

2+ Examples/PutBucketNearLine.hs:5:1-6

3+ parse error on input `import'

4+

5+The GHC parser (in Haddock mode) failed:

6+ Examples/Sqs.hs:(88,3)-(90,4)

7+ parse error on input `{- | Let's make sure the queue was actually deleted and that the same number of queues exist at when

8+ | the program ends as when it started.

9+ -}'

expected-failures/distributed-process.txtnew file+7

@@ -0,0 +1,7 @@

1+The GHC parser (in Haddock mode) failed:

2+ benchmarks/Channels.hs:2:1-6

3+ parse error on input `import'

4+

5+The GHC parser (in Haddock mode) failed:

6+ benchmarks/Spawns.hs:5:1-6

7+ parse error on input `import'

expected-failures/esqueleto.txtnew file+7

@@ -0,0 +1,7 @@

1+The GHC parser (in Haddock mode) failed:

2+ src/Database/Esqueleto/Internal/Internal.hs:379:1

3+ lexical error in string/character literal at character 's'

4+

5+The GHC parser (in Haddock mode) failed:

6+ test/PostgreSQL/Test.hs:562:9-41

7+ parse error on input `-- | Check the result is not null'

expected-failures/fay.txtnew file+18

@@ -0,0 +1,18 @@

1+The GHC parser (in Haddock mode) failed:

2+ examples/Separated.hs:12:1-6

3+ parse error on input `module'

4+

5+The GHC parser (in Haddock mode) failed:

6+ examples/calc.hs:(4,1)-(6,2)

7+ parse error on input `-- $ fay -p --html-wrapper --html-js-lib jquery.min.js examples/calc.hs

8+-- You also need to download jquery.min.js.

9+--'

10+

11+The GHC parser (in Haddock mode) failed:

12+ examples/canvaswater.hs:(6,1)-(7,17)

13+ parse error on input `-- | A demonstration of Fay using the canvas element to display a

14+-- simple effect.'

15+

16+The GHC parser (in Haddock mode) failed:

17+ examples/data.hs:9:1-6

18+ parse error on input `module'

expected-failures/hlint.txtnew file+11

@@ -0,0 +1,11 @@

1+Formatting is not idempotent:

2+ src/Extension.hs<rendered>:19:22

3+ before: "DoRec , -} Recursive"

4+ after: "DoRec , -}\n "

5+Please, consider reporting the bug.

6+

7+Formatting is not idempotent:

8+ src/Hint/Bracket.hs<rendered>:249:50

9+ before: "\" x y [r]) {ideaSpan"

10+ after: "\" x y [r])\n "

11+Please, consider reporting the bug.

expected-failures/idris.txtnew file+7

@@ -0,0 +1,7 @@

1+The GHC parser (in Haddock mode) failed:

2+ src/Idris/Parser.hs:1052:1

3+ parse error on input `@'

4+

5+The GHC parser (in Haddock mode) failed:

6+ src/Idris/Parser/Expr.hs:75:1

7+ parse error on input `@'

expected-failures/intero.txtnew file+5

@@ -0,0 +1,5 @@

1+Formatting is not idempotent:

2+ src/InteractiveUI.hs<rendered>:3748:33

3+ before: "text \"Try\" <+> doWha"

4+ after: "text \"Try\"\n "

5+Please, consider reporting the bug.

expected-failures/leksah.txtnew file+5

@@ -0,0 +1,5 @@

1+Formatting is not idempotent:

2+ src/IDE/Pane/Modules.hs<rendered>:1184:7

3+ before: "cr\n -- show"

4+ after: "cr\n in -- show"

5+Please, consider reporting the bug.

expected-failures/lens.txtnew file+3

@@ -0,0 +1,3 @@

1+The GHC parser (in Haddock mode) failed:

2+ src/Control/Exception/Lens.hs:180:13-37

3+ parse error on input `AllocationLimitExceeded__'

expected-failures/pandoc.txtnew file+9

@@ -0,0 +1,9 @@

1+The GHC parser (in Haddock mode) failed:

2+ benchmark/weigh-pandoc.hs:14:1-6

3+ parse error on input `import'

4+

5+Formatting is not idempotent:

6+ src/Text/Pandoc/Readers/Vimwiki.hs<rendered>:613:19

7+ before: ".softbreak <$ endlin"

8+ after: ".softbreak\n <$ en"

9+Please, consider reporting the bug.

expected-failures/pipes.txtnew file+3

@@ -0,0 +1,3 @@

1+AST of input and AST of formatted code differ.

2+ at src/Pipes/Core.hs:(128,1)-(151,2)

3+Please, consider reporting the bug.

expected-failures/postgrest.txtnew file+5

@@ -0,0 +1,5 @@

1+Formatting is not idempotent:

2+ src/PostgREST/DbRequestBuilder.hs<rendered>:149:24

3+ before: " || -- clients"

4+ after: " || ( origin ="

5+Please, consider reporting the bug.

expected-failures/purescript.txtnew file+18

@@ -0,0 +1,18 @@

1+The GHC parser (in Haddock mode) failed:

2+ src/Language/PureScript/AST/Declarations.hs:479:1-17

3+ Invalid type signature: pattern ValueDecl :: ...

4+Perhaps you meant to use PatternSynonyms?

5+

6+The GHC parser (in Haddock mode) failed:

7+ src/Language/PureScript/AST/SourcePos.hs:99:1-22

8+ Invalid type signature: pattern NullSourceSpan :: ...

9+Perhaps you meant to use PatternSynonyms?

10+

11+The GHC parser (in Haddock mode) failed:

12+ src/Language/PureScript/Constants.hs:42:1-15

13+ Invalid type signature: pattern Discard :: ...

14+Perhaps you meant to use PatternSynonyms?

15+

16+The GHC parser (in Haddock mode) failed:

17+ src/Language/PureScript/Crash.hs:16:1-6

18+ parse error on input `import'

expected-failures/tensorflow.txtnew file+7

@@ -0,0 +1,7 @@

1+The GHC parser (in Haddock mode) failed:

2+ tensorflow-mnist/app/Main.hs:50:13-14

3+ parse error on input `->'

4+

5+The GHC parser (in Haddock mode) failed:

6+ tensorflow-ops/tests/RegressionTest.hs:3:1-6

7+ parse error on input `import'

format.sh+6−4

@@ -1,5 +1,5 @@

1#!/usr/bin/env nix-shell

2−#!nix-shell default.nix -A withOrmolu -i bash --pure

2+#!nix-shell default.nix -A dev.withOrmolu -i bash --pure

3#

4# Format Ormolu using current version of Ormolu.

5

@@ -7,6 +7,8 @@ set -e

7

8export LANG="C.UTF-8"

9

10+cabal format

11+

10−ormolu -p -m inplace $(find app -type f -name "*.hs")

12+ormolu -m inplace $(find app -type f -name "*.hs")

11−ormolu -p -m inplace $(find src -type f $ -name "*.hs" -o -name "*.hs-boot" $)

13+ormolu -m inplace $(find src -type f $ -name "*.hs" -o -name "*.hs-boot" $)

12−ormolu -p -m inplace $(find tests -type f -name "*.hs")

14+ormolu -m inplace $(find tests -type f -name "*.hs")

nix/nixpkgs/default.nix+7−3

@@ -1,9 +1,13 @@

1+{ system ? builtins.currentSystem }:

1let

2let

2− rev = "19.09";

3+ rev = "32b46dd897ab2143a609988a04d87452f0bbef59";

3− sha256 = "0mhqhq21y5vrr1f30qd2bvydv4bbbslvyzclhw0kdxmkgg3z4c92";

4+ sha256 = "1gzfrpjnr1bz9zljsyg3a4zrhk8r927sz761mrgcg56dwinkhpjk";

4 nixpkgs = builtins.fetchTarball {

5 nixpkgs = builtins.fetchTarball {

5 url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";

6 url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";

6 inherit sha256;

7 inherit sha256;

7 };

8 };

9+ pkgs = import nixpkgs {

10+ inherit system;

8− pkgs = import nixpkgs { config.allowUnfree = true; };

11+ config.allowUnfree = true;

12+ };

9in pkgs

13in pkgs

nix/ormolize/default.nix+29−13

@@ -2,32 +2,48 @@

2, haskellPackages

3}:

4{ package

5+, expectedFailures ? null

5, doCheck ? false

6, doCheck ? false

6−, excludedDirs ? []

7}:

8 pkgs.stdenv.mkDerivation rec {

9 name = package.name + "-ormolized";

10 src = package.src;

11 buildInputs = [

12 haskellPackages.cpphs

13− (if doCheck

14− then haskellPackages.ormolu

13+ haskellPackages.ormolu

15− else pkgs.haskell.lib.dontCheck haskellPackages.ormolu)

14+ pkgs.diffutils

16 pkgs.glibcLocales

15 pkgs.glibcLocales

17 ];

16 ];

18 LANG = "en_US.UTF-8";

17 LANG = "en_US.UTF-8";

19− excludedDirsRendered =

20− if excludedDirs == []

21− then ""

22− else pkgs.lib.concatMapStringsSep " " (x: "-not -path './" + x + "/*'") excludedDirs;

23 buildPhase = ''

18 buildPhase = ''

24− find . -name '*.hs' ${excludedDirsRendered} -exec bash ${./ormolize.sh} {} \; 2> log.txt

19+ hs_files=$(find . -name '*.hs')

25− cat log.txt

20+ for hs_file in $hs_files; do

21+

22+ # drop includes

23+ sed -i '/^#include/d' "$hs_file"

24+

25+ # deal with CPP

26+ cpphs "$hs_file" --noline -DARCH_X86 > "''${hs_file}-nocpp" 2> /dev/null

27+

28+ # annoyingly, cpphs cannot modify files in place

29+ mv "''${hs_file}-nocpp" "$hs_file"

30+

31+ # preserve the original

32+ cp "$hs_file" "''${hs_file}-original"

33+ done

34+

35+ (ormolu --check-idempotence --mode inplace $hs_files || true) 2> log.txt

26 '';

36 '';

27 inherit doCheck;

37 inherit doCheck;

28− checkPhase = ''

38+ checkPhase =

39+ if expectedFailures == null

40+ then ''

41+ echo "No failures expected"

29− if [[ -s log.txt ]]; then exit 1; fi

42+ if [[ -s log.txt ]]; then exit 1; fi

43+ ''

44+ else ''

45+ diff --ignore-blank-lines --color=always ${expectedFailures} log.txt

30− '';

46+ '';

31 installPhase = ''

47 installPhase = ''

32 mkdir "$out"

48 mkdir "$out"

33 find . -name '*.hs-original' -exec cp --parents {} $out \;

49 find . -name '*.hs-original' -exec cp --parents {} $out \;

nix/ormolize/ormolize.shdeleted−17

@@ -1,17 +0,0 @@

1−set -euo pipefail

2−

3−# drop includes

4−sed -i '/^#include/d' "$1"

5−

6−# deal with CPP in a fairly straightforward way

7−cpphs "$1" --noline > "$1-nocpp" 2> /dev/null

8−

9−# annoyingly, cpphs cannot modify files in place

10−mv "$1-nocpp" "$1"

11−

12−# preserve the original

13−cp "$1" "$1-original"

14−

15−# run ormolu

16−ormolu --tolerate-cpp --check-idempotency --mode inplace "$1" ||

17− ormolu --tolerate-cpp --unsafe --mode inplace "$1"

ormolu.cabal+174−155

@@ -1,165 +1,184 @@

1−name: ormolu

2−version: 0.0.3.1

3−cabal-version: 1.18

1+cabal-version: 1.18

4−tested-with: GHC==8.6.5

2+name: ormolu

3+version: 0.1.2.0

5−license: BSD3

4+license: BSD3

6−license-file: LICENSE.md

5+license-file: LICENSE.md

7−maintainer: Mark Karpov <mark.karpov@tweag.io>

6+maintainer: Mark Karpov <mark.karpov@tweag.io>

7+tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.1

8−homepage: https://github.com/tweag/ormolu

8+homepage: https://github.com/tweag/ormolu

9−bug-reports: https://github.com/tweag/ormolu/issues

9+bug-reports: https://github.com/tweag/ormolu/issues

10+synopsis: A formatter for Haskell source code

11+description: A formatter for Haskell source code.

10−category: Development, Formatting

12+category: Development, Formatting

11−synopsis: A formatter for Haskell source code

12−build-type: Simple

13+build-type: Simple

13−description: A formatter for Haskell source code.

14+data-files:

14−extra-doc-files: CONTRIBUTING.md

15− , CHANGELOG.md

16− , DESIGN.md

17− , README.md

18−data-files: data/examples/declaration/annotation/*.hs

15+ data/examples/declaration/annotation/*.hs

19− , data/examples/declaration/class/*.hs

16+ data/examples/declaration/class/*.hs

20− , data/examples/declaration/data/*.hs

17+ data/examples/declaration/data/*.hs

21− , data/examples/declaration/data/gadt/*.hs

18+ data/examples/declaration/data/gadt/*.hs

22− , data/examples/declaration/default/*.hs

19+ data/examples/declaration/default/*.hs

23− , data/examples/declaration/deriving/*.hs

20+ data/examples/declaration/deriving/*.hs

24− , data/examples/declaration/foreign/*.hs

21+ data/examples/declaration/foreign/*.hs

25− , data/examples/declaration/instance/*.hs

22+ data/examples/declaration/instance/*.hs

26− , data/examples/declaration/rewrite-rule/*.hs

23+ data/examples/declaration/rewrite-rule/*.hs

27− , data/examples/declaration/role-annotation/*.hs

24+ data/examples/declaration/role-annotation/*.hs

28− , data/examples/declaration/signature/complete/*.hs

25+ data/examples/declaration/signature/complete/*.hs

29− , data/examples/declaration/signature/fixity/*.hs

26+ data/examples/declaration/signature/fixity/*.hs

30− , data/examples/declaration/signature/inline/*.hs

27+ data/examples/declaration/signature/inline/*.hs

31− , data/examples/declaration/signature/minimal/*.hs

28+ data/examples/declaration/signature/minimal/*.hs

32− , data/examples/declaration/signature/pattern/*.hs

29+ data/examples/declaration/signature/pattern/*.hs

33− , data/examples/declaration/signature/set-cost-centre/*.hs

30+ data/examples/declaration/signature/set-cost-centre/*.hs

34− , data/examples/declaration/signature/specialize/*.hs

31+ data/examples/declaration/signature/specialize/*.hs

35− , data/examples/declaration/signature/type/*.hs

32+ data/examples/declaration/signature/type/*.hs

36− , data/examples/declaration/splice/*.hs

33+ data/examples/declaration/splice/*.hs

37− , data/examples/declaration/type-families/closed-type-family/*.hs

34+ data/examples/declaration/type-families/closed-type-family/*.hs

38− , data/examples/declaration/type-families/data-family/*.hs

35+ data/examples/declaration/type-families/data-family/*.hs

39− , data/examples/declaration/type-families/type-family/*.hs

36+ data/examples/declaration/type-families/type-family/*.hs

40− , data/examples/declaration/type-synonyms/*.hs

37+ data/examples/declaration/type-synonyms/*.hs

41− , data/examples/declaration/type/*.hs

38+ data/examples/declaration/type/*.hs

42− , data/examples/declaration/value/function/*.hs

39+ data/examples/declaration/value/function/*.hs

43− , data/examples/declaration/value/function/arrow/*.hs

40+ data/examples/declaration/value/function/arrow/*.hs

44− , data/examples/declaration/value/function/comprehension/*.hs

41+ data/examples/declaration/value/function/comprehension/*.hs

45− , data/examples/declaration/value/function/do/*.hs

42+ data/examples/declaration/value/function/do/*.hs

46− , data/examples/declaration/value/function/infix/*.hs

43+ data/examples/declaration/value/function/infix/*.hs

47− , data/examples/declaration/value/function/pattern/*.hs

44+ data/examples/declaration/value/function/pattern/*.hs

48− , data/examples/declaration/value/other/*.hs

45+ data/examples/declaration/value/other/*.hs

49− , data/examples/declaration/value/pattern-synonyms/*.hs

46+ data/examples/declaration/value/pattern-synonyms/*.hs

50− , data/examples/declaration/warning/*.hs

47+ data/examples/declaration/warning/*.hs

51− , data/examples/import/*.hs

48+ data/examples/import/*.hs

52− , data/examples/module-header/*.hs

49+ data/examples/module-header/*.hs

53− , data/examples/other/*.hs

50+ data/examples/other/*.hs

51+

52+extra-doc-files:

53+ CONTRIBUTING.md

54+ CHANGELOG.md

55+ DESIGN.md

56+ README.md

54

57

55source-repository head

58source-repository head

56− type: git

59+ type: git

57− location: https://github.com/tweag/ormolu.git

60+ location: https://github.com/tweag/ormolu.git

58

61

59flag dev

62flag dev

60− description: Turn on development settings.

63+ description: Turn on development settings.

61− manual: True

62− default: False

64+ default: False

65+ manual: True

63

66

64library

67library

65− hs-source-dirs: src

66− build-depends: base >= 4.12 && < 5.0

67− , bytestring >= 0.2 && < 0.11

68− , containers >= 0.5 && < 0.7

69− , dlist >= 0.8 && < 0.9

70− , exceptions >= 0.6 && < 0.11

71− , ghc-lib-parser >= 8.10 && < 8.11

72− , mtl >= 2.0 && < 3.0

73− , syb >= 0.7 && < 0.8

74− , text >= 0.2 && < 1.3

75− exposed-modules: Ormolu

68+ exposed-modules:

69+ Ormolu

76− , Ormolu.Config

70+ Ormolu.Config

77− , Ormolu.Diff

71+ Ormolu.Diff

78− , Ormolu.Exception

72+ Ormolu.Exception

79− , Ormolu.Imports

73+ Ormolu.Imports

80− , Ormolu.Parser

74+ Ormolu.Parser

81− , Ormolu.Parser.Anns

75+ Ormolu.Parser.Anns

82− , Ormolu.Parser.CommentStream

76+ Ormolu.Parser.CommentStream

83− , Ormolu.Parser.Pragma

77+ Ormolu.Parser.Pragma

84− , Ormolu.Parser.Result

78+ Ormolu.Parser.Result

79+ Ormolu.Parser.Shebang

85− , Ormolu.Printer

80+ Ormolu.Printer

86− , Ormolu.Printer.Combinators

81+ Ormolu.Printer.Combinators

87− , Ormolu.Printer.Comments

82+ Ormolu.Printer.Comments

88− , Ormolu.Printer.Internal

83+ Ormolu.Printer.Internal

89− , Ormolu.Printer.Meat.Common

84+ Ormolu.Printer.Meat.Common

90− , Ormolu.Printer.Meat.Declaration

85+ Ormolu.Printer.Meat.Declaration

91− , Ormolu.Printer.Meat.Declaration.Annotation

86+ Ormolu.Printer.Meat.Declaration.Annotation

92− , Ormolu.Printer.Meat.Declaration.Class

87+ Ormolu.Printer.Meat.Declaration.Class

93− , Ormolu.Printer.Meat.Declaration.Data

88+ Ormolu.Printer.Meat.Declaration.Data

94− , Ormolu.Printer.Meat.Declaration.Default

89+ Ormolu.Printer.Meat.Declaration.Default

95− , Ormolu.Printer.Meat.Declaration.Foreign

90+ Ormolu.Printer.Meat.Declaration.Foreign

96− , Ormolu.Printer.Meat.Declaration.Instance

91+ Ormolu.Printer.Meat.Declaration.Instance

97− , Ormolu.Printer.Meat.Declaration.RoleAnnotation

92+ Ormolu.Printer.Meat.Declaration.RoleAnnotation

98− , Ormolu.Printer.Meat.Declaration.Rule

93+ Ormolu.Printer.Meat.Declaration.Rule

99− , Ormolu.Printer.Meat.Declaration.Signature

94+ Ormolu.Printer.Meat.Declaration.Signature

100− , Ormolu.Printer.Meat.Declaration.Splice

95+ Ormolu.Printer.Meat.Declaration.Splice

101− , Ormolu.Printer.Meat.Declaration.Type

96+ Ormolu.Printer.Meat.Declaration.Type

102− , Ormolu.Printer.Meat.Declaration.TypeFamily

97+ Ormolu.Printer.Meat.Declaration.TypeFamily

103− , Ormolu.Printer.Meat.Declaration.Value

98+ Ormolu.Printer.Meat.Declaration.Value

104− , Ormolu.Printer.Meat.Declaration.Warning

99+ Ormolu.Printer.Meat.Declaration.Warning

105− , Ormolu.Printer.Meat.ImportExport

100+ Ormolu.Printer.Meat.ImportExport

106− , Ormolu.Printer.Meat.Module

101+ Ormolu.Printer.Meat.Module

107− , Ormolu.Printer.Meat.Pragma

102+ Ormolu.Printer.Meat.Pragma

108− , Ormolu.Printer.Meat.Type

103+ Ormolu.Printer.Meat.Type

109− , Ormolu.Printer.Operators

104+ Ormolu.Printer.Operators

110− , Ormolu.Printer.SpanStream

105+ Ormolu.Printer.SpanStream

106+ Ormolu.Processing.Common

107+ Ormolu.Processing.Cpp

108+ Ormolu.Processing.Postprocess

109+ Ormolu.Processing.Preprocess

111− , Ormolu.Utils

110+ Ormolu.Utils

112− other-modules: GHC

113− , GHC.DynFlags

114− if flag(dev)

115− ghc-options: -Wall -Werror -Wcompat

116− -Wincomplete-record-updates

117− -Wincomplete-uni-patterns

118− -Wnoncanonical-monad-instances

119− -- https://github.com/haskell/haddock/issues/1116

120− -Wno-missing-home-modules

121− else

122− ghc-options: -O2 -Wall

123− default-language: Haskell2010

124

111

125−test-suite tests

126− main-is: Spec.hs

127− hs-source-dirs: tests

112+ hs-source-dirs: src

128− type: exitcode-stdio-1.0

113+ other-modules:

114+ GHC

115+ GHC.DynFlags

116+

117+ default-language: Haskell2010

129− build-depends: base >= 4.12 && < 5.0

118+ build-depends:

119+ base >=4.12 && <5.0,

120+ bytestring >=0.2 && <0.11,

130− , containers >= 0.5 && < 0.7

121+ containers >=0.5 && <0.7,

131− , filepath >= 1.2 && < 1.5

122+ dlist >=0.8 && <2.0,

132− , hspec >= 2.0 && < 3.0

123+ exceptions >=0.6 && <0.11,

133− , ormolu

124+ ghc-lib-parser >=8.10 && <8.11,

134− , path >= 0.6 && < 0.8

125+ mtl >=2.0 && <3.0,

135− , path-io >= 1.4.2 && < 2.0

126+ syb >=0.7 && <0.8,

136− , text >= 0.2 && < 1.3

127+ text >=0.2 && <1.3

137− build-tools: hspec-discover >= 2.0 && < 3.0

138− other-modules:

139− Ormolu.Parser.PragmaSpec

140− , Ormolu.PrinterSpec

141

128

142− if flag(dev)

129+ if flag(dev)

143− ghc-options: -Wall -Werror

130+ ghc-options:

131+ -Wall -Werror -Wcompat -Wincomplete-record-updates

132+ -Wincomplete-uni-patterns -Wnoncanonical-monad-instances

133+ -Wno-missing-home-modules

134+

144− else

135+ else

145− ghc-options: -O2 -Wall

136+ ghc-options: -O2 -Wall

146− default-language: Haskell2010

147

137

148executable ormolu

138executable ormolu

149− main-is: Main.hs

139+ main-is: Main.hs

150− hs-source-dirs: app

140+ hs-source-dirs: app

141+ other-modules: Paths_ormolu

142+ default-language: Haskell2010

151− build-depends: base >= 4.12 && < 5.0

143+ build-depends:

144+ base >=4.12 && <5.0,

152− , ghc-lib-parser >= 8.10 && < 8.11

145+ ghc-lib-parser >=8.10 && <8.11,

153− , gitrev >= 1.3 && < 1.4

146+ gitrev >=1.3 && <1.4,

154− , optparse-applicative >= 0.14 && < 0.16

147+ optparse-applicative >=0.14 && <0.17,

155− , ormolu

148+ ormolu -any,

156− , text >= 0.2 && < 1.3

149+ text >=0.2 && <1.3

157− other-modules: Paths_ormolu

150+

158− if flag(dev)

151+ if flag(dev)

159− ghc-options: -Wall -Werror -Wcompat

152+ ghc-options:

160− -Wincomplete-record-updates

153+ -Wall -Werror -Wcompat -Wincomplete-record-updates

161− -Wincomplete-uni-patterns

162− -Wnoncanonical-monad-instances

154+ -Wincomplete-uni-patterns -Wnoncanonical-monad-instances

163− else

155+ -optP-Wno-nonportable-include-path

156+

157+ else

164− ghc-options: -O2 -Wall -rtsopts

158+ ghc-options: -O2 -Wall -rtsopts

159+

160+test-suite tests

161+ type: exitcode-stdio-1.0

162+ main-is: Spec.hs

163+ build-tools: hspec-discover >=2.0 && <3.0

164+ hs-source-dirs: tests

165+ other-modules:

166+ Ormolu.Parser.PragmaSpec

167+ Ormolu.PrinterSpec

168+

165− default-language: Haskell2010

169+ default-language: Haskell2010

170+ build-depends:

171+ base >=4.12 && <5.0,

172+ containers >=0.5 && <0.7,

173+ filepath >=1.2 && <1.5,

174+ hspec >=2.0 && <3.0,

175+ ormolu -any,

176+ path >=0.6 && <0.8,

177+ path-io >=1.4.2 && <2.0,

178+ text >=0.2 && <1.3

179+

180+ if flag(dev)

181+ ghc-options: -Wall -Werror

182+

183+ else

184+ ghc-options: -O2 -Wall

region-tests/expected-result-17-18.hsnew file+17

@@ -0,0 +1,17 @@

1+{-# LANGUAGE LambdaCase #-}

2+

3+module Foo (

4+ foo, bar, baz) where

5+

6+foo :: Int

7+foo = 5

8+

9+bar :: Int -> Int

10+bar = \case

11+ 0 -> foo

12+ x -> x - foo

13+

14+baz :: Int -> Int

15+baz = gege

16+ where

17+ gege = 1 + 2

region-tests/expected-result-6-7.hsnew file+17

@@ -0,0 +1,17 @@

1+{-# LANGUAGE LambdaCase #-}

2+

3+module Foo (

4+ foo, bar, baz) where

5+

6+foo :: Int

7+foo = 5

8+

9+bar :: Int -> Int

10+bar = \case

11+ 0 -> foo

12+ x -> x - foo

13+

14+baz :: Int -> Int

15+baz = gege

16+ where

17+ gege = 1 + 2

region-tests/expected-result-6-8.hsnew file+16

@@ -0,0 +1,16 @@

1+{-# LANGUAGE LambdaCase #-}

2+

3+module Foo (

4+ foo, bar, baz) where

5+

6+foo :: Int

7+foo = 5

8+bar :: Int -> Int

9+bar = \case

10+ 0 -> foo

11+ x -> x - foo

12+

13+baz :: Int -> Int

14+baz = gege

15+ where

16+ gege = 1 + 2

region-tests/expected-result-9-12.hsnew file+17

@@ -0,0 +1,17 @@

1+{-# LANGUAGE LambdaCase #-}

2+

3+module Foo (

4+ foo, bar, baz) where

5+

6+foo :: Int

7+foo = 5

8+

9+bar :: Int -> Int

10+bar = \case

11+ 0 -> foo

12+ x -> x - foo

13+

14+baz :: Int -> Int

15+baz = gege

16+ where

17+ gege = 1 + 2

region-tests/expected-result-all.hsnew file+21

@@ -0,0 +1,21 @@

1+{-# LANGUAGE LambdaCase #-}

2+

3+module Foo

4+ ( foo,

5+ bar,

6+ baz,

7+ )

8+where

9+

10+foo :: Int

11+foo = 5

12+

13+bar :: Int -> Int

14+bar = \case

15+ 0 -> foo

16+ x -> x - foo

17+

18+baz :: Int -> Int

19+baz = gege

20+ where

21+ gege = 1 + 2

region-tests/src.hsnew file+17

@@ -0,0 +1,17 @@

1+{-# LANGUAGE LambdaCase #-}

2+

3+module Foo (

4+ foo, bar, baz) where

5+

6+foo :: Int

7+foo = 5

8+

9+bar :: Int -> Int

10+bar = \case

11+ 0 -> foo

12+ x -> x - foo

13+

14+baz :: Int -> Int

15+baz = gege

16+ where

17+ gege = 1 + 2

shell.nix+4−2

@@ -1,3 +1,5 @@

1−{ pkgs ? (import ./nix/nixpkgs) }:

1+{ pkgs ? (import ./nix/nixpkgs { inherit system; })

2+, system ? builtins.currentSystem

3+}:

2

4

3−(import ./default.nix { inherit pkgs; }).ormoluShell

5+(import ./default.nix { inherit pkgs; }).dev.ormoluShell

src/GHC.hs−3

@@ -1,6 +1,5 @@

1module GHC

2 ( module X,

3− ParsedSource,

4 )

3 )

5where

4where

6

5

@@ -11,5 +10,3 @@ import GHC.Hs.Instances as X ()

11import Module as X

10import Module as X

12import RdrName as X

11import RdrName as X

13import SrcLoc as X

12import SrcLoc as X

14−

15−type ParsedSource = Located (HsModule GhcPs)

src/Ormolu.hs+10−7

@@ -6,6 +6,7 @@ module Ormolu

6 ormoluFile,

7 ormoluStdin,

8 Config (..),

9+ RegionIndices (..),

9 defaultConfig,

10 defaultConfig,

10 DynOption (..),

11 DynOption (..),

11 OrmoluException (..),

12 OrmoluException (..),

@@ -42,13 +43,15 @@ import qualified SrcLoc as GHC

42ormolu ::

43ormolu ::

43 MonadIO m =>

44 MonadIO m =>

44 -- | Ormolu configuration

45 -- | Ormolu configuration

45− Config ->

46+ Config RegionIndices ->

46 -- | Location of source file

47 -- | Location of source file

47 FilePath ->

48 FilePath ->

48 -- | Input to format

49 -- | Input to format

49 String ->

50 String ->

50 m Text

51 m Text

51−ormolu cfg path str = do

52+ormolu cfgWithIndices path str = do

53+ let totalLines = length (lines str)

54+ cfg = regionIndicesToDeltas totalLines <$> cfgWithIndices

52 (warnings, result0) <-

55 (warnings, result0) <-

53 parseModule' cfg OrmoluParsingFailed path str

56 parseModule' cfg OrmoluParsingFailed path str

54 when (cfgDebug cfg) $ do

57 when (cfgDebug cfg) $ do

@@ -60,7 +63,7 @@ ormolu cfg path str = do

60 -- to parse the rendered code back, inside of GHC monad wrapper which will

63 -- to parse the rendered code back, inside of GHC monad wrapper which will

61 -- lead to error messages presenting the exceptions as GHC bugs.

64 -- lead to error messages presenting the exceptions as GHC bugs.

62 let !txt = printModule result0

65 let !txt = printModule result0

63− when (not (cfgUnsafe cfg) || cfgCheckIdempotency cfg) $ do

66+ when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do

64 let pathRendered = path ++ "<rendered>"

67 let pathRendered = path ++ "<rendered>"

65 -- Parse the result of pretty-printing again and make sure that AST

68 -- Parse the result of pretty-printing again and make sure that AST

66 -- is the same as AST of original snippet module span positions.

69 -- is the same as AST of original snippet module span positions.

@@ -76,7 +79,7 @@ ormolu cfg path str = do

76 Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss)

79 Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss)

77 -- Try re-formatting the formatted result to check if we get exactly

80 -- Try re-formatting the formatted result to check if we get exactly

78 -- the same output.

81 -- the same output.

79− when (cfgCheckIdempotency cfg) $

82+ when (cfgCheckIdempotence cfg) $

80 let txt2 = printModule result1

83 let txt2 = printModule result1

81 in case diffText txt txt2 pathRendered of

84 in case diffText txt txt2 pathRendered of

82 Nothing -> return ()

85 Nothing -> return ()

@@ -93,7 +96,7 @@ ormolu cfg path str = do

93ormoluFile ::

96ormoluFile ::

94 MonadIO m =>

97 MonadIO m =>

95 -- | Ormolu configuration

98 -- | Ormolu configuration

96− Config ->

99+ Config RegionIndices ->

97 -- | Location of source file

100 -- | Location of source file

98 FilePath ->

101 FilePath ->

99 -- | Resulting rendition

102 -- | Resulting rendition

@@ -108,7 +111,7 @@ ormoluFile cfg path =

108ormoluStdin ::

111ormoluStdin ::

109 MonadIO m =>

112 MonadIO m =>

110 -- | Ormolu configuration

113 -- | Ormolu configuration

111− Config ->

114+ Config RegionIndices ->

112 -- | Resulting rendition

115 -- | Resulting rendition

113 m Text

116 m Text

114ormoluStdin cfg =

117ormoluStdin cfg =

@@ -121,7 +124,7 @@ ormoluStdin cfg =

121parseModule' ::

124parseModule' ::

122 MonadIO m =>

125 MonadIO m =>

123 -- | Ormolu configuration

126 -- | Ormolu configuration

124− Config ->

127+ Config RegionDeltas ->

125 -- | How to obtain 'OrmoluException' to throw when parsing fails

128 -- | How to obtain 'OrmoluException' to throw when parsing fails

126 (GHC.SrcSpan -> String -> OrmoluException) ->

129 (GHC.SrcSpan -> String -> OrmoluException) ->

127 -- | File name to use in errors

130 -- | File name to use in errors

src/Ormolu/Config.hs+62−23

@@ -1,7 +1,13 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE RecordWildCards #-}

3+

1-- | Configuration options used by the tool.

4-- | Configuration options used by the tool.

2module Ormolu.Config

5module Ormolu.Config

3 ( Config (..),

6 ( Config (..),

7+ RegionIndices (..),

8+ RegionDeltas (..),

4 defaultConfig,

9 defaultConfig,

10+ regionIndicesToDeltas,

5 DynOption (..),

11 DynOption (..),

6 dynOptionToLocatedStr,

12 dynOptionToLocatedStr,

7 )

13 )

@@ -10,39 +16,72 @@ where

10import qualified SrcLoc as GHC

16import qualified SrcLoc as GHC

11

17

12-- | Ormolu configuration.

18-- | Ormolu configuration.

13−data Config

19+data Config region = Config

14− = Config

15− { -- | Dynamic options to pass to GHC parser

20+ { -- | Dynamic options to pass to GHC parser

16− cfgDynOptions :: ![DynOption],

21+ cfgDynOptions :: ![DynOption],

17− -- | Do formatting faster but without automatic detection of defects

22+ -- | Do formatting faster but without automatic detection of defects

18− cfgUnsafe :: !Bool,

23+ cfgUnsafe :: !Bool,

19− -- | Output information useful for debugging

24+ -- | Output information useful for debugging

20− cfgDebug :: !Bool,

25+ cfgDebug :: !Bool,

21− -- | Do not fail if CPP pragma is present (still doesn't handle CPP but

22− -- useful for formatting of files that enable the extension without

23− -- actually containing CPP macros)

24− cfgTolerateCpp :: !Bool,

25− -- | Checks if re-formatting the result is idempotent.

26+ -- | Checks if re-formatting the result is idempotent

26− cfgCheckIdempotency :: !Bool

27+ cfgCheckIdempotence :: !Bool,

28+ -- | Region selection

29+ cfgRegion :: !region

30+ }

31+ deriving (Eq, Show, Functor)

32+

33+-- | Region selection as the combination of start and end line numbers.

34+data RegionIndices = RegionIndices

35+ { -- | Start line of the region to format

36+ regionStartLine :: !(Maybe Int),

37+ -- | End line of the region to format

38+ regionEndLine :: !(Maybe Int)

39+ }

40+ deriving (Eq, Show)

41+

42+-- | Region selection as the length of the literal prefix and the literal

43+-- suffix.

44+data RegionDeltas = RegionDeltas

45+ { -- | Prefix length in number of lines

46+ regionPrefixLength :: !Int,

47+ -- | Suffix length in number of lines

48+ regionSuffixLength :: !Int

27− }

49+ }

28 deriving (Eq, Show)

50 deriving (Eq, Show)

29

51

30−-- | Default 'Config'.

52+-- | Default @'Config' 'RegionIndices'@.

31−defaultConfig :: Config

53+defaultConfig :: Config RegionIndices

32defaultConfig =

54defaultConfig =

33 Config

55 Config

34 { cfgDynOptions = [],

56 { cfgDynOptions = [],

35 cfgUnsafe = False,

57 cfgUnsafe = False,

36 cfgDebug = False,

58 cfgDebug = False,

37− cfgTolerateCpp = False,

59+ cfgCheckIdempotence = False,

38− cfgCheckIdempotency = False

60+ cfgRegion =

61+ RegionIndices

62+ { regionStartLine = Nothing,

63+ regionEndLine = Nothing

64+ }

65+ }

66+

67+-- | Convert 'RegionIndices' into 'RegionDeltas'.

68+regionIndicesToDeltas ::

69+ -- | Total number of lines in the input

70+ Int ->

71+ -- | Region indices

72+ RegionIndices ->

73+ -- | Region deltas

74+ RegionDeltas

75+regionIndicesToDeltas total RegionIndices {..} =

76+ RegionDeltas

77+ { regionPrefixLength = maybe 0 (subtract 1) regionStartLine,

78+ regionSuffixLength = maybe 0 (total -) regionEndLine

39 }

79 }

40

80

41-- | A wrapper for dynamic options.

81-- | A wrapper for dynamic options.

42−newtype DynOption

82+newtype DynOption = DynOption

43− = DynOption

44− { unDynOption :: String

83+ { unDynOption :: String

45− }

84+ }

46 deriving (Eq, Ord, Show)

85 deriving (Eq, Ord, Show)

47

86

48-- | Convert 'DynOption' to @'GHC.Located' 'String'@.

87-- | Convert 'DynOption' to @'GHC.Located' 'String'@.

src/Ormolu/Diff.hs+15−12

@@ -14,7 +14,8 @@ import Data.Text (Text)

14import qualified Data.Text as T

15import qualified FastString as GHC

16import GHC

17−import Ormolu.Imports (sortImports)

17+import Ormolu.Imports (normalizeImports)

18+import Ormolu.Parser.CommentStream

18import Ormolu.Parser.Result

19import Ormolu.Parser.Result

19import Ormolu.Utils

20import Ormolu.Utils

20

21

@@ -38,14 +39,16 @@ diffParseResult :: ParseResult -> ParseResult -> Diff

38diffParseResult

39diffParseResult

39 ParseResult

40 ParseResult

40 { prCommentStream = cstream0,

41 { prCommentStream = cstream0,

41− prParsedSource = ps0

42+ prParsedSource = hs0

42 }

43 }

43 ParseResult

44 ParseResult

44 { prCommentStream = cstream1,

45 { prCommentStream = cstream1,

45− prParsedSource = ps1

46+ prParsedSource = hs1

46 } =

47 } =

47 matchIgnoringSrcSpans cstream0 cstream1

48 matchIgnoringSrcSpans cstream0 cstream1

48− <> matchIgnoringSrcSpans ps0 ps1

49+ <> matchIgnoringSrcSpans

50+ hs0 {hsmodImports = normalizeImports (hsmodImports hs0)}

51+ hs1 {hsmodImports = normalizeImports (hsmodImports hs1)}

49

52

50-- | Compare two values for equality disregarding differences in 'SrcSpan's

53-- | Compare two values for equality disregarding differences in 'SrcSpan's

51-- and the ordering of import lists.

54-- and the ordering of import lists.

@@ -67,7 +70,7 @@ matchIgnoringSrcSpans = genericQuery

67 gzipWithQ

70 gzipWithQ

68 ( genericQuery

71 ( genericQuery

69 `extQ` srcSpanEq

72 `extQ` srcSpanEq

70− `extQ` hsModuleEq

73+ `extQ` commentEq

71 `extQ` sourceTextEq

74 `extQ` sourceTextEq

72 `extQ` hsDocStringEq

75 `extQ` hsDocStringEq

73 `extQ` importDeclQualifiedStyleEq

76 `extQ` importDeclQualifiedStyleEq

@@ -78,14 +81,14 @@ matchIgnoringSrcSpans = genericQuery

78 | otherwise = Different []

81 | otherwise = Different []

79 srcSpanEq :: SrcSpan -> GenericQ Diff

82 srcSpanEq :: SrcSpan -> GenericQ Diff

80 srcSpanEq _ _ = Same

83 srcSpanEq _ _ = Same

81− hsModuleEq :: HsModule GhcPs -> GenericQ Diff

84+ commentEq :: Comment -> GenericQ Diff

82− hsModuleEq hs0 hs1' =

85+ commentEq (Comment _ x) d =

83− case cast hs1' :: Maybe (HsModule GhcPs) of

86+ case cast d :: Maybe Comment of

84 Nothing -> Different []

87 Nothing -> Different []

85− Just hs1 ->

88+ Just (Comment _ y) ->

86− matchIgnoringSrcSpans

89+ if x == y

87− hs0 {hsmodImports = sortImports (hsmodImports hs0)}

90+ then Same

88− hs1 {hsmodImports = sortImports (hsmodImports hs1)}

91+ else Different []

89 sourceTextEq :: SourceText -> GenericQ Diff

92 sourceTextEq :: SourceText -> GenericQ Diff

90 sourceTextEq _ _ = Same

93 sourceTextEq _ _ = Same

91 importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff

94 importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff

src/Ormolu/Exception.hs+4−11

@@ -19,9 +19,7 @@ import System.IO

19

20-- | Ormolu exception representing all cases when Ormolu can fail.

21data OrmoluException

22− = -- | Ormolu does not work with source files that use CPP

23− OrmoluCppEnabled FilePath

24− | -- | Parsing of original source code failed

22+ = -- | Parsing of original source code failed

25 OrmoluParsingFailed GHC.SrcSpan String

23 OrmoluParsingFailed GHC.SrcSpan String

26 | -- | Parsing of formatted source code failed

24 | -- | Parsing of formatted source code failed

27 OrmoluOutputParsingFailed GHC.SrcSpan String

25 OrmoluOutputParsingFailed GHC.SrcSpan String

@@ -35,13 +33,8 @@ data OrmoluException

35

33

36instance Exception OrmoluException where

34instance Exception OrmoluException where

37 displayException = \case

35 displayException = \case

38− OrmoluCppEnabled path ->

39− unlines

40− [ "CPP is not supported:",

41− withIndent path

42− ]

43 OrmoluParsingFailed s e ->

36 OrmoluParsingFailed s e ->

44− showParsingErr "Parsing of source code failed:" s [e]

37+ showParsingErr "The GHC parser (in Haddock mode) failed:" s [e]

45 OrmoluOutputParsingFailed s e ->

38 OrmoluOutputParsingFailed s e ->

46 showParsingErr "Parsing of formatted code failed:" s [e]

39 showParsingErr "Parsing of formatted code failed:" s [e]

47 ++ "Please, consider reporting the bug.\n"

40 ++ "Please, consider reporting the bug.\n"

@@ -81,8 +74,8 @@ withPrettyOrmoluExceptions m = m `catch` h

81 hPutStrLn stderr (displayException e)

74 hPutStrLn stderr (displayException e)

82 exitWith . ExitFailure $

75 exitWith . ExitFailure $

83 case e of

76 case e of

84− -- Error code 1 is for `error` or `notImplemented`

77+ -- Error code 1 is for 'error' or 'notImplemented'

85− OrmoluCppEnabled {} -> 2

78+ -- 2 used to be for erroring out on CPP

86 OrmoluParsingFailed {} -> 3

79 OrmoluParsingFailed {} -> 3

87 OrmoluOutputParsingFailed {} -> 4

80 OrmoluOutputParsingFailed {} -> 4

88 OrmoluASTDiffers {} -> 5

81 OrmoluASTDiffers {} -> 5

src/Ormolu/Imports.hs+161−44

@@ -4,82 +4,199 @@

4

5-- | Manipulations on import lists.

6module Ormolu.Imports

7− ( sortImports,

7+ ( normalizeImports,

8 )

9where

10

11import Data.Bifunctor

12+import Data.Char (isAlphaNum)

12import Data.Function (on)

13import Data.Function (on)

13−import Data.Generics (gcompare)

14+import Data.List (foldl', nubBy, sortBy, sortOn)

14−import Data.List (sortBy)

15+import Data.Map.Strict (Map)

16+import qualified Data.Map.Strict as M

17+import FastString (FastString)

15import GHC hiding (GhcPs, IE)

18import GHC hiding (GhcPs, IE)

16import GHC.Hs.Extension

19import GHC.Hs.Extension

17import GHC.Hs.ImpExp (IE (..))

20import GHC.Hs.ImpExp (IE (..))

18−import Ormolu.Utils (notImplemented)

21+import Ormolu.Utils (notImplemented, showOutputable)

19

22

20−-- | Sort imports by module name. This also sorts explicit import lists for

23+-- | Sort and normalize imports.

21−-- each declaration.

22−sortImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]

24+normalizeImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]

23−sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)

25+normalizeImports =

26+ fmap snd

27+ . M.toAscList

28+ . M.fromListWith combineImports

29+ . fmap (\x -> (importId x, g x))

24 where

30 where

25− sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs

26− sortImportLists = \case

27− ImportDecl {..} ->

31+ g (L l ImportDecl {..}) =

32+ L

33+ l

28 ImportDecl

34 ImportDecl

29− { ideclHiding = second (fmap sortLies) <$> ideclHiding,

35+ { ideclHiding = second (fmap normalizeLies) <$> ideclHiding,

30 ..

36 ..

31 }

37 }

32− XImportDecl x -> noExtCon x

38+ g _ = notImplemented "XImportDecl"

33

39

40+-- | Combine two import declarations. It should be assumed that 'ImportId's

41+-- are equal.

42+combineImports ::

34−-- | Compare two @'LImportDecl' 'GhcPs'@ things.

43+ LImportDecl GhcPs ->

35−compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering

44+ LImportDecl GhcPs ->

36−compareIdecl (L _ m0) (L _ m1) =

45+ LImportDecl GhcPs

37− case (isPrelude n0, isPrelude n1) of

46+combineImports (L lx ImportDecl {..}) (L _ y) =

38− (False, False) -> n0 `compare` n1

47+ L

39− (True, False) -> GT

48+ lx

40− (False, True) -> LT

49+ ImportDecl

41− (True, True) -> m0 `gcompare` m1

50+ { ideclHiding = case (ideclHiding, GHC.ideclHiding y) of

51+ (Just (hiding, L l' xs), Just (_, L _ ys)) ->

52+ Just (hiding, (L l' (normalizeLies (xs ++ ys))))

53+ _ -> Nothing,

54+ ..

55+ }

56+combineImports _ _ = notImplemented "XImportDecl"

57+

58+-- | Import id, a collection of all things that justify having a separate

59+-- import entry. This is used for merging of imports. If two imports have

60+-- the same 'ImportId' they can be merged.

61+data ImportId = ImportId

62+ { importIsPrelude :: Bool,

63+ importIdName :: ModuleName,

64+ importPkgQual :: Maybe FastString,

65+ importSource :: Bool,

66+ importSafe :: Bool,

67+ importQualified :: Bool,

68+ importImplicit :: Bool,

69+ importAs :: Maybe ModuleName,

70+ importHiding :: Maybe Bool

71+ }

72+ deriving (Eq, Ord)

73+

74+-- | Obtain an 'ImportId' for a given import.

75+importId :: LImportDecl GhcPs -> ImportId

76+importId (L _ ImportDecl {..}) =

77+ ImportId

78+ { importIsPrelude = isPrelude,

79+ importIdName = moduleName,

80+ importPkgQual = sl_fs <$> ideclPkgQual,

81+ importSource = ideclSource,

82+ importSafe = ideclSafe,

83+ importQualified = case ideclQualified of

84+ QualifiedPre -> True

85+ QualifiedPost -> True

86+ NotQualified -> False,

87+ importImplicit = ideclImplicit,

88+ importAs = unLoc <$> ideclAs,

89+ importHiding = fst <$> ideclHiding

90+ }

42 where

91 where

43− n0 = unLoc (ideclName m0)

44− n1 = unLoc (ideclName m1)

45− isPrelude = (== "Prelude") . moduleNameString

92+ isPrelude = moduleNameString moduleName == "Prelude"

93+ moduleName = unLoc ideclName

94+importId _ = notImplemented "XImportDecl"

46

95

47−-- | Sort located import or export.

96+-- | Normalize a collection of import\/export items.

48−sortLies :: [LIE GhcPs] -> [LIE GhcPs]

97+normalizeLies :: [LIE GhcPs] -> [LIE GhcPs]

49−sortLies = sortBy (compareIE `on` unLoc) . fmap (fmap sortThings)

98+normalizeLies = sortOn (getIewn . unLoc) . M.elems . foldl' combine M.empty

99+ where

100+ combine ::

101+ Map IEWrappedNameOrd (LIE GhcPs) ->

102+ LIE GhcPs ->

103+ Map IEWrappedNameOrd (LIE GhcPs)

104+ combine m (L new_l new) =

105+ let wname = getIewn new

106+ normalizeWNames =

107+ nubBy (\x y -> compareLIewn x y == EQ) . sortBy compareLIewn

108+ alter = \case

109+ Nothing -> Just . L new_l $

110+ case new of

111+ IEThingWith NoExtField n wildcard g flbl ->

112+ IEThingWith NoExtField n wildcard (normalizeWNames g) flbl

113+ other -> other

114+ Just old ->

115+ let f = \case

116+ IEVar NoExtField n -> IEVar NoExtField n

117+ IEThingAbs NoExtField _ -> new

118+ IEThingAll NoExtField n -> IEThingAll NoExtField n

119+ IEThingWith NoExtField n wildcard g flbl ->

120+ case new of

121+ IEVar NoExtField _ ->

122+ error "Ormolu.Imports broken presupposition"

123+ IEThingAbs NoExtField _ ->

124+ IEThingWith NoExtField n wildcard g flbl

125+ IEThingAll NoExtField n' ->

126+ IEThingAll NoExtField n'

127+ IEThingWith NoExtField n' wildcard' g' flbl' ->

128+ let combinedWildcard =

129+ case (wildcard, wildcard') of

130+ (IEWildcard _, _) -> IEWildcard 0

131+ (_, IEWildcard _) -> IEWildcard 0

132+ _ -> NoIEWildcard

133+ in IEThingWith

134+ NoExtField

135+ n'

136+ combinedWildcard

137+ (normalizeWNames (g <> g'))

138+ flbl'

139+ IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"

140+ IEGroup NoExtField _ _ -> notImplemented "IEGroup"

141+ IEDoc NoExtField _ -> notImplemented "IEDoc"

142+ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"

143+ XIE x -> noExtCon x

144+ IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"

145+ IEGroup NoExtField _ _ -> notImplemented "IEGroup"

146+ IEDoc NoExtField _ -> notImplemented "IEDoc"

147+ IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"

148+ XIE x -> noExtCon x

149+ in Just (f <$> old)

150+ in M.alter alter wname m

50

151

51−-- | Sort imports\/exports inside of 'IEThingWith'.

152+-- | A wrapper for @'IEWrappedName' 'RdrName'@ that allows us to define an

52−sortThings :: IE GhcPs -> IE GhcPs

153+-- 'Ord' instance for it.

53−sortThings = \case

154+newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName RdrName)

54− IEThingWith NoExtField x w xs fl ->

155+ deriving (Eq)

55− IEThingWith NoExtField x w (sortBy (compareIewn `on` unLoc) xs) fl

56− other -> other

57

156

58−-- | Compare two located imports or exports.

157+instance Ord IEWrappedNameOrd where

59−compareIE :: IE GhcPs -> IE GhcPs -> Ordering

158+ compare (IEWrappedNameOrd x) (IEWrappedNameOrd y) = compareIewn x y

60−compareIE = compareIewn `on` getIewn

61

159

62-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.

160-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.

63−getIewn :: IE GhcPs -> IEWrappedName RdrName

161+getIewn :: IE GhcPs -> IEWrappedNameOrd

64getIewn = \case

162getIewn = \case

65− IEVar NoExtField x -> unLoc x

163+ IEVar NoExtField x -> IEWrappedNameOrd (unLoc x)

66− IEThingAbs NoExtField x -> unLoc x

164+ IEThingAbs NoExtField x -> IEWrappedNameOrd (unLoc x)

67− IEThingAll NoExtField x -> unLoc x

165+ IEThingAll NoExtField x -> IEWrappedNameOrd (unLoc x)

68− IEThingWith NoExtField x _ _ _ -> unLoc x

166+ IEThingWith NoExtField x _ _ _ -> IEWrappedNameOrd (unLoc x)

69 IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"

167 IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"

70 IEGroup NoExtField _ _ -> notImplemented "IEGroup"

168 IEGroup NoExtField _ _ -> notImplemented "IEGroup"

71 IEDoc NoExtField _ -> notImplemented "IEDoc"

169 IEDoc NoExtField _ -> notImplemented "IEDoc"

72 IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"

170 IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"

73 XIE x -> noExtCon x

171 XIE x -> noExtCon x

74

172

173+-- | Like 'compareIewn' for located wrapped names.

174+compareLIewn :: LIEWrappedName RdrName -> LIEWrappedName RdrName -> Ordering

175+compareLIewn = compareIewn `on` unLoc

176+

75-- | Compare two @'IEWrapppedName' 'RdrName'@ things.

177-- | Compare two @'IEWrapppedName' 'RdrName'@ things.

76compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering

178compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering

77−compareIewn (IEName x) (IEName y) = unLoc x `compare` unLoc y

179+compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y

78compareIewn (IEName _) (IEPattern _) = LT

180compareIewn (IEName _) (IEPattern _) = LT

79compareIewn (IEName _) (IEType _) = LT

181compareIewn (IEName _) (IEType _) = LT

80compareIewn (IEPattern _) (IEName _) = GT

182compareIewn (IEPattern _) (IEName _) = GT

81−compareIewn (IEPattern x) (IEPattern y) = unLoc x `compare` unLoc y

183+compareIewn (IEPattern x) (IEPattern y) = unLoc x `compareRdrName` unLoc y

82compareIewn (IEPattern _) (IEType _) = LT

184compareIewn (IEPattern _) (IEType _) = LT

83compareIewn (IEType _) (IEName _) = GT

185compareIewn (IEType _) (IEName _) = GT

84compareIewn (IEType _) (IEPattern _) = GT

186compareIewn (IEType _) (IEPattern _) = GT

85−compareIewn (IEType x) (IEType y) = unLoc x `compare` unLoc y

187+compareIewn (IEType x) (IEType y) = unLoc x `compareRdrName` unLoc y

188+

189+compareRdrName :: RdrName -> RdrName -> Ordering

190+compareRdrName x y =

191+ case (getNameStr x, getNameStr y) of

192+ ([], []) -> EQ

193+ ((_ : _), []) -> GT

194+ ([], (_ : _)) -> LT

195+ ((x' : _), (y' : _)) ->

196+ case (isAlphaNum x', isAlphaNum y') of

197+ (False, False) -> x `compare` y

198+ (True, False) -> LT

199+ (False, True) -> GT

200+ (True, True) -> x `compare` y

201+ where

202+ getNameStr = showOutputable . rdrNameOcc

src/Ormolu/Parser.hs+52−100

@@ -12,12 +12,11 @@ where

12import Bag (bagToList)

13import qualified CmdLineParser as GHC

14import Control.Exception

15−import Control.Monad

16import Control.Monad.IO.Class

15import Control.Monad.IO.Class

17−import Data.List ((\\), foldl', isPrefixOf, sortOn)

16+import qualified Data.List as L

18import qualified Data.List.NonEmpty as NE

17import qualified Data.List.NonEmpty as NE

19−import Data.Maybe (catMaybes)

20import Data.Ord (Down (Down))

18import Data.Ord (Down (Down))

19+import qualified Data.Text as T

21import DynFlags as GHC

20import DynFlags as GHC

22import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)

21import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)

23import qualified FastString as GHC

22import qualified FastString as GHC

@@ -32,6 +31,8 @@ import Ormolu.Exception

32import Ormolu.Parser.Anns

31import Ormolu.Parser.Anns

33import Ormolu.Parser.CommentStream

32import Ormolu.Parser.CommentStream

34import Ormolu.Parser.Result

33import Ormolu.Parser.Result

34+import Ormolu.Processing.Preprocess (preprocess)

35+import Ormolu.Utils (incSpanLine, removeIndentation)

35import qualified Panic as GHC

36import qualified Panic as GHC

36import qualified Parser as GHC

37import qualified Parser as GHC

37import qualified StringBuffer as GHC

38import qualified StringBuffer as GHC

@@ -40,7 +41,7 @@ import qualified StringBuffer as GHC

40parseModule ::

41parseModule ::

41 MonadIO m =>

42 MonadIO m =>

42 -- | Ormolu configuration

43 -- | Ormolu configuration

43− Config ->

44+ Config RegionDeltas ->

44 -- | File name (only for source location annotations)

45 -- | File name (only for source location annotations)

45 FilePath ->

46 FilePath ->

46 -- | Input for parser

47 -- | Input for parser

@@ -49,8 +50,10 @@ parseModule ::

49 ( [GHC.Warn],

50 ( [GHC.Warn],

50 Either (SrcSpan, String) ParseResult

51 Either (SrcSpan, String) ParseResult

51 )

52 )

52−parseModule Config {..} path input' = liftIO $ do

53+parseModule Config {..} path rawInput = liftIO $ do

53− let (input, extraComments) = extractCommentsFromLines path input'

54+ let (literalPrefix, indentedInput, literalSuffix, extraComments) =

55+ preprocess path rawInput cfgRegion

56+ (input, indent) = removeIndentation indentedInput

54 -- It's important that 'setDefaultExts' is done before

57 -- It's important that 'setDefaultExts' is done before

55 -- 'parsePragmasIntoDynFlags', because otherwise we might enable an

58 -- 'parsePragmasIntoDynFlags', because otherwise we might enable an

56 -- extension that was explicitly disabled in the file.

59 -- extension that was explicitly disabled in the file.

@@ -60,7 +63,7 @@ parseModule Config {..} path input' = liftIO $ do

60 (setDefaultExts baseDynFlags)

63 (setDefaultExts baseDynFlags)

61 extraOpts = dynOptionToLocatedStr <$> cfgDynOptions

64 extraOpts = dynOptionToLocatedStr <$> cfgDynOptions

62 (warnings, dynFlags) <-

65 (warnings, dynFlags) <-

63− parsePragmasIntoDynFlags baseFlags extraOpts path input' >>= \case

66+ parsePragmasIntoDynFlags baseFlags extraOpts path rawInput >>= \case

64 Right res -> pure res

67 Right res -> pure res

65 Left err ->

68 Left err ->

66 let loc =

69 let loc =

@@ -68,8 +71,6 @@ parseModule Config {..} path input' = liftIO $ do

68 (mkSrcLoc (GHC.mkFastString path) 1 1)

71 (mkSrcLoc (GHC.mkFastString path) 1 1)

69 (mkSrcLoc (GHC.mkFastString path) 1 1)

72 (mkSrcLoc (GHC.mkFastString path) 1 1)

70 in throwIO (OrmoluParsingFailed loc err)

73 in throwIO (OrmoluParsingFailed loc err)

71− when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $

72− throwIO (OrmoluCppEnabled path)

73 let useRecordDot =

74 let useRecordDot =

74 "record-dot-preprocessor" == pgm_F dynFlags

75 "record-dot-preprocessor" == pgm_F dynFlags

75 || any

76 || any

@@ -77,15 +78,18 @@ parseModule Config {..} path input' = liftIO $ do

77 (pluginModNames dynFlags)

78 (pluginModNames dynFlags)

78 pStateErrors = \pstate ->

79 pStateErrors = \pstate ->

79 let errs = bagToList $ GHC.getErrorMessages pstate dynFlags

80 let errs = bagToList $ GHC.getErrorMessages pstate dynFlags

81+ fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion)

80− in case sortOn (Down . SeverityOrd . errMsgSeverity) errs of

82+ in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of

81 [] -> Nothing

83 [] -> Nothing

84+ err : _ ->

82− err : _ -> Just (errMsgSpan err, show err) -- Show instance returns a short error message

85+ -- Show instance returns a short error message

86+ Just (fixupErrSpan (errMsgSpan err), show err)

83 r = case runParser GHC.parseModule dynFlags path input of

87 r = case runParser GHC.parseModule dynFlags path input of

84 GHC.PFailed pstate ->

88 GHC.PFailed pstate ->

85 case pStateErrors pstate of

89 case pStateErrors pstate of

86 Just err -> Left err

90 Just err -> Left err

87− Nothing -> error "invariant violation: PFailed does not have an error"

91+ Nothing -> error "PFailed does not have an error"

88− GHC.POk pstate pmod ->

92+ GHC.POk pstate (L _ hsModule) ->

89 case pStateErrors pstate of

93 case pStateErrors pstate of

90 -- Some parse errors (pattern/arrow syntax in expr context)

94 -- Some parse errors (pattern/arrow syntax in expr context)

91 -- do not cause a parse error, but they are replaced with "_"

95 -- do not cause a parse error, but they are replaced with "_"

@@ -93,20 +97,33 @@ parseModule Config {..} path input' = liftIO $ do

93 -- later stages; but we fail in those cases.

97 -- later stages; but we fail in those cases.

94 Just err -> Left err

98 Just err -> Left err

95 Nothing ->

99 Nothing ->

100+ let (stackHeader, shebangs, pragmas, comments) =

96− let (comments, exts, shebangs) = mkCommentStream extraComments pstate

101+ mkCommentStream input extraComments pstate

97 in Right

102 in Right

98 ParseResult

103 ParseResult

99− { prParsedSource = pmod,

104+ { prParsedSource = hsModule,

100 prAnns = mkAnns pstate,

105 prAnns = mkAnns pstate,

101− prCommentStream = comments,

106+ prStackHeader = stackHeader,

102− prExtensions = exts,

103 prShebangs = shebangs,

107 prShebangs = shebangs,

108+ prPragmas = pragmas,

109+ prCommentStream = comments,

104 prUseRecordDot = useRecordDot,

110 prUseRecordDot = useRecordDot,

105 prImportQualifiedPost =

111 prImportQualifiedPost =

106− GHC.xopt ImportQualifiedPost dynFlags

112+ GHC.xopt ImportQualifiedPost dynFlags,

113+ prLiteralPrefix = T.pack literalPrefix,

114+ prLiteralSuffix = T.pack literalSuffix,

115+ prIndent = indent

107 }

116 }

108 return (warnings, r)

117 return (warnings, r)

109

118

119+-- | Enable all language extensions that we think should be enabled by

120+-- default for ease of use.

121+setDefaultExts :: DynFlags -> DynFlags

122+setDefaultExts flags = L.foldl' xopt_set flags autoExts

123+ where

124+ autoExts = allExts L.\\ manualExts

125+ allExts = [minBound .. maxBound]

126+

110-- | Extensions that are not enabled automatically and should be activated

127-- | Extensions that are not enabled automatically and should be activated

111-- by user.

128-- by user.

112manualExts :: [Extension]

129manualExts :: [Extension]

@@ -133,9 +150,6 @@ manualExts =

133 -- decision of enabling this style is left to the user

150 -- decision of enabling this style is left to the user

134 ]

151 ]

135

152

136−----------------------------------------------------------------------------

137−-- Helpers (taken from ghc-exactprint)

138−

139-- | Run a 'GHC.P' computation.

153-- | Run a 'GHC.P' computation.

140runParser ::

154runParser ::

141 -- | Computation to run

155 -- | Computation to run

@@ -154,67 +168,27 @@ runParser parser flags filename input = GHC.unP parser parseState

154 buffer = GHC.stringToStringBuffer input

168 buffer = GHC.stringToStringBuffer input

155 parseState = GHC.mkPState flags buffer location

169 parseState = GHC.mkPState flags buffer location

156

170

157−-- | Transform given lines possibly returning comments extracted from them.

171+-- | Wrap GHC's 'Severity' to add 'Ord' instance.

158−-- This handles LINE pragmas and shebangs.

172+newtype SeverityOrd = SeverityOrd Severity

159−extractCommentsFromLines ::

160− -- | File name, just to use in the spans

161− FilePath ->

162− -- | List of lines from that file

163− String ->

164− -- | Adjusted lines together with comments extracted from them

165− (String, [Located String])

166−extractCommentsFromLines path =

167− unlines' . unzip . zipWith (extractCommentFromLine path) [1 ..] . lines

168− where

169− unlines' (a, b) = (unlines a, catMaybes b)

170−

171−-- | Transform a given line possibly returning a comment extracted from it.

172−extractCommentFromLine ::

173− -- | File name, just to use in the spans

174− FilePath ->

175− -- | Line number of this line

176− Int ->

177− -- | The actual line

178− String ->

179− -- | Adjusted line and possibly a comment extracted from it

180− (String, Maybe (Located String))

181−extractCommentFromLine path line s

182− | "{-# LINE" `isPrefixOf` s =

183− let (pragma, res) = getPragma s

184− size = length pragma

185− ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))

186− in (res, Just $ L ss pragma)

187− | isShebang s =

188− let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))

189− in ("", Just $ L ss s)

190− | otherwise = (s, Nothing)

191− where

192− mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line

193

173

194−-- | Take a line pragma and output its replacement (where line pragma is

174+instance Eq SeverityOrd where

195−-- replaced with spaces) and the contents of the pragma itself.

175+ s1 == s2 = compare s1 s2 == EQ

196−getPragma ::

197− -- | Pragma line to analyze

198− String ->

199− -- | Contents of the pragma and its replacement line

200− (String, String)

201−getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"

202−getPragma s@(x : xs)

203− | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)

204− | otherwise =

205− let (prag, remline) = getPragma xs

206− in (x : prag, ' ' : remline)

207

176

208−-- | Enable all language extensions that we think should be enabled by

177+instance Ord SeverityOrd where

209−-- default for ease of use.

178+ compare (SeverityOrd s1) (SeverityOrd s2) =

210−setDefaultExts :: DynFlags -> DynFlags

179+ compare (f s1) (f s2)

211−setDefaultExts flags = foldl' GHC.xopt_set flags autoExts

180+ where

212− where

181+ f :: Severity -> Int

213− autoExts = allExts \\ manualExts

182+ f SevOutput = 1

214− allExts = [minBound .. maxBound]

183+ f SevFatal = 2

184+ f SevInteractive = 3

185+ f SevDump = 4

186+ f SevInfo = 5

187+ f SevWarning = 6

188+ f SevError = 7

215

189

216----------------------------------------------------------------------------

190----------------------------------------------------------------------------

217−-- More helpers (taken from HLint)

191+-- Helpers taken from HLint

218

192

219parsePragmasIntoDynFlags ::

193parsePragmasIntoDynFlags ::

220 -- | Pre-set 'DynFlags'

194 -- | Pre-set 'DynFlags'

@@ -243,25 +217,3 @@ parsePragmasIntoDynFlags flags extraOpts filepath str =

243 reportErr

217 reportErr

244 (GHC.handleSourceError reportErr act)

218 (GHC.handleSourceError reportErr act)

245 reportErr e = return $ Left (show e)

219 reportErr e = return $ Left (show e)

246−

247−----------------------------------------------------------------------------

248−-- Even more helpers

249−

250−-- Wrap GHC's ErrUtils.Severity to add Ord instance

251−newtype SeverityOrd = SeverityOrd Severity

252−

253−instance Eq SeverityOrd where

254− s1 == s2 = compare s1 s2 == EQ

255−

256−instance Ord SeverityOrd where

257− compare (SeverityOrd s1) (SeverityOrd s2) =

258− compare (f s1) (f s2)

259− where

260− f :: Severity -> Int

261− f SevOutput = 1

262− f SevFatal = 2

263− f SevInteractive = 3

264− f SevDump = 4

265− f SevInfo = 5

266− f SevWarning = 6

267− f SevError = 7

src/Ormolu/Parser/CommentStream.hs+147−61

@@ -4,78 +4,74 @@

4

5-- | Functions for working with comment stream.

6module Ormolu.Parser.CommentStream

7− ( CommentStream (..),

7+ ( -- * Comment stream

8− Comment (..),

8+ CommentStream (..),

9 mkCommentStream,

10− isShebang,

11− isPrevHaddock,

12− isMultilineComment,

13 showCommentStream,

10 showCommentStream,

11+

12+ -- * Comment

13+ Comment (..),

14+ unComment,

15+ hasAtomsBefore,

16+ isMultilineComment,

14 )

17 )

15where

18where

16

19

17import Data.Char (isSpace)

20import Data.Char (isSpace)

18import Data.Data (Data)

21import Data.Data (Data)

19−import Data.Either (partitionEithers)

22+import qualified Data.List as L

20−import Data.List (dropWhileEnd, isPrefixOf, sortOn)

21import Data.List.NonEmpty (NonEmpty (..))

23import Data.List.NonEmpty (NonEmpty (..))

22import qualified Data.List.NonEmpty as NE

24import qualified Data.List.NonEmpty as NE

23import Data.Maybe (mapMaybe)

25import Data.Maybe (mapMaybe)

24import qualified GHC

26import qualified GHC

25import qualified Lexer as GHC

27import qualified Lexer as GHC

26import Ormolu.Parser.Pragma

28import Ormolu.Parser.Pragma

29+import Ormolu.Parser.Shebang

30+import Ormolu.Processing.Common

27−import Ormolu.Utils (showOutputable)

31+import Ormolu.Utils (onTheSameLine, showOutputable)

28import SrcLoc

32import SrcLoc

29

33

34+----------------------------------------------------------------------------

35+-- Comment stream

36+

30-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to

37-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to

31-- beginning of corresponding spans.

38-- beginning of corresponding spans.

32newtype CommentStream = CommentStream [RealLocated Comment]

39newtype CommentStream = CommentStream [RealLocated Comment]

33 deriving (Eq, Data, Semigroup, Monoid)

40 deriving (Eq, Data, Semigroup, Monoid)

34

41

35−-- | A wrapper for a single comment. The 'NonEmpty' list inside contains

36−-- lines of multiline comment @{- … -}@ or just single item\/line otherwise.

37−newtype Comment = Comment (NonEmpty String)

38− deriving (Eq, Show, Data)

39−

40-- | Create 'CommentStream' from 'GHC.PState'. The pragmas and shebangs are

42-- | Create 'CommentStream' from 'GHC.PState'. The pragmas and shebangs are

41-- removed from the 'CommentStream'. Shebangs are only extracted from the

43-- removed from the 'CommentStream'. Shebangs are only extracted from the

42-- comments that come from the first argument.

44-- comments that come from the first argument.

43mkCommentStream ::

45mkCommentStream ::

46+ -- | Original input

47+ String ->

44 -- | Extra comments to include

48 -- | Extra comments to include

45 [Located String] ->

49 [Located String] ->

46 -- | Parser state to use for comment extraction

50 -- | Parser state to use for comment extraction

47 GHC.PState ->

51 GHC.PState ->

48− -- | Comment stream, a set of extracted pragmas, and extracted shebangs

52+ -- | Stack header, shebangs, pragmas, and comment stream

49− (CommentStream, [Pragma], [Located String])

53+ ( Maybe (RealLocated Comment),

54+ [Shebang],

55+ [([RealLocated Comment], Pragma)],

56+ CommentStream

57+ )

50−mkCommentStream extraComments pstate =

58+mkCommentStream input extraComments pstate =

51− ( CommentStream $

59+ ( mstackHeader,

52− mkComment <$> sortOn (realSrcSpanStart . getRealSrcSpan) comments,

60+ shebangs,

53 pragmas,

61 pragmas,

54− shebangs

62+ CommentStream comments

55 )

63 )

56 where

64 where

57− (comments, pragmas) = partitionEithers (partitionComments <$> rawComments)

65+ (comments, pragmas) = extractPragmas input rawComments1

58− rawComments =

66+ (rawComments1, mstackHeader) = extractStackHeader rawComments0

67+ rawComments0 =

59− mapMaybe toRealSpan $

68+ L.sortOn (realSrcSpanStart . getRealSrcSpan) . mapMaybe toRealSpan $

60 otherExtraComments

69 otherExtraComments

61 ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)

70 ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)

62 ++ concatMap

71 ++ concatMap

63 (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)

72 (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)

64 (GHC.annotations_comments pstate)

73 (GHC.annotations_comments pstate)

65− (shebangs, otherExtraComments) = span (isShebang . unLoc) extraComments

74+ (shebangs, otherExtraComments) = extractShebangs extraComments

66−

67−-- | Return 'True' if given 'String' is a shebang.

68−isShebang :: String -> Bool

69−isShebang str = "#!" `isPrefixOf` str

70−

71−-- | Test whether a 'Comment' looks like a Haddock following a definition,

72−-- i.e. something starting with @-- ^@.

73−isPrevHaddock :: Comment -> Bool

74−isPrevHaddock (Comment (x :| _)) = "-- ^" `isPrefixOf` x

75−

76−-- | Is this comment multiline-style?

77−isMultilineComment :: Comment -> Bool

78−isMultilineComment (Comment (x :| _)) = "{-" `isPrefixOf` x

79

75

80-- | Pretty-print a 'CommentStream'.

76-- | Pretty-print a 'CommentStream'.

81showCommentStream :: CommentStream -> String

77showCommentStream :: CommentStream -> String

@@ -86,28 +82,117 @@ showCommentStream (CommentStream xs) =

86 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str

82 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str

87

83

88----------------------------------------------------------------------------

84----------------------------------------------------------------------------

89−-- Helpers

85+-- Comment

86+

87+-- | A wrapper for a single comment. The 'Bool' indicates whether there were

88+-- atoms before beginning of the comment in the original input. The

89+-- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or

90+-- just single item\/line otherwise.

91+data Comment = Comment Bool (NonEmpty String)

92+ deriving (Eq, Show, Data)

90

93

91-- | Normalize comment string. Sometimes one multi-line comment is turned

94-- | Normalize comment string. Sometimes one multi-line comment is turned

92-- into several lines for subsequent outputting with correct indentation for

95-- into several lines for subsequent outputting with correct indentation for

93-- each line.

96-- each line.

94−mkComment :: RealLocated String -> RealLocated Comment

97+mkComment ::

95−mkComment (L l s) =

98+ -- | Lines of original input with their indices

96− L l . Comment . fmap dropTrailing $

99+ [(Int, String)] ->

97− if "{-" `isPrefixOf` s

100+ -- | Raw comment string

98− then case NE.nonEmpty (lines s) of

101+ RealLocated String ->

99− Nothing -> s :| []

102+ -- | Remaining lines of original input and the constructed 'Comment'

100− Just (x :| xs) ->

103+ ([(Int, String)], RealLocated Comment)

101− let getIndent y =

104+mkComment ls (L l s) = (ls', comment)

102− if all isSpace y

103− then startIndent

104− else length (takeWhile isSpace y)

105− n = minimum (startIndent : fmap getIndent xs)

106− in x :| (drop n <$> xs)

107− else s :| []

108 where

105 where

106+ comment =

107+ L l . Comment atomsBefore . removeConseqBlanks . fmap dropTrailing $

108+ if "{-" `L.isPrefixOf` s

109+ then case NE.nonEmpty (lines s) of

110+ Nothing -> s :| []

111+ Just (x :| xs) ->

112+ let getIndent y =

113+ if all isSpace y || y == endDisabling

114+ then startIndent

115+ else length (takeWhile isSpace y)

116+ n = minimum (startIndent : fmap getIndent xs)

117+ removeIndent y =

118+ if y == endDisabling

119+ then y

120+ else drop n y

121+ in x :| (removeIndent <$> xs)

122+ else s :| []

123+ (atomsBefore, ls') =

124+ case dropWhile ((< commentLine) . fst) ls of

125+ [] -> (False, [])

126+ ((_, i) : ls'') ->

127+ case take 2 (dropWhile isSpace i) of

128+ "--" -> (False, ls'')

129+ "{-" -> (False, ls'')

130+ _ -> (True, ls'')

109− dropTrailing = dropWhileEnd isSpace

131+ dropTrailing = L.dropWhileEnd isSpace

110 startIndent = srcSpanStartCol l - 1

132 startIndent = srcSpanStartCol l - 1

133+ commentLine = srcSpanStartLine l

134+

135+-- | Get a collection of lines from a 'Comment'.

136+unComment :: Comment -> NonEmpty String

137+unComment (Comment _ xs) = xs

138+

139+-- | Check whether the 'Comment' had some non-whitespace atoms in front of

140+-- it in the original input.

141+hasAtomsBefore :: Comment -> Bool

142+hasAtomsBefore (Comment atomsBefore _) = atomsBefore

143+

144+-- | Is this comment multiline-style?

145+isMultilineComment :: Comment -> Bool

146+isMultilineComment (Comment _ (x :| _)) = "{-" `L.isPrefixOf` x

147+

148+----------------------------------------------------------------------------

149+-- Helpers

150+

151+-- | Detect and extract stack header if it is present.

152+extractStackHeader ::

153+ -- | Comment stream to analyze

154+ [RealLocated String] ->

155+ ([RealLocated String], Maybe (RealLocated Comment))

156+extractStackHeader = \case

157+ [] -> ([], Nothing)

158+ (x : xs) ->

159+ let comment = snd (mkComment [] x)

160+ in if isStackHeader (unRealSrcSpan comment)

161+ then (xs, Just comment)

162+ else (x : xs, Nothing)

163+ where

164+ isStackHeader (Comment _ (x :| _)) =

165+ "stack" `L.isPrefixOf` dropWhile isSpace (drop 2 x)

166+

167+-- | Extract pragmas and their associated comments.

168+extractPragmas ::

169+ -- | Input

170+ String ->

171+ -- | Comment stream to analyze

172+ [RealLocated String] ->

173+ ([RealLocated Comment], [([RealLocated Comment], Pragma)])

174+extractPragmas input = go initialLs id id

175+ where

176+ initialLs = zip [1 ..] (lines input)

177+ go ls csSoFar pragmasSoFar = \case

178+ [] -> (csSoFar [], pragmasSoFar [])

179+ (x : xs) ->

180+ case parsePragma (unRealSrcSpan x) of

181+ Nothing ->

182+ let (ls', x') = mkComment ls x

183+ in go ls' (csSoFar . (x' :)) pragmasSoFar xs

184+ Just pragma ->

185+ let combined ys = (csSoFar ys, pragma)

186+ go' ls' ys rest = go ls' id (pragmasSoFar . (combined ys :)) rest

187+ in case xs of

188+ [] -> go' ls [] xs

189+ (y : ys) ->

190+ let (ls', y') = mkComment ls y

191+ in if onTheSameLine

192+ (RealSrcSpan (getRealSrcSpan x))

193+ (RealSrcSpan (getRealSrcSpan y))

194+ then go' ls' [y'] ys

195+ else go' ls [] xs

111

196

112-- | Get a 'String' from 'GHC.AnnotationComment'.

197-- | Get a 'String' from 'GHC.AnnotationComment'.

113unAnnotationComment :: GHC.AnnotationComment -> Maybe String

198unAnnotationComment :: GHC.AnnotationComment -> Maybe String

@@ -129,12 +214,13 @@ toRealSpan :: Located a -> Maybe (RealLocated a)

129toRealSpan (L (RealSrcSpan l) a) = Just (L l a)

214toRealSpan (L (RealSrcSpan l) a) = Just (L l a)

130toRealSpan _ = Nothing

215toRealSpan _ = Nothing

131

216

132−-- | If a given comment is a pragma, return it in parsed form in 'Right'.

217+-- | Remove consecutive blank lines.

133−-- Otherwise return the original comment unchanged.

218+removeConseqBlanks :: NonEmpty String -> NonEmpty String

134−partitionComments ::

219+removeConseqBlanks (x :| xs) = x :| go (null x) id xs

135− RealLocated String ->

220+ where

136− Either (RealLocated String) Pragma

221+ go seenBlank acc = \case

137−partitionComments input =

222+ [] -> acc []

138− case parsePragma (unRealSrcSpan input) of

223+ (y : ys) ->

139− Nothing -> Left input

224+ if seenBlank && null y

140− Just pragma -> Right pragma

225+ then go True acc ys

226+ else go (null y) (acc . (y :)) ys

src/Ormolu/Parser/Pragma.hs+4−4

@@ -10,7 +10,7 @@ where

10

11import Control.Monad

12import Data.Char (isSpace, toLower)

13−import Data.List

13+import qualified Data.List as L

14import qualified EnumSet as ES

15import FastString (mkFastString, unpackFS)

16import qualified Lexer as L

@@ -35,8 +35,8 @@ parsePragma ::

35 String ->

36 Maybe Pragma

37parsePragma input = do

38− inputNoPrefix <- stripPrefix "{-#" input

38+ inputNoPrefix <- L.stripPrefix "{-#" input

39− guard ("#-}" `isSuffixOf` input)

39+ guard ("#-}" `L.isSuffixOf` input)

40 let contents = take (length inputNoPrefix - 3) inputNoPrefix

41 (pragmaName, cs) = (break isSpace . dropWhile isSpace) contents

42 case toLower <$> pragmaName of

@@ -46,7 +46,7 @@ parsePragma input = do

46 _ -> Nothing

47 where

48 trimSpaces :: String -> String

49− trimSpaces = dropWhileEnd isSpace . dropWhile isSpace

49+ trimSpaces = L.dropWhileEnd isSpace . dropWhile isSpace

50

51-- | Assuming the input consists of a series of tokens from a language

52-- pragma, return the set of enabled extensions.

src/Ormolu/Parser/Result.hs+26−17

@@ -7,29 +7,38 @@ module Ormolu.Parser.Result

7 )

8where

9

10+import Data.Text (Text)

10import GHC

11import GHC

11import Ormolu.Parser.Anns

12import Ormolu.Parser.Anns

12import Ormolu.Parser.CommentStream

13import Ormolu.Parser.CommentStream

13import Ormolu.Parser.Pragma (Pragma)

14import Ormolu.Parser.Pragma (Pragma)

15+import Ormolu.Parser.Shebang (Shebang)

14

16

15-- | A collection of data that represents a parsed module in Ormolu.

17-- | A collection of data that represents a parsed module in Ormolu.

16−data ParseResult

18+data ParseResult = ParseResult

17− = ParseResult

18− { -- | 'ParsedSource' from GHC

19+ { -- | 'ParsedSource' from GHC

19− prParsedSource :: ParsedSource,

20+ prParsedSource :: HsModule GhcPs,

20− -- | Ormolu-specfic representation of annotations

21+ -- | Ormolu-specfic representation of annotations

21− prAnns :: Anns,

22+ prAnns :: Anns,

22− -- | Comment stream

23+ -- | Stack header

23− prCommentStream :: CommentStream,

24+ prStackHeader :: Maybe (RealLocated Comment),

24− -- | Extensions enabled in that module

25− prExtensions :: [Pragma],

26− -- | Shebangs found in the input

25+ -- | Shebangs found in the input

27− prShebangs :: [Located String],

26+ prShebangs :: [Shebang],

27+ -- | Pragmas and the associated comments

28+ prPragmas :: [([RealLocated Comment], Pragma)],

29+ -- | Comment stream

30+ prCommentStream :: CommentStream,

28− -- | Whether or not record dot syntax is enabled

31+ -- | Whether or not record dot syntax is enabled

29− prUseRecordDot :: Bool,

32+ prUseRecordDot :: Bool,

30− -- | Whether or not ImportQualifiedPost is enabled

33+ -- | Whether or not ImportQualifiedPost is enabled

31− prImportQualifiedPost :: Bool

34+ prImportQualifiedPost :: Bool,

35+ -- | Literal prefix

36+ prLiteralPrefix :: Text,

37+ -- | Literal suffix

38+ prLiteralSuffix :: Text,

39+ -- | Indentation level, can be non-zero in case of region formatting

40+ prIndent :: Int

32− }

41+ }

33

42

34-- | Pretty-print a 'ParseResult'.

43-- | Pretty-print a 'ParseResult'.

35prettyPrintParseResult :: ParseResult -> String

44prettyPrintParseResult :: ParseResult -> String

src/Ormolu/Parser/Shebang.hsnew file+27

@@ -0,0 +1,27 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+

3+-- | A module for dealing with shebangs.

4+module Ormolu.Parser.Shebang

5+ ( Shebang (..),

6+ extractShebangs,

7+ isShebang,

8+ )

9+where

10+

11+import Data.Data (Data)

12+import qualified Data.List as L

13+import SrcLoc

14+

15+-- | A wrapper for a shebang.

16+newtype Shebang = Shebang (Located String)

17+ deriving (Eq, Data)

18+

19+-- | Extract shebangs from the beginning of a comment stream.

20+extractShebangs :: [Located String] -> ([Shebang], [Located String])

21+extractShebangs comments = (Shebang <$> shebangs, rest)

22+ where

23+ (shebangs, rest) = span (isShebang . unLoc) comments

24+

25+-- | Return 'True' if given 'String' is a shebang.

26+isShebang :: String -> Bool

27+isShebang str = "#!" `L.isPrefixOf` str

src/Ormolu/Printer.hs+17−11

@@ -11,6 +11,7 @@ import Ormolu.Parser.Result

11import Ormolu.Printer.Combinators

12import Ormolu.Printer.Meat.Module

13import Ormolu.Printer.SpanStream

14+import Ormolu.Processing.Postprocess (postprocess)

14

15

15-- | Render a module.

16-- | Render a module.

16printModule ::

17printModule ::

@@ -19,14 +20,19 @@ printModule ::

19 -- | Resulting rendition

20 -- | Resulting rendition

20 Text

21 Text

21printModule ParseResult {..} =

22printModule ParseResult {..} =

23+ prLiteralPrefix <> region <> prLiteralSuffix

24+ where

25+ region =

26+ postprocess prIndent $

22− runR

27+ runR

23− ( p_hsModule

28+ ( p_hsModule

29+ prStackHeader

24− prShebangs

30+ prShebangs

25− prExtensions

31+ prPragmas

26− prImportQualifiedPost

32+ prImportQualifiedPost

27− prParsedSource

33+ prParsedSource

28− )

34+ )

29− (mkSpanStream prParsedSource)

35+ (mkSpanStream prParsedSource)

30− prCommentStream

36+ prCommentStream

31− prAnns

37+ prAnns

32− prUseRecordDot

38+ prUseRecordDot

src/Ormolu/Printer/Combinators.hs+39−29

@@ -21,6 +21,7 @@ module Ormolu.Printer.Combinators

21 space,

22 newline,

23 inci,

24+ inciIf,

24 located,

25 located,

25 located',

26 located',

26 switchLayout,

27 switchLayout,

@@ -51,57 +52,57 @@ module Ormolu.Printer.Combinators

51

52

52 -- ** Literals

53 -- ** Literals

53 comma,

54 comma,

55+ commaDel,

56+ equals,

54

57

55− -- ** Comments

58+ -- ** Stateful markers

59+ SpanMark (..),

60+ spanMarkSpan,

56 HaddockStyle (..),

61 HaddockStyle (..),

57− setLastCommentSpan,

62+ setSpanMark,

58− getLastCommentSpan,

63+ getSpanMark,

59 )

64 )

60where

65where

61

66

62import Control.Monad

67import Control.Monad

63−import Data.Data (Data)

64import Data.List (intersperse)

68import Data.List (intersperse)

65import Data.Text (Text)

69import Data.Text (Text)

66import Ormolu.Printer.Comments

70import Ormolu.Printer.Comments

67import Ormolu.Printer.Internal

71import Ormolu.Printer.Internal

68−import Ormolu.Utils (isModule)

69import SrcLoc

72import SrcLoc

70

73

71----------------------------------------------------------------------------

74----------------------------------------------------------------------------

72-- Basic

75-- Basic

73

76

77+-- | Indent the inner expression if the first argument is 'True'.

78+inciIf ::

79+ -- | Whether to indent

80+ Bool ->

81+ -- | The expression to indent

82+ R () ->

83+ R ()

84+inciIf b m = if b then inci m else m

85+

74-- | Enter a 'Located' entity. This combinator handles outputting comments

86-- | Enter a 'Located' entity. This combinator handles outputting comments

75-- and sets layout (single-line vs multi-line) for the inner computation.

87-- and sets layout (single-line vs multi-line) for the inner computation.

76-- Roughly, the rule for using 'located' is that every time there is a

88-- Roughly, the rule for using 'located' is that every time there is a

77-- 'Located' wrapper, it should be “discharged” with a corresponding

89-- 'Located' wrapper, it should be “discharged” with a corresponding

78-- 'located' invocation.

90-- 'located' invocation.

79located ::

91located ::

80− Data a =>

81 -- | Thing to enter

92 -- | Thing to enter

82 Located a ->

93 Located a ->

83 -- | How to render inner value

94 -- | How to render inner value

84 (a -> R ()) ->

95 (a -> R ()) ->

85 R ()

96 R ()

86−located loc f = do

97+located (L (UnhelpfulSpan _) a) f = f a

87− let withRealLocated (L l a) g =

98+located (L (RealSrcSpan l) a) f = do

88− case l of

89− UnhelpfulSpan _ -> return ()

90− RealSrcSpan l' -> g (L l' a)

91− withRealLocated loc spitPrecedingComments

99+ spitPrecedingComments l

92− let setEnclosingSpan =

93− case getLoc loc of

94− UnhelpfulSpan _ -> id

95− RealSrcSpan orf ->

96− if isModule (unLoc loc)

97− then id

98− else withEnclosingSpan orf

100+ withEnclosingSpan l $

99− setEnclosingSpan $ switchLayout [getLoc loc] (f (unLoc loc))

101+ switchLayout [RealSrcSpan l] (f a)

100− withRealLocated loc spitFollowingComments

102+ spitFollowingComments l

101

103

102-- | A version of 'located' with arguments flipped.

104-- | A version of 'located' with arguments flipped.

103located' ::

105located' ::

104− Data a =>

105 -- | How to render inner value

106 -- | How to render inner value

106 (a -> R ()) ->

107 (a -> R ()) ->

107 -- | Thing to enter

108 -- | Thing to enter

@@ -184,10 +185,12 @@ sepSemi f xs = vlayout singleLine multiLine

184 xs' ->

185 xs' ->

185 if ub

186 if ub

186 then do

187 then do

187− txt "{ "

188+ txt "{"

189+ space

188− sep (txt "; ") (dontUseBraces . f) xs'

190+ sep (txt ";" >> space) (dontUseBraces . f) xs'

191+ space

189− txt " }"

192+ txt "}"

190− else sep (txt "; ") f xs'

193+ else sep (txt ";" >> space) f xs'

191 multiLine =

194 multiLine =

192 sep newline (dontUseBraces . f) xs

195 sep newline (dontUseBraces . f) xs

193

196

@@ -200,6 +203,7 @@ data BracketStyle

200 N

203 N

201 | -- | Shifted one level

204 | -- | Shifted one level

202 S

205 S

206+ deriving (Eq, Show)

203

207

204-- | Surround given entity by backticks.

208-- | Surround given entity by backticks.

205backticks :: R () -> R ()

209backticks :: R () -> R ()

@@ -276,9 +280,7 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)

276 then newline >> inci m

280 then newline >> inci m

277 else space >> sitcc m

281 else space >> sitcc m

278 newline

282 newline

279− case style of

280− N -> txt close

281− S -> inci (txt close)

283+ inciIf (style == S) (txt close)

282

284

283----------------------------------------------------------------------------

285----------------------------------------------------------------------------

284-- Literals

286-- Literals

@@ -286,3 +288,11 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)

286-- | Print @,@.

288-- | Print @,@.

287comma :: R ()

289comma :: R ()

288comma = txt ","

290comma = txt ","

291+

292+-- | Delimiting combination with 'comma'. To be used with 'sep'.

293+commaDel :: R ()

294+commaDel = comma >> breakpoint

295+

296+-- | Print @=@. Do not use @'txt' "="@.

297+equals :: R ()

298+equals = interferingTxt "="

src/Ormolu/Printer/Comments.hs+62−76

@@ -1,3 +1,4 @@

1+{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2

3

3-- | Helpers for formatting of comments. This is low-level code, use

4-- | Helpers for formatting of comments. This is low-level code, use

@@ -6,21 +7,17 @@ module Ormolu.Printer.Comments

6 ( spitPrecedingComments,

7 ( spitPrecedingComments,

7 spitFollowingComments,

8 spitFollowingComments,

8 spitRemainingComments,

9 spitRemainingComments,

9− spitStackHeader,

10+ spitCommentNow,

11+ spitCommentPending,

10 )

12 )

11where

13where

12

14

13import Control.Monad

15import Control.Monad

14−import Data.Char (isSpace)

15−import Data.Coerce (coerce)

16−import Data.Data (Data)

17−import Data.List (isPrefixOf)

18import qualified Data.List.NonEmpty as NE

16import qualified Data.List.NonEmpty as NE

19−import Data.List.NonEmpty (NonEmpty (..))

17+import Data.Maybe (listToMaybe)

20import qualified Data.Text as T

18import qualified Data.Text as T

21import Ormolu.Parser.CommentStream

19import Ormolu.Parser.CommentStream

22import Ormolu.Printer.Internal

20import Ormolu.Printer.Internal

23−import Ormolu.Utils (isModule)

24import SrcLoc

21import SrcLoc

25

22

26----------------------------------------------------------------------------

23----------------------------------------------------------------------------

@@ -28,108 +25,91 @@ import SrcLoc

28

25

29-- | Output all preceding comments for an element at given location.

26-- | Output all preceding comments for an element at given location.

30spitPrecedingComments ::

27spitPrecedingComments ::

31− Data a =>

32− -- | AST element to attach comments to

28+ -- | Span of the element to attach comments to

33− RealLocated a ->

29+ RealSrcSpan ->

34 R ()

30 R ()

35spitPrecedingComments ref = do

31spitPrecedingComments ref = do

36 gotSome <- handleCommentSeries (spitPrecedingComment ref)

32 gotSome <- handleCommentSeries (spitPrecedingComment ref)

37 when gotSome $ do

33 when gotSome $ do

34+ lastMark <- getSpanMark

38 -- Insert a blank line between the preceding comments and the thing

35 -- Insert a blank line between the preceding comments and the thing

39 -- after them if there was a blank line in the input.

36 -- after them if there was a blank line in the input.

40− lastSpn <- fmap snd <$> getLastCommentSpan

41− when (needsNewlineBefore (getRealSrcSpan ref) lastSpn) newline

37+ when (needsNewlineBefore ref lastMark) newline

42

38

43-- | Output all comments following an element at given location.

39-- | Output all comments following an element at given location.

44spitFollowingComments ::

40spitFollowingComments ::

45− Data a =>

46− -- | AST element of attach comments to

41+ -- | Span of the element to attach comments to

47− RealLocated a ->

42+ RealSrcSpan ->

48 R ()

43 R ()

49spitFollowingComments ref = do

44spitFollowingComments ref = do

50− trimSpanStream (getRealSrcSpan ref)

45+ trimSpanStream ref

51 void $ handleCommentSeries (spitFollowingComment ref)

46 void $ handleCommentSeries (spitFollowingComment ref)

52

47

53-- | Output all remaining comments in the comment stream.

48-- | Output all remaining comments in the comment stream.

54spitRemainingComments :: R ()

49spitRemainingComments :: R ()

50+spitRemainingComments = do

51+ -- Make sure we have a blank a line between the last definition and the

52+ -- trailing comments.

53+ newline

55−spitRemainingComments = void $ handleCommentSeries spitRemainingComment

54+ void $ handleCommentSeries spitRemainingComment

56−

57−-- | If there is a stack header in the comment stream, print it.

58−spitStackHeader :: R ()

59−spitStackHeader = do

60− let isStackHeader (Comment (x :| _)) =

61− "stack" `isPrefixOf` dropWhile isSpace (drop 2 x)

62− mstackHeader <- popComment (isStackHeader . unRealSrcSpan)

63− forM_ mstackHeader $ \(L spn x) -> do

64− spitCommentNow spn x

65− newline

66

55

67----------------------------------------------------------------------------

56----------------------------------------------------------------------------

68-- Single-comment functions

57-- Single-comment functions

69

58

70-- | Output a single preceding comment for an element at given location.

59-- | Output a single preceding comment for an element at given location.

71spitPrecedingComment ::

60spitPrecedingComment ::

72− Data a =>

73− -- | AST element to attach comments to

61+ -- | Span of the element to attach comments to

74− RealLocated a ->

75− -- | Location of last comment in the series

76− Maybe RealSrcSpan ->

62+ RealSrcSpan ->

77 -- | Are we done?

63 -- | Are we done?

78 R Bool

64 R Bool

79−spitPrecedingComment (L ref a) mlastSpn = do

65+spitPrecedingComment ref = do

66+ mlastMark <- getSpanMark

80 let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref

67 let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref

81 withPoppedComment p $ \l comment -> do

68 withPoppedComment p $ \l comment -> do

82− dirtyLine <-

69+ lineSpans <- thisLineSpans

83− case mlastSpn of

70+ let thisCommentLine = srcLocLine (realSrcSpanStart l)

84− -- When the current line is dirty it means that something that can

71+ needsNewline =

85− -- have comments attached to it is already on the line. To avoid

72+ case listToMaybe lineSpans of

86− -- problems with idempotence we cannot output the first comment

73+ Nothing -> False

87− -- immediately because it'll be attached to the previous element (on

74+ Just spn -> srcLocLine (realSrcSpanEnd spn) /= thisCommentLine

88− -- the same line) on the next run, so we play safe here and output

89− -- an extra 'newline' in this case.

90− Nothing -> isLineDirty -- only for very first preceding comment

91− Just _ -> return False

92− when (dirtyLine || needsNewlineBefore l mlastSpn) newline

75+ when (needsNewline || needsNewlineBefore l mlastMark) newline

93 spitCommentNow l comment

76 spitCommentNow l comment

94− if theSameLinePre l ref && not (isModule a)

77+ if theSameLinePre l ref

95 then space

78 then space

96 else newline

79 else newline

97

80

98-- | Output a comment that follows element at given location immediately on

81-- | Output a comment that follows element at given location immediately on

99-- the same line, if there is any.

82-- the same line, if there is any.

100spitFollowingComment ::

83spitFollowingComment ::

101− Data a =>

102 -- | AST element to attach comments to

84 -- | AST element to attach comments to

103− RealLocated a ->

104− -- | Location of last comment in the series

105− Maybe RealSrcSpan ->

85+ RealSrcSpan ->

106 -- | Are we done?

86 -- | Are we done?

107 R Bool

87 R Bool

108−spitFollowingComment (L ref a) mlastSpn = do

88+spitFollowingComment ref = do

89+ mlastMark <- getSpanMark

109 mnSpn <- nextEltSpan

90 mnSpn <- nextEltSpan

110 -- Get first enclosing span that is not equal to reference span, i.e. it's

91 -- Get first enclosing span that is not equal to reference span, i.e. it's

111 -- truly something enclosing the AST element.

92 -- truly something enclosing the AST element.

112 meSpn <- getEnclosingSpan (/= ref)

93 meSpn <- getEnclosingSpan (/= ref)

113− withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastSpn) $ \l comment ->

94+ withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastMark) $ \l comment ->

114− if theSameLinePost l ref && not (isModule a)

95+ if theSameLinePost l ref

115 then

96 then

116 if isMultilineComment comment

97 if isMultilineComment comment

117 then space >> spitCommentNow l comment

98 then space >> spitCommentNow l comment

118 else spitCommentPending OnTheSameLine l comment

99 else spitCommentPending OnTheSameLine l comment

119 else do

100 else do

120− when (needsNewlineBefore l mlastSpn) $

101+ when (needsNewlineBefore l mlastMark) $

121 registerPendingCommentLine OnNextLine ""

102 registerPendingCommentLine OnNextLine ""

122 spitCommentPending OnNextLine l comment

103 spitCommentPending OnNextLine l comment

123

104

124-- | Output a single remaining comment from the comment stream.

105-- | Output a single remaining comment from the comment stream.

125spitRemainingComment ::

106spitRemainingComment ::

126− -- | Location of last comment in the series

127− Maybe RealSrcSpan ->

128 -- | Are we done?

107 -- | Are we done?

129 R Bool

108 R Bool

130−spitRemainingComment mlastSpn =

109+spitRemainingComment = do

110+ mlastMark <- getSpanMark

131 withPoppedComment (const True) $ \l comment -> do

111 withPoppedComment (const True) $ \l comment -> do

132− when (needsNewlineBefore l mlastSpn) newline

112+ when (needsNewlineBefore l mlastMark) newline

133 spitCommentNow l comment

113 spitCommentNow l comment

134 newline

114 newline

135

115

@@ -140,13 +120,13 @@ spitRemainingComment mlastSpn =

140handleCommentSeries ::

120handleCommentSeries ::

141 -- | Given location of previous comment, output the next comment

121 -- | Given location of previous comment, output the next comment

142 -- returning 'True' if we're done

122 -- returning 'True' if we're done

143− (Maybe RealSrcSpan -> R Bool) ->

123+ R Bool ->

144 -- | Whether we printed any comments

124 -- | Whether we printed any comments

145 R Bool

125 R Bool

146handleCommentSeries f = go False

126handleCommentSeries f = go False

147 where

127 where

148 go gotSome = do

128 go gotSome = do

149− done <- getLastCommentSpan >>= f . fmap snd

129+ done <- f

150 if done

130 if done

151 then return gotSome

131 then return gotSome

152 else go True

132 else go True

@@ -172,13 +152,14 @@ needsNewlineBefore ::

172 -- | Current comment span

152 -- | Current comment span

173 RealSrcSpan ->

153 RealSrcSpan ->

174 -- | Last printed comment span

154 -- | Last printed comment span

175− Maybe RealSrcSpan ->

155+ Maybe SpanMark ->

176 Bool

156 Bool

177−needsNewlineBefore l mlastSpn =

157+needsNewlineBefore _ (Just (HaddockSpan _ _)) = True

178− case mlastSpn of

158+needsNewlineBefore l mlastMark =

159+ case spanMarkSpan <$> mlastMark of

179 Nothing -> False

160 Nothing -> False

180− Just lastSpn ->

161+ Just lastMark ->

181− srcSpanStartLine l > srcSpanEndLine lastSpn + 1

162+ srcSpanStartLine l > srcSpanEndLine lastMark + 1

182

163

183-- | Is the preceding comment and AST element are on the same line?

164-- | Is the preceding comment and AST element are on the same line?

184theSameLinePre ::

165theSameLinePre ::

@@ -209,11 +190,11 @@ commentFollowsElt ::

209 -- | Location of enclosing AST element

190 -- | Location of enclosing AST element

210 Maybe RealSrcSpan ->

191 Maybe RealSrcSpan ->

211 -- | Location of last comment in the series

192 -- | Location of last comment in the series

212− Maybe RealSrcSpan ->

193+ Maybe SpanMark ->

213 -- | Comment to test

194 -- | Comment to test

214 RealLocated Comment ->

195 RealLocated Comment ->

215 Bool

196 Bool

216−commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =

197+commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =

217 -- A comment follows a AST element if all 4 conditions are satisfied:

198 -- A comment follows a AST element if all 4 conditions are satisfied:

218 goesAfter

199 goesAfter

219 && logicallyFollows

200 && logicallyFollows

@@ -226,9 +207,8 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =

226 -- 2) The comment logically belongs to the element, four cases:

207 -- 2) The comment logically belongs to the element, four cases:

227 logicallyFollows =

208 logicallyFollows =

228 theSameLinePost l ref -- a) it's on the same line

209 theSameLinePost l ref -- a) it's on the same line

229− || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^

230− || continuation -- c) it's a continuation of a comment block

210+ || continuation -- b) it's a continuation of a comment block

231− || lastInEnclosing -- d) it's the last element in the enclosing construct

211+ || lastInEnclosing -- c) it's the last element in the enclosing construct

232

212

233 -- 3) There is no other AST element between this element and the comment:

213 -- 3) There is no other AST element between this element and the comment:

234 noEltBetween =

214 noEltBetween =

@@ -255,9 +235,15 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =

255 >= abs (startColumn ref - startColumn l)

235 >= abs (startColumn ref - startColumn l)

256 )

236 )

257 continuation =

237 continuation =

238+ -- A comment is a continuation when it doesn't have non-whitespace

239+ -- lexemes in front of it and goes right after the previous comment.

240+ not (hasAtomsBefore comment)

258− case mlastSpn of

241+ && ( case mlastMark of

259− Nothing -> False

242+ Just (HaddockSpan _ _) -> False

243+ Just (CommentSpan spn) ->

260− Just spn -> srcSpanEndLine spn + 1 == srcSpanStartLine l

244+ srcSpanEndLine spn + 1 == srcSpanStartLine l

245+ _ -> False

246+ )

261 lastInEnclosing =

247 lastInEnclosing =

262 case meSpn of

248 case meSpn of

263 -- When there is no enclosing element, return false

249 -- When there is no enclosing element, return false

@@ -279,9 +265,9 @@ spitCommentNow spn comment = do

279 . sequence_

265 . sequence_

280 . NE.intersperse newline

266 . NE.intersperse newline

281 . fmap (txt . T.pack)

267 . fmap (txt . T.pack)

282− . coerce

268+ . unComment

283 $ comment

269 $ comment

284− setLastCommentSpan Nothing spn

270+ setSpanMark (CommentSpan spn)

285

271

286-- | Output a 'Comment' at the end of correct line or after it depending on

272-- | Output a 'Comment' at the end of correct line or after it depending on

287-- 'CommentPosition'. Used for comments that may potentially follow on the

273-- 'CommentPosition'. Used for comments that may potentially follow on the

@@ -295,6 +281,6 @@ spitCommentPending position spn comment = do

295 . sequence_

281 . sequence_

296 . NE.toList

282 . NE.toList

297 . fmap (registerPendingCommentLine position . T.pack)

283 . fmap (registerPendingCommentLine position . T.pack)

298− . coerce

284+ . unComment

299 $ comment

285 $ comment

300− setLastCommentSpan Nothing spn

286+ setSpanMark (CommentSpan spn)

src/Ormolu/Printer/Internal.hs+149−96

@@ -1,4 +1,5 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

4

5

@@ -13,10 +14,10 @@ module Ormolu.Printer.Internal

13

14

14 -- * Internal functions

15 -- * Internal functions

15 txt,

16 txt,

17+ interferingTxt,

16 atom,

18 atom,

17 space,

19 space,

18 newline,

20 newline,

19− isLineDirty,

20 useRecordDot,

21 useRecordDot,

21 inci,

22 inci,

22 sitcc,

23 sitcc,

@@ -38,9 +39,14 @@ module Ormolu.Printer.Internal

38 popComment,

39 popComment,

39 getEnclosingSpan,

40 getEnclosingSpan,

40 withEnclosingSpan,

41 withEnclosingSpan,

42+ thisLineSpans,

43+

44+ -- * Stateful markers

45+ SpanMark (..),

46+ spanMarkSpan,

41 HaddockStyle (..),

47 HaddockStyle (..),

42− setLastCommentSpan,

48+ setSpanMark,

43− getLastCommentSpan,

49+ getSpanMark,

44

50

45 -- * Annotations

51 -- * Annotations

46 getAnns,

52 getAnns,

@@ -73,45 +79,44 @@ newtype R a = R (ReaderT RC (State SC) a)

73

79

74-- | Reader context of 'R'. This should be used when we control rendering by

80-- | Reader context of 'R'. This should be used when we control rendering by

75-- enclosing certain expressions with wrappers.

81-- enclosing certain expressions with wrappers.

76−data RC

82+data RC = RC

77− = RC

78− { -- | Indentation level, as the column index we need to start from after

83+ { -- | Indentation level, as the column index we need to start from after

79− -- a newline if we break lines

84+ -- a newline if we break lines

80− rcIndent :: !Int,

85+ rcIndent :: !Int,

81− -- | Current layout

86+ -- | Current layout

82− rcLayout :: Layout,

87+ rcLayout :: Layout,

83− -- | Spans of enclosing elements of AST

88+ -- | Spans of enclosing elements of AST

84− rcEnclosingSpans :: [RealSrcSpan],

89+ rcEnclosingSpans :: [RealSrcSpan],

85− -- | Collection of annotations

90+ -- | Collection of annotations

86− rcAnns :: Anns,

91+ rcAnns :: Anns,

87− -- | Whether the last expression in the layout can use braces

92+ -- | Whether the last expression in the layout can use braces

88− rcCanUseBraces :: Bool,

93+ rcCanUseBraces :: Bool,

89− -- | Whether the source could have used the record dot preprocessor

94+ -- | Whether the source could have used the record dot preprocessor

90− rcUseRecDot :: Bool

95+ rcUseRecDot :: Bool

91− }

96+ }

92

97

93-- | State context of 'R'.

98-- | State context of 'R'.

94−data SC

99+data SC = SC

95− = SC

96− { -- | Index of the next column to render

100+ { -- | Index of the next column to render

97− scColumn :: !Int,

101+ scColumn :: !Int,

102+ -- | Indentation level that was used for the current line

103+ scIndent :: !Int,

98− -- | Rendered source code so far

104+ -- | Rendered source code so far

99− scBuilder :: Builder,

105+ scBuilder :: Builder,

100− -- | Span stream

106+ -- | Span stream

101− scSpanStream :: SpanStream,

107+ scSpanStream :: SpanStream,

108+ -- | Spans of atoms that have been printed on the current line so far

109+ scThisLineSpans :: [RealSrcSpan],

102− -- | Comment stream

110+ -- | Comment stream

103− scCommentStream :: CommentStream,

111+ scCommentStream :: CommentStream,

104− -- | Pending comment lines (in reverse order) to be inserted before next

112+ -- | Pending comment lines (in reverse order) to be inserted before next

105− -- newline, 'Int' is the indentation level

113+ -- newline, 'Int' is the indentation level

106− scPendingComments :: ![(CommentPosition, Int, Text)],

114+ scPendingComments :: ![(CommentPosition, Text)],

107− -- | Whether the current line is “dirty”, that is, already contains

108− -- atoms that can have comments attached to them

109− scDirtyLine :: !Bool,

110− -- | Whether to output a space before the next output

115+ -- | Whether to output a space before the next output

111− scRequestedDelimiter :: !RequestedDelimiter,

116+ scRequestedDelimiter :: !RequestedDelimiter,

112− -- | Span of last output comment

117+ -- | An auxiliary marker for keeping track of last output element

113− scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))

118+ scSpanMark :: !(Maybe SpanMark)

114− }

119+ }

115

120

116-- | Make sure next output is delimited by one of the following.

121-- | Make sure next output is delimited by one of the following.

117data RequestedDelimiter

122data RequestedDelimiter

@@ -172,18 +177,36 @@ runR (R m) sstream cstream anns recDot =

172 sc =

177 sc =

173 SC

178 SC

174 { scColumn = 0,

179 { scColumn = 0,

180+ scIndent = 0,

175 scBuilder = mempty,

181 scBuilder = mempty,

176 scSpanStream = sstream,

182 scSpanStream = sstream,

183+ scThisLineSpans = [],

177 scCommentStream = cstream,

184 scCommentStream = cstream,

178 scPendingComments = [],

185 scPendingComments = [],

179− scDirtyLine = False,

180 scRequestedDelimiter = VeryBeginning,

186 scRequestedDelimiter = VeryBeginning,

181− scLastCommentSpan = Nothing

187+ scSpanMark = Nothing

182 }

188 }

183

189

184----------------------------------------------------------------------------

190----------------------------------------------------------------------------

185-- Internal functions

191-- Internal functions

186

192

193+-- | Type of the thing to output. Influences the primary low-level rendering

194+-- function 'spit'.

195+data SpitType

196+ = -- | Simple opaque text that breaks comment series.

197+ SimpleText

198+ | -- | Like 'SimpleText', but assume that when this text is inserted it

199+ -- will separate an 'Atom' and its pending comments, so insert an extra

200+ -- 'newline' in that case to force the pending comments and continue on

201+ -- a fresh line.

202+ InterferingText

203+ | -- | An atom that typically have span information in the AST and can

204+ -- have comments attached to it.

205+ Atom

206+ | -- | Used for rendering comment lines.

207+ CommentPart

208+ deriving (Show, Eq)

209+

187-- | Output a fixed 'Text' fragment. The argument may not contain any line

210-- | Output a fixed 'Text' fragment. The argument may not contain any line

188-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like

211-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like

189-- keywords and pipes @|@ in functional dependencies.

212-- keywords and pipes @|@ in functional dependencies.

@@ -195,7 +218,15 @@ txt ::

195 -- | 'Text' to output

218 -- | 'Text' to output

196 Text ->

219 Text ->

197 R ()

220 R ()

198−txt = spit False False

221+txt = spit SimpleText

222+

223+-- | Similar to 'txt' but the text inserted this way is assumed to break the

224+-- “link” between the preceding atom and its pending comments.

225+interferingTxt ::

226+ -- | 'Text' to output

227+ Text ->

228+ R ()

229+interferingTxt = spit InterferingText

199

230

200-- | Output 'Outputable' fragment of AST. This can be used to output numeric

231-- | Output 'Outputable' fragment of AST. This can be used to output numeric

201-- literals and similar. Everything that doesn't have inner structure but

232-- literals and similar. Everything that doesn't have inner structure but

@@ -204,48 +235,61 @@ atom ::

204 Outputable a =>

235 Outputable a =>

205 a ->

236 a ->

206 R ()

237 R ()

207−atom = spit True False . T.pack . showOutputable

238+atom = spit Atom . T.pack . showOutputable

208

239

209-- | Low-level non-public helper to define 'txt' and 'atom'.

240-- | Low-level non-public helper to define 'txt' and 'atom'.

210spit ::

241spit ::

211− -- | Should we mark the line as dirty?

242+ -- | Type of the thing to spit

212− Bool ->

243+ SpitType ->

213− -- | Used during outputting of pending comments?

214− Bool ->

215 -- | 'Text' to output

244 -- | 'Text' to output

216 Text ->

245 Text ->

217 R ()

246 R ()

218−spit dirty printingComments txt' = do

247+spit _ "" = return ()

248+spit stype text = do

219 requestedDel <- R (gets scRequestedDelimiter)

249 requestedDel <- R (gets scRequestedDelimiter)

250+ pendingComments <- R (gets scPendingComments)

251+ when (stype == InterferingText && not (null pendingComments)) newline

220 case requestedDel of

252 case requestedDel of

221 RequestedNewline -> do

253 RequestedNewline -> do

222 R . modify $ \sc ->

254 R . modify $ \sc ->

223 sc

255 sc

224 { scRequestedDelimiter = RequestedNothing

256 { scRequestedDelimiter = RequestedNothing

225 }

257 }

226− if printingComments

258+ case stype of

227− then newlineRaw

259+ CommentPart -> newlineRaw

228− else newline

260+ _ -> newline

229 _ -> return ()

261 _ -> return ()

230 R $ do

262 R $ do

231 i <- asks rcIndent

263 i <- asks rcIndent

232 c <- gets scColumn

264 c <- gets scColumn

265+ closestEnclosing <- listToMaybe <$> asks rcEnclosingSpans

233− let spaces =

266+ let indentedTxt = spaces <> text

267+ spaces = T.replicate spacesN " "

268+ spacesN =

234− if c < i

269+ if c == 0

235− then T.replicate (i - c) " "

270+ then i

236− else bool mempty " " (requestedDel == RequestedSpace)

271+ else bool 0 1 (requestedDel == RequestedSpace)

237− indentedTxt = spaces <> txt'

238 modify $ \sc ->

272 modify $ \sc ->

239 sc

273 sc

240 { scBuilder = scBuilder sc <> fromText indentedTxt,

274 { scBuilder = scBuilder sc <> fromText indentedTxt,

241 scColumn = scColumn sc + T.length indentedTxt,

275 scColumn = scColumn sc + T.length indentedTxt,

242− scDirtyLine = scDirtyLine sc || dirty,

276+ scIndent =

277+ if c == 0

278+ then i

279+ else scIndent sc,

280+ scThisLineSpans =

281+ let xs = scThisLineSpans sc

282+ in case stype of

283+ Atom -> case closestEnclosing of

284+ Nothing -> xs

285+ Just x -> x : xs

286+ _ -> xs,

243 scRequestedDelimiter = RequestedNothing,

287 scRequestedDelimiter = RequestedNothing,

244− scLastCommentSpan =

288+ scSpanMark =

245 -- If there are pending comments, do not reset last comment

289 -- If there are pending comments, do not reset last comment

246 -- location.

290 -- location.

247− if printingComments || (not . null . scPendingComments) sc

291+ if (stype == CommentPart) || (not . null . scPendingComments) sc

248− then scLastCommentSpan sc

292+ then scSpanMark sc

249 else Nothing

293 else Nothing

250 }

294 }

251

295

@@ -276,21 +320,22 @@ space = R . modify $ \sc ->

276-- hard to output more than one blank newline in a row.

320-- hard to output more than one blank newline in a row.

277newline :: R ()

321newline :: R ()

278newline = do

322newline = do

323+ indent <- R (gets scIndent)

279 cs <- reverse <$> R (gets scPendingComments)

324 cs <- reverse <$> R (gets scPendingComments)

280 case cs of

325 case cs of

281 [] -> newlineRaw

326 [] -> newlineRaw

282− ((position, _, _) : _) -> do

327+ ((position, _) : _) -> do

283 case position of

328 case position of

284 OnTheSameLine -> space

329 OnTheSameLine -> space

285 OnNextLine -> newlineRaw

330 OnNextLine -> newlineRaw

286− R . forM_ cs $ \(_, indent, txt') ->

331+ R . forM_ cs $ \(_, text) ->

287 let modRC rc =

332 let modRC rc =

288 rc

333 rc

289 { rcIndent = indent

334 { rcIndent = indent

290 }

335 }

291 R m = do

336 R m = do

292− unless (T.null txt') $

337+ unless (T.null text) $

293− spit False True txt'

338+ spit CommentPart text

294 newlineRaw

339 newlineRaw

295 in local modRC m

340 in local modRC m

296 R . modify $ \sc ->

341 R . modify $ \sc ->

@@ -311,7 +356,8 @@ newlineRaw = R . modify $ \sc ->

311 VeryBeginning -> builderSoFar

356 VeryBeginning -> builderSoFar

312 _ -> builderSoFar <> "\n",

357 _ -> builderSoFar <> "\n",

313 scColumn = 0,

358 scColumn = 0,

314− scDirtyLine = False,

359+ scIndent = 0,

360+ scThisLineSpans = [],

315 scRequestedDelimiter = case scRequestedDelimiter sc of

361 scRequestedDelimiter = case scRequestedDelimiter sc of

316 AfterNewline -> RequestedNewline

362 AfterNewline -> RequestedNewline

317 RequestedNewline -> RequestedNewline

363 RequestedNewline -> RequestedNewline

@@ -319,14 +365,9 @@ newlineRaw = R . modify $ \sc ->

319 _ -> AfterNewline

365 _ -> AfterNewline

320 }

366 }

321

367

322−-- | Check if the current line is “dirty”, that is, there is something on it

323−-- that can have comments attached to it.

324−isLineDirty :: R Bool

325−isLineDirty = R (gets scDirtyLine)

326−

327-- | Return 'True' if we should print record dot syntax.

368-- | Return 'True' if we should print record dot syntax.

328useRecordDot :: R Bool

369useRecordDot :: R Bool

329−useRecordDot = R $ asks rcUseRecDot

370+useRecordDot = R (asks rcUseRecDot)

330

371

331-- | Increase indentation level by one indentation step for the inner

372-- | Increase indentation level by one indentation step for the inner

332-- computation. 'inci' should be used when a part of code must be more

373-- computation. 'inci' should be used when a part of code must be more

@@ -343,8 +384,7 @@ inci (R m) = R (local modRC m)

343

384

344-- | Set indentation level for the inner computation equal to current

385-- | Set indentation level for the inner computation equal to current

345-- column. This makes sure that the entire inner block is uniformly

386-- column. This makes sure that the entire inner block is uniformly

346−-- \"shifted\" to the right. Only works (and makes sense) when enclosing

387+-- \"shifted\" to the right.

347−-- layout is multi-line.

348sitcc :: R () -> R ()

388sitcc :: R () -> R ()

349sitcc (R m) = do

389sitcc (R m) = do

350 requestedDel <- R (gets scRequestedDelimiter)

390 requestedDel <- R (gets scRequestedDelimiter)

@@ -352,16 +392,9 @@ sitcc (R m) = do

352 c <- R (gets scColumn)

392 c <- R (gets scColumn)

353 let modRC rc =

393 let modRC rc =

354 rc

394 rc

355− { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)

395+ { rcIndent = max i (c + bool 0 1 (requestedDel == RequestedSpace))

356 }

396 }

357− vlayout (R m) . R $ do

358− modify $ \sc ->

359− sc

360− { scRequestedDelimiter = case requestedDel of

361− RequestedSpace -> RequestedNothing

362− other -> other

363− }

364− local modRC m

397+ R (local modRC m)

365

398

366-- | Set 'Layout' for internal computation.

399-- | Set 'Layout' for internal computation.

367enterLayout :: Layout -> R () -> R ()

400enterLayout :: Layout -> R () -> R ()

@@ -402,11 +435,10 @@ registerPendingCommentLine ::

402 -- | 'Text' to output

435 -- | 'Text' to output

403 Text ->

436 Text ->

404 R ()

437 R ()

405−registerPendingCommentLine position txt' = R $ do

438+registerPendingCommentLine position text = R $ do

406− i <- asks rcIndent

407 modify $ \sc ->

439 modify $ \sc ->

408 sc

440 sc

409− { scPendingComments = (position, i, txt') : scPendingComments sc

441+ { scPendingComments = (position, text) : scPendingComments sc

410 }

442 }

411

443

412-- | Drop elements that begin before or at the same place as given

444-- | Drop elements that begin before or at the same place as given

@@ -465,6 +497,29 @@ withEnclosingSpan spn (R m) = R (local modRC m)

465 { rcEnclosingSpans = spn : rcEnclosingSpans rc

497 { rcEnclosingSpans = spn : rcEnclosingSpans rc

466 }

498 }

467

499

500+-- | Get spans on this line so far.

501+thisLineSpans :: R [RealSrcSpan]

502+thisLineSpans = R (gets scThisLineSpans)

503+

504+----------------------------------------------------------------------------

505+-- Stateful markers

506+

507+-- | An auxiliary marker for keeping track of last output element.

508+data SpanMark

509+ = -- | Haddock comment

510+ HaddockSpan HaddockStyle RealSrcSpan

511+ | -- | Non-haddock comment

512+ CommentSpan RealSrcSpan

513+ | -- | A statement in a do-block and such span

514+ StatementSpan RealSrcSpan

515+

516+-- | Project 'RealSrcSpan' from 'SpanMark'.

517+spanMarkSpan :: SpanMark -> RealSrcSpan

518+spanMarkSpan = \case

519+ HaddockSpan _ s -> s

520+ CommentSpan s -> s

521+ StatementSpan s -> s

522+

468-- | Haddock string style.

523-- | Haddock string style.

469data HaddockStyle

524data HaddockStyle

470 = -- | @-- |@

525 = -- | @-- |@

@@ -477,20 +532,18 @@ data HaddockStyle

477 Named String

532 Named String

478

533

479-- | Set span of last output comment.

534-- | Set span of last output comment.

480−setLastCommentSpan ::

535+setSpanMark ::

481− -- | 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment

536+ -- | Span mark to set

482− Maybe HaddockStyle ->

537+ SpanMark ->

483− -- | Location of last printed comment

484− RealSrcSpan ->

485 R ()

538 R ()

486−setLastCommentSpan mhStyle spn = R . modify $ \sc ->

539+setSpanMark spnMark = R . modify $ \sc ->

487 sc

540 sc

488− { scLastCommentSpan = Just (mhStyle, spn)

541+ { scSpanMark = Just spnMark

489 }

542 }

490

543

491-- | Get span of last output comment.

544-- | Get span of last output comment.

492−getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))

545+getSpanMark :: R (Maybe SpanMark)

493−getLastCommentSpan = R (gets scLastCommentSpan)

546+getSpanMark = R (gets scSpanMark)

494

547

495----------------------------------------------------------------------------

548----------------------------------------------------------------------------

496-- Annotations

549-- Annotations

@@ -514,7 +567,7 @@ dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)

514

567

515-- | Return 'True' if we can use braces in this context.

568-- | Return 'True' if we can use braces in this context.

516canUseBraces :: R Bool

569canUseBraces :: R Bool

517−canUseBraces = R $ asks rcCanUseBraces

570+canUseBraces = R (asks rcCanUseBraces)

518

571

519----------------------------------------------------------------------------

572----------------------------------------------------------------------------

520-- Constants

573-- Constants

src/Ormolu/Printer/Meat/Common.hs+13−10

@@ -17,7 +17,6 @@ where

17

18import Control.Monad

19import Data.List (isPrefixOf)

20−import Data.Maybe (isJust)

21import qualified Data.Text as T

20import qualified Data.Text as T

22import GHC hiding (GhcPs, IE)

21import GHC hiding (GhcPs, IE)

23import Name (nameStableString)

22import Name (nameStableString)

@@ -115,14 +114,14 @@ p_qualName mname occName = do

115p_infixDefHelper ::

114p_infixDefHelper ::

116 -- | Whether to format in infix style

115 -- | Whether to format in infix style

117 Bool ->

116 Bool ->

118− -- | Indentation-bumping wrapper

117+ -- | Whether to bump indentation for arguments

119− (R () -> R ()) ->

118+ Bool ->

120 -- | How to print the operator\/name

119 -- | How to print the operator\/name

121 R () ->

120 R () ->

122 -- | How to print the arguments

121 -- | How to print the arguments

123 [R ()] ->

122 [R ()] ->

124 R ()

123 R ()

125−p_infixDefHelper isInfix inci' name args =

124+p_infixDefHelper isInfix indentArgs name args =

126 case (isInfix, args) of

125 case (isInfix, args) of

127 (True, p0 : p1 : ps) -> do

126 (True, p0 : p1 : ps) -> do

128 let parens' =

127 let parens' =

@@ -132,18 +131,18 @@ p_infixDefHelper isInfix inci' name args =

132 parens' $ do

131 parens' $ do

133 p0

132 p0

134 breakpoint

133 breakpoint

135− inci $ sitcc $ do

134+ inci . sitcc $ do

136 name

135 name

137 space

136 space

138 p1

137 p1

139− unless (null ps) . inci' $ do

138+ unless (null ps) . inciIf indentArgs $ do

140 breakpoint

139 breakpoint

141 sitcc (sep breakpoint sitcc ps)

140 sitcc (sep breakpoint sitcc ps)

142 (_, ps) -> do

141 (_, ps) -> do

143 name

142 name

144 unless (null ps) $ do

143 unless (null ps) $ do

145 breakpoint

144 breakpoint

146− inci' $ sitcc (sep breakpoint sitcc args)

145+ inciIf indentArgs $ sitcc (sep breakpoint sitcc args)

147

146

148-- | Print a Haddock.

147-- | Print a Haddock.

149p_hsDocString ::

148p_hsDocString ::

@@ -155,7 +154,11 @@ p_hsDocString ::

155 LHsDocString ->

154 LHsDocString ->

156 R ()

155 R ()

157p_hsDocString hstyle needsNewline (L l str) = do

156p_hsDocString hstyle needsNewline (L l str) = do

158− goesAfterComment <- isJust <$> getLastCommentSpan

157+ let isCommentSpan = \case

158+ HaddockSpan _ _ -> True

159+ CommentSpan _ -> True

160+ _ -> False

161+ goesAfterComment <- maybe False isCommentSpan <$> getSpanMark

159 -- Make sure the Haddock is separated by a newline from other comments.

162 -- Make sure the Haddock is separated by a newline from other comments.

160 when goesAfterComment newline

163 when goesAfterComment newline

161 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do

164 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do

@@ -174,8 +177,8 @@ p_hsDocString hstyle needsNewline (L l str) = do

174 -- It's often the case that the comment itself doesn't have a span

177 -- It's often the case that the comment itself doesn't have a span

175 -- attached to it and instead its location can be obtained from

178 -- attached to it and instead its location can be obtained from

176 -- nearest enclosing span.

179 -- nearest enclosing span.

177− getEnclosingSpan (const True) >>= mapM_ (setLastCommentSpan (Just hstyle))

180+ getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle)

178− RealSrcSpan spn -> setLastCommentSpan (Just hstyle) spn

181+ RealSrcSpan spn -> setSpanMark (HaddockSpan hstyle spn)

179

182

180-- | Print anchor of named doc section.

183-- | Print anchor of named doc section.

181p_hsDocName :: String -> R ()

184p_hsDocName :: String -> R ()

src/Ormolu/Printer/Meat/Declaration.hs+76−57

@@ -12,7 +12,7 @@ module Ormolu.Printer.Meat.Declaration

12where

13

14import Data.List (sort)

15−import Data.List.NonEmpty ((<|), NonEmpty (..))

15+import Data.List.NonEmpty (NonEmpty (..), (<|))

16import qualified Data.List.NonEmpty as NE

17import GHC hiding (InlinePragma)

18import OccName (occNameFS)

@@ -54,25 +54,27 @@ p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

54p_hsDeclsRespectGrouping = p_hsDecls' Respect

55

56p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()

57−p_hsDecls' grouping style decls = sepSemi id $

57+p_hsDecls' grouping style decls =

58+ sepSemi id $

58− -- Return a list of rendered declarations, adding a newline to separate

59+ -- Return a list of rendered declarations, adding a newline to separate

59− -- groups.

60+ -- groups.

60− case groupDecls decls of

61+ case groupDecls decls of

61− [] -> []

62+ [] -> []

62− (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)

63+ (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)

63 where

64 where

64 renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)

65 renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)

65 renderGroupWithPrev prev curr =

66 renderGroupWithPrev prev curr =

66 -- We can omit a blank line when the user didn't add one, but we must

67 -- We can omit a blank line when the user didn't add one, but we must

67 -- ensure we always add blank lines around documented declarations

68 -- ensure we always add blank lines around documented declarations

68− if or

69+ case grouping of

69− [ grouping == Disregard,

70+ Disregard ->

71+ breakpoint : renderGroup curr

72+ Respect ->

70− separatedByBlank getLoc prev curr,

73+ if separatedByBlankNE getLoc prev curr

71− isDocumented prev,

74+ || isDocumented prev

72− isDocumented curr

75+ || isDocumented curr

73− ]

74− then breakpoint : renderGroup curr

76+ then breakpoint : renderGroup curr

75− else renderGroup curr

77+ else renderGroup curr

76

78

77-- | Is a declaration group documented?

79-- | Is a declaration group documented?

78isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool

80isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool

@@ -83,9 +85,6 @@ isDocumented = any (isHaddock . unLoc)

83 isHaddock _ = False

85 isHaddock _ = False

84

86

85-- | Group relevant declarations together.

87-- | Group relevant declarations together.

86−--

87−-- Add a declaration to a group iff it is relevant to either the first or

88−-- the last declaration of the group.

89groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]

88groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]

90groupDecls [] = []

89groupDecls [] = []

91groupDecls (l@(L _ DocNext) : xs) =

90groupDecls (l@(L _ DocNext) : xs) =

@@ -94,18 +93,13 @@ groupDecls (l@(L _ DocNext) : xs) =

94 case groupDecls xs of

93 case groupDecls xs of

95 [] -> [l :| []]

94 [] -> [l :| []]

96 (x : xs') -> (l <| x) : xs'

95 (x : xs') -> (l <| x) : xs'

97−groupDecls (lhdr : xs) =

96+groupDecls (header : xs) =

98− let -- Pick the first decl as the group header

97+ let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) ->

99− hdr = unLoc lhdr

100− -- Zip rest of the decls with their previous decl

101− zipped = zip (lhdr : xs) xs

102− -- Pick decls from the tail if they are relevant to the group header

103− -- or the previous decl.

104− (grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->

105− let relevantToHdr = groupedDecls hdr cur

98+ let relevantToHdr = groupedDecls header current

106− relevantToPrev = groupedDecls prev cur

99+ relevantToPrev = groupedDecls previous current

100+ isDeclSeries = declSeries previous current

107− in relevantToHdr || relevantToPrev

101+ in isDeclSeries || relevantToHdr || relevantToPrev

108− in (lhdr :| map snd grp) : groupDecls (map snd rest)

102+ in (header :| map snd grp) : groupDecls (map snd rest)

109

103

110p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()

104p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()

111p_hsDecl style = \case

105p_hsDecl style = \case

@@ -164,35 +158,54 @@ p_instDecl style = \case

164

158

165p_derivDecl :: DerivDecl GhcPs -> R ()

159p_derivDecl :: DerivDecl GhcPs -> R ()

166p_derivDecl = \case

160p_derivDecl = \case

167− d@DerivDecl {..} -> p_standaloneDerivDecl d

161+ d@DerivDecl {} -> p_standaloneDerivDecl d

168 XDerivDecl x -> noExtCon x

162 XDerivDecl x -> noExtCon x

169

163

170-- | Determine if these declarations should be grouped together.

164-- | Determine if these declarations should be grouped together.

171groupedDecls ::

165groupedDecls ::

172− HsDecl GhcPs ->

166+ LHsDecl GhcPs ->

173− HsDecl GhcPs ->

167+ LHsDecl GhcPs ->

174 Bool

168 Bool

169+groupedDecls (L l_x x') (L l_y y') =

170+ case (x', y') of

175−groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'

171+ (TypeSignature ns, FunctionBody ns') -> ns `intersects` ns'

176−groupedDecls (TypeSignature ns) (DefaultSignature ns') = ns `intersects` ns'

172+ (TypeSignature ns, DefaultSignature ns') -> ns `intersects` ns'

177−groupedDecls (DefaultSignature ns) (TypeSignature ns') = ns `intersects` ns'

173+ (DefaultSignature ns, TypeSignature ns') -> ns `intersects` ns'

178−groupedDecls (DefaultSignature ns) (FunctionBody ns') = ns `intersects` ns'

174+ (DefaultSignature ns, FunctionBody ns') -> ns `intersects` ns'

179−groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'

175+ (x, FunctionBody ns) | Just ns' <- isPragma x -> ns `intersects` ns'

180−groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'

176+ (FunctionBody ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'

181−groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns

177+ (x, DataDeclaration n) | Just ns <- isPragma x -> n `elem` ns

182−groupedDecls (DataDeclaration n) x

178+ (DataDeclaration n, x)

183− | Just ns <- isPragma x =

179+ | Just ns <- isPragma x ->

184− let f = occNameFS . rdrNameOcc in f n `elem` map f ns

180+ let f = occNameFS . rdrNameOcc in f n `elem` map f ns

181+ (x, y)

185−groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'

182+ | Just ns <- isPragma x,

183+ Just ns' <- isPragma y ->

184+ ns `intersects` ns'

186−groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'

185+ (x, TypeSignature ns) | Just ns' <- isPragma x -> ns `intersects` ns'

187−groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns'

186+ (TypeSignature ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'

188−groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns

187+ (PatternSignature ns, Pattern n) -> n `elem` ns

189−groupedDecls (KindSignature n) (DataDeclaration n') = n == n'

188+ (KindSignature n, DataDeclaration n') -> n == n'

190−groupedDecls (KindSignature n) (ClassDeclaration n') = n == n'

189+ (KindSignature n, ClassDeclaration n') -> n == n'

191−groupedDecls (KindSignature n) (FamilyDeclaration n') = n == n'

190+ (KindSignature n, FamilyDeclaration n') -> n == n'

191+ -- Special case for TH splices, we look at locations

192+ (Splice, Splice) -> not (separatedByBlank id l_x l_y)

192−-- This looks only at Haddocks, normal comments are handled elsewhere

193+ -- This looks only at Haddocks, normal comments are handled elsewhere

193−groupedDecls DocNext _ = True

194+ (DocNext, _) -> True

194−groupedDecls _ DocPrev = True

195+ (_, DocPrev) -> True

196+ _ -> False

197+

198+-- | Detect declaration series that should not have blanks between them.

199+declSeries ::

200+ LHsDecl GhcPs ->

201+ LHsDecl GhcPs ->

202+ Bool

203+declSeries (L _ x) (L _ y) =

204+ case (x, y) of

205+ ( SigD NoExtField (TypeSig NoExtField _ _),

206+ SigD NoExtField (TypeSig NoExtField _ _)

207+ ) -> True

195−groupedDecls _ _ = False

208+ _ -> False

196

209

197intersects :: Ord a => [a] -> [a] -> Bool

210intersects :: Ord a => [a] -> [a] -> Bool

198intersects a b = go (sort a) (sort b)

211intersects a b = go (sort a) (sort b)

@@ -217,6 +230,11 @@ isPragma = \case

217 WarningPragma n -> Just n

230 WarningPragma n -> Just n

218 _ -> Nothing

231 _ -> Nothing

219

232

233+-- Declarations that do not refer to names

234+

235+pattern Splice :: HsDecl GhcPs

236+pattern Splice <- SpliceD NoExtField (SpliceDecl NoExtField _ _)

237+

220-- Declarations referring to a single name

238-- Declarations referring to a single name

221

239

222pattern

240pattern

@@ -281,9 +299,10 @@ patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc

281patSigRdrNames _ = Nothing

299patSigRdrNames _ = Nothing

282

300

283warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

301warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

284−warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ flip concatMap ws $ \case

302+warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $

303+ flip concatMap ws $ \case

285− L _ (Warning NoExtField ns _) -> map unLoc ns

304+ L _ (Warning NoExtField ns _) -> map unLoc ns

286− L _ (XWarnDecl x) -> noExtCon x

305+ L _ (XWarnDecl x) -> noExtCon x

287warnSigRdrNames _ = Nothing

306warnSigRdrNames _ = Nothing

288

307

289patBindNames :: Pat GhcPs -> [RdrName]

308patBindNames :: Pat GhcPs -> [RdrName]

src/Ormolu/Printer/Meat/Declaration.hs-boot−1

@@ -9,5 +9,4 @@ import Ormolu.Printer.Combinators

9import Ormolu.Printer.Meat.Common

10

11p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

12−

13p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

12p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

src/Ormolu/Printer/Meat/Declaration/Class.hs+2−2

@@ -58,7 +58,7 @@ p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = d

58 switchLayout signatureSpans $

59 p_infixDefHelper

60 (isInfix fixity)

61− inci

61+ True

62 (p_rdrName name)

63 (located' p_hsTyVarBndr <$> hsq_explicit)

64 inci (p_classFundeps fdeps)

@@ -82,7 +82,7 @@ p_classFundeps fdeps = unless (null fdeps) $ do

82 breakpoint

83 txt "|"

84 space

85− sitcc $ sep (comma >> breakpoint) (sitcc . located' p_funDep) fdeps

85+ inci $ sep commaDel (sitcc . located' p_funDep) fdeps

86

87p_funDep :: FunDep (Located RdrName) -> R ()

88p_funDep (before, after) = do

src/Ormolu/Printer/Meat/Declaration/Data.hs+54−29

@@ -41,7 +41,7 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do

41 inci $

42 p_infixDefHelper

43 (isInfix fixity)

44− inci

44+ True

45 (p_rdrName name)

46 (located' p_hsType <$> tpats)

47 case dd_kindSig of

@@ -59,25 +59,37 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do

59 breakpoint

60 txt "where"

61 breakpoint

62− sepSemi (located' p_conDecl) dd_cons

62+ sepSemi (located' (p_conDecl False)) dd_cons

63− else switchLayout (getLoc name : (getLoc <$> dd_cons))

63+ else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do

64− $ inci

64+ let singleConstRec = isSingleConstRec dd_cons

65− $ do

65+ if singleConstRec

66+ then space

67+ else

68+ if hasHaddocks dd_cons

69+ then newline

66− breakpoint

70+ else breakpoint

67− txt "="

71+ equals

68− space

72+ space

73+ layout <- getLayout

69− let s =

74+ let s =

70− vlayout

75+ if layout == MultiLine || hasHaddocks dd_cons

71− (space >> txt "|" >> space)

76+ then newline >> txt "|" >> space

72− (newline >> txt "|" >> space)

77+ else space >> txt "|" >> space

78+ sitcc' =

79+ if singleConstRec

80+ then id

81+ else sitcc

73− sep s (sitcc . located' p_conDecl) dd_cons

82+ sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons

74 unless (null $ unLoc dd_derivs) breakpoint

83 unless (null $ unLoc dd_derivs) breakpoint

75 inci . located dd_derivs $ \xs ->

84 inci . located dd_derivs $ \xs ->

76 sep newline (located' p_hsDerivingClause) xs

85 sep newline (located' p_hsDerivingClause) xs

77p_dataDecl _ _ _ _ (XHsDataDefn x) = noExtCon x

86p_dataDecl _ _ _ _ (XHsDataDefn x) = noExtCon x

78

87

88+p_conDecl ::

89+ Bool ->

79−p_conDecl :: ConDecl GhcPs -> R ()

90+ ConDecl GhcPs ->

91+ R ()

80−p_conDecl = \case

92+p_conDecl singleConstRec = \case

81 ConDeclGADT {..} -> do

93 ConDeclGADT {..} -> do

82 mapM_ (p_hsDocString Pipe True) con_doc

94 mapM_ (p_hsDocString Pipe True) con_doc

83 let conDeclSpn =

95 let conDeclSpn =

@@ -92,11 +104,10 @@ p_conDecl = \case

92 (c : cs) -> do

104 (c : cs) -> do

93 p_rdrName c

105 p_rdrName c

94 unless (null cs) . inci $ do

106 unless (null cs) . inci $ do

95− comma

107+ commaDel

96− breakpoint

97− sitcc $ sep (comma >> breakpoint) p_rdrName cs

108+ sep commaDel p_rdrName cs

98− space

99 inci $ do

109 inci $ do

110+ space

100 txt "::"

111 txt "::"

101 let interArgBreak =

112 let interArgBreak =

102 if hasDocStrings (unLoc con_res_ty)

113 if hasDocStrings (unLoc con_res_ty)

@@ -124,26 +135,27 @@ p_conDecl = \case

124 p_hsType (unLoc con_res_ty)

135 p_hsType (unLoc con_res_ty)

125 ConDeclH98 {..} -> do

136 ConDeclH98 {..} -> do

126 mapM_ (p_hsDocString Pipe True) con_doc

137 mapM_ (p_hsDocString Pipe True) con_doc

127− let conDeclSpn =

138+ let conDeclWithContextSpn =

128− [getLoc con_name]

129− <> [getLoc con_forall]

139+ [getLoc con_forall]

130 <> fmap getLoc con_ex_tvs

140 <> fmap getLoc con_ex_tvs

131 <> maybeToList (fmap getLoc con_mb_cxt)

141 <> maybeToList (fmap getLoc con_mb_cxt)

142+ <> conDeclSpn

143+ conDeclSpn =

132− <> conArgsSpans con_args

144+ getLoc con_name : conArgsSpans con_args

133− switchLayout conDeclSpn $ do

145+ switchLayout conDeclWithContextSpn $ do

134 when (unLoc con_forall) $ do

146 when (unLoc con_forall) $ do

135 p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs

147 p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs

136 breakpoint

148 breakpoint

137 forM_ con_mb_cxt p_lhsContext

149 forM_ con_mb_cxt p_lhsContext

138− case con_args of

150+ switchLayout conDeclSpn $ case con_args of

139 PrefixCon xs -> do

151 PrefixCon xs -> do

140 p_rdrName con_name

152 p_rdrName con_name

141 unless (null xs) breakpoint

153 unless (null xs) breakpoint

142− inci . sitcc $ sep breakpoint (sitcc . located' p_hsType) xs

154+ inci . sitcc $ sep breakpoint (sitcc . located' p_hsTypePostDoc) xs

143 RecCon l -> do

155 RecCon l -> do

144 p_rdrName con_name

156 p_rdrName con_name

145 breakpoint

157 breakpoint

146− inci $ located l p_conDeclFields

158+ inciIf (not singleConstRec) (located l p_conDeclFields)

147 InfixCon x y -> do

159 InfixCon x y -> do

148 located x p_hsType

160 located x p_hsType

149 breakpoint

161 breakpoint

@@ -192,9 +204,9 @@ p_hsDerivingClause HsDerivingClause {..} = do

192 let derivingWhat = located deriv_clause_tys $ \case

204 let derivingWhat = located deriv_clause_tys $ \case

193 [] -> txt "()"

205 [] -> txt "()"

194 xs ->

206 xs ->

195− parens N . sitcc $

207+ parens N $

196 sep

208 sep

197− (comma >> breakpoint)

209+ commaDel

198 (sitcc . located' p_hsType . hsib_body)

210 (sitcc . located' p_hsType . hsib_body)

199 xs

211 xs

200 space

212 space

@@ -234,3 +246,16 @@ isInfix :: LexicalFixity -> Bool

234isInfix = \case

246isInfix = \case

235 Infix -> True

247 Infix -> True

236 Prefix -> False

248 Prefix -> False

249+

250+isSingleConstRec :: [LConDecl GhcPs] -> Bool

251+isSingleConstRec [(L _ ConDeclH98 {..})] =

252+ case con_args of

253+ RecCon _ -> True

254+ _ -> False

255+isSingleConstRec _ = False

256+

257+hasHaddocks :: [LConDecl GhcPs] -> Bool

258+hasHaddocks = any (f . unLoc)

259+ where

260+ f ConDeclH98 {..} = isJust con_doc

261+ f _ = False

src/Ormolu/Printer/Meat/Declaration/Default.hs+2−2

@@ -15,6 +15,6 @@ p_defaultDecl = \case

15 DefaultDecl NoExtField ts -> do

16 txt "default"

17 breakpoint

18− inci . parens N . sitcc $

18+ inci . parens N $

19− sep (comma >> breakpoint) (sitcc . located' p_hsType) ts

19+ sep commaDel (sitcc . located' p_hsType) ts

20 XDefaultDecl x -> noExtCon x

src/Ormolu/Printer/Meat/Declaration/Instance.hs+5−9

@@ -32,9 +32,7 @@ p_standaloneDerivDecl DerivDecl {..} = do

32 txt "instance"

33 breakpoint

34 match_overlap_mode deriv_overlap_mode breakpoint

35− if toIndent

36− then inci typesAfterInstance

37− else typesAfterInstance

35+ inciIf toIndent typesAfterInstance

38 txt "deriving"

36 txt "deriving"

39 space

37 space

40 case deriv_strategy of

38 case deriv_strategy of

@@ -90,12 +88,10 @@ p_clsInstDecl = \case

90 unless (null allDecls) $ do

88 unless (null allDecls) $ do

91 breakpoint

89 breakpoint

92 txt "where"

90 txt "where"

93− unless (null allDecls)

91+ unless (null allDecls) . inci $ do

94− $ inci

95− $ do

96− -- Ensure whitespace is added after where clause.

92+ -- Ensure whitespace is added after where clause.

97− breakpoint

93+ breakpoint

98− dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls

94+ dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls

99 XHsImplicitBndrs x -> noExtCon x

95 XHsImplicitBndrs x -> noExtCon x

100 XClsInstDecl x -> noExtCon x

96 XClsInstDecl x -> noExtCon x

101

97

src/Ormolu/Printer/Meat/Declaration/Rule.hs+2−2

@@ -18,7 +18,7 @@ import Ormolu.Printer.Meat.Type

18p_ruleDecls :: RuleDecls GhcPs -> R ()

19p_ruleDecls = \case

20 HsRules NoExtField _ xs ->

21− pragma "RULES" . sitcc $

21+ pragma "RULES" $

22 sep breakpoint (sitcc . located' p_ruleDecl) xs

23 XRuleDecls x -> noExtCon x

24

@@ -43,7 +43,7 @@ p_ruleDecl = \case

43 inci $ do

44 located lhs p_hsExpr

45 space

46− txt "="

46+ equals

47 inci $ do

48 breakpoint

49 located rhs p_hsExpr

src/Ormolu/Printer/Meat/Declaration/Signature.hs+29−27

@@ -14,7 +14,6 @@ where

14import BasicTypes

15import BooleanFormula

16import Control.Monad

17−import Data.Bool (bool)

18import GHC

17import GHC

19import Ormolu.Printer.Combinators

18import Ormolu.Printer.Combinators

20import Ormolu.Printer.Meat.Common

19import Ormolu.Printer.Meat.Common

@@ -48,24 +47,22 @@ p_typeSig indentTail (n : ns) hswc = do

48 p_rdrName n

47 p_rdrName n

49 if null ns

48 if null ns

50 then p_typeAscription hswc

49 then p_typeAscription hswc

51− else bool id inci indentTail $ do

50+ else inciIf indentTail $ do

52− comma

51+ commaDel

53− breakpoint

54− sep (comma >> breakpoint) p_rdrName ns

52+ sep commaDel p_rdrName ns

55 p_typeAscription hswc

53 p_typeAscription hswc

56

54

57p_typeAscription ::

55p_typeAscription ::

58 LHsSigWcType GhcPs ->

56 LHsSigWcType GhcPs ->

59 R ()

57 R ()

60−p_typeAscription HsWC {..} = do

58+p_typeAscription HsWC {..} = inci $ do

61 space

59 space

62− inci $ do

63− txt "::"

60+ txt "::"

64− let t = hsib_body hswc_body

61+ let t = hsib_body hswc_body

65− if hasDocStrings (unLoc t)

62+ if hasDocStrings (unLoc t)

66− then newline

63+ then newline

67− else breakpoint

64+ else breakpoint

68− located t p_hsType

65+ located t p_hsType

69p_typeAscription (XHsWildCardBndrs x) = noExtCon x

66p_typeAscription (XHsWildCardBndrs x) = noExtCon x

70

67

71p_patSynSig ::

68p_patSynSig ::

@@ -74,7 +71,11 @@ p_patSynSig ::

74 R ()

71 R ()

75p_patSynSig names hsib = do

72p_patSynSig names hsib = do

76 txt "pattern"

73 txt "pattern"

74+ let body =

75+ p_typeSig

76+ False

77+ names

77− let body = p_typeSig False names HsWC {hswc_ext = NoExtField, hswc_body = hsib}

78+ HsWC {hswc_ext = NoExtField, hswc_body = hsib}

78 if length names > 1

79 if length names > 1

79 then breakpoint >> inci body

80 then breakpoint >> inci body

80 else space >> body

81 else space >> body

@@ -103,7 +104,7 @@ p_fixSig = \case

103 space

104 space

104 atom n

105 atom n

105 space

106 space

106− sitcc $ sep (comma >> breakpoint) p_rdrName names

107+ sitcc $ sep commaDel p_rdrName names

107 XFixitySig x -> noExtCon x

108 XFixitySig x -> noExtCon x

108

109

109p_inlineSig ::

110p_inlineSig ::

@@ -142,7 +143,7 @@ p_specSig name ts InlinePragma {..} = pragmaBraces $ do

142 space

143 space

143 txt "::"

144 txt "::"

144 breakpoint

145 breakpoint

145− inci $ sep (comma >> breakpoint) (located' p_hsType . hsib_body) ts

146+ inci $ sep commaDel (located' p_hsType . hsib_body) ts

146

147

147p_inlineSpec :: InlineSpec -> R ()

148p_inlineSpec :: InlineSpec -> R ()

148p_inlineSpec = \case

149p_inlineSpec = \case

@@ -186,13 +187,13 @@ p_booleanFormula = \case

186 And xs ->

187 And xs ->

187 sitcc $

188 sitcc $

188 sep

189 sep

189− (comma >> breakpoint)

190+ commaDel

190 (located' p_booleanFormula)

191 (located' p_booleanFormula)

191 xs

192 xs

192 Or xs ->

193 Or xs ->

193 sitcc $

194 sitcc $

194 sep

195 sep

195− (breakpoint >> txt "| ")

196+ (breakpoint >> txt "|" >> space)

196 (located' p_booleanFormula)

197 (located' p_booleanFormula)

197 xs

198 xs

198 Parens l -> located l (parens N . p_booleanFormula)

199 Parens l -> located l (parens N . p_booleanFormula)

@@ -206,7 +207,7 @@ p_completeSig ::

206p_completeSig cs' mty =

207p_completeSig cs' mty =

207 located cs' $ \cs ->

208 located cs' $ \cs ->

208 pragma "COMPLETE" . inci $ do

209 pragma "COMPLETE" . inci $ do

209− sitcc $ sep (comma >> breakpoint) p_rdrName cs

210+ sep commaDel p_rdrName cs

210 forM_ mty $ \ty -> do

211 forM_ mty $ \ty -> do

211 space

212 space

212 txt "::"

213 txt "::"

@@ -223,12 +224,13 @@ p_sccSig loc literal = pragma "SCC" . inci $ do

223p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()

224p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()

224p_standaloneKindSig (StandaloneKindSig NoExtField name bndrs) = do

225p_standaloneKindSig (StandaloneKindSig NoExtField name bndrs) = do

225 txt "type"

226 txt "type"

227+ inci $ do

226− space

228+ space

227− p_rdrName name

229+ p_rdrName name

228− space

230+ space

229− txt "::"

231+ txt "::"

230− breakpoint

232+ breakpoint

231− inci $ case bndrs of

233+ case bndrs of

232− HsIB NoExtField sig -> located sig p_hsType

234+ HsIB NoExtField sig -> located sig p_hsType

233− XHsImplicitBndrs x -> noExtCon x

235+ XHsImplicitBndrs x -> noExtCon x

234p_standaloneKindSig (XStandaloneKindSig c) = noExtCon c

236p_standaloneKindSig (XStandaloneKindSig c) = noExtCon c

src/Ormolu/Printer/Meat/Declaration/Type.hs+5−3

@@ -28,11 +28,13 @@ p_synDecl name fixity HsQTvs {..} t = do

28 switchLayout (getLoc name : map getLoc hsq_explicit) $

29 p_infixDefHelper

30 (case fixity of Infix -> True; _ -> False)

31− inci

31+ True

32 (p_rdrName name)

33 (map (located' p_hsTyVarBndr) hsq_explicit)

34 space

35− txt "="

35+ equals

36+ if hasDocStrings (unLoc t)

37+ then newline

36− breakpoint

38+ else breakpoint

37 inci (located t p_hsType)

39 inci (located t p_hsType)

38p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x

40p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x

src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+5−5

@@ -31,7 +31,7 @@ p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do

31 switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $

32 p_infixDefHelper

33 (isInfix fdFixity)

34− inci

34+ True

35 (p_rdrName fdLName)

36 (located' p_hsTyVarBndr <$> hsq_explicit)

37 let resultSig = p_familyResultSigL fdResultSig

@@ -69,7 +69,7 @@ p_familyResultSigL l =

69 breakpoint

70 located k p_hsType

71 TyVarSig NoExtField bndr -> Just $ do

72− txt "="

72+ equals

73 breakpoint

74 located bndr p_hsTyVarBndr

75 XFamilyResultSig x ->

@@ -92,16 +92,16 @@ p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do

92 Just bndrs -> do

93 p_forallBndrs ForallInvis p_hsTyVarBndr bndrs

94 breakpoint

95− (if null feqn_bndrs then id else inci) $ do

95+ inciIf (not $ null feqn_bndrs) $ do

96 let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats

97 switchLayout famLhsSpn $

98 p_infixDefHelper

99 (isInfix feqn_fixity)

100− inci

100+ True

101 (p_rdrName feqn_tycon)

102 (located' p_hsType . typeArgToType <$> feqn_pats)

103 space

104− txt "="

104+ equals

105 breakpoint

106 inci (located feqn_rhs p_hsType)

107p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x

src/Ormolu/Printer/Meat/Declaration/Value.hs+210−172

@@ -1,4 +1,5 @@

1{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE MultiWayIf #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TypeApplications #-}

5{-# LANGUAGE TypeApplications #-}

@@ -21,12 +22,12 @@ import Data.Char (isPunctuation, isSymbol)

21import Data.Data hiding (Infix, Prefix)

22import Data.Data hiding (Infix, Prefix)

22import Data.Functor ((<&>))

23import Data.Functor ((<&>))

23import Data.List (intersperse, sortOn)

24import Data.List (intersperse, sortOn)

24−import Data.List.NonEmpty ((<|), NonEmpty ((:|)))

25+import Data.List.NonEmpty (NonEmpty (..), (<|))

25import qualified Data.List.NonEmpty as NE

26import qualified Data.List.NonEmpty as NE

26import Data.Text (Text)

27import Data.Text (Text)

27import qualified Data.Text as Text

28import qualified Data.Text as Text

28import GHC

29import GHC

29−import OccName (mkVarOcc)

30+import OccName (occNameString)

30import Ormolu.Printer.Combinators

31import Ormolu.Printer.Combinators

31import Ormolu.Printer.Internal

32import Ormolu.Printer.Internal

32import Ormolu.Printer.Meat.Common

33import Ormolu.Printer.Meat.Common

@@ -60,7 +61,7 @@ data Placement

60 -- should use it and avoid bumping one level

61 -- should use it and avoid bumping one level

61 -- of indentation

62 -- of indentation

62 Hanging

63 Hanging

63− deriving (Eq)

64+ deriving (Eq, Show)

64

65

65p_valDecl :: HsBindLR GhcPs GhcPs -> R ()

66p_valDecl :: HsBindLR GhcPs GhcPs -> R ()

66p_valDecl = \case

67p_valDecl = \case

@@ -179,25 +180,24 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do

179 NoSrcStrict -> return ()

180 NoSrcStrict -> return ()

180 SrcStrict -> txt "!"

181 SrcStrict -> txt "!"

181 SrcLazy -> txt "~"

182 SrcLazy -> txt "~"

182− inci' <- case NE.nonEmpty m_pats of

183+ indentBody <- case NE.nonEmpty m_pats of

184+ Nothing ->

183− Nothing -> id <$ case style of

185+ False <$ case style of

184− Function name -> p_rdrName name

186+ Function name -> p_rdrName name

185− _ -> return ()

187+ _ -> return ()

186 Just ne_pats -> do

188 Just ne_pats -> do

187− let combinedSpans =

189+ let combinedSpans = case style of

190+ Function name -> combineSrcSpans (getLoc name) patSpans

191+ _ -> patSpans

188− combineSrcSpans' $

192+ patSpans = combineSrcSpans' (getLoc <$> ne_pats)

189− getLoc <$> ne_pats

190− inci' =

191− if isOneLineSpan combinedSpans

193+ indentBody = not (isOneLineSpan combinedSpans)

192− then id

193− else inci

194 switchLayout [combinedSpans] $ do

195 let stdCase = sep breakpoint (located' p_pat) m_pats

196 case style of

197 Function name ->

198 p_infixDefHelper

199 isInfix

200− inci'

200+ indentBody

201 (p_rdrName name)

202 (located' p_pat <$> m_pats)

203 PatternBind -> stdCase

@@ -212,40 +212,32 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do

212 when needsSpace space

213 sitcc stdCase

214 LambdaCase -> stdCase

215− return inci'

215+ return indentBody

216 let -- Calculate position of end of patterns. This is useful when we decide

217 -- about putting certain constructions in hanging positions.

218 endOfPats = case NE.nonEmpty m_pats of

219 Nothing -> case style of

220− Function name -> (Just . srcSpanEnd . getLoc) name

220+ Function name -> Just (getLoc name)

221 _ -> Nothing

222− Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats

222+ Just pats -> (Just . getLoc . NE.last) pats

223 isCase = \case

224 Case -> True

225 LambdaCase -> True

226 _ -> False

227− let hasGuards = withGuards grhssGRHSs

227+ hasGuards = withGuards grhssGRHSs

228− unless (length grhssGRHSs > 1) $

229− case style of

230− Function _ | hasGuards -> return ()

231− Function _ -> space >> txt "="

232− PatternBind -> space >> txt "="

233− s | isCase s && hasGuards -> return ()

234− _ -> space >> txt "->"

235− let grhssSpan =

228+ grhssSpan =

236 combineSrcSpans' $

229 combineSrcSpans' $

237 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs

230 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs

238 patGrhssSpan =

231 patGrhssSpan =

239 maybe

232 maybe

240 grhssSpan

233 grhssSpan

241− (combineSrcSpans grhssSpan . srcLocSpan)

234+ (combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd)

242 endOfPats

235 endOfPats

243 placement =

236 placement =

244 case endOfPats of

237 case endOfPats of

245 Nothing -> blockPlacement placer grhssGRHSs

238 Nothing -> blockPlacement placer grhssGRHSs

246 Just spn ->

239 Just spn ->

247− if isOneLineSpan

248− (mkSrcSpan spn (srcSpanStart grhssSpan))

240+ if onTheSameLine spn grhssSpan

249 then blockPlacement placer grhssGRHSs

241 then blockPlacement placer grhssGRHSs

250 else Normal

242 else Normal

251 p_body = do

243 p_body = do

@@ -261,7 +253,14 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do

261 txt "where"

253 txt "where"

262 unless whereIsEmpty breakpoint

254 unless whereIsEmpty breakpoint

263 inci $ located grhssLocalBinds p_hsLocalBinds

255 inci $ located grhssLocalBinds p_hsLocalBinds

264− inci' $ do

256+ inciIf indentBody $ do

257+ unless (length grhssGRHSs > 1) $

258+ case style of

259+ Function _ | hasGuards -> return ()

260+ Function _ -> space >> inci equals

261+ PatternBind -> space >> inci equals

262+ s | isCase s && hasGuards -> return ()

263+ _ -> space >> txt "->"

265 switchLayout [patGrhssSpan] $

264 switchLayout [patGrhssSpan] $

266 placeHanging placement p_body

265 placeHanging placement p_body

267 inci p_where

266 inci p_where

@@ -285,24 +284,24 @@ p_grhs' placer render style (GRHS NoExtField guards body) =

285 xs -> do

284 xs -> do

286 txt "|"

285 txt "|"

287 space

286 space

288− sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs)

287+ sitcc (sep commaDel (sitcc . located' p_stmt) xs)

289 space

288 space

290− txt $ case style of

289+ inci $ case style of

291− EqualSign -> "="

290+ EqualSign -> equals

292− RightArrow -> "->"

291+ RightArrow -> txt "->"

293 placeHanging placement p_body

292 placeHanging placement p_body

294 where

293 where

295 placement =

294 placement =

296 case endOfGuards of

295 case endOfGuards of

297 Nothing -> placer (unLoc body)

296 Nothing -> placer (unLoc body)

298 Just spn ->

297 Just spn ->

299− if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body)))

298+ if onTheSameLine spn (getLoc body)

300 then placer (unLoc body)

299 then placer (unLoc body)

301 else Normal

300 else Normal

302 endOfGuards =

301 endOfGuards =

303 case NE.nonEmpty guards of

302 case NE.nonEmpty guards of

304 Nothing -> Nothing

303 Nothing -> Nothing

305− Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs

304+ Just gs -> (Just . getLoc . NE.last) gs

306 p_body = located body render

305 p_body = located body render

307p_grhs' _ _ _ (XGRHS x) = noExtCon x

306p_grhs' _ _ _ (XGRHS x) = noExtCon x

308

307

@@ -310,13 +309,14 @@ p_hsCmd :: HsCmd GhcPs -> R ()

310p_hsCmd = \case

309p_hsCmd = \case

311 HsCmdArrApp NoExtField body input arrType _ -> do

310 HsCmdArrApp NoExtField body input arrType _ -> do

312 located body p_hsExpr

311 located body p_hsExpr

313− space

312+ breakpoint

313+ inci $ do

314− case arrType of

314+ case arrType of

315− HsFirstOrderApp -> txt "-<"

315+ HsFirstOrderApp -> txt "-<"

316− HsHigherOrderApp -> txt "-<<"

316+ HsHigherOrderApp -> txt "-<<"

317− placeHanging (exprPlacement (unLoc input)) $

317+ placeHanging (exprPlacement (unLoc input)) $

318− located input p_hsExpr

318+ located input p_hsExpr

319− HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ sitcc $ do

319+ HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ do

320 located form p_hsExpr

321 unless (null cmds) $ do

322 breakpoint

@@ -344,7 +344,7 @@ p_hsCmd = \case

344 txt "do"

345 newline

346 inci . located es $

347− sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))

347+ sitcc . sep newline (sitcc . withSpacing (p_stmt' cmdPlacement p_hsCmd))

348 HsCmdWrap {} -> notImplemented "HsCmdWrap"

349 XCmd x -> noExtCon x

350

@@ -353,6 +353,35 @@ p_hsCmdTop = \case

353 HsCmdTop NoExtField cmd -> located cmd p_hsCmd

354 XCmdTop x -> noExtCon x

355

356+-- | Render an expression preserving blank lines between such consecutive

357+-- expressions found in the original source code.

358+withSpacing ::

359+ -- | Rendering function

360+ (a -> R ()) ->

361+ -- | Entity to render

362+ Located a ->

363+ R ()

364+withSpacing f l = located l $ \x -> do

365+ case getLoc l of

366+ UnhelpfulSpan _ -> f x

367+ RealSrcSpan currentSpn -> do

368+ getSpanMark >>= \case

369+ -- Spacing before comments will be handled by the code

370+ -- that prints comments, so we just have to deal with

371+ -- blank lines between statements here.

372+ Just (StatementSpan lastSpn) ->

373+ if srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1

374+ then newline

375+ else return ()

376+ _ -> return ()

377+ f x

378+ -- In some cases the (f x) expression may insert a new mark. We want

379+ -- to be careful not to override comment marks.

380+ getSpanMark >>= \case

381+ Just (HaddockSpan _ _) -> return ()

382+ Just (CommentSpan _) -> return ()

383+ _ -> setSpanMark (StatementSpan currentSpn)

384+

356p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()

385p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()

357p_stmt = p_stmt' exprPlacement p_hsExpr

386p_stmt = p_stmt' exprPlacement p_hsExpr

358

387

@@ -424,7 +453,7 @@ p_stmt' placer render = \case

424 RecStmt {..} -> do

453 RecStmt {..} -> do

425 txt "rec"

454 txt "rec"

426 space

455 space

427− sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts

456+ sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts

428 XStmtLR c -> noExtCon c

457 XStmtLR c -> noExtCon c

429

458

430gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]

459gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]

@@ -442,34 +471,31 @@ gatherStmtBlock (XParStmtBlock x) = noExtCon x

442p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()

471p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()

443p_hsLocalBinds = \case

472p_hsLocalBinds = \case

444 HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do

473 HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do

445− let ssStart =

446− either

447− (srcSpanStart . getLoc)

448− (srcSpanStart . getLoc)

449− items =

450− (Left <$> bagToList bag) ++ (Right <$> lsigs)

451− p_item (Left x) = located x p_valDecl

452− p_item (Right x) = located x p_sigDecl

453− -- Assigns 'False' to the last element, 'True' to the rest.

454− markInit :: [a] -> [(Bool, a)]

455− markInit [] = []

456− markInit [x] = [(False, x)]

457− markInit (x : xs) = (True, x) : markInit xs

458 -- When in a single-line layout, there is a chance that the inner

474 -- When in a single-line layout, there is a chance that the inner

459 -- elements will also contain semicolons and they will confuse the

475 -- elements will also contain semicolons and they will confuse the

460 -- parser. so we request braces around every element except the last.

476 -- parser. so we request braces around every element except the last.

461 br <- layoutToBraces <$> getLayout

477 br <- layoutToBraces <$> getLayout

462− sitcc $

478+ let items =

463− sepSemi

479+ let injectLeft (L l x) = L l (Left x)

464− (\(m, i) -> (if m then br else id) $ p_item i)

480+ injectRight (L l x) = L l (Right x)

465− (markInit $ sortOn ssStart items)

481+ in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs)

482+ positionToBracing = \case

483+ SinglePos -> id

484+ FirstPos -> br

485+ MiddlePos -> br

486+ LastPos -> id

487+ p_item' (p, item) =

488+ positionToBracing p $

489+ withSpacing (either p_valDecl p_sigDecl) item

490+ binds = sortOn (srcSpanStart . getLoc) items

491+ sitcc $ sepSemi p_item' (attachRelativePos binds)

466 HsValBinds NoExtField _ -> notImplemented "HsValBinds"

492 HsValBinds NoExtField _ -> notImplemented "HsValBinds"

467 HsIPBinds NoExtField (IPBinds NoExtField xs) ->

493 HsIPBinds NoExtField (IPBinds NoExtField xs) ->

468 -- Second argument of IPBind is always Left before type-checking.

494 -- Second argument of IPBind is always Left before type-checking.

469 let p_ipBind (IPBind NoExtField (Left name) expr) = do

495 let p_ipBind (IPBind NoExtField (Left name) expr) = do

470 atom name

496 atom name

471 space

497 space

472− txt "="

498+ equals

473 breakpoint

499 breakpoint

474 useBraces $ inci $ located expr p_hsExpr

500 useBraces $ inci $ located expr p_hsExpr

475 p_ipBind (IPBind NoExtField (Right _) _) =

501 p_ipBind (IPBind NoExtField (Right _) _) =

@@ -488,15 +514,12 @@ p_hsRecField HsRecField {..} = do

488 p_rdrName hsRecFieldLbl

514 p_rdrName hsRecFieldLbl

489 unless hsRecPun $ do

515 unless hsRecPun $ do

490 space

516 space

491− txt "="

517+ equals

518+ let placement =

519+ if onTheSameLine (getLoc hsRecFieldLbl) (getLoc hsRecFieldArg)

492− let placement = exprPlacement (unLoc hsRecFieldArg)

520+ then exprPlacement (unLoc hsRecFieldArg)

521+ else Normal

493− placeHanging placement $ located hsRecFieldArg p_hsExpr

522+ placeHanging placement (located hsRecFieldArg p_hsExpr)

494−

495−p_hsTupArg :: HsTupArg GhcPs -> R ()

496−p_hsTupArg = \case

497− Present NoExtField x -> located x p_hsExpr

498− Missing NoExtField -> pure ()

499− XTupArg x -> noExtCon x

500

523

501p_hsExpr :: HsExpr GhcPs -> R ()

524p_hsExpr :: HsExpr GhcPs -> R ()

502p_hsExpr = p_hsExpr' N

525p_hsExpr = p_hsExpr' N

@@ -561,23 +584,21 @@ p_hsExpr' s = \case

561 -- do-block or case expression it is not a good idea. It seems

584 -- do-block or case expression it is not a good idea. It seems

562 -- to be safe to always bump indentation when the function

585 -- to be safe to always bump indentation when the function

563 -- expression is parenthesised.

586 -- expression is parenthesised.

564− indent =

587+ doIndent =

565 case func of

588 case func of

566− L _ (HsPar NoExtField _) -> inci

589+ L _ (HsPar NoExtField _) -> True

567− L _ (HsAppType NoExtField _ _) -> inci

590+ L _ (HsAppType NoExtField _ _) -> True

568− L _ (HsMultiIf NoExtField _) -> inci

591+ L _ (HsMultiIf NoExtField _) -> True

569− L spn _ ->

570− if isOneLineSpan spn

592+ L spn _ -> isOneLineSpan spn

571− then inci

593+ ub <-

572− else id

573− ub <- getLayout <&> \case

594+ getLayout <&> \case

574− SingleLine -> useBraces

595+ SingleLine -> useBraces

575− MultiLine -> id

596+ MultiLine -> id

576 ub $ do

597 ub $ do

577 located func (p_hsExpr' s)

598 located func (p_hsExpr' s)

578 breakpoint

599 breakpoint

579− indent $ sep breakpoint (located' p_hsExpr) initp

600+ inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp

580− indent $ do

601+ inciIf doIndent $ do

581 unless (null initp) breakpoint

602 unless (null initp) breakpoint

582 located lastp p_hsExpr

603 located lastp p_hsExpr

583 Hanging -> do

604 Hanging -> do

@@ -592,10 +613,15 @@ p_hsExpr' s = \case

592 breakpoint

613 breakpoint

593 inci $ do

614 inci $ do

594 txt "@"

615 txt "@"

616+ -- Insert a space when the type is represented as a TH splice to avoid

617+ -- gluing @ and $ together.

618+ case unLoc (hswc_body a) of

619+ HsSpliceTy {} -> space

620+ _ -> return ()

595 located (hswc_body a) p_hsType

621 located (hswc_body a) p_hsType

596 OpApp NoExtField x op y -> do

622 OpApp NoExtField x op y -> do

597 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)

623 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)

598− p_exprOpTree True s (reassociateOpTree getOpName opTree)

624+ p_exprOpTree s (reassociateOpTree getOpName opTree)

599 NegApp NoExtField e _ -> do

625 NegApp NoExtField e _ -> do

600 txt "-"

626 txt "-"

601 space

627 space

@@ -612,22 +638,27 @@ p_hsExpr' s = \case

612 let isRecordDot' = isRecordDot (unLoc op) (getLoc x)

638 let isRecordDot' = isRecordDot (unLoc op) (getLoc x)

613 unless (useRecordDot' && isRecordDot') breakpoint

639 unless (useRecordDot' && isRecordDot') breakpoint

614 inci (located x p_hsExpr)

640 inci (located x p_hsExpr)

615− ExplicitTuple NoExtField args boxity -> do

641+ ExplicitTuple NoExtField args boxity ->

616 let isSection = any (isMissing . unLoc) args

642 let isSection = any (isMissing . unLoc) args

617 isMissing = \case

643 isMissing = \case

618 Missing NoExtField -> True

644 Missing NoExtField -> True

619 _ -> False

645 _ -> False

646+ p_arg = \case

647+ Present NoExtField x -> located x p_hsExpr

648+ Missing NoExtField -> pure ()

649+ XTupArg x -> noExtCon x

650+ p_larg = sitcc . located' p_arg

620− let parens' =

651+ parens' =

621 case boxity of

652 case boxity of

622 Boxed -> parens

653 Boxed -> parens

623 Unboxed -> parensHash

654 Unboxed -> parensHash

624− if isSection

655+ in if isSection

625− then

656+ then

626− switchLayout [] . parens' s $

657+ switchLayout [] . parens' s $

627− sep comma (located' p_hsTupArg) args

658+ sep comma p_larg args

628− else

659+ else

629− switchLayout (getLoc <$> args) . parens' s . sitcc $

660+ switchLayout (getLoc <$> args) . parens' s $

630− sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args

661+ sep commaDel p_larg args

631 ExplicitSum NoExtField tag arity e ->

662 ExplicitSum NoExtField tag arity e ->

632 p_unboxedSum N tag arity (located e p_hsExpr)

663 p_unboxedSum N tag arity (located e p_hsExpr)

633 HsCase NoExtField e mgroup ->

664 HsCase NoExtField e mgroup ->

@@ -635,8 +666,9 @@ p_hsExpr' s = \case

635 HsIf NoExtField _ if' then' else' ->

666 HsIf NoExtField _ if' then' else' ->

636 p_if exprPlacement p_hsExpr if' then' else'

667 p_if exprPlacement p_hsExpr if' then' else'

637 HsMultiIf NoExtField guards -> do

668 HsMultiIf NoExtField guards -> do

638− txt "if "

669+ txt "if"

670+ breakpoint

639− inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards

671+ inci . inci $ sep newline (located' (p_grhs RightArrow)) guards

640 HsLet NoExtField localBinds e ->

672 HsLet NoExtField localBinds e ->

641 p_let p_hsExpr localBinds e

673 p_let p_hsExpr localBinds e

642 HsDo NoExtField ctx es -> do

674 HsDo NoExtField ctx es -> do

@@ -646,17 +678,17 @@ p_hsExpr' s = \case

646 ub <- layoutToBraces <$> getLayout

678 ub <- layoutToBraces <$> getLayout

647 inci $

679 inci $

648 sepSemi

680 sepSemi

649− (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))

681+ (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))

650 (unLoc es)

682 (unLoc es)

651− compBody = brackets N $ located es $ \xs -> do

683+ compBody = brackets N . located es $ \xs -> do

652 let p_parBody =

684 let p_parBody =

653 sep

685 sep

654− (breakpoint >> txt "| ")

686+ (breakpoint >> txt "|" >> space)

655 p_seqBody

687 p_seqBody

656 p_seqBody =

688 p_seqBody =

657 sitcc

689 sitcc

658 . sep

690 . sep

659− (comma >> breakpoint)

691+ commaDel

660 (located' (sitcc . p_stmt))

692 (located' (sitcc . p_stmt))

661 stmts = init xs

693 stmts = init xs

662 yield = last xs

694 yield = last xs

@@ -677,8 +709,8 @@ p_hsExpr' s = \case

677 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"

709 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"

678 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"

710 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"

679 ExplicitList _ _ xs ->

711 ExplicitList _ _ xs ->

680− brackets s . sitcc $

712+ brackets s $

681− sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs

713+ sep commaDel (sitcc . located' p_hsExpr) xs

682 RecordCon {..} -> do

714 RecordCon {..} -> do

683 located rcon_con_name atom

715 located rcon_con_name atom

684 breakpoint

716 breakpoint

@@ -694,8 +726,8 @@ p_hsExpr' s = \case

694 case rec_dotdot of

726 case rec_dotdot of

695 Just {} -> [txt ".."]

727 Just {} -> [txt ".."]

696 Nothing -> []

728 Nothing -> []

697− inci . braces N . sitcc $

729+ inci . braces N $

698− sep (comma >> breakpoint) sitcc (fields <> dotdot)

730+ sep commaDel sitcc (fields <> dotdot)

699 RecordUpd {..} -> do

731 RecordUpd {..} -> do

700 located rupd_expr p_hsExpr

732 located rupd_expr p_hsExpr

701 useRecordDot' <- useRecordDot

733 useRecordDot' <- useRecordDot

@@ -713,9 +745,9 @@ p_hsExpr' s = \case

713 Unambiguous _ n -> n

745 Unambiguous _ n -> n

714 XAmbiguousFieldOcc x -> noExtCon x

746 XAmbiguousFieldOcc x -> noExtCon x

715 }

747 }

716− inci . braces N . sitcc $

748+ inci . braces N $

717 sep

749 sep

718− (comma >> breakpoint)

750+ commaDel

719 (sitcc . located' (p_hsRecField . updName))

751 (sitcc . located' (p_hsRecField . updName))

720 rupd_flds

752 rupd_flds

721 ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do

753 ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do

@@ -728,22 +760,22 @@ p_hsExpr' s = \case

728 ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x

760 ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x

729 ArithSeq NoExtField _ x ->

761 ArithSeq NoExtField _ x ->

730 case x of

762 case x of

731− From from -> brackets s . sitcc $ do

763+ From from -> brackets s $ do

732 located from p_hsExpr

764 located from p_hsExpr

733 breakpoint

765 breakpoint

734 txt ".."

766 txt ".."

735− FromThen from next -> brackets s . sitcc $ do

767+ FromThen from next -> brackets s $ do

736− sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]

768+ sep commaDel (located' p_hsExpr) [from, next]

737 breakpoint

769 breakpoint

738 txt ".."

770 txt ".."

739− FromTo from to -> brackets s . sitcc $ do

771+ FromTo from to -> brackets s $ do

740 located from p_hsExpr

772 located from p_hsExpr

741 breakpoint

773 breakpoint

742 txt ".."

774 txt ".."

743 space

775 space

744 located to p_hsExpr

776 located to p_hsExpr

745− FromThenTo from next to -> brackets s . sitcc $ do

777+ FromThenTo from next to -> brackets s $ do

746− sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]

778+ sep commaDel (located' p_hsExpr) [from, next]

747 breakpoint

779 breakpoint

748 txt ".."

780 txt ".."

749 space

781 space

@@ -793,7 +825,7 @@ p_patSynBind PSB {..} = do

793 breakpoint

825 breakpoint

794 located psb_def p_pat

826 located psb_def p_pat

795 ImplicitBidirectional -> do

827 ImplicitBidirectional -> do

796− txt "="

828+ equals

797 breakpoint

829 breakpoint

798 located psb_def p_pat

830 located psb_def p_pat

799 ExplicitBidirectional mgroup -> do

831 ExplicitBidirectional mgroup -> do

@@ -820,8 +852,8 @@ p_patSynBind PSB {..} = do

820 inci $ do

852 inci $ do

821 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do

853 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do

822 unless (null xs) breakpoint

854 unless (null xs) breakpoint

823− braces N . sitcc $

855+ braces N $

824− sep (comma >> breakpoint) (p_rdrName . recordPatSynPatVar) xs

856+ sep commaDel (p_rdrName . recordPatSynPatVar) xs

825 rhs

857 rhs

826 InfixCon l r -> do

858 InfixCon l r -> do

827 switchLayout [getLoc l, getLoc r] $ do

859 switchLayout [getLoc l, getLoc r] $ do

@@ -875,10 +907,12 @@ p_if placer render if' then' else' = do

875 breakpoint

907 breakpoint

876 inci $ do

908 inci $ do

877 txt "then"

909 txt "then"

910+ space

878 located then' $ \x ->

911 located then' $ \x ->

879 placeHanging (placer x) (render x)

912 placeHanging (placer x) (render x)

880 breakpoint

913 breakpoint

881 txt "else"

914 txt "else"

915+ space

882 located else' $ \x ->

916 located else' $ \x ->

883 placeHanging (placer x) (render x)

917 placeHanging (placer x) (render x)

884

918

@@ -915,13 +949,13 @@ p_pat = \case

915 txt "!"

949 txt "!"

916 located pat p_pat

950 located pat p_pat

917 ListPat NoExtField pats ->

951 ListPat NoExtField pats ->

918− brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats

952+ brackets S $ sep commaDel (located' p_pat) pats

919 TuplePat NoExtField pats boxing -> do

953 TuplePat NoExtField pats boxing -> do

920− let f =

954+ let parens' =

921 case boxing of

955 case boxing of

922 Boxed -> parens S

956 Boxed -> parens S

923 Unboxed -> parensHash S

957 Unboxed -> parensHash S

924− f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats

958+ parens' $ sep commaDel (sitcc . located' p_pat) pats

925 SumPat NoExtField pat tag arity ->

959 SumPat NoExtField pat tag arity ->

926 p_unboxedSum S tag arity (located pat p_pat)

960 p_unboxedSum S tag arity (located pat p_pat)

927 ConPatIn pat details ->

961 ConPatIn pat details ->

@@ -937,7 +971,7 @@ p_pat = \case

937 let f = \case

971 let f = \case

938 Nothing -> txt ".."

972 Nothing -> txt ".."

939 Just x -> located x p_pat_hsRecField

973 Just x -> located x p_pat_hsRecField

940− inci . braces N . sitcc . sep (comma >> breakpoint) f $

974+ inci . braces N . sep commaDel f $

941 case dotdot of

975 case dotdot of

942 Nothing -> Just <$> fields

976 Nothing -> Just <$> fields

943 Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]

977 Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]

@@ -978,7 +1012,7 @@ p_pat_hsRecField HsRecField {..} = do

978 p_rdrName (rdrNameFieldOcc x)

1012 p_rdrName (rdrNameFieldOcc x)

979 unless hsRecPun $ do

1013 unless hsRecPun $ do

980 space

1014 space

981− txt "="

1015+ equals

982 breakpoint

1016 breakpoint

983 inci (located hsRecFieldArg p_pat)

1017 inci (located hsRecFieldArg p_pat)

984

1018

@@ -987,17 +1021,15 @@ p_unboxedSum s tag arity m = do

987 let before = tag - 1

1021 let before = tag - 1

988 after = arity - before - 1

1022 after = arity - before - 1

989 args = replicate before Nothing <> [Just m] <> replicate after Nothing

1023 args = replicate before Nothing <> [Just m] <> replicate after Nothing

990− f (x, i) = do

1024+ f x =

991− let isFirst = i == 0

992− isLast = i == arity - 1

993 case x :: Maybe (R ()) of

1025 case x :: Maybe (R ()) of

994 Nothing ->

1026 Nothing ->

995− unless (isFirst || isLast) space

1027+ space

996 Just m' -> do

1028 Just m' -> do

997− unless isFirst space

1029+ space

998 m'

1030 m'

999− unless isLast space

1031+ space

1000− parensHash s $ sep (txt "|") f (zip args [0 ..])

1032+ parensHash s $ sep (txt "|") f args

1001

1033

1002p_hsSplice :: HsSplice GhcPs -> R ()

1034p_hsSplice :: HsSplice GhcPs -> R ()

1003p_hsSplice = \case

1035p_hsSplice = \case

@@ -1199,11 +1231,10 @@ exprPlacement = \case

1199 HsCase NoExtField _ _ -> Hanging

1231 HsCase NoExtField _ _ -> Hanging

1200 HsDo NoExtField DoExpr _ -> Hanging

1232 HsDo NoExtField DoExpr _ -> Hanging

1201 HsDo NoExtField MDoExpr _ -> Hanging

1233 HsDo NoExtField MDoExpr _ -> Hanging

1202− -- If the rightmost expression in an operator chain is hanging, make the

1234+ OpApp NoExtField _ op y ->

1203− -- whole block hanging; so that we can use the common @f = foo $ do@

1235+ case (fmap getOpNameStr . getOpName . unLoc) op of

1204− -- style.

1205− OpApp NoExtField _ _ y -> exprPlacement (unLoc y)

1236+ Just "$" -> exprPlacement (unLoc y)

1206− -- Same thing for function applications (usually with -XBlockArguments)

1237+ _ -> Normal

1207 HsApp NoExtField _ y -> exprPlacement (unLoc y)

1238 HsApp NoExtField _ y -> exprPlacement (unLoc y)

1208 HsProc NoExtField p _ ->

1239 HsProc NoExtField p _ ->

1209 -- Indentation breaks if pattern is longer than one line and left

1240 -- Indentation breaks if pattern is longer than one line and left

@@ -1229,15 +1260,16 @@ getOpName = \case

1229 HsVar NoExtField (L _ a) -> Just a

1260 HsVar NoExtField (L _ a) -> Just a

1230 _ -> Nothing

1261 _ -> Nothing

1231

1262

1263+getOpNameStr :: RdrName -> String

1264+getOpNameStr = occNameString . rdrNameOcc

1265+

1232p_exprOpTree ::

1266p_exprOpTree ::

1233− -- | Can use special handling of dollar?

1234− Bool ->

1235 -- | Bracket style to use

1267 -- | Bracket style to use

1236 BracketStyle ->

1268 BracketStyle ->

1237 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->

1269 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->

1238 R ()

1270 R ()

1239−p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)

1271+p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)

1240−p_exprOpTree isDollarSpecial s (OpBranch x op y) = do

1272+p_exprOpTree s (OpBranch x op y) = do

1241 -- If the beginning of the first argument and the second argument are on

1273 -- If the beginning of the first argument and the second argument are on

1242 -- the same line, and the second argument has a hanging form, use hanging

1274 -- the same line, and the second argument has a hanging form, use hanging

1243 -- placement.

1275 -- placement.

@@ -1259,44 +1291,54 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do

1259 MultiLine -> case placement of

1291 MultiLine -> case placement of

1260 Hanging -> useBraces

1292 Hanging -> useBraces

1261 Normal -> dontUseBraces

1293 Normal -> dontUseBraces

1262− gotDollar = case getOpName (unLoc op) of

1294+ opNameStr = (fmap getOpNameStr . getOpName . unLoc) op

1263− Just rname -> mkVarOcc "$" == rdrNameOcc rname

1295+ gotDollar = opNameStr == Just "$"

1264− _ -> False

1296+ gotColon = opNameStr == Just ":"

1297+ gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)

1265 lhs =

1298 lhs =

1266 switchLayout [opTreeLoc x] $

1299 switchLayout [opTreeLoc x] $

1267− p_exprOpTree (not gotDollar) s x

1300+ p_exprOpTree s x

1268− let p_op = located op (opWrapper . p_hsExpr)

1301+ p_op = located op (opWrapper . p_hsExpr)

1269− p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)

1302+ p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)

1270 isSection = case (opTreeLoc x, getLoc op) of

1303 isSection = case (opTreeLoc x, getLoc op) of

1271 (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->

1304 (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->

1272 srcSpanEndCol treeSpan /= srcSpanStartCol opSpan

1305 srcSpanEndCol treeSpan /= srcSpanStartCol opSpan

1273 _ -> False

1306 _ -> False

1307+ isDoBlock = \case

1308+ OpNode (L _ HsDo {}) -> True

1309+ _ -> False

1274 useRecordDot' <- useRecordDot

1310 useRecordDot' <- useRecordDot

1275− let isRecordDot' = isRecordDot (unLoc op) (opTreeLoc y)

1311+ if

1276− if useRecordDot' && isRecordDot'

1312+ | gotColon -> do

1277− then do

1278− lhs

1279− when isSection space

1280− p_op

1281− p_y

1282− else

1283− if isDollarSpecial

1284− && gotDollar

1285− && placement

1286− == Normal

1287− && isOneLineSpan (opTreeLoc x)

1288− then do

1289− useBraces lhs

1313+ lhs

1290− space

1314+ space

1291− p_op

1315+ p_op

1292− breakpoint

1316+ case placement of

1293− inci p_y

1317+ Hanging -> do

1294− else do

1295− ub lhs

1296− placeHanging placement $ do

1297− p_op

1298 space

1318 space

1299 p_y

1319 p_y

1320+ Normal -> do

1321+ breakpoint

1322+ inciIf (isDoBlock y) p_y

1323+ | gotDollar

1324+ && isOneLineSpan (opTreeLoc x)

1325+ && placement == Normal -> do

1326+ useBraces lhs

1327+ space

1328+ p_op

1329+ breakpoint

1330+ inci p_y

1331+ | useRecordDot' && gotRecordDot -> do

1332+ lhs

1333+ when isSection space

1334+ p_op

1335+ p_y

1336+ | otherwise -> do

1337+ ub lhs

1338+ placeHanging placement $ do

1339+ p_op

1340+ space

1341+ p_y

1300

1342

1301-- | Return 'True' if given expression is a record-dot operator expression.

1343-- | Return 'True' if given expression is a record-dot operator expression.

1302isRecordDot ::

1344isRecordDot ::

@@ -1307,14 +1349,10 @@ isRecordDot ::

1307 Bool

1349 Bool

1308isRecordDot op (RealSrcSpan ySpan) = case op of

1350isRecordDot op (RealSrcSpan ySpan) = case op of

1309 HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->

1351 HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->

1310− isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)

1352+ (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)

1311 _ -> False

1353 _ -> False

1312isRecordDot _ _ = False

1354isRecordDot _ _ = False

1313

1355

1314−-- | Check whether a given 'RdrName' is the dot operator.

1315−isDot :: RdrName -> Bool

1316−isDot name = rdrNameOcc name == mkVarOcc "."

1317−

1318-- | Get annotations for the enclosing element.

1356-- | Get annotations for the enclosing element.

1319getEnclosingAnns :: R [AnnKeywordId]

1357getEnclosingAnns :: R [AnnKeywordId]

1320getEnclosingAnns = do

1358getEnclosingAnns = do

src/Ormolu/Printer/Meat/Declaration/Value.hs-boot−4

@@ -11,11 +11,7 @@ import GHC

11import Ormolu.Printer.Combinators

12

13p_valDecl :: HsBindLR GhcPs GhcPs -> R ()

14−

15p_pat :: Pat GhcPs -> R ()

14p_pat :: Pat GhcPs -> R ()

16−

17p_hsExpr :: HsExpr GhcPs -> R ()

15p_hsExpr :: HsExpr GhcPs -> R ()

18−

19p_hsSplice :: HsSplice GhcPs -> R ()

16p_hsSplice :: HsSplice GhcPs -> R ()

20−

21p_stringLit :: String -> R ()

17p_stringLit :: String -> R ()

src/Ormolu/Printer/Meat/Declaration/Warning.hs+5−8

@@ -27,17 +27,14 @@ p_warnDecl (XWarnDecl x) = noExtCon x

27p_moduleWarning :: WarningTxt -> R ()

28p_moduleWarning wtxt = do

29 let (pragmaText, lits) = warningText wtxt

30− switchLayout (getLoc <$> lits)

31− $ inci

32− $ pragma pragmaText (inci $ p_lits lits)

30+ inci $ pragma pragmaText $ inci $ p_lits lits

33

31

34p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()

32p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()

35p_topLevelWarning fnames wtxt = do

33p_topLevelWarning fnames wtxt = do

36 let (pragmaText, lits) = warningText wtxt

34 let (pragmaText, lits) = warningText wtxt

37− switchLayout (fmap getLoc fnames ++ fmap getLoc lits)

35+ switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $

38− $ pragma pragmaText . inci

36+ pragma pragmaText . inci $ do

39− $ do

40− sitcc $ sep (comma >> breakpoint) p_rdrName fnames

37+ sep commaDel p_rdrName fnames

41 breakpoint

38 breakpoint

42 p_lits lits

39 p_lits lits

43

40

@@ -49,4 +46,4 @@ warningText = \case

49p_lits :: [Located StringLiteral] -> R ()

46p_lits :: [Located StringLiteral] -> R ()

50p_lits = \case

47p_lits = \case

51 [l] -> atom l

48 [l] -> atom l

52− ls -> brackets N . sitcc $ sep (comma >> breakpoint) atom ls

49+ ls -> brackets N $ sep commaDel atom ls

src/Ormolu/Printer/Meat/ImportExport.hs+26−20

@@ -13,6 +13,7 @@ import Control.Monad

13import GHC

14import Ormolu.Printer.Combinators

15import Ormolu.Printer.Meat.Common

16+import Ormolu.Utils (RelativePos (..), attachRelativePos)

16

17

17p_hsmodExports :: [LIE GhcPs] -> R ()

18p_hsmodExports :: [LIE GhcPs] -> R ()

18p_hsmodExports [] = do

19p_hsmodExports [] = do

@@ -20,9 +21,12 @@ p_hsmodExports [] = do

20 breakpoint'

21 breakpoint'

21 txt ")"

22 txt ")"

22p_hsmodExports xs =

23p_hsmodExports xs =

23− parens N . sitcc $ do

24+ parens N $ do

24 layout <- getLayout

25 layout <- getLayout

26+ sep

27+ breakpoint

25− sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)

28+ (\(p, l) -> sitcc (located l (p_lie layout p)))

29+ (attachRelativePos xs)

26

30

27p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()

31p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()

28p_hsmodImport useQualifiedPost ImportDecl {..} = do

32p_hsmodImport useQualifiedPost ImportDecl {..} = do

@@ -61,14 +65,17 @@ p_hsmodImport useQualifiedPost ImportDecl {..} = do

61 Nothing -> return ()

65 Nothing -> return ()

62 Just (_, L _ xs) -> do

66 Just (_, L _ xs) -> do

63 breakpoint

67 breakpoint

64− parens N . sitcc $ do

68+ parens N $ do

65 layout <- getLayout

69 layout <- getLayout

70+ sep

71+ breakpoint

66− sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)

72+ (\(p, l) -> sitcc (located l (p_lie layout p)))

73+ (attachRelativePos xs)

67 newline

74 newline

68p_hsmodImport _ (XImportDecl x) = noExtCon x

75p_hsmodImport _ (XImportDecl x) = noExtCon x

69

76

70−p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R ()

77+p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()

71−p_lie encLayout (i, totalItems) = \case

78+p_lie encLayout relativePos = \case

72 IEVar NoExtField l1 -> do

79 IEVar NoExtField l1 -> do

73 located l1 p_ieWrappedName

80 located l1 p_ieWrappedName

74 p_comma

81 p_comma

@@ -86,9 +93,8 @@ p_lie encLayout (i, totalItems) = \case

86 inci $ do

93 inci $ do

87 let names :: [R ()]

94 let names :: [R ()]

88 names = located' p_ieWrappedName <$> xs

95 names = located' p_ieWrappedName <$> xs

89− parens N . sitcc

96+ parens N . sep commaDel sitcc $

90− $ sep (comma >> breakpoint) sitcc

91− $ case w of

97+ case w of

92 NoIEWildcard -> names

98 NoIEWildcard -> names

93 IEWildcard n ->

99 IEWildcard n ->

94 let (before, after) = splitAt n names

100 let (before, after) = splitAt n names

@@ -98,7 +104,11 @@ p_lie encLayout (i, totalItems) = \case

98 located l1 p_hsmodName

104 located l1 p_hsmodName

99 p_comma

105 p_comma

100 IEGroup NoExtField n str -> do

106 IEGroup NoExtField n str -> do

107+ case relativePos of

108+ SinglePos -> return ()

109+ FirstPos -> return ()

110+ MiddlePos -> newline

101− unless (i == 0) newline

111+ LastPos -> newline

102 p_hsDocString (Asterisk n) False (noLoc str)

112 p_hsDocString (Asterisk n) False (noLoc str)

103 IEDoc NoExtField str ->

113 IEDoc NoExtField str ->

104 p_hsDocString Pipe False (noLoc str)

114 p_hsDocString Pipe False (noLoc str)

@@ -107,14 +117,10 @@ p_lie encLayout (i, totalItems) = \case

107 where

117 where

108 p_comma =

118 p_comma =

109 case encLayout of

119 case encLayout of

110− SingleLine -> unless (i + 1 == totalItems) comma

120+ SingleLine ->

121+ case relativePos of

122+ SinglePos -> return ()

123+ FirstPos -> comma

124+ MiddlePos -> comma

125+ LastPos -> return ()

111 MultiLine -> comma

126 MultiLine -> comma

112−

113−-- | Attach positions to 'Located' things in a list.

114−attachPositions ::

115− [Located a] ->

116− [Located ((Int, Int), a)]

117−attachPositions xs =

118− let f i (L l x) = L l ((i, n), x)

119− n = length xs

120− in zipWith f [0 ..] xs

src/Ormolu/Printer/Meat/Module.hs+23−20

@@ -11,8 +11,10 @@ where

11import Control.Monad

12import qualified Data.Text as T

13import GHC

14−import Ormolu.Imports

14+import Ormolu.Imports (normalizeImports)

15+import Ormolu.Parser.CommentStream

15import Ormolu.Parser.Pragma

16import Ormolu.Parser.Pragma

17+import Ormolu.Parser.Shebang

16import Ormolu.Printer.Combinators

18import Ormolu.Printer.Combinators

17import Ormolu.Printer.Comments

19import Ormolu.Printer.Comments

18import Ormolu.Printer.Meat.Common

20import Ormolu.Printer.Meat.Common

@@ -23,28 +25,28 @@ import Ormolu.Printer.Meat.Pragma

23

25

24-- | Render a module.

26-- | Render a module.

25p_hsModule ::

27p_hsModule ::

28+ -- | Stack header

29+ Maybe (RealLocated Comment) ->

26 -- | Shebangs

30 -- | Shebangs

27− [Located String] ->

31+ [Shebang] ->

28− -- | Pragmas

32+ -- | Pragmas and the associated comments

29− [Pragma] ->

33+ [([RealLocated Comment], Pragma)] ->

30 -- | Whether to use postfix qualified imports

34 -- | Whether to use postfix qualified imports

31 Bool ->

35 Bool ->

32 -- | AST to print

36 -- | AST to print

33− ParsedSource ->

37+ HsModule GhcPs ->

34 R ()

38 R ()

35−p_hsModule shebangs pragmas qualifiedPost (L moduleSpan HsModule {..}) = do

39+p_hsModule mstackHeader shebangs pragmas qualifiedPost HsModule {..} = do

36− -- If span of exports in multiline, the whole thing is multiline. This is

37− -- especially important because span of module itself always seems to have

38− -- length zero, so it's not reliable for layout selection.

39− let exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports

40− deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage

40+ let deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage

41− spans' = exportSpans ++ deprecSpan ++ [moduleSpan]

41+ exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports

42− switchLayout spans' $ do

42+ switchLayout (deprecSpan <> exportSpans) $ do

43− forM_ shebangs $ \x ->

43+ forM_ shebangs $ \(Shebang x) ->

44 located x $ \shebang -> do

45 txt (T.pack shebang)

46 newline

47− spitStackHeader

47+ forM_ mstackHeader $ \(L spn comment) -> do

48+ spitCommentNow spn comment

49+ newline

48 newline

50 newline

49 p_pragmas pragmas

51 p_pragmas pragmas

50 newline

52 newline

@@ -54,19 +56,20 @@ p_hsModule shebangs pragmas qualifiedPost (L moduleSpan HsModule {..}) = do

54 located hsmodName' $ \name -> do

56 located hsmodName' $ \name -> do

55 forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)

57 forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)

56 p_hsmodName name

58 p_hsmodName name

59+ breakpoint

57 forM_ hsmodDeprecMessage $ \w -> do

60 forM_ hsmodDeprecMessage $ \w -> do

58− breakpoint

59 located' p_moduleWarning w

61 located' p_moduleWarning w

62+ breakpoint

60 case hsmodExports of

63 case hsmodExports of

61 Nothing -> return ()

64 Nothing -> return ()

62− Just hsmodExports' -> do

65+ Just l -> do

66+ located l $ \exports -> do

67+ inci (p_hsmodExports exports)

63 breakpoint

68 breakpoint

64− inci (p_hsmodExports (unLoc hsmodExports'))

65− breakpoint

66 txt "where"

69 txt "where"

67 newline

70 newline

68 newline

71 newline

69− forM_ (sortImports hsmodImports) (located' (p_hsmodImport qualifiedPost))

72+ forM_ (normalizeImports hsmodImports) (located' (p_hsmodImport qualifiedPost))

70 newline

73 newline

71 switchLayout (getLoc <$> hsmodDecls) $ do

74 switchLayout (getLoc <$> hsmodDecls) $ do

72 p_hsDecls Free hsmodDecls

75 p_hsDecls Free hsmodDecls

src/Ormolu/Printer/Meat/Pragma.hs+22−12

@@ -8,12 +8,16 @@ module Ormolu.Printer.Meat.Pragma

8 )

9where

10

11+import Control.Monad

11import Data.Char (isUpper)

12import Data.Char (isUpper)

13+import qualified Data.List as L

12import Data.Maybe (listToMaybe)

14import Data.Maybe (listToMaybe)

13−import qualified Data.Set as S

14import qualified Data.Text as T

15import qualified Data.Text as T

16+import Ormolu.Parser.CommentStream

15import Ormolu.Parser.Pragma (Pragma (..))

17import Ormolu.Parser.Pragma (Pragma (..))

16import Ormolu.Printer.Combinators

18import Ormolu.Printer.Combinators

19+import Ormolu.Printer.Comments

20+import SrcLoc

17

21

18-- | Pragma classification.

22-- | Pragma classification.

19data PragmaTy

23data PragmaTy

@@ -42,25 +46,31 @@ data LanguagePragmaClass

42 Final

46 Final

43 deriving (Eq, Ord)

47 deriving (Eq, Ord)

44

48

49+-- | Print a collection of 'Pragma's with their associated comments.

45−p_pragmas :: [Pragma] -> R ()

50+p_pragmas :: [([RealLocated Comment], Pragma)] -> R ()

46−p_pragmas ps =

51+p_pragmas ps = do

47− let prepare = concatMap $ \case

52+ let prepare = L.sortOn snd . L.nub . concatMap analyze

53+ analyze = \case

48− PragmaLanguage xs ->

54+ (cs, PragmaLanguage xs) ->

49− let f x = (Language (classifyLanguagePragma x), x)

55+ let f x = (cs, (Language (classifyLanguagePragma x), x))

50 in f <$> xs

56 in f <$> xs

51− PragmaOptionsGHC x -> [(OptionsGHC, x)]

57+ (cs, PragmaOptionsGHC x) -> [(cs, (OptionsGHC, x))]

52− PragmaOptionsHaddock x -> [(OptionsHaddock, x)]

58+ (cs, PragmaOptionsHaddock x) -> [(cs, (OptionsHaddock, x))]

53− in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)

59+ forM_ (prepare ps) $ \(cs, (pragmaTy, x)) ->

60+ p_pragma cs pragmaTy x

54

61

55−p_pragma :: PragmaTy -> String -> R ()

62+p_pragma :: [RealLocated Comment] -> PragmaTy -> String -> R ()

56−p_pragma ty c = do

63+p_pragma comments ty x = do

64+ forM_ comments $ \(L l comment) -> do

65+ spitCommentNow l comment

66+ newline

57 txt "{-# "

67 txt "{-# "

58 txt $ case ty of

68 txt $ case ty of

59 Language _ -> "LANGUAGE"

69 Language _ -> "LANGUAGE"

60 OptionsGHC -> "OPTIONS_GHC"

70 OptionsGHC -> "OPTIONS_GHC"

61 OptionsHaddock -> "OPTIONS_HADDOCK"

71 OptionsHaddock -> "OPTIONS_HADDOCK"

62 space

72 space

63− txt (T.pack c)

73+ txt (T.pack x)

64 txt " #-}"

74 txt " #-}"

65 newline

75 newline

66

76

src/Ormolu/Printer/Meat/Type.hs+48−27

@@ -5,6 +5,7 @@

5-- | Rendering of types.

6module Ormolu.Printer.Meat.Type

7 ( p_hsType,

8+ p_hsTypePostDoc,

8 hasDocStrings,

9 hasDocStrings,

9 p_hsContext,

10 p_hsContext,

10 p_hsTyVarBndr,

11 p_hsTyVarBndr,

@@ -23,14 +24,22 @@ import Ormolu.Printer.Operators

23import Ormolu.Utils

24import Ormolu.Utils

24

25

25p_hsType :: HsType GhcPs -> R ()

26p_hsType :: HsType GhcPs -> R ()

26−p_hsType t = p_hsType' (hasDocStrings t) t

27+p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t

27

28

29+p_hsTypePostDoc :: HsType GhcPs -> R ()

30+p_hsTypePostDoc t = p_hsType' (hasDocStrings t) CaretStyle t

31+

32+-- | How to render Haddocks associated with a type.

33+data TypeDocStyle

34+ = PipeStyle

35+ | CaretStyle

36+

28−p_hsType' :: Bool -> HsType GhcPs -> R ()

37+p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R ()

29−p_hsType' multilineArgs = \case

38+p_hsType' multilineArgs docStyle = \case

30 HsForAllTy NoExtField visibility bndrs t -> do

39 HsForAllTy NoExtField visibility bndrs t -> do

31 p_forallBndrs visibility p_hsTyVarBndr bndrs

40 p_forallBndrs visibility p_hsTyVarBndr bndrs

32 interArgBreak

41 interArgBreak

33− p_hsType' multilineArgs (unLoc t)

42+ p_hsTypeR (unLoc t)

34 HsQualTy NoExtField qs t -> do

43 HsQualTy NoExtField qs t -> do

35 located qs p_hsContext

44 located qs p_hsContext

36 space

45 space

@@ -49,10 +58,20 @@ p_hsType' multilineArgs = \case

49 _ -> return ()

58 _ -> return ()

50 NotPromoted -> return ()

59 NotPromoted -> return ()

51 p_rdrName n

60 p_rdrName n

52− HsAppTy NoExtField f x -> sitcc $ do

61+ HsAppTy NoExtField f x -> do

62+ let -- In order to format type applications with multiple parameters

63+ -- nicer, traverse the AST to gather the function and all the

64+ -- parameters together.

65+ gatherArgs f' knownArgs =

66+ case f' of

67+ L _ (HsAppTy _ l r) -> gatherArgs l (r : knownArgs)

68+ _ -> (f', knownArgs)

69+ (func, args) = gatherArgs f [x]

70+ switchLayout (getLoc f : fmap getLoc args) . sitcc $ do

53− located f p_hsType

71+ located func p_hsType

54− breakpoint

72+ breakpoint

73+ inci $

55− inci (located x p_hsType)

74+ sep breakpoint (located' p_hsType) args

56 HsAppKindTy _ ty kd -> sitcc $ do

75 HsAppKindTy _ ty kd -> sitcc $ do

57 -- The first argument is the location of the "@..." part. Not 100% sure,

76 -- The first argument is the location of the "@..." part. Not 100% sure,

58 -- but I think we can ignore it as long as we use 'located' on both the

77 -- but I think we can ignore it as long as we use 'located' on both the

@@ -79,10 +98,9 @@ p_hsType' multilineArgs = \case

79 HsBoxedTuple -> parens N

98 HsBoxedTuple -> parens N

80 HsConstraintTuple -> parens N

99 HsConstraintTuple -> parens N

81 HsBoxedOrConstraintTuple -> parens N

100 HsBoxedOrConstraintTuple -> parens N

82− in parens' . sitcc $

83− sep (comma >> breakpoint) (sitcc . located' p_hsType) xs

101+ in parens' $ sep commaDel (sitcc . located' p_hsType) xs

84 HsSumTy NoExtField xs ->

102 HsSumTy NoExtField xs ->

85− parensHash N . sitcc $

103+ parensHash N $

86 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs

104 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs

87 HsOpTy NoExtField x op y ->

105 HsOpTy NoExtField x op y ->

88 sitcc $

106 sitcc $

@@ -99,14 +117,20 @@ p_hsType' multilineArgs = \case

99 HsStarTy NoExtField _ -> txt "*"

117 HsStarTy NoExtField _ -> txt "*"

100 HsKindSig NoExtField t k -> sitcc $ do

118 HsKindSig NoExtField t k -> sitcc $ do

101 located t p_hsType

119 located t p_hsType

102− space -- FIXME

103− txt "::"

104 space

120 space

121+ txt "::"

122+ breakpoint

105 inci (located k p_hsType)

123 inci (located k p_hsType)

106 HsSpliceTy NoExtField splice -> p_hsSplice splice

124 HsSpliceTy NoExtField splice -> p_hsSplice splice

107− HsDocTy NoExtField t str -> do

125+ HsDocTy NoExtField t str ->

126+ case docStyle of

127+ PipeStyle -> do

108− p_hsDocString Pipe True str

128+ p_hsDocString Pipe True str

129+ located t p_hsType

130+ CaretStyle -> do

109− located t p_hsType

131+ located t p_hsType

132+ newline

133+ p_hsDocString Caret False str

110 HsBangTy NoExtField (HsSrcBang _ u s) t -> do

134 HsBangTy NoExtField (HsSrcBang _ u s) t -> do

111 case u of

135 case u of

112 SrcUnpack -> txt "{-# UNPACK #-}" >> space

136 SrcUnpack -> txt "{-# UNPACK #-}" >> space

@@ -129,14 +153,14 @@ p_hsType' multilineArgs = \case

129 case (p, xs) of

153 case (p, xs) of

130 (IsPromoted, L _ t : _) | isPromoted t -> space

154 (IsPromoted, L _ t : _) | isPromoted t -> space

131 _ -> return ()

155 _ -> return ()

132− sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs

156+ sep commaDel (sitcc . located' p_hsType) xs

133 HsExplicitTupleTy NoExtField xs -> do

157 HsExplicitTupleTy NoExtField xs -> do

134 txt "'"

158 txt "'"

135 parens N $ do

159 parens N $ do

136 case xs of

160 case xs of

137 L _ t : _ | isPromoted t -> space

161 L _ t : _ | isPromoted t -> space

138 _ -> return ()

162 _ -> return ()

139− sep (comma >> breakpoint) (located' p_hsType) xs

163+ sep commaDel (located' p_hsType) xs

140 HsTyLit NoExtField t ->

164 HsTyLit NoExtField t ->

141 case t of

165 case t of

142 HsStrTy (SourceText s) _ -> p_stringLit s

166 HsStrTy (SourceText s) _ -> p_stringLit s

@@ -146,14 +170,14 @@ p_hsType' multilineArgs = \case

146 where

170 where

147 isPromoted = \case

171 isPromoted = \case

148 HsTyVar _ IsPromoted _ -> True

172 HsTyVar _ IsPromoted _ -> True

149− HsExplicitListTy {} -> True

150 HsExplicitTupleTy {} -> True

173 HsExplicitTupleTy {} -> True

174+ HsExplicitListTy {} -> True

151 _ -> False

175 _ -> False

152 interArgBreak =

176 interArgBreak =

153 if multilineArgs

177 if multilineArgs

154 then newline

178 then newline

155 else breakpoint

179 else breakpoint

156− p_hsTypeR = p_hsType' multilineArgs

180+ p_hsTypeR = p_hsType' multilineArgs docStyle

157

181

158-- | Return 'True' if at least one argument in 'HsType' has a doc string

182-- | Return 'True' if at least one argument in 'HsType' has a doc string

159-- attached to it.

183-- attached to it.

@@ -167,9 +191,7 @@ p_hsContext :: HsContext GhcPs -> R ()

167p_hsContext = \case

191p_hsContext = \case

168 [] -> txt "()"

192 [] -> txt "()"

169 [x] -> located x p_hsType

193 [x] -> located x p_hsType

170− xs ->

171− parens N . sitcc $

172− sep (comma >> breakpoint) (sitcc . located' p_hsType) xs

194+ xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs

173

195

174p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()

196p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()

175p_hsTyVarBndr = \case

197p_hsTyVarBndr = \case

@@ -199,15 +221,14 @@ p_forallBndrs vis p tyvars =

199

221

200p_conDeclFields :: [LConDeclField GhcPs] -> R ()

222p_conDeclFields :: [LConDeclField GhcPs] -> R ()

201p_conDeclFields xs =

223p_conDeclFields xs =

202− braces N . sitcc $

203− sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs

224+ braces N $ sep commaDel (sitcc . located' p_conDeclField) xs

204

225

205p_conDeclField :: ConDeclField GhcPs -> R ()

226p_conDeclField :: ConDeclField GhcPs -> R ()

206p_conDeclField ConDeclField {..} = do

227p_conDeclField ConDeclField {..} = do

207 mapM_ (p_hsDocString Pipe True) cd_fld_doc

228 mapM_ (p_hsDocString Pipe True) cd_fld_doc

208 sitcc $

229 sitcc $

209 sep

230 sep

210− (comma >> breakpoint)

231+ commaDel

211 (located' (p_rdrName . rdrNameFieldOcc))

232 (located' (p_rdrName . rdrNameFieldOcc))

212 cd_fld_names

233 cd_fld_names

213 space

234 space

@@ -249,6 +270,6 @@ tyVarToType = \case

249 -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as

270 -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as

250 -- long as 'tyVarToType' does not get applied to right-hand sides of

271 -- long as 'tyVarToType' does not get applied to right-hand sides of

251 -- declarations.

272 -- declarations.

252− HsParTy NoExtField $ noLoc $

273+ HsParTy NoExtField . noLoc $

253 HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind

274 HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind

254 XTyVarBndr x -> noExtCon x

275 XTyVarBndr x -> noExtCon x

src/Ormolu/Printer/Operators.hs+50−63

@@ -11,11 +11,12 @@ module Ormolu.Printer.Operators

11where

12

13import Data.Function (on)

14−import Data.List

14+import qualified Data.List as L

15+import Data.Map.Strict (Map)

16+import qualified Data.Map.Strict as M

15import Data.Maybe (fromMaybe, mapMaybe)

17import Data.Maybe (fromMaybe, mapMaybe)

16−import Data.Ord (Down (Down), comparing)

17import GHC

18import GHC

18−import OccName (mkVarOcc)

19+import OccName (occNameString)

19import Ormolu.Utils (unSrcSpan)

20import Ormolu.Utils (unSrcSpan)

20

21

21-- | Intermediate representation of operator trees. It has two type

22-- | Intermediate representation of operator trees. It has two type

@@ -56,7 +57,7 @@ reassociateOpTree getOpName opTree =

56reassociateOpTreeWith ::

57reassociateOpTreeWith ::

57 forall ty op.

58 forall ty op.

58 -- | Fixity map for operators

59 -- | Fixity map for operators

59− [(RdrName, Fixity)] ->

60+ Map String Fixity ->

60 -- | How to get the name of an operator

61 -- | How to get the name of an operator

61 (op -> Maybe RdrName) ->

62 (op -> Maybe RdrName) ->

62 -- | Original 'OpTree'

63 -- | Original 'OpTree'

@@ -67,13 +68,13 @@ reassociateOpTreeWith fixityMap getOpName = go

67 where

68 where

68 fixityOf :: op -> Fixity

69 fixityOf :: op -> Fixity

69 fixityOf op = fromMaybe defaultFixity $ do

70 fixityOf op = fromMaybe defaultFixity $ do

70− opName <- getOpName op

71+ s <- occNameString . rdrNameOcc <$> getOpName op

71− lookup opName fixityMap

72+ M.lookup s fixityMap

72 -- Here, left branch is already associated and the root alongside with

73 -- Here, left branch is already associated and the root alongside with

73 -- the right branch is right-associated. This function picks up one item

74 -- the right branch is right-associated. This function picks up one item

74 -- from the right and inserts it correctly to the left.

75 -- from the right and inserts it correctly to the left.

75 --

76 --

76− -- Also, we are using the 'compareFixity' function which returns if the

77+ -- Also, we are using the 'compareFixity' function which tells if the

77 -- expression should associate to right.

78 -- expression should associate to right.

78 go :: OpTree ty op -> OpTree ty op

79 go :: OpTree ty op -> OpTree ty op

79 -- base cases

80 -- base cases

@@ -93,6 +94,16 @@ reassociateOpTreeWith fixityMap getOpName = go

93 then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'

94 then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'

94 else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'

95 else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'

95

96

97+-- | A score assigned to an operator.

98+data Score

99+ = -- | The operator was placed at the beginning of a line

100+ AtBeginning Int

101+ | -- | The operator was placed at the end of a line

102+ AtEnd

103+ | -- | The operator was placed in between arguments on a single line

104+ InBetween

105+ deriving (Eq, Ord)

106+

96-- | Build a map of inferred 'Fixity's from an 'OpTree'.

107-- | Build a map of inferred 'Fixity's from an 'OpTree'.

97buildFixityMap ::

108buildFixityMap ::

98 forall ty op.

109 forall ty op.

@@ -101,23 +112,26 @@ buildFixityMap ::

101 -- | Operator tree

112 -- | Operator tree

102 OpTree (Located ty) (Located op) ->

113 OpTree (Located ty) (Located op) ->

103 -- | Fixity map

114 -- | Fixity map

104− [(RdrName, Fixity)]

115+ Map String Fixity

105buildFixityMap getOpName opTree =

116buildFixityMap getOpName opTree =

117+ addOverrides

118+ . M.fromList

106− concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)

119+ . concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)

107− . zip [0 ..]

120+ . zip [2 ..]

108− . groupBy (doubleWithinEps 0.00001 `on` snd)

121+ . L.groupBy ((==) `on` snd)

109− . (overrides ++)

122+ . selectScores

110− . modeScores

111 $ score opTree

123 $ score opTree

112 where

124 where

113− -- Add a special case for ($), since it is pretty unlikely for someone

125+ addOverrides :: Map String Fixity -> Map String Fixity

114− -- to override it.

126+ addOverrides m =

115− overrides :: [(RdrName, Double)]

127+ M.fromList

116− overrides =

128+ [ ("$", fixity 0 InfixR),

117− [ (mkRdrUnqual $ mkVarOcc "$", -1)

129+ (":", fixity 1 InfixR),

118− ]

130+ (".", fixity 100 InfixL)

119− -- Assign scores to operators based on their location in the source.

131+ ]

132+ `M.union` m

133+ fixity = Fixity NoSourceText

120− score :: OpTree (Located ty) (Located op) -> [(RdrName, Double)]

134+ score :: OpTree (Located ty) (Located op) -> [(String, Score)]

121 score (OpNode _) = []

135 score (OpNode _) = []

122 score (OpBranch l o r) = fromMaybe (score r) $ do

136 score (OpBranch l o r) = fromMaybe (score r) $ do

123 -- If we fail to get any of these, 'defaultFixity' will be used by

137 -- If we fail to get any of these, 'defaultFixity' will be used by

@@ -127,48 +141,27 @@ buildFixityMap getOpName opTree =

127 oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end

141 oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end

128 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin

142 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin

129 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column

143 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column

130− opName <- getOpName (unLoc o)

144+ opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o)

131 let s

145 let s

132− | le < ob =

146+ | le < ob = AtBeginning oc

133− -- if the operator is in the beginning of a line, assign

134− -- a score relative to its column within range [0, 1).

135− fromIntegral oc / fromIntegral (maxCol + 1)

136− | oe < rb =

147+ | oe < rb = AtEnd

137− -- if the operator is in the end of the line, assign the

138− -- score 1.

139− 1

140− | otherwise =

148+ | otherwise = InBetween

141− 2 -- otherwise, assign a high score.

142 return $ (opName, s) : score r

149 return $ (opName, s) : score r

143− -- Pick the most common score per 'RdrName'.

150+ selectScores :: [(String, Score)] -> [(String, Score)]

144− modeScores :: [(RdrName, Double)] -> [(RdrName, Double)]

151+ selectScores =

145− modeScores =

146− sortOn snd

152+ L.sortOn snd

147 . mapMaybe

153 . mapMaybe

148 ( \case

154 ( \case

149 [] -> Nothing

155 [] -> Nothing

150− xs@((n, _) : _) -> Just (n, mode $ map snd xs)

156+ xs@((n, _) : _) -> Just (n, selectScore $ map snd xs)

151 )

157 )

152− . groupBy ((==) `on` fst)

158+ . L.groupBy ((==) `on` fst)

153− . sort

159+ . L.sort

154− -- Return the most common number, leaning to the smaller

160+ selectScore :: [Score] -> Score

155− -- one in case of a tie.

161+ selectScore xs =

156− mode :: [Double] -> Double

162+ case filter (/= InBetween) xs of

157− mode =

163+ [] -> InBetween

158− head

159− . minimumBy (comparing (Down . length))

160− . groupBy (doubleWithinEps 0.0001)

161− . sort

162− -- The start column of the rightmost operator.

163− maxCol = go opTree

164− where

165− go (OpNode (L _ _)) = 0

166− go (OpBranch l (L o _) r) =

167− maximum

164+ xs' -> maximum xs'

168− [ go l,

169− maybe 0 srcSpanStartCol (unSrcSpan o),

170− go r

171− ]

172

165

173----------------------------------------------------------------------------

166----------------------------------------------------------------------------

174-- Helpers

167-- Helpers

@@ -182,9 +175,3 @@ normalizeOpTree (OpBranch (OpNode l) lop r) =

182 OpBranch (OpNode l) lop (normalizeOpTree r)

175 OpBranch (OpNode l) lop (normalizeOpTree r)

183normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =

176normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =

184 normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))

177 normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))

185−

186−fixity :: Int -> FixityDirection -> Fixity

187−fixity = Fixity NoSourceText

188−

189−doubleWithinEps :: Double -> Double -> Double -> Bool

190−doubleWithinEps eps a b = abs (a - b) < eps

src/Ormolu/Processing/Common.hsnew file+27

@@ -0,0 +1,27 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+

3+-- | Common definitions for pre- and post- processing.

4+module Ormolu.Processing.Common

5+ ( OrmoluState (..),

6+ startDisabling,

7+ endDisabling,

8+ )

9+where

10+

11+import Data.String (IsString (..))

12+

13+-- | Ormolu state.

14+data OrmoluState

15+ = -- | Enabled

16+ OrmoluEnabled

17+ | -- | Disabled

18+ OrmoluDisabled

19+ deriving (Eq, Show)

20+

21+-- | Marker for the beginning of the region where Ormolu should be disabled.

22+startDisabling :: IsString s => s

23+startDisabling = "{- ORMOLU_DISABLE_START"

24+

25+-- | Marker for the end of the region where Ormolu should be disabled.

26+endDisabling :: IsString s => s

27+endDisabling = "ORMOLU_DISABLE_END -}"

src/Ormolu/Processing/Cpp.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+

3+-- | Support for CPP.

4+module Ormolu.Processing.Cpp

5+ ( State (..),

6+ processLine,

7+ unmaskLine,

8+ )

9+where

10+

11+import Control.Monad

12+import Data.Char (isSpace)

13+import qualified Data.List as L

14+import Data.Maybe (isJust)

15+import Data.String

16+import Data.Text (Text)

17+import qualified Data.Text as T

18+

19+-- | State of the CPP processor.

20+data State

21+ = -- | Outside of CPP directives

22+ Outside

23+ | -- | In a conditional expression

24+ InConditional

25+ | -- | In a continuation (after @\\@)

26+ InContinuation

27+ deriving (Eq, Show)

28+

29+-- | Automatically mask the line when needed and update the 'State'.

30+processLine :: String -> State -> (String, State)

31+processLine line state

32+ | for "define " = (masked, state')

33+ | for "include " = (masked, state')

34+ | for "undef " = (masked, state')

35+ | for "ifdef " = (masked, InConditional)

36+ | for "ifndef " = (masked, InConditional)

37+ | for "if " = (masked, InConditional)

38+ | for "else" = (masked, InConditional)

39+ | for "elif" = (masked, InConditional)

40+ | for "endif" = (masked, state')

41+ | otherwise =

42+ case state of

43+ Outside -> (line, Outside)

44+ InConditional -> (masked, InConditional)

45+ InContinuation -> (masked, state')

46+ where

47+ for directive = isJust $ do

48+ s <- dropWhile isSpace <$> L.stripPrefix "#" line

49+ void (L.stripPrefix directive s)

50+ masked = maskLine line

51+ state' =

52+ if "\\" `L.isSuffixOf` line

53+ then InContinuation

54+ else Outside

55+

56+-- | Mask the given line.

57+maskLine :: String -> String

58+maskLine x = maskPrefix ++ x

59+

60+-- | If the given line is masked, unmask it. Otherwise return the line

61+-- unchanged.

62+unmaskLine :: Text -> Text

63+unmaskLine x =

64+ case T.stripPrefix maskPrefix (T.stripStart x) of

65+ Nothing -> x

66+ Just x' -> x'

67+

68+-- | Mask prefix for CPP.

69+maskPrefix :: IsString s => s

70+maskPrefix = "-- ORMOLU_CPP_MASK"

src/Ormolu/Processing/Postprocess.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE ViewPatterns #-}

3+

4+-- | Postprocessing for the results of printing.

5+module Ormolu.Processing.Postprocess

6+ ( postprocess,

7+ )

8+where

9+

10+import Data.Text (Text)

11+import qualified Data.Text as T

12+import Ormolu.Processing.Common

13+import qualified Ormolu.Processing.Cpp as Cpp

14+

15+-- | Postprocess output of the formatter.

16+postprocess ::

17+ -- | Desired indentation level

18+ Int ->

19+ -- | Input to process

20+ Text ->

21+ Text

22+postprocess indent =

23+ T.unlines

24+ . fmap indentLine

25+ . fmap Cpp.unmaskLine

26+ . filter (not . magicComment)

27+ . T.lines

28+ where

29+ magicComment (T.stripStart -> x) =

30+ x == startDisabling || x == endDisabling

31+ indentLine x = T.replicate indent " " <> x

src/Ormolu/Processing/Preprocess.hsnew file+149

@@ -0,0 +1,149 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE RecordWildCards #-}

4+

5+-- | Preprocessing for input source code.

6+module Ormolu.Processing.Preprocess

7+ ( preprocess,

8+ )

9+where

10+

11+import Control.Monad

12+import Data.Char (isSpace)

13+import qualified Data.List as L

14+import Data.Maybe (isJust, maybeToList)

15+import FastString

16+import Ormolu.Config (RegionDeltas (..))

17+import Ormolu.Parser.Shebang (isShebang)

18+import Ormolu.Processing.Common

19+import qualified Ormolu.Processing.Cpp as Cpp

20+import SrcLoc

21+

22+-- | Transform given input possibly returning comments extracted from it.

23+-- This handles LINE pragmas, CPP, shebangs, and the magic comments for

24+-- enabling\/disabling of Ormolu.

25+preprocess ::

26+ -- | File name, just to use in the spans

27+ FilePath ->

28+ -- | Input to process

29+ String ->

30+ -- | Region deltas

31+ RegionDeltas ->

32+ -- | Literal prefix, pre-processed input, literal suffix, extra comments

33+ (String, String, String, [Located String])

34+preprocess path input RegionDeltas {..} =

35+ go 1 OrmoluEnabled Cpp.Outside id id regionLines

36+ where

37+ (prefixLines, otherLines) = splitAt regionPrefixLength (lines input)

38+ (regionLines, suffixLines) =

39+ let regionLength = length otherLines - regionSuffixLength

40+ in splitAt regionLength otherLines

41+ go !n ormoluState cppState inputSoFar csSoFar = \case

42+ [] ->

43+ let input' = unlines (inputSoFar [])

44+ in ( unlines prefixLines,

45+ case ormoluState of

46+ OrmoluEnabled -> input'

47+ OrmoluDisabled -> input' ++ endDisabling,

48+ unlines suffixLines,

49+ csSoFar []

50+ )

51+ (x : xs) ->

52+ let (x', ormoluState', cppState', cs) =

53+ processLine path n ormoluState cppState x

54+ in go

55+ (n + 1)

56+ ormoluState'

57+ cppState'

58+ (inputSoFar . (x' :))

59+ (csSoFar . (maybeToList cs ++))

60+ xs

61+

62+-- | Transform a given line possibly returning a comment extracted from it.

63+processLine ::

64+ -- | File name, just to use in the spans

65+ FilePath ->

66+ -- | Line number of this line

67+ Int ->

68+ -- | Whether Ormolu is currently enabled

69+ OrmoluState ->

70+ -- | CPP state

71+ Cpp.State ->

72+ -- | The actual line

73+ String ->

74+ -- | Adjusted line and possibly a comment extracted from it

75+ (String, OrmoluState, Cpp.State, Maybe (Located String))

76+processLine path n ormoluState Cpp.Outside line

77+ | "{-# LINE" `L.isPrefixOf` line =

78+ let (pragma, res) = getPragma line

79+ size = length pragma

80+ ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))

81+ in (res, ormoluState, Cpp.Outside, Just (L ss pragma))

82+ | isOrmoluEnable line =

83+ case ormoluState of

84+ OrmoluEnabled ->

85+ (enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)

86+ OrmoluDisabled ->

87+ (endDisabling ++ enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)

88+ | isOrmoluDisable line =

89+ case ormoluState of

90+ OrmoluEnabled ->

91+ (disableMarker ++ startDisabling, OrmoluDisabled, Cpp.Outside, Nothing)

92+ OrmoluDisabled ->

93+ (disableMarker, OrmoluDisabled, Cpp.Outside, Nothing)

94+ | isShebang line =

95+ let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length line))

96+ in ("", ormoluState, Cpp.Outside, Just (L ss line))

97+ | otherwise =

98+ let (line', cppState') = Cpp.processLine line Cpp.Outside

99+ in (line', ormoluState, cppState', Nothing)

100+ where

101+ mkSrcLoc' = mkSrcLoc (mkFastString path) n

102+processLine _ _ ormoluState cppState line =

103+ let (line', cppState') = Cpp.processLine line cppState

104+ in (line', ormoluState, cppState', Nothing)

105+

106+-- | Take a line pragma and output its replacement (where line pragma is

107+-- replaced with spaces) and the contents of the pragma itself.

108+getPragma ::

109+ -- | Pragma line to analyze

110+ String ->

111+ -- | Contents of the pragma and its replacement line

112+ (String, String)

113+getPragma [] = error "Ormolu.Preprocess.getPragma: input must not be empty"

114+getPragma s@(x : xs)

115+ | "#-}" `L.isPrefixOf` s = ("#-}", " " ++ drop 3 s)

116+ | otherwise =

117+ let (prag, remline) = getPragma xs

118+ in (x : prag, ' ' : remline)

119+

120+-- | Canonical enable marker.

121+enableMarker :: String

122+enableMarker = "{- ORMOLU_ENABLE -}"

123+

124+-- | Canonical disable marker.

125+disableMarker :: String

126+disableMarker = "{- ORMOLU_DISABLE -}"

127+

128+-- | Return 'True' if the given string is an enabling marker.

129+isOrmoluEnable :: String -> Bool

130+isOrmoluEnable = magicComment "ORMOLU_ENABLE"

131+

132+-- | Return 'True' if the given string is a disabling marker.

133+isOrmoluDisable :: String -> Bool

134+isOrmoluDisable = magicComment "ORMOLU_DISABLE"

135+

136+-- | Construct a function for whitespace-insensitive matching of string.

137+magicComment ::

138+ -- | What to expect

139+ String ->

140+ -- | String to test

141+ String ->

142+ -- | Whether or not the two strings watch

143+ Bool

144+magicComment expected s0 = isJust $ do

145+ let trim = dropWhile isSpace

146+ s1 <- trim <$> L.stripPrefix "{-" (trim s0)

147+ s2 <- trim <$> L.stripPrefix expected s1

148+ s3 <- L.stripPrefix "-}" s2

149+ guard (all isSpace s3)

src/Ormolu/Utils.hs+74−15

@@ -1,44 +1,66 @@

1{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE ViewPatterns #-}

3

4

4-- | Random utilities used by the code.

5-- | Random utilities used by the code.

5module Ormolu.Utils

6module Ormolu.Utils

7+ ( RelativePos (..),

8+ attachRelativePos,

6− ( combineSrcSpans',

9+ combineSrcSpans',

7− isModule,

8 notImplemented,

10 notImplemented,

9 showOutputable,

11 showOutputable,

10 splitDocString,

12 splitDocString,

11 typeArgToType,

13 typeArgToType,

12 unSrcSpan,

14 unSrcSpan,

15+ incSpanLine,

13 separatedByBlank,

16 separatedByBlank,

17+ separatedByBlankNE,

18+ onTheSameLine,

19+ removeIndentation,

14 )

20 )

15where

21where

16

22

17−import Data.Data (Data, showConstr, toConstr)

23+import Data.Char (isSpace)

18import Data.List (dropWhileEnd)

24import Data.List (dropWhileEnd)

19−import qualified Data.List.NonEmpty as NE

20import Data.List.NonEmpty (NonEmpty (..))

25import Data.List.NonEmpty (NonEmpty (..))

26+import qualified Data.List.NonEmpty as NE

21import Data.Maybe (fromMaybe)

27import Data.Maybe (fromMaybe)

22import Data.Text (Text)

28import Data.Text (Text)

23import qualified Data.Text as T

29import qualified Data.Text as T

24import GHC

30import GHC

31+import GHC.DynFlags (baseDynFlags)

25import qualified Outputable as GHC

32import qualified Outputable as GHC

26

33

34+-- | Relative positions in a list.

35+data RelativePos

36+ = SinglePos

37+ | FirstPos

38+ | MiddlePos

39+ | LastPos

40+ deriving (Eq, Show)

41+

42+-- | Attach 'RelativePos'es to elements of a given list.

43+attachRelativePos :: [a] -> [(RelativePos, a)]

44+attachRelativePos = \case

45+ [] -> []

46+ [x] -> [(SinglePos, x)]

47+ (x : xs) -> (FirstPos, x) : markLast xs

48+ where

49+ markLast [] = []

50+ markLast [x] = [(LastPos, x)]

51+ markLast (x : xs) = (MiddlePos, x) : markLast xs

52+

27-- | Combine all source spans from the given list.

53-- | Combine all source spans from the given list.

28combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan

54combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan

29combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs

55combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs

30

56

31−-- | Return 'True' if given element of AST is module.

32−isModule :: Data a => a -> Bool

33−isModule x = showConstr (toConstr x) == "HsModule"

34−

35-- | Placeholder for things that are not yet implemented.

57-- | Placeholder for things that are not yet implemented.

36notImplemented :: String -> a

58notImplemented :: String -> a

37notImplemented msg = error $ "not implemented yet: " ++ msg

59notImplemented msg = error $ "not implemented yet: " ++ msg

38

60

39-- | Pretty-print an 'GHC.Outputable' thing.

61-- | Pretty-print an 'GHC.Outputable' thing.

40showOutputable :: GHC.Outputable o => o -> String

62showOutputable :: GHC.Outputable o => o -> String

41−showOutputable = GHC.showSDocUnsafe . GHC.ppr

63+showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr

42

64

43-- | Split and normalize a doc string. The result is a list of lines that

65-- | Split and normalize a doc string. The result is a list of lines that

44-- make up the comment.

66-- make up the comment.

@@ -77,20 +99,57 @@ splitDocString docStr =

77 then dropSpace <$> xs

99 then dropSpace <$> xs

78 else xs

100 else xs

79

101

102+-- | Get 'LHsType' out of 'LHsTypeArg'.

80typeArgToType :: LHsTypeArg p -> LHsType p

103typeArgToType :: LHsTypeArg p -> LHsType p

81typeArgToType = \case

104typeArgToType = \case

82 HsValArg tm -> tm

105 HsValArg tm -> tm

83 HsTypeArg _ ty -> ty

106 HsTypeArg _ ty -> ty

84 HsArgPar _ -> notImplemented "HsArgPar"

107 HsArgPar _ -> notImplemented "HsArgPar"

85

108

109+-- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.

86unSrcSpan :: SrcSpan -> Maybe RealSrcSpan

110unSrcSpan :: SrcSpan -> Maybe RealSrcSpan

111+unSrcSpan = \case

87−unSrcSpan (RealSrcSpan r) = Just r

112+ RealSrcSpan r -> Just r

88−unSrcSpan (UnhelpfulSpan _) = Nothing

113+ UnhelpfulSpan _ -> Nothing

89

114

115+-- | Increment line number in a 'SrcSpan'.

116+incSpanLine :: Int -> SrcSpan -> SrcSpan

117+incSpanLine i = \case

118+ RealSrcSpan s ->

119+ let start = realSrcSpanStart s

120+ end = realSrcSpanEnd s

121+ incLine x =

122+ let file = srcLocFile x

123+ line = srcLocLine x

124+ col = srcLocCol x

125+ in mkRealSrcLoc file (line + i) col

126+ in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end))

127+ UnhelpfulSpan x -> UnhelpfulSpan x

128+

90−-- | Do two declaration groups have a blank between them?

129+-- | Do two declarations have a blank between them?

91−separatedByBlank :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool

130+separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool

92separatedByBlank loc a b =

131separatedByBlank loc a b =

93 fromMaybe False $ do

132 fromMaybe False $ do

94− endA <- srcSpanEndLine <$> unSrcSpan (loc $ NE.last a)

133+ endA <- srcSpanEndLine <$> unSrcSpan (loc a)

95− startB <- srcSpanStartLine <$> unSrcSpan (loc $ NE.head b)

134+ startB <- srcSpanStartLine <$> unSrcSpan (loc b)

96 pure (startB - endA >= 2)

135 pure (startB - endA >= 2)

136+

137+-- | Do two declaration groups have a blank between them?

138+separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool

139+separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b)

140+

141+-- | Return 'True' if one span ends on the same line the second one starts.

142+onTheSameLine :: SrcSpan -> SrcSpan -> Bool

143+onTheSameLine a b =

144+ isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))

145+

146+-- | Remove indentation from a given 'String'. Return the input with

147+-- indentation removed and the detected indentation level.

148+removeIndentation :: String -> (String, Int)

149+removeIndentation (lines -> xs) = (unlines (drop n <$> xs), n)

150+ where

151+ n = minimum (getIndent <$> xs)

152+ getIndent y =

153+ if all isSpace y

154+ then 0

155+ else length (takeWhile isSpace y)

tests/Ormolu/PrinterSpec.hs+4−7

@@ -1,9 +1,6 @@

1{-# LANGUAGE TemplateHaskell #-}

2

3−module Ormolu.PrinterSpec

3+module Ormolu.PrinterSpec (spec) where

4− ( spec,

5− )

6−where

7

4

8import Control.Exception

5import Control.Exception

9import Control.Monad

6import Control.Monad

@@ -65,7 +62,7 @@ deriveOutput path =

65-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.

62-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.

66-- It also prints multi-line snippets in a more readable form.

63-- It also prints multi-line snippets in a more readable form.

67shouldMatch :: Bool -> Text -> Text -> Expectation

64shouldMatch :: Bool -> Text -> Text -> Expectation

68−shouldMatch idempotencyTest actual expected =

65+shouldMatch idempotenceTest actual expected =

69 when (actual /= expected) . expectationFailure $

66 when (actual /= expected) . expectationFailure $

70 unlines

67 unlines

71 [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",

68 [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",

@@ -75,8 +72,8 @@ shouldMatch idempotencyTest actual expected =

75 ]

72 ]

76 where

73 where

77 pass =

74 pass =

78− if idempotencyTest

75+ if idempotenceTest

79− then "idempotency pass"

76+ then "idempotence pass"

80 else "first pass"

77 else "first pass"

81

78

82examplesDir :: Path Rel Dir

79examplesDir :: Path Rel Dir