master..34dc1cb · ormolu

.buildkite/pipeline.ymldeleted−18

since splitsnapshots

unifiedsplit

@@ -1,18 +0,0 @@

1−steps:

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

16− command: |

17− ./format.sh

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

.circleci/config.ymlnew file+49

@@ -0,0 +1,49 @@

1+version: 2

2+

3+jobs:

4+ build:

5+ docker:

6+ - image: nixos/nix:2.1.3

7+ steps:

8+ - checkout

9+ - run:

10+ name: Add ca-certificates

11+ command: |

12+ apk --no-progress update

13+ apk --no-progress add ca-certificates

14+ - run:

15+ name: Setup Cachix

16+ command: |

17+ nix-env -iA cachix -f https://cachix.org/api/v1/install

18+ USER=dummy cachix use tweag

19+ - run:

20+ name: Build environment

21+ command: |

22+ nix-shell --pure --run :

23+ - run:

24+ name: Push Cachix

25+ command: |

26+ if [ -n "$CACHIX_SIGNING_KEY" ];

27+ then nix-store -qR --include-outputs $(nix-instantiate default.nix) | cachix push tweag;

28+ fi

29+ - run:

30+ name: Build the package (includes running the tests)

31+ command: nix-build --keep-going

32+ - run:

33+ name: Check formatting

34+ command: |

35+ ./format.sh

36+ nix-shell -p "(import ./nix/nixpkgs/default.nix).git" --command "git diff --exit-code --color=always"

37+ - run:

38+ name: Generate Haddocks

39+ command: nix-build --attr ormolu.doc

40+ - store_artifacts:

41+ path: result-doc/share/doc

42+ destination: haddock

43+

44+workflows:

45+ version: 2

46+ build:

47+ jobs:

48+ - build:

49+ context: org-global

.github/workflows/binaries.ymldeleted−39

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

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.shdeleted−7

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

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−149

@@ -1,158 +1,9 @@

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−

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

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

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

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

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

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

127

6

128−* Made rendering of pattern matches involving operators consistent with

129− other cases of rendering of operators. [Issue

130− 500](https://github.com/tweag/ormolu/issues/500).

131−

132−* More compact rendering of type family injectivity constraints. [Issue

133− 482](https://github.com/tweag/ormolu/issues/482).

134−

135−* Improved rendering of the keyword `where` in class, data, and type family

136− declarations. When headers of these declarations are multi-line `where` is

137− now put on its own line. [Issue

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

139−

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

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

142−

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

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).

150−

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

152−

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

154− and `StandaloneKindSignatures`.

155−

156## Ormolu 0.0.3.1

7## Ormolu 0.0.3.1

157

8

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

9* 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−* Idempotence property is verified: formatting already formatted code

33+* Idempotency 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 when no CPP is used;

27+* Preserve the meaning of the formatted functions;

28* Make reasonable use of screen space;

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

30* Preserve comments;

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

140

141### CPP

142

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

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

144−meaning of the formatted functions in that case.

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

146−do conditional compilation.

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

147

145

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

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

149

147

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

182```

180```

183

181

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

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

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

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

186−were considered comments:

184+considered comments:

187

185

188```

186```

189−$ ormolu --version

187+$ hindent --version

190−ormolu 0.0.5.0 HEAD fc64eada5c4da7a5b07d2872e253671b48aec115

188+hindent 5.2.7

191−using ghc-lib-parser 8.10.1.20200412

192

189

193−$ ormolu --mode inplace test.hs

190+$ hindent test.hs

194

191

195$ cat test.hs

192$ cat test.hs

196{-# LANGUAGE CPP #-}

193{-# LANGUAGE CPP #-}

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

230extension or mechanism to do conditional compilation, all tools

227extension or mechanism to do conditional compilation, all tools

231will benefit from it.

228will benefit from it.

232

229

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+13−57

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

4[![Hackage](https://img.shields.io/hackage/v/ormolu.svg?style=flat)](https://hackage.haskell.org/package/ormolu)

5[![Stackage Nightly](http://stackage.org/package/ormolu/badge/nightly)](http://stackage.org/nightly/package/ormolu)

6[![Stackage LTS](http://stackage.org/package/ormolu/badge/lts)](http://stackage.org/lts/package/ormolu)

7−[![Build status](https://badge.buildkite.com/8e3b0951f3652b77e1c422b361904136a539b0522029156354.svg?branch=master)](https://buildkite.com/tweag-1/ormolu)

7+[![CircleCI](https://circleci.com/gh/tweag/ormolu/tree/master.svg?style=svg&circle-token=cfd37a39265561eb44e608f97cf953cb2a394c03)](https://circleci.com/gh/tweag/ormolu/tree/master)

8

9Ormolu is a formatter for Haskell source code. The project was created with

10the following goals in mind:

@@ -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 accommodate them.

25+ extensions enter broad use, we may change the style to accomodate 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,12 +45,11 @@ Alternatively, `stack` could be used with a `stack.yaml` file as follows.

45

46```console

47$ cat stack.yaml

48−resolver: lts-16.0

48+resolver: lts-14.3

49packages:

50- '.'

51

52−$ stack build # to build

52+$ stack build

53−$ stack install # to install

54```

53```

55

54

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

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

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

92$ ormolu --mode inplace Module.hs

91$ ormolu --mode inplace Module.hs

93```

92```

94

93

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−

122## Current limitations

94## Current limitations

123

95

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

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

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.

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

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

130 criterion than just being valid Haskell modules.

98 criterion than just being valid Haskell modules.

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

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

132

100

101+## Editor integration

102+

103+We know of the following editor integrations:

104+

105+* [Emacs][emacs-package]

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

107+

133## Running on Hackage

108## Running on Hackage

134

109

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

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

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

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

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

145into Ormolu).

120into Ormolu).

146

121

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−

163## Contributing

122## Contributing

164

123

165See [CONTRIBUTING.md][contributing].

124See [CONTRIBUTING.md][contributing].

@@ -170,12 +129,9 @@ See [LICENSE.md][license].

170

129

172

131

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

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

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

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

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

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

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

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

177[emacs-package]: https://github.com/vyorkin/ormolu.el

136[emacs-package]: https://github.com/vyorkin/ormolu.el

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

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

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

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

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

app/Main.hs+36−48

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

4{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE TypeApplications #-}

6

7−module Main (main) where

7+module Main

8+ ( main,

9+ )

10+where

8

11

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

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

10import Control.Monad

13import Control.Monad

11−import Data.Bool (bool)

12import Data.Either (lefts)

14import Data.Either (lefts)

13import Data.List (intercalate, sort)

15import Data.List (intercalate, sort)

14import qualified Data.Text.IO as TIO

16import qualified Data.Text.IO as TIO

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

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

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

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

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

37 errs <-

39 errs <-

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

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

39 unless (null errs) $ do

41 unless (null errs) $ do

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

40 mapM_ (hPutStrLn stderr . displayException) errs

43 mapM_ (hPutStrLn stderr . displayException) errs

41 exitWith (ExitFailure 102)

44 exitWith (ExitFailure 102)

42

45

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

45 -- | Mode of operation

48 -- | Mode of operation

46 Mode ->

49 Mode ->

47 -- | Configuration

50 -- | Configuration

48− Config RegionIndices ->

51+ Config ->

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

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

50 Maybe FilePath ->

53 Maybe FilePath ->

51 IO ()

54 IO ()

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

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

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

62 exitWith (ExitFailure 101)

65 exitWith (ExitFailure 101)

63 Just inputFile -> do

66 Just inputFile -> do

64− originalInput <- TIO.readFile inputFile

65− formattedInput <- ormoluFile config inputFile

67+ r <- ormoluFile config inputFile

66 case mode of

68 case mode of

67 Stdout ->

69 Stdout ->

68− TIO.putStr formattedInput

70+ TIO.putStr r

69− InPlace -> do

71+ InPlace ->

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) $

74− TIO.writeFile inputFile formattedInput

72+ TIO.writeFile inputFile r

75 Check -> do

73 Check -> do

76− when (formattedInput /= originalInput) $

74+ r' <- TIO.readFile inputFile

75+ when (r /= r') $

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

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

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

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

79 -- 'notImplemented'.

78 -- 'notImplemented'.

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

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

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

83-- Command line options parsing.

82-- Command line options parsing.

84

83

85−data Opts = Opts

84+data 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 RegionIndices),

89+ optConfig :: !Config,

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,25 +139,20 @@ 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− ]

146− <|> (option parseMode . mconcat)

142+ <$> (option parseMode . mconcat)

147− [ long "mode",

143+ [ long "mode",

148− short 'm',

144+ short 'm',

149− metavar "MODE",

145+ metavar "MODE",

150− value Stdout,

146+ value Stdout,

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

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

152− ]

148+ ]

153− )

154 <*> configParser

149 <*> configParser

155 <*> (many . strArgument . mconcat)

150 <*> (many . strArgument . mconcat)

156 [ metavar "FILE",

151 [ metavar "FILE",

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

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

158 ]

153 ]

159

154

160−configParser :: Parser (Config RegionIndices)

155+configParser :: Parser Config

161configParser =

156configParser =

162 Config

157 Config

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

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

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

177 help "Output information useful for debugging"

172 help "Output information useful for debugging"

178 ]

173 ]

179 <*> (switch . mconcat)

174 <*> (switch . mconcat)

180− [ long "check-idempotence",

175+ [ long "tolerate-cpp",

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− )

196

184

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

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

198-- Helpers

186-- Helpers

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

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

18

19data Foo = Foo Int

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

21−

22{- Comment -}

21{- Comment -}

data/examples/declaration/class/dependency-super-classes-out.hs+1−2

@@ -13,8 +13,7 @@ class

13 MonadPlus m -- Potential for failure

14 ) =>

15 MonadParsec e s m

16− | m -> e s

17− where

16+ | m -> e s where

18 -- | 'getState' returns state

17 -- | 'getState' returns state

19 getState ::

18 getState ::

20 m s

19 m s

data/examples/declaration/class/functional-dependencies-out.hs+1−2

@@ -14,6 +14,5 @@ class

14 b c -> a d, -- Bar

15 a c -> b d, -- Baz

16 a c d -> b,

17− a b d -> a b c d

17+ a b d -> a b c d where

18− where

19 baz :: a -> b

18 baz :: a -> b

data/examples/declaration/class/multi-parameters2-out.hs+1−2

@@ -10,8 +10,7 @@ class

10 c -- Baz bar

11 d -- Baz baz

12 e -- Rest

13− f

14− where

13+ f where

15 barbaz ::

14 barbaz ::

16 a -> f

15 a -> f

17 bazbar ::

16 bazbar ::

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

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

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,10 +3,3 @@

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+1−2

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

6 Foo :: Foo Int Int

7 -- | Something else

8 Bar ::

9− Foo

10− Char

9+ Foo Char

11 Char

10 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 = Foo

4+data Foo

5+ = Foo

5− { -- | Something

6+ { -- | Something

6− foo :: Foo Int Int,

7+ foo :: Foo Int Int,

7− -- | Something else

8+ -- | Something else

8− bar ::

9+ bar ::

9− Bar

10− Char

10+ Bar 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/gadt/multiline-where-out.hsdeleted−7

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

1−data

2− Foo

3− a

4− b

5− c

6− where

7− Foo :: a -> b -> c -> Foo a b c

data/examples/declaration/data/gadt/multiline-where.hsdeleted−6

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

1−data

2− Foo

3− a

4− b

5− c where

6− Foo :: a -> b -> c -> Foo a b c

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.hsdeleted−5

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

1−data Optimisation

2− = PETransform

3− | -- | partial eval and associated transforms

4− GeneralisedNatHack

5− deriving (Show, Eq, Generic)

data/examples/declaration/data/partly-documented.hsdeleted−2

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

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

2− deriving (Show, Eq, Generic)

data/examples/declaration/data/record-multi-const-out.hsdeleted−17

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

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.hsdeleted−13

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

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+20−19

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

1module Main where

2

3-- | Something.

4−data Foo = Foo

4+data Foo

5+ = Foo

5− { -- | X

6+ { -- | X

6− fooX :: Int,

7+ fooX :: Int,

7− -- | Y

8+ -- | Y

8− fooY :: Int,

9+ fooY :: Int,

9− -- | BarBaz

10+ -- | BarBaz

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

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

11− -- | GagGog

12+ -- | GagGog

12− fooGag,

13+ fooGag,

13− fooGog ::

14+ fooGog ::

14− NonEmpty

15+ NonEmpty

15− ( Indentity

16+ ( Indentity

16− Bool

17+ Bool

17− ),

18+ ),

18− -- | Huh!

19+ -- | Huh!

19− fooFoo,

20+ fooFoo,

20− barBar ::

21+ barBar ::

21− Int

22+ Int

22− }

23+ }

23 deriving (Eq, Show)

24 deriving (Eq, Show)

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

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

1module Main where

2

3-- | Here we go.

4+data Foo

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

5+ = Foo {unFoo :: Int}

5 deriving (Eq)

6 deriving (Eq)

6

7

7-- | And once again.

8-- | And once again.

data/examples/declaration/data/unnamed-field-comment-0-out.hsdeleted−7

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

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.hsdeleted−5

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

1−data Foo

2− = -- | Bar

3− Bar

4− Field1 -- ^ Field 1

5− Field2 -- ^ Field 2

data/examples/declaration/data/unnamed-field-comment-1-out.hsdeleted−5

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

1−data X

2− = B

3− !Int

4− -- ^ y

5− C

data/examples/declaration/data/unnamed-field-comment-1.hsdeleted−4

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

1−data X

2− = B

3− !Int -- ^ y

4− C

data/examples/declaration/data/with-comment-out.hsdeleted−4

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

1−data A

2− = B -- C

3− | -- D

4− E

data/examples/declaration/data/with-comment.hsdeleted−5

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

1−data A =

2− B -- C

3−

4− -- D

5− | E

data/examples/declaration/data/with-weird-haddock-out.hsdeleted−4

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

1−data PlusLevel' t

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

3− Plus Integer (LevelAtom' t)

4− deriving (Show, Data)

data/examples/declaration/data/with-weird-haddock.hsdeleted−2

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

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

2− deriving (Show, Data)

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

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

3

4data instance Bar Int a where

5 SameBar ::

6− Bar

6+ Bar Int

7− Int

8 Int

7 Int

9 CloseBar :: Bar Int Double

8 CloseBar :: Bar Int Double

10 OtherBar ::

9 OtherBar ::

11− Bar

10+ Bar Int

12− Int

13 a

11 a

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

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

1{-# LANGUAGE GADTSyntax #-}

2{-# LANGUAGE TypeFamilies #-}

3

4−newtype instance Foo [Double] = DoubleListFoo

4+newtype instance Foo [Double]

5+ = DoubleListFoo

5− { unDoubleListFoo :: Double

6+ { unDoubleListFoo :: Double

6− }

7+ }

data/examples/declaration/signature/standalone-kind-out.hsdeleted−13

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

1−{-# LANGUAGE StandaloneKindSignatures #-}

2−

3−type T ::

4− (k -> Type) ->

5− k ->

6− Type

7−data T m a = MkT (m a) (T Maybe (m a))

8−

9−type C1 :: Type -> Constraint

10−class C1 a

11−

12−type F :: Type -> Type

13−type family F

data/examples/declaration/signature/standalone-kind.hsdeleted−13

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

1−{-# LANGUAGE StandaloneKindSignatures #-}

2−

3−type T :: (k -> Type)

4− -> k

5− -> Type

6−

7−data T m a = MkT (m a) (T Maybe (m a))

8−

9−type C1 :: Type -> Constraint

10−class C1 a

11−

12−type F :: Type -> Type

13−type family F

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

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

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

2+

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

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

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

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

2foo = 1

3bar = 2

4

5−a, b, c :: Int

6−a = 1

7−b = 2

8−c = 3

9−

10foo,

5foo,

11 bar,

6 bar,

12 baz ::

7 baz ::

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

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

2foo = 1

3bar = 2

4

5−a, b, c :: Int

6−a = 1

7−b = 2

8−c = 3

9−

10foo,

5foo,

11 bar,

6 bar,

12 baz :: Int

7 baz :: Int

data/examples/declaration/signature/type/unrelated-out.hsdeleted−4

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

1−clientFunc1 :: SomeType1

2−clientFunc2 :: SomeType2

3−clientFunc3 :: SomeType3

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

data/examples/declaration/signature/type/unrelated.hsdeleted−4

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

1−clientFunc1 :: SomeType1

2−clientFunc2 :: SomeType2

3−clientFunc3 :: SomeType3

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

data/examples/declaration/splice/grouped-splices-out.hsdeleted−3

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

1−$(deriveJSON fieldLabelMod ''A)

2−$(deriveJSON fieldLabelMod ''B)

3−$(deriveJSON fieldLabelMod ''C)

data/examples/declaration/splice/grouped-splices.hsdeleted−3

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

1−$(deriveJSON fieldLabelMod ''A)

2−$(deriveJSON fieldLabelMod ''B)

3−$(deriveJSON fieldLabelMod ''C)

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

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

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

16do

17 pure []

18+

data/examples/declaration/type-families/closed-type-family/multi-line-out.hs+5−6

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

1type family

2 Id a =

3− result | result -> a

3+ result

4− where

4+ | result -> a where

5 Id a =

6 a

7

@@ -10,15 +10,14 @@ type family

10 (a :: k)

11 b

12 c =

13− foo | foo -> k b

13+ foo

14− where

14+ | foo -> k b where

15 G a b c =

16 (a, b)

17

18type family

19 F a ::

20− * -> *

21− where

20+ * -> * where

22 F Int = Double

21 F Int = Double

23 F Bool =

22 F Bool =

24 Char

23 Char

data/examples/declaration/type-synonyms/with-weird-haddock-out.hsdeleted−3

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

1−type Elims =

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

3− [Elim]

data/examples/declaration/type-synonyms/with-weird-haddock.hsdeleted−1

@@ -1 +0,0 @@

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

data/examples/declaration/type/visible-forall-out.hsdeleted−2

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

1−-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst

2−data T :: forall k -> k -> Type

data/examples/declaration/type/visible-forall.hsdeleted−2

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

1−-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst

2−data T :: forall k -> k -> Type

data/examples/declaration/value/function/arg-breakpoints-out.hsdeleted−3

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

1−foo

2− bar =

3− body

data/examples/declaration/value/function/arg-breakpoints.hsdeleted−3

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

1−foo

2− bar =

3− body

data/examples/declaration/value/function/arrow/expression-applications-out.hsnew file+9

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

1+{-# LANGUAGE Arrows #-}

2+

3+foo x y = x -< y

4+

5+bar f x =

6+ f x -< -- Hello

7+ x -- World

8+

9+baz x y = x -<< y

data/examples/declaration/value/function/arrow/expression-applications.hsnew file+9

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

1+{-# LANGUAGE Arrows #-}

2+

3+foo x y = x -< y

4+

5+bar f x

6+ = f x -- Hello

7+ -< x -- World

8+

9+baz x y = x -<< y

data/examples/declaration/value/function/arrow/expression-forms-out.hsnew file+14

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

1+{-# LANGUAGE Arrows #-}

2+

3+foo f g x y = (| test (f -< x) (g -< y) |)

4+

5+bar f g x y =

6+ (|

7+ test

8+ ( f -<

9+ x

10+ )

11+ ( g -<

12+ y

13+ )

14+ |)

data/examples/declaration/value/function/arrow/expression-forms.hsnew file+11

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

1+{-# LANGUAGE Arrows #-}

2+

3+foo f g x y = (| test (f -< x) (g -< y) |)

4+

5+bar f g x y = (|

6+ test

7+ (f

8+ -< x)

9+ (g

10+ -< y)

11+ |)

data/examples/declaration/value/function/arrow/multiline-case-out.hsdeleted−8

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

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.hsdeleted−7

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

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+5−6

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

9 w

10 )

11 ->

12− f -- The value

12+ f -< -- The value

13− -<

14− ( x, -- Foo

13+ ( x, -- Foo

15− w, -- Bar

14+ w, -- Bar

16− z -- Baz

15+ z -- Baz

17− )

16+ )

18

17

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

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

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

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

19 )

20 ( b,

21 d

22+ ) -<

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

24+ d * b

22 )

25 )

23− -<

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

25− d * b

26− )

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

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

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

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

29 Left

28 Left

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

33 let v =

32 let v =

34 u -- Actually never used

33 u -- Actually never used

35 ^ 2

34 ^ 2

36− in ( returnA

35+ in ( returnA -<

37− -<

38− -- Just do the calculation

36+ -- Just do the calculation

39− (x + y * z)

37+ (x + y * z)

40 )

38 )

41 else do

39 else do

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

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

43− -- Could pattern match directly on x

41+ -- Could pattern match directly on x

44 i <- case u of

42 i <- case u of

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

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

46 n ->

44 n ->

47− ( ( h . g

45+ ( ( h . g -<

48− -<

49− y -- First actual use of y

46+ y -- First actual use of y

50 )

47 )

51 )

48 )

52 returnA -< ()

49 returnA -< ()

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

54 if i > 0

51 if i > 0

55 then ma -< ()

52 then ma -< ()

56 else returnA -< ()

53 else returnA -< ()

57− returnA

54+ returnA -<

58− -<

59− ( i

55+ ( i

60− + x

56+ + x

61− * y -- Just do the calculation

57+ * y -- Just do the calculation

62− )

58+ )

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

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

13

14bazbar f = proc a -> do

15 a <-

16− f

16+ f -<

17− -<

18− a

17+ a

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

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

11 z <-

12 h

13 x

14− y

14+ y -<

15− -<

16− ( a,

15+ ( a,

17− b,

16+ b,

18− c

17+ c

19− )

18+ )

20− returnA

19+ returnA -<

21− -<

22− (x, y, z)

20+ (x, y, z)

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

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

7 (|

8 test

9 ( h f

10− . h g

10+ . h g -<

11− -<

12− y x

11+ y x

13− . y z

12+ . y z

14 )

13 )

15 ( h g

14 ( h g

16− . h f

15+ . h f -<

17− -<

18− y z

16+ y z

19− . y x

17+ . y x

20 )

18 )

21 |)

19 |)

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

@@ -4,19 +4,15 @@ bar0 f g h x =

4 proc (y, z) ->

5 (| test (h f . (h g) -< (y x) . y z) ((h g) . h f -< y z . (y x)) |)

6

7−bar1 f g x y = proc _ -> (f -< x) &&& (g -< y)

7+bar1 f g x y = proc _ -> f -< x &&& g -< y

8

9bar2 f g h x =

10 proc (y, z) ->

11− (h f . (h g) -< (y x) . y z) ||| ((h g) . h f -< y z . (y x))

11+ h f . (h g) -< (y x) . y z ||| (h g) . h f -< y z . (y x)

12

13bar3 f g h x =

14 proc (y, z) ->

15− ( (h f . h g)

15+ (h f . h g) -<

16− -<

17− (y x) . y z

16+ (y x) . y z

18− ) |||

19− ( (h g . h f)

17+ ||| (h g . h f) -<

20− -<

21− y z . (y x)

18+ y z . (y x)

22− )

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

@@ -4,16 +4,16 @@ bar0 f g h x =

4 proc (y, z) ->

5 (| test (h f.(h g) -< (y x).y z)((h g) . h f-<y z . (y x)) |)

6

7−bar1 f g x y = proc _ -> (f -< x)&&&(g -< y)

7+bar1 f g x y = proc _ -> f -< x&&&g -< y

8

9bar2 f g h x =

10 proc (y, z) ->

11− (h f.(h g) -< (y x).y z) ||| ((h g) . h f-<y z . (y x))

11+ h f.(h g) -< (y x).y z ||| (h g) . h f-<y z . (y x)

12

13bar3 f g h x =

14 proc (y, z) ->

15− ((h f.h g)

15+ (h f.h g)

16− -< (y x).y z)

16+ -< (y x).y z

17 |||

18− ((h g . h f)

18+ (h g . h f)

19− -<y z . (y x))

19+ -<y z . (y x)

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

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

6 if f a

7 then

8 f

9− . g

9+ . g -<

10− -<

11− a

10+ a

12 else

11 else

13− g

12+ g -<

14− -<

15− b

13+ b

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

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

6 ( ( (f)

7 ( g

8 )

9− )

9+ ) -<

10− -<

11− ( ( ( ( ( ( g

10+ ( ( ( ( ( ( g

12− a

11+ a

13− )

14 )

12 )

15 )

13 )

16 )

14 )

17 )

15 )

18 )

16 )

17+ )

19 )

18 )

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

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

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

4 rec a <- f y -< x

5 b <-

6− g x

6+ g x -<

7− -<

8− y

7+ y

9− bar

8+ bar -<

10− -<

11− ( a,

9+ ( a,

12− b

10+ b

13− )

11+ )

14 rec p <-

12 rec p <-

15 f

13 f

16− p

14+ p -<

17− -<

18− a

15+ a

19 rec q <-

16 rec q <-

20 g

17 g

21− q

18+ q -<

22− -<

23− b

19+ b

data/examples/declaration/value/function/awkward-comment-0-out.hsdeleted−6

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

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.hsdeleted−5

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

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.hsdeleted−9

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

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.hsdeleted−7

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

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.hsdeleted−6

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

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.hsdeleted−9

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

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.hsdeleted−6

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

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.hsdeleted−7

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

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,5 +15,4 @@ readInClause = do

15 <|> do

16 optional g_Semi

17 void allspacing

18−

19 return things

18 return things

data/examples/declaration/value/function/do/comment-alignment-out.hsdeleted−9

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

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.hsdeleted−9

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

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.hsdeleted−7

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

1−foo = do

2− bar

3− -- foo

4− baz

5−

6− -- foo

7− quux

data/examples/declaration/value/function/do/comment-spacing.hsdeleted−7

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

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,18 +2,13 @@

2

3foo = do

4 rec a <- b + 5

5−

6 let d = c

5 let d = c

7−

8 b <- a * 5

6 b <- a * 5

9−

10 something

7 something

11−

12 c <- a + b

8 c <- a + b

13 print c

9 print c

14 rec something $ do

10 rec something $ do

15 x <- a

11 x <- a

16 print x

12 print x

17−

18 y <- c

13 y <- c

19 print y

14 print y

data/examples/declaration/value/function/if-with-comment-out.hsdeleted−8

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

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.hsdeleted−8

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

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,7 +1,6 @@

1{-# LANGUAGE ImplicitParams #-}

2

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

4−sortBy = undefined

5

4

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

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

7sort = sortBy ?cmp

6sort = sortBy ?cmp

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

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

1{-# LANGUAGE ImplicitParams #-}

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

3

4−sortBy = undefined

5−

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

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

7sort = sortBy ?cmp

5sort = sortBy ?cmp

8

6

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+3−4

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

17 `catch` \case

18 a -> a

19

20−foo =

20+foo = bar

21− bar

22− ++ case foo of

21+ ++ case foo of

23− a -> a

22+ a -> a

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

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

1lenses =

2− Just $

3− M.fromList $

2+ Just $ M.fromList $

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

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

5− # "connection" .= uc

4+ # "connection" .= uc

6− # "user" .= case name of

5+ # "user" .= case name of

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

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

8− Nothing -> Nothing

7+ Nothing -> Nothing

9− # []

8+ # []

10

9

11foo =

10foo =

12 a

11 a

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

@@ -5,6 +5,7 @@ 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+

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

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

9

10

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

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

data/examples/declaration/value/function/list-notation-0-out.hsdeleted−5

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

1−foo =

2− testCase "Foo" testFoo :

3− testCase "Bar" testBar :

4− testCase "Baz" testBaz :

5− []

data/examples/declaration/value/function/list-notation-0.hsdeleted−5

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

1−foo =

2− testCase "Foo" testFoo :

3− testCase "Bar" testBar :

4− testCase "Baz" testBaz :

5− []

data/examples/declaration/value/function/list-notation-1-out.hsdeleted−8

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

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.hsdeleted−7

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

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.hsdeleted−6

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

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.hsdeleted−5

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

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.hsdeleted−12

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

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.hsdeleted−10

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

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+2−4

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

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

4

5bar x y =

6− if

7− | x > y -> x

6+ if | x > y -> x

8 | x < y ->

7 | x < y ->

9 y

8 y

10 | otherwise -> x

9 | otherwise -> x

11

10

12baz =

11baz =

13− if

12+ if | p -> f

14− | p -> f

15 | otherwise -> g

13 | otherwise -> g

16 x

14 x

data/examples/declaration/value/function/operator-comments-2-out.hsdeleted−5

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

1−x =

2− y

3− ++ f g -- commentA

4− -- commentB

5− -- commentC

data/examples/declaration/value/function/operator-comments-2.hsdeleted−4

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

1−x =

2− y ++ -- commentA

3−-- commentB

4− f g -- commentC

data/examples/declaration/value/function/operators-1-out.hsdeleted−4

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

1−foo =

2− f

3− . g

4− =<< h . i

data/examples/declaration/value/function/operators-1.hsdeleted−3

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

1−foo = f

2− . g

3− =<< h . i

data/examples/declaration/value/function/operators-2-out.hsdeleted−4

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

1−foo n

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

3− || x && n =

4− 42

data/examples/declaration/value/function/operators-2.hsdeleted−4

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

1−foo n

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

3− || x && n =

4− 42

data/examples/declaration/value/function/operators-3-out.hsdeleted−3

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

1−foo =

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

3− <+> prettySe <> text sc

data/examples/declaration/value/function/operators-3.hsdeleted−3

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

1−foo =

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

3− prettySe <> text sc

data/examples/declaration/value/function/operators-4-out.hsdeleted−3

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

1−foo =

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

3− <+> align <> prettyPs

data/examples/declaration/value/function/operators-4.hsdeleted−3

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

1−foo =

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

3− align <> prettyPs

data/examples/declaration/value/function/operators-5-out.hsdeleted−5

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

1−foo =

2− map bar $

3− [ baz

4− ]

5− ++ quux

data/examples/declaration/value/function/operators-5.hsdeleted−4

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

1−foo =

2− map bar $

3− [ baz

4− ] ++ quux

data/examples/declaration/value/function/operators-6-out.hsdeleted−9

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

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.hsdeleted−7

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

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/operators-0-out.hs → data/examples/declaration/value/function/operators-out.hsrenamed

The content is the same.

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

The content is the same.

data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs+8−8

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

1−( getNodeSettingsR

1+( getNodeSettingsR :<|>

2− :<|> getNodeInfoR

2+ getNodeInfoR :<|>

3− :<|> getNextUpdateR

3+ getNextUpdateR :<|>

4− :<|> restartNodeR

4+ restartNodeR

5− )

5+ ) :<|>

6− :<|> ( getUtxoR

6+ ( getUtxoR :<|>

7− :<|> getConfirmedProposalsR

7+ getConfirmedProposalsR

8− ) = client nodeV1Api

8+ ) = client nodeV1Api

data/examples/declaration/value/function/pattern/multiline-case-pattern-out.hs+2−2

@@ -10,6 +10,6 @@ f xs = case xs of

10 ] -> a + b

11

12g xs = case xs of

13− ( a

13+ ( a :

14− : bs

14+ bs

15 ) -> a + b

data/examples/declaration/value/function/pattern/view-pattern-out.hs+3

@@ -13,3 +13,6 @@ multiline

13 bar

14 baz

15 ) = True

16+

17+-- https://github.com/tweag/ormolu/issues/343

18+foo = (f -> 4)

data/examples/declaration/value/function/pattern/view-pattern.hs+3

@@ -10,3 +10,6 @@ g ((f, _), f -> 4) = True

10multiline (t -> Foo

11 bar

12 baz) = True

13+

14+-- https://github.com/tweag/ormolu/issues/343

15+foo = (f -> 4)

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/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/record/hanging-after-equal-con-out.hsdeleted−8

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

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.hsdeleted−7

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

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.hsdeleted−8

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

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.hsdeleted−7

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

1−foo = foo

2− { foo =

3− -- Blah blah

4− case x of

5− Blah -> 1

6− Blim -> 2

7− }

data/examples/declaration/value/function/type-applications-and-splice-out.hsdeleted−4

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

1−{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE TypeApplications #-}

3−

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

data/examples/declaration/value/function/type-applications-and-splice.hsdeleted−4

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

1−{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE TypeApplications #-}

3−

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

data/examples/import/deduplication-bug-out.hsdeleted−6

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

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.hsdeleted−6

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

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+ (>>>),

2− ( Either,

4+ Either,

3 Maybe (Just, Nothing),

5 Maybe (Just, Nothing),

4 MaybeT (..),

6 MaybeT (..),

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

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

6 MonadBaseControl,

8 MonadBaseControl,

7 join,

9 join,

8 liftIO,

10 liftIO,

9 void,

11 void,

10− (<<<),

11− (>>>),

12 )

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

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

1import qualified MegaModule as M

2 ( -- (1)

3− -- (2)

4− Either, -- (3)

5− (<<<),

3+ (<<<), -- (2)

6 (>>>),

4 (>>>),

5+ Either, -- (3)

7 )

6 )

data/examples/import/merging-0-out.hsdeleted−3

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

1−import Foo

2−import Foo (bar, foo)

3−import Foo as F

data/examples/import/merging-0.hsdeleted−4

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

1−import Foo

2−import Foo (foo)

3−import Foo (bar)

4−import Foo as F

data/examples/import/merging-1-out.hsdeleted−2

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

1−import "bar" Foo (bar)

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

data/examples/import/merging-1.hsdeleted−3

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

1−import "foo" Foo (foo)

2−import "bar" Foo (bar)

3−import "foo" Foo (baz)

data/examples/import/merging-2-out.hsdeleted−2

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

1−import Foo hiding (bar4, foo2)

2−import qualified Foo (bar3, foo1)

data/examples/import/merging-2.hsdeleted−4

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

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,5 +1,11 @@

1import A hiding

2 ( foobarbazqux,

3+ foobarbazqux,

4+ foobarbazqux,

5+ foobarbazqux,

6+ foobarbazqux,

7+ foobarbazqux,

8+ foobarbazqux,

3 )

9 )

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

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

5import Name hiding ()

11import Name hiding ()

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

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

1import qualified MegaModule as M

2+ ( (<<<),

3+ (>>>),

2− ( Either,

4+ Either,

3 Monad

5 Monad

4− ( return,

5− (>>),

6+ ( (>>),

6− (>>=)

7+ (>>=),

8+ return

7 ),

9 ),

8− (<<<),

9− (>>>),

10 )

data/examples/import/qualified-post-out.hsdeleted−5

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

1−{-# LANGUAGE ImportQualifiedPost #-}

2−

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

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

5−import Data.Text qualified as T

data/examples/import/qualified-post.hsdeleted−5

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

1−{-# LANGUAGE ImportQualifiedPost #-}

2−

3−import qualified Data.Text as T

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

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

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

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

1module P where

2

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

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

4import qualified Prelude

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

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

1import Data.Text

2+import Data.Text

3+import qualified Data.Text as T

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

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

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

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

6import 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,5 +4,3 @@ 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.hsdeleted−1

@@ -1 +0,0 @@

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

data/examples/import/sorted-export-list.hsdeleted−1

@@ -1 +0,0 @@

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

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

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

1{-# LANGUAGE PatternSynonyms #-}

2

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

3+module ExportSyntax

4+ ( A (.., NoA),

5+ Q (F, ..),

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

7+ )

8+where

4

9

5data A = A | B

10data A = A | B

6

11

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+4−1

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

3-}

4

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

6−module Main (main) where

6+module Main

7+ ( main,

8+ )

9+where

7

10

8main = return ()

11main = return ()

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

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

1-- | This demonstrates a BUG.

2−module Foo () where

2+module Foo

3+ (

4+ )

5+where

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

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

3{-# LANGUAGE OverloadedStrings #-}

4

5main = return ()

6−

7-- stack runhaskell

6-- stack runhaskell

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

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

4{-# LANGUAGE OverloadedStrings #-}

5

6main = return ()

7−

8-- stack runhaskell

7-- stack runhaskell

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

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

1module Test

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

3− (foo, bar, baz)

3+ ( foo,

4+ bar,

5+ baz,

6+ )

4where

7where

5

8

6import Blah

9import Blah

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

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

1module Test

2− {-# WARNING

3− "This module is very internal"

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

4− #-}

5where

3where

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

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

9 -- | Foo

10 Int ->

11 Int

12+

12foo ::

13foo ::

13 Foo a =>

14 Foo a =>

14 -- | Foo

15 -- | Foo

data/examples/other/comment-glued-together-out.hsdeleted−7

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

1−module Main (main) where

2−

3−-- | Foo.

4−

5−-- Bar

6−main :: IO ()

7−main = return ()

data/examples/other/comment-glued-together.hsdeleted−6

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

1−module Main (main) where

2−

3−{- | Foo. -}

4−-- Bar

5−main :: IO ()

6−main = return ()

data/examples/other/comment-trailing-space-out.hsdeleted−9

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

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.hsdeleted−9

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

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.hsdeleted−8

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

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.hsdeleted−8

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

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.hsdeleted−14

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

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.hsdeleted−14

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

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.hsdeleted−7

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

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.hsdeleted−6

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

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.hsdeleted−10

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

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.hsdeleted−9

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

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.hsdeleted−12

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

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.hsdeleted−11

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

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.hsdeleted−15

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

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.hsdeleted−14

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

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.hsdeleted−9

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

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.hsdeleted−8

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

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.hsdeleted−11

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

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.hsdeleted−11

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

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.hsdeleted−21

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

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.hsdeleted−17

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

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.hsdeleted−14

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

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.hsdeleted−14

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

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.hsdeleted−7

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

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.hsdeleted−7

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

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.hsdeleted−10

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

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.hsdeleted−10

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

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.hsdeleted−10

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

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.hsdeleted−10

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

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.hsdeleted−3

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

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

2−

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

data/examples/other/inline-comment-0.hsdeleted−3

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

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

2−

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

data/examples/other/inline-comment-1-out.hsdeleted−12

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

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.hsdeleted−9

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

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+2−1

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

12 )

13 (x :: *)

14 (y :: *).

15+ D

15− D (f x y)

16+ (f x y)

16

17

17data G where

18data G where

18 G ::

19 G ::

data/examples/other/multiple-blank-line-comment-out.hsdeleted−9

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

1−module A where

2−

3−a =

4− b

5− [ f

6− {-,

7−

8− -}

9− ]

data/examples/other/multiple-blank-line-comment.hsdeleted−10

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

1−module A where

2−

3−a =

4− b

5− [ f

6− {-,

7−

8−

9− -}

10− ]

data/examples/other/pragma-comments-after-out.hsdeleted−4

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

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.hsdeleted−3

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

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.hsdeleted−8

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

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.hsdeleted−11

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

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+4−1

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

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

10

11-- | Header comment.

12−module Foo () where

12+module Foo

13+ (

14+ )

15+where

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

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

1{-# LANGUAGE NondecreasingIndentation #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE NoMonoLocalBinds #-}

5+

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

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

5-- NoMonoLocalBinds before TypeFamilies

7-- NoMonoLocalBinds before TypeFamilies

6−{-# LANGUAGE NoMonoLocalBinds #-}

7

8

8module Foo

9module Foo

9 ( bar,

10 ( bar,

default.nix+51−108

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

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

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

2−, system ? builtins.currentSystem

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

4−}:

5

2

6let

3let

4+ ormoluCompiler = "ghc865";

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

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

8 "^.*\.md$"

6 "^.*\.md$"

9 "^app.*$"

7 "^app.*$"

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

16 overrides = ormoluOverlay;

14 overrides = ormoluOverlay;

17 };

15 };

18 ormoluOverlay = self: super: {

16 ormoluOverlay = self: super: {

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

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

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

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

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

21+ # too slow.

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

23+ (super.callHackage "ghc-lib-parser" "8.8.1" { });

20 };

24 };

21 ormolize = import ./nix/ormolize {

25 ormolize = import ./nix/ormolize {

22 inherit pkgs;

26 inherit pkgs;

23 inherit haskellPackages;

27 inherit haskellPackages;

24 };

28 };

25− expectedFailures = [

29+ # NOTE We have to exclude some directories for some packages because

26− "Agda"

30+ # Ormolu needs files to be parsable by Haddock which is not always the

31+ # case. For example some tests and examples do not parse.

32+ excludedHackageDirs = {

27− "aws"

33+ "aws" = ["Examples"];

28− "distributed-process"

34+ "distributed-process" = ["benchmarks"];

29− "esqueleto"

35+ "esqueleto" = ["test"];

30− "fay"

36+ "fay" = ["examples"];

31− "hlint"

32− "idris"

33− "intero"

34− "leksah"

35− "pandoc"

36− "pipes"

37− "postgrest"

37+ "postgrest" = ["test"];

38− "purescript"

38+ };

39− "tensorflow"

40− ] ++ (if ormoluCompiler == "ghc8101" then [] else ["lens"]);

41 ormolizedPackages = doCheck:

39 ormolizedPackages = doCheck:

42 pkgs.lib.mapAttrs (name: p: ormolize {

40 pkgs.lib.mapAttrs (name: p: ormolize {

43 package = p;

41 package = p;

44 inherit doCheck;

42 inherit doCheck;

45− expectedFailures =

43+ excludedDirs =

46− if pkgs.lib.lists.any (x: x == name) expectedFailures

44+ if builtins.hasAttr name excludedHackageDirs

47− then ./expected-failures + "/${name}.txt"

45+ then excludedHackageDirs.${name}

48− else null;

46+ else [];

49 }) haskellPackages;

47 }) haskellPackages;

50in {

48in {

51 ormolu = haskellPackages.ormolu;

49 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 =

56− haskellPackages.shellFor {

50+ ormoluShell = haskellPackages.shellFor {

57− packages = ps: [

51+ packages = ps: [

58− ps.ormolu

52+ ps.ormolu

59− ];

53+ ];

60− buildInputs = [

54+ buildInputs = [

61− haskellPackages.cabal-install

55+ haskellPackages.cabal-install

62− haskellPackages.ghcid

56+ haskellPackages.ghcid

63− ];

64− };

65− withOrmolu = haskellPackages.shellFor {

66− packages = ps: [];

67− buildInputs = [

68− haskellPackages.cabal-install

69− haskellPackages.ormolu

70− ];

71− };

57+ ];

72 };

58 };

73 inherit ormoluOverlay ormoluCompiler;

59 inherit ormoluOverlay ormoluCompiler;

74 hackage = ormolizedPackages false;

60 hackage = ormolizedPackages false;

75 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (

61 hackageTests = with pkgs.lib; pkgs.recurseIntoAttrs (

76 let ps = [

62 let ps = [

77− "Agda"

78 "QuickCheck"

63 "QuickCheck"

79 "ShellCheck"

64 "ShellCheck"

80 "aeson"

65 "aeson"

81 "attoparsec"

66 "attoparsec"

82 "aws"

67 "aws"

83− "brick"

84 "capability"

68 "capability"

85 "cassava"

69 "cassava"

86 "conduit"

70 "conduit"

@@ -92,78 +76,37 @@ in {

92 "hakyll"

76 "hakyll"

93 "haxl"

77 "haxl"

94 "hedgehog"

78 "hedgehog"

95− "hledger"

96 "hlint"

79 "hlint"

97− "http-client"

98− "idris"

99− "intero"

100− "leksah"

101− "lens"

102 "megaparsec"

80 "megaparsec"

103− "optics"

104 "ormolu"

81 "ormolu"

105− "pandoc"

82+ "optics"

106− "parsec3"

107− "pipes"

108 "postgrest"

83 "postgrest"

109− "purescript"

110 "servant"

84 "servant"

111 "servant-server"

85 "servant-server"

112− "stack"

113 "tensorflow"

86 "tensorflow"

114 "text_1_2_4_0"

87 "text_1_2_4_0"

115 "tls"

88 "tls"

116 "yesod-core"

89 "yesod-core"

90+

91+ # Comment idempotence issue

92+

93+ # "Agda"

94+ # "brick"

95+ # "hledger"

96+ # "http-client"

97+ # "idris"

98+ # "intero"

99+ # "leksah"

100+ # "pandoc"

101+ # "pipes"

102+ # "stack"

103+

104+ # Missing language extension

105+

106+ # "lens" #fixed in master

107+ # "purescript"

108+

117 ];

109 ];

118 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)

110 in listToAttrs (map (p: nameValuePair p (ormolizedPackages true).${p}) ps)

119 );

111 );

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− };

169}

112}

expected-failures/Agda.txtdeleted−11

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

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.txtdeleted−9

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

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.txtdeleted−7

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

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.txtdeleted−7

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

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.txtdeleted−18

@@ -1,18 +0,0 @@

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.txtdeleted−11

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

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.txtdeleted−7

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

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.txtdeleted−5

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

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.txtdeleted−5

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

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.txtdeleted−3

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

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.txtdeleted−9

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

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.txtdeleted−3

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

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.txtdeleted−5

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

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.txtdeleted−18

@@ -1,18 +0,0 @@

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.txtdeleted−7

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

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+4−6

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

1#!/usr/bin/env nix-shell

2−#!nix-shell default.nix -A dev.withOrmolu -i bash --pure

2+#!nix-shell -p "(import ./default.nix {}).ormolu" -i bash --pure

3#

4# Format Ormolu using current version of Ormolu.

5

@@ -7,8 +7,6 @@ set -e

7

8export LANG="C.UTF-8"

9

10−cabal format

11−

12−ormolu -m inplace $(find app -type f -name "*.hs")

10+ormolu -p -m inplace $(find app -type f -name "*.hs")

13−ormolu -m inplace $(find src -type f $ -name "*.hs" -o -name "*.hs-boot" $)

11+ormolu -p -m inplace $(find src -type f $ -name "*.hs" -o -name "*.hs-boot" $)

14−ormolu -m inplace $(find tests -type f -name "*.hs")

12+ormolu -p -m inplace $(find tests -type f -name "*.hs")

nix/nixpkgs/default.nix+3−7

@@ -1,13 +1,9 @@

1−{ system ? builtins.currentSystem }:

2let

1let

3− rev = "32b46dd897ab2143a609988a04d87452f0bbef59";

2+ rev = "19.09";

4− sha256 = "1gzfrpjnr1bz9zljsyg3a4zrhk8r927sz761mrgcg56dwinkhpjk";

3+ sha256 = "0mhqhq21y5vrr1f30qd2bvydv4bbbslvyzclhw0kdxmkgg3z4c92";

5 nixpkgs = builtins.fetchTarball {

4 nixpkgs = builtins.fetchTarball {

6 url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";

5 url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";

7 inherit sha256;

6 inherit sha256;

8 };

7 };

9− pkgs = import nixpkgs {

10− inherit system;

11− config.allowUnfree = true;

8+ pkgs = import nixpkgs { config.allowUnfree = true; };

12− };

13in pkgs

9in pkgs

nix/ormolize/default.nix+13−29

@@ -2,48 +2,32 @@

2, haskellPackages

3}:

4{ package

5−, expectedFailures ? null

6, doCheck ? false

5, 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

13− haskellPackages.ormolu

14+ then haskellPackages.ormolu

14− pkgs.diffutils

15+ else pkgs.haskell.lib.dontCheck haskellPackages.ormolu)

15 pkgs.glibcLocales

16 pkgs.glibcLocales

16 ];

17 ];

17 LANG = "en_US.UTF-8";

18 LANG = "en_US.UTF-8";

19+ excludedDirsRendered =

20+ if excludedDirs == []

21+ then ""

22+ else pkgs.lib.concatMapStringsSep " " (x: "-not -path './" + x + "/*'") excludedDirs;

18 buildPhase = ''

23 buildPhase = ''

19− hs_files=$(find . -name '*.hs')

24+ find . -name '*.hs' ${excludedDirsRendered} -exec bash ${./ormolize.sh} {} \; 2> log.txt

20− for hs_file in $hs_files; do

25+ cat log.txt

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

36 '';

26 '';

37 inherit doCheck;

27 inherit doCheck;

38− checkPhase =

28+ checkPhase = ''

39− if expectedFailures == null

40− then ''

41− echo "No failures expected"

42− if [[ -s log.txt ]]; then exit 1; fi

29+ if [[ -s log.txt ]]; then exit 1; fi

43− ''

44− else ''

45− diff --ignore-blank-lines --color=always ${expectedFailures} log.txt

46− '';

30+ '';

47 installPhase = ''

31 installPhase = ''

48 mkdir "$out"

32 mkdir "$out"

49 find . -name '*.hs-original' -exec cp --parents {} $out \;

33 find . -name '*.hs-original' -exec cp --parents {} $out \;

nix/ormolize/ormolize.shnew file+17

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

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+157−174

@@ -1,184 +1,167 @@

1+name: ormolu

2+version: 0.0.3.1

1−cabal-version: 1.18

3+cabal-version: 1.18

2−name: ormolu

4+tested-with: GHC==8.6.5

3−version: 0.1.2.0

4−license: BSD3

5+license: BSD3

5−license-file: LICENSE.md

6+license-file: LICENSE.md

6−maintainer: Mark Karpov <mark.karpov@tweag.io>

7+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.

12−category: Development, Formatting

10+category: Development, Formatting

11+synopsis: A formatter for Haskell source code

13−build-type: Simple

12+build-type: Simple

14−data-files:

13+description: A formatter for Haskell source code.

14+extra-doc-files: CONTRIBUTING.md

15+ , CHANGELOG.md

16+ , DESIGN.md

17+ , README.md

15− data/examples/declaration/annotation/*.hs

18+data-files: data/examples/declaration/annotation/*.hs

16− data/examples/declaration/class/*.hs

19+ , data/examples/declaration/class/*.hs

17− data/examples/declaration/data/*.hs

20+ , data/examples/declaration/data/*.hs

18− data/examples/declaration/data/gadt/*.hs

21+ , data/examples/declaration/data/gadt/*.hs

19− data/examples/declaration/default/*.hs

22+ , data/examples/declaration/default/*.hs

20− data/examples/declaration/deriving/*.hs

23+ , data/examples/declaration/deriving/*.hs

21− data/examples/declaration/foreign/*.hs

24+ , data/examples/declaration/foreign/*.hs

22− data/examples/declaration/instance/*.hs

25+ , data/examples/declaration/instance/*.hs

23− data/examples/declaration/rewrite-rule/*.hs

26+ , data/examples/declaration/rewrite-rule/*.hs

24− data/examples/declaration/role-annotation/*.hs

27+ , data/examples/declaration/role-annotation/*.hs

25− data/examples/declaration/signature/complete/*.hs

28+ , data/examples/declaration/signature/complete/*.hs

26− data/examples/declaration/signature/fixity/*.hs

29+ , data/examples/declaration/signature/fixity/*.hs

27− data/examples/declaration/signature/inline/*.hs

30+ , data/examples/declaration/signature/inline/*.hs

28− data/examples/declaration/signature/minimal/*.hs

31+ , data/examples/declaration/signature/minimal/*.hs

29− data/examples/declaration/signature/pattern/*.hs

32+ , data/examples/declaration/signature/pattern/*.hs

30− data/examples/declaration/signature/set-cost-centre/*.hs

33+ , data/examples/declaration/signature/set-cost-centre/*.hs

31− data/examples/declaration/signature/specialize/*.hs

34+ , data/examples/declaration/signature/specialize/*.hs

32− data/examples/declaration/signature/type/*.hs

35+ , data/examples/declaration/signature/type/*.hs

33− data/examples/declaration/splice/*.hs

36+ , data/examples/declaration/splice/*.hs

34− data/examples/declaration/type-families/closed-type-family/*.hs

37+ , data/examples/declaration/type-families/closed-type-family/*.hs

35− data/examples/declaration/type-families/data-family/*.hs

38+ , data/examples/declaration/type-families/data-family/*.hs

36− data/examples/declaration/type-families/type-family/*.hs

39+ , data/examples/declaration/type-families/type-family/*.hs

37− data/examples/declaration/type-synonyms/*.hs

40+ , data/examples/declaration/type-synonyms/*.hs

38− data/examples/declaration/type/*.hs

41+ , data/examples/declaration/type/*.hs

39− data/examples/declaration/value/function/*.hs

42+ , data/examples/declaration/value/function/*.hs

40− data/examples/declaration/value/function/arrow/*.hs

43+ , data/examples/declaration/value/function/arrow/*.hs

41− data/examples/declaration/value/function/comprehension/*.hs

44+ , data/examples/declaration/value/function/comprehension/*.hs

42− data/examples/declaration/value/function/do/*.hs

45+ , data/examples/declaration/value/function/do/*.hs

43− data/examples/declaration/value/function/infix/*.hs

46+ , data/examples/declaration/value/function/infix/*.hs

44− data/examples/declaration/value/function/pattern/*.hs

47+ , data/examples/declaration/value/function/pattern/*.hs

45− data/examples/declaration/value/other/*.hs

48+ , data/examples/declaration/value/other/*.hs

46− data/examples/declaration/value/pattern-synonyms/*.hs

49+ , data/examples/declaration/value/pattern-synonyms/*.hs

47− data/examples/declaration/warning/*.hs

50+ , data/examples/declaration/warning/*.hs

48− data/examples/import/*.hs

51+ , data/examples/import/*.hs

49− data/examples/module-header/*.hs

52+ , data/examples/module-header/*.hs

50− data/examples/other/*.hs

53+ , data/examples/other/*.hs

51−

52−extra-doc-files:

53− CONTRIBUTING.md

54− CHANGELOG.md

55− DESIGN.md

56− README.md

57

54

58source-repository head

55source-repository head

59− type: git

56+ type: git

60− location: https://github.com/tweag/ormolu.git

57+ location: https://github.com/tweag/ormolu.git

61

58

62flag dev

59flag dev

63− description: Turn on development settings.

60+ description: Turn on development settings.

64− default: False

65− manual: True

61+ manual: True

62+ default: False

66

63

67library

64library

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.8.1 && < 8.8.3

72+ , mtl >= 2.0 && < 3.0

73+ , syb >= 0.7 && < 0.8

74+ , text >= 0.2 && < 1.3

68− exposed-modules:

75+ exposed-modules: Ormolu

69− Ormolu

70− Ormolu.Config

76+ , Ormolu.Config

71− Ormolu.Diff

77+ , Ormolu.Diff

72− Ormolu.Exception

78+ , Ormolu.Exception

73− Ormolu.Imports

79+ , Ormolu.Imports

74− Ormolu.Parser

80+ , Ormolu.Parser

75− Ormolu.Parser.Anns

81+ , Ormolu.Parser.Anns

76− Ormolu.Parser.CommentStream

82+ , Ormolu.Parser.CommentStream

77− Ormolu.Parser.Pragma

83+ , Ormolu.Parser.Pragma

78− Ormolu.Parser.Result

84+ , Ormolu.Parser.Result

79− Ormolu.Parser.Shebang

80− Ormolu.Printer

85+ , Ormolu.Printer

81− Ormolu.Printer.Combinators

86+ , Ormolu.Printer.Combinators

82− Ormolu.Printer.Comments

87+ , Ormolu.Printer.Comments

83− Ormolu.Printer.Internal

88+ , Ormolu.Printer.Internal

84− Ormolu.Printer.Meat.Common

89+ , Ormolu.Printer.Meat.Common

85− Ormolu.Printer.Meat.Declaration

90+ , Ormolu.Printer.Meat.Declaration

86− Ormolu.Printer.Meat.Declaration.Annotation

91+ , Ormolu.Printer.Meat.Declaration.Annotation

87− Ormolu.Printer.Meat.Declaration.Class

92+ , Ormolu.Printer.Meat.Declaration.Class

88− Ormolu.Printer.Meat.Declaration.Data

93+ , Ormolu.Printer.Meat.Declaration.Data

89− Ormolu.Printer.Meat.Declaration.Default

94+ , Ormolu.Printer.Meat.Declaration.Default

90− Ormolu.Printer.Meat.Declaration.Foreign

95+ , Ormolu.Printer.Meat.Declaration.Foreign

91− Ormolu.Printer.Meat.Declaration.Instance

96+ , Ormolu.Printer.Meat.Declaration.Instance

92− Ormolu.Printer.Meat.Declaration.RoleAnnotation

97+ , Ormolu.Printer.Meat.Declaration.RoleAnnotation

93− Ormolu.Printer.Meat.Declaration.Rule

98+ , Ormolu.Printer.Meat.Declaration.Rule

94− Ormolu.Printer.Meat.Declaration.Signature

99+ , Ormolu.Printer.Meat.Declaration.Signature

95− Ormolu.Printer.Meat.Declaration.Splice

100+ , Ormolu.Printer.Meat.Declaration.Splice

96− Ormolu.Printer.Meat.Declaration.Type

101+ , Ormolu.Printer.Meat.Declaration.Type

97− Ormolu.Printer.Meat.Declaration.TypeFamily

102+ , Ormolu.Printer.Meat.Declaration.TypeFamily

98− Ormolu.Printer.Meat.Declaration.Value

103+ , Ormolu.Printer.Meat.Declaration.Value

99− Ormolu.Printer.Meat.Declaration.Warning

104+ , Ormolu.Printer.Meat.Declaration.Warning

100− Ormolu.Printer.Meat.ImportExport

105+ , Ormolu.Printer.Meat.ImportExport

101− Ormolu.Printer.Meat.Module

106+ , Ormolu.Printer.Meat.Module

102− Ormolu.Printer.Meat.Pragma

107+ , Ormolu.Printer.Meat.Pragma

103− Ormolu.Printer.Meat.Type

108+ , Ormolu.Printer.Meat.Type

104− Ormolu.Printer.Operators

109+ , Ormolu.Printer.Operators

105− Ormolu.Printer.SpanStream

110+ , Ormolu.Printer.SpanStream

106− Ormolu.Processing.Common

107− Ormolu.Processing.Cpp

108− Ormolu.Processing.Postprocess

109− Ormolu.Processing.Preprocess

110− Ormolu.Utils

111+ , Ormolu.Utils

111−

112− hs-source-dirs: src

113− other-modules:

112+ other-modules: GHC

114− GHC

115− GHC.DynFlags

113+ , GHC.DynFlags

116−

117− default-language: Haskell2010

118− build-depends:

119− base >=4.12 && <5.0,

120− bytestring >=0.2 && <0.11,

121− containers >=0.5 && <0.7,

122− dlist >=0.8 && <2.0,

123− exceptions >=0.6 && <0.11,

124− ghc-lib-parser >=8.10 && <8.11,

125− mtl >=2.0 && <3.0,

126− syb >=0.7 && <0.8,

127− text >=0.2 && <1.3

128−

129− if flag(dev)

114+ if flag(dev)

130− ghc-options:

115+ ghc-options: -Wall -Werror -Wcompat

131− -Wall -Werror -Wcompat -Wincomplete-record-updates

116+ -Wincomplete-record-updates

117+ -Wincomplete-uni-patterns

132− -Wincomplete-uni-patterns -Wnoncanonical-monad-instances

118+ -Wnoncanonical-monad-instances

119+ -Wnoncanonical-monadfail-instances

120+ -- https://github.com/haskell/haddock/issues/1116

133− -Wno-missing-home-modules

121+ -Wno-missing-home-modules

134−

135− else

122+ else

136− ghc-options: -O2 -Wall

123+ ghc-options: -O2 -Wall

137−

138−executable ormolu

139− main-is: Main.hs

140− hs-source-dirs: app

141− other-modules: Paths_ormolu

142− default-language: Haskell2010

124+ default-language: Haskell2010

143− build-depends:

144− base >=4.12 && <5.0,

145− ghc-lib-parser >=8.10 && <8.11,

146− gitrev >=1.3 && <1.4,

147− optparse-applicative >=0.14 && <0.17,

148− ormolu -any,

149− text >=0.2 && <1.3

150−

151− if flag(dev)

152− ghc-options:

153− -Wall -Werror -Wcompat -Wincomplete-record-updates

154− -Wincomplete-uni-patterns -Wnoncanonical-monad-instances

155− -optP-Wno-nonportable-include-path

156−

157− else

158− ghc-options: -O2 -Wall -rtsopts

159

125

160test-suite tests

126test-suite tests

161− type: exitcode-stdio-1.0

162− main-is: Spec.hs

127+ main-is: Spec.hs

163− build-tools: hspec-discover >=2.0 && <3.0

164− hs-source-dirs: tests

128+ hs-source-dirs: tests

129+ type: exitcode-stdio-1.0

130+ build-depends: base >= 4.12 && < 5.0

131+ , containers >= 0.5 && < 0.7

132+ , filepath >= 1.2 && < 1.5

133+ , hspec >= 2.0 && < 3.0

134+ , ormolu

135+ , path >= 0.6 && < 0.8

136+ , path-io >= 1.4.2 && < 2.0

137+ , text >= 0.2 && < 1.3

138+ build-tools: hspec-discover >= 2.0 && < 3.0

165− other-modules:

139+ other-modules:

166− Ormolu.Parser.PragmaSpec

140+ Ormolu.Parser.PragmaSpec

167− Ormolu.PrinterSpec

141+ , Ormolu.PrinterSpec

168

142

143+ if flag(dev)

144+ ghc-options: -Wall -Werror

145+ else

146+ ghc-options: -O2 -Wall

169− default-language: Haskell2010

147+ 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

148

149+executable ormolu

150+ main-is: Main.hs

151+ hs-source-dirs: app

152+ build-depends: base >= 4.12 && < 5.0

153+ , ghc-lib-parser >= 8.8.1 && < 8.8.3

154+ , gitrev >= 1.3 && < 1.4

155+ , optparse-applicative >= 0.14 && < 0.16

156+ , ormolu

157+ , text >= 0.2 && < 1.3

158+ other-modules: Paths_ormolu

180− if flag(dev)

159+ if flag(dev)

181− ghc-options: -Wall -Werror

160+ ghc-options: -Wall -Werror -Wcompat

182−

161+ -Wincomplete-record-updates

162+ -Wincomplete-uni-patterns

163+ -Wnoncanonical-monad-instances

164+ -Wnoncanonical-monadfail-instances

183− else

165+ else

184− ghc-options: -O2 -Wall

166+ ghc-options: -O2 -Wall

167+ default-language: Haskell2010

region-tests/expected-result-17-18.hsdeleted−17

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

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.hsdeleted−17

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

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.hsdeleted−16

@@ -1,16 +0,0 @@

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.hsdeleted−17

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

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.hsdeleted−21

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

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.hsdeleted−17

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

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+2−4

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

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

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

2−, system ? builtins.currentSystem

3−}:

4

2

5−(import ./default.nix { inherit pkgs; }).dev.ormoluShell

3+(import ./default.nix { inherit pkgs; }).ormoluShell

src/GHC.hs+13−2

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

1module GHC

2 ( module X,

3+ ParsedSource,

3 )

4 )

4where

5where

5

6

6import ApiAnnotation as X

7import ApiAnnotation as X

7import BasicTypes as X

8import BasicTypes as X

8−import GHC.Hs as X

9+import HsBinds as X

9−import GHC.Hs.Instances as X ()

10+import HsDecls as X

11+import HsDoc as X

12+import HsExpr as X

13+import HsExtension as X

14+import HsImpExp as X

15+import HsInstances as X ()

16+import HsLit as X

17+import HsPat as X

18+import HsSyn as X

10import Module as X

19import Module as X

11import RdrName as X

20import RdrName as X

12import SrcLoc as X

21import SrcLoc as X

22+

23+type ParsedSource = Located (HsModule GhcPs)

src/GHC/DynFlags.hs+19−30

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

1{-# OPTIONS_GHC -Wno-missing-fields #-}

2

3−-- Modified from ghc-lib-api-ext.

4−

5module GHC.DynFlags

3module GHC.DynFlags

6 ( baseDynFlags,

4 ( baseDynFlags,

7 )

5 )

@@ -10,40 +8,31 @@ where

10import Config

8import Config

11import DynFlags

9import DynFlags

12import Fingerprint

10import Fingerprint

13−import GHC.Platform

11+import Platform

14−import ToolSettings

15

12

13+-- | Taken from HLint.

16fakeSettings :: Settings

14fakeSettings :: Settings

17fakeSettings =

15fakeSettings =

18 Settings

16 Settings

19− { sGhcNameVersion =

20− GhcNameVersion

21− { ghcNameVersion_programName = "ghc",

22− ghcNameVersion_projectVersion = cProjectVersion

23− },

24− sFileSettings = FileSettings {},

25− sTargetPlatform =

17+ { sTargetPlatform = platform,

26− Platform

27− { platformWordSize = PW8,

28− platformMini =

29− PlatformMini

30− { platformMini_arch = ArchUnknown,

31− platformMini_os = OSUnknown

32− },

33− platformUnregisterised = True

34− },

35− sPlatformMisc = PlatformMisc {},

36− sPlatformConstants =

18+ sPlatformConstants = platformConstants,

37− PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8},

19+ sProjectVersion = cProjectVersion,

38− sToolSettings =

20+ sProgramName = "ghc",

39− ToolSettings

21+ sOpt_P_fingerprint = fingerprint0,

40− { toolSettings_opt_P_fingerprint = fingerprint0,

22+ sPgm_F = ""

41− toolSettings_pgm_F = ""

42− }

43 }

23 }

24+ where

25+ platform =

26+ Platform

27+ { platformWordSize = 8,

28+ platformOS = OSUnknown,

29+ platformUnregisterised = True

30+ }

31+ platformConstants =

32+ PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8}

44

33

45−fakeLlvmConfig :: LlvmConfig

34+fakeLlvmConfig :: (LlvmTargets, LlvmPasses)

46−fakeLlvmConfig = LlvmConfig [] []

35+fakeLlvmConfig = ([], [])

47

36

48baseDynFlags :: DynFlags

37baseDynFlags :: DynFlags

49baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig

38baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig

src/Ormolu.hs+7−10

@@ -6,7 +6,6 @@ module Ormolu

6 ormoluFile,

7 ormoluStdin,

8 Config (..),

9− RegionIndices (..),

10 defaultConfig,

9 defaultConfig,

11 DynOption (..),

10 DynOption (..),

12 OrmoluException (..),

11 OrmoluException (..),

@@ -43,15 +42,13 @@ import qualified SrcLoc as GHC

43ormolu ::

42ormolu ::

44 MonadIO m =>

43 MonadIO m =>

45 -- | Ormolu configuration

44 -- | Ormolu configuration

46− Config RegionIndices ->

45+ Config ->

47 -- | Location of source file

46 -- | Location of source file

48 FilePath ->

47 FilePath ->

49 -- | Input to format

48 -- | Input to format

50 String ->

49 String ->

51 m Text

50 m Text

52−ormolu cfgWithIndices path str = do

51+ormolu cfg path str = do

53− let totalLines = length (lines str)

54− cfg = regionIndicesToDeltas totalLines <$> cfgWithIndices

55 (warnings, result0) <-

52 (warnings, result0) <-

56 parseModule' cfg OrmoluParsingFailed path str

53 parseModule' cfg OrmoluParsingFailed path str

57 when (cfgDebug cfg) $ do

54 when (cfgDebug cfg) $ do

@@ -63,7 +60,7 @@ ormolu cfgWithIndices path str = do

63 -- to parse the rendered code back, inside of GHC monad wrapper which will

60 -- to parse the rendered code back, inside of GHC monad wrapper which will

64 -- lead to error messages presenting the exceptions as GHC bugs.

61 -- lead to error messages presenting the exceptions as GHC bugs.

65 let !txt = printModule result0

62 let !txt = printModule result0

66− when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do

63+ when (not (cfgUnsafe cfg) || cfgCheckIdempotency cfg) $ do

67 let pathRendered = path ++ "<rendered>"

64 let pathRendered = path ++ "<rendered>"

68 -- Parse the result of pretty-printing again and make sure that AST

65 -- Parse the result of pretty-printing again and make sure that AST

69 -- is the same as AST of original snippet module span positions.

66 -- is the same as AST of original snippet module span positions.

@@ -79,7 +76,7 @@ ormolu cfgWithIndices path str = do

79 Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss)

76 Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss)

80 -- Try re-formatting the formatted result to check if we get exactly

77 -- Try re-formatting the formatted result to check if we get exactly

81 -- the same output.

78 -- the same output.

82− when (cfgCheckIdempotence cfg) $

79+ when (cfgCheckIdempotency cfg) $

83 let txt2 = printModule result1

80 let txt2 = printModule result1

84 in case diffText txt txt2 pathRendered of

81 in case diffText txt txt2 pathRendered of

85 Nothing -> return ()

82 Nothing -> return ()

@@ -96,7 +93,7 @@ ormolu cfgWithIndices path str = do

96ormoluFile ::

93ormoluFile ::

97 MonadIO m =>

94 MonadIO m =>

98 -- | Ormolu configuration

95 -- | Ormolu configuration

99− Config RegionIndices ->

96+ Config ->

100 -- | Location of source file

97 -- | Location of source file

101 FilePath ->

98 FilePath ->

102 -- | Resulting rendition

99 -- | Resulting rendition

@@ -111,7 +108,7 @@ ormoluFile cfg path =

111ormoluStdin ::

108ormoluStdin ::

112 MonadIO m =>

109 MonadIO m =>

113 -- | Ormolu configuration

110 -- | Ormolu configuration

114− Config RegionIndices ->

111+ Config ->

115 -- | Resulting rendition

112 -- | Resulting rendition

116 m Text

113 m Text

117ormoluStdin cfg =

114ormoluStdin cfg =

@@ -124,7 +121,7 @@ ormoluStdin cfg =

124parseModule' ::

121parseModule' ::

125 MonadIO m =>

122 MonadIO m =>

126 -- | Ormolu configuration

123 -- | Ormolu configuration

127− Config RegionDeltas ->

124+ Config ->

128 -- | How to obtain 'OrmoluException' to throw when parsing fails

125 -- | How to obtain 'OrmoluException' to throw when parsing fails

129 (GHC.SrcSpan -> String -> OrmoluException) ->

126 (GHC.SrcSpan -> String -> OrmoluException) ->

130 -- | File name to use in errors

127 -- | File name to use in errors

src/Ormolu/Config.hs+23−62

@@ -1,13 +1,7 @@

1−{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE RecordWildCards #-}

3−

4-- | Configuration options used by the tool.

1-- | Configuration options used by the tool.

5module Ormolu.Config

2module Ormolu.Config

6 ( Config (..),

3 ( Config (..),

7− RegionIndices (..),

8− RegionDeltas (..),

9 defaultConfig,

4 defaultConfig,

10− regionIndicesToDeltas,

11 DynOption (..),

5 DynOption (..),

12 dynOptionToLocatedStr,

6 dynOptionToLocatedStr,

13 )

7 )

@@ -16,72 +10,39 @@ where

16import qualified SrcLoc as GHC

10import qualified SrcLoc as GHC

17

11

18-- | Ormolu configuration.

12-- | Ormolu configuration.

19−data Config region = Config

13+data Config

14+ = Config

20− { -- | Dynamic options to pass to GHC parser

15+ { -- | Dynamic options to pass to GHC parser

21− cfgDynOptions :: ![DynOption],

16+ cfgDynOptions :: ![DynOption],

22− -- | Do formatting faster but without automatic detection of defects

17+ -- | Do formatting faster but without automatic detection of defects

23− cfgUnsafe :: !Bool,

18+ cfgUnsafe :: !Bool,

24− -- | Output information useful for debugging

19+ -- | Output information useful for debugging

25− cfgDebug :: !Bool,

20+ 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,

26− -- | Checks if re-formatting the result is idempotent

25+ -- | Checks if re-formatting the result is idempotent.

27− cfgCheckIdempotence :: !Bool,

26+ cfgCheckIdempotency :: !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

49− }

27+ }

50 deriving (Eq, Show)

28 deriving (Eq, Show)

51

29

52−-- | Default @'Config' 'RegionIndices'@.

30+-- | Default 'Config'.

53−defaultConfig :: Config RegionIndices

31+defaultConfig :: Config

54defaultConfig =

32defaultConfig =

55 Config

33 Config

56 { cfgDynOptions = [],

34 { cfgDynOptions = [],

57 cfgUnsafe = False,

35 cfgUnsafe = False,

58 cfgDebug = False,

36 cfgDebug = False,

59− cfgCheckIdempotence = False,

37+ cfgTolerateCpp = False,

60− cfgRegion =

38+ cfgCheckIdempotency = False

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

79 }

39 }

80

40

81-- | A wrapper for dynamic options.

41-- | A wrapper for dynamic options.

82−newtype DynOption = DynOption

42+newtype DynOption

43+ = DynOption

83− { unDynOption :: String

44+ { unDynOption :: String

84− }

45+ }

85 deriving (Eq, Ord, Show)

46 deriving (Eq, Ord, Show)

86

47

87-- | Convert 'DynOption' to @'GHC.Located' 'String'@.

48-- | Convert 'DynOption' to @'GHC.Located' 'String'@.

src/Ormolu/Diff.hs+13−23

@@ -8,14 +8,14 @@ module Ormolu.Diff

8 )

9where

10

11+import BasicTypes (SourceText)

11import Data.ByteString (ByteString)

12import Data.ByteString (ByteString)

12import Data.Generics

13import Data.Generics

13import Data.Text (Text)

14import Data.Text (Text)

14import qualified Data.Text as T

15import qualified Data.Text as T

15import qualified FastString as GHC

16import qualified FastString as GHC

16import GHC

17import GHC

17−import Ormolu.Imports (normalizeImports)

18+import Ormolu.Imports (sortImports)

18−import Ormolu.Parser.CommentStream

19import Ormolu.Parser.Result

20import Ormolu.Utils

21

@@ -39,16 +39,14 @@ diffParseResult :: ParseResult -> ParseResult -> Diff

39diffParseResult

40 ParseResult

41 { prCommentStream = cstream0,

42− prParsedSource = hs0

42+ prParsedSource = ps0

43 }

44 ParseResult

45 { prCommentStream = cstream1,

46− prParsedSource = hs1

46+ prParsedSource = ps1

47 } =

48 matchIgnoringSrcSpans cstream0 cstream1

49− <> matchIgnoringSrcSpans

49+ <> matchIgnoringSrcSpans ps0 ps1

50− hs0 {hsmodImports = normalizeImports (hsmodImports hs0)}

51− hs1 {hsmodImports = normalizeImports (hsmodImports hs1)}

52

50

53-- | Compare two values for equality disregarding differences in 'SrcSpan's

51-- | Compare two values for equality disregarding differences in 'SrcSpan's

54-- and the ordering of import lists.

52-- and the ordering of import lists.

@@ -70,10 +68,9 @@ matchIgnoringSrcSpans = genericQuery

70 gzipWithQ

68 gzipWithQ

71 ( genericQuery

69 ( genericQuery

72 `extQ` srcSpanEq

70 `extQ` srcSpanEq

73− `extQ` commentEq

71+ `extQ` hsModuleEq

74 `extQ` sourceTextEq

72 `extQ` sourceTextEq

75 `extQ` hsDocStringEq

73 `extQ` hsDocStringEq

76− `extQ` importDeclQualifiedStyleEq

77 `ext2Q` forLocated

74 `ext2Q` forLocated

78 )

75 )

79 x

76 x

@@ -81,23 +78,16 @@ matchIgnoringSrcSpans = genericQuery

81 | otherwise = Different []

78 | otherwise = Different []

82 srcSpanEq :: SrcSpan -> GenericQ Diff

79 srcSpanEq :: SrcSpan -> GenericQ Diff

83 srcSpanEq _ _ = Same

80 srcSpanEq _ _ = Same

84− commentEq :: Comment -> GenericQ Diff

81+ hsModuleEq :: HsModule GhcPs -> GenericQ Diff

85− commentEq (Comment _ x) d =

82+ hsModuleEq hs0 hs1' =

86− case cast d :: Maybe Comment of

83+ case cast hs1' :: Maybe (HsModule GhcPs) of

87 Nothing -> Different []

84 Nothing -> Different []

88− Just (Comment _ y) ->

85+ Just hs1 ->

89− if x == y

86+ matchIgnoringSrcSpans

90− then Same

87+ hs0 {hsmodImports = sortImports (hsmodImports hs0)}

91− else Different []

88+ hs1 {hsmodImports = sortImports (hsmodImports hs1)}

92 sourceTextEq :: SourceText -> GenericQ Diff

89 sourceTextEq :: SourceText -> GenericQ Diff

93 sourceTextEq _ _ = Same

90 sourceTextEq _ _ = Same

94− importDeclQualifiedStyleEq :: ImportDeclQualifiedStyle -> GenericQ Diff

95− importDeclQualifiedStyleEq d0 d1' =

96− case (d0, cast d1' :: Maybe ImportDeclQualifiedStyle) of

97− (x, Just x') | x == x' -> Same

98− (QualifiedPre, Just QualifiedPost) -> Same

99− (QualifiedPost, Just QualifiedPre) -> Same

100− _ -> Different []

101 hsDocStringEq :: HsDocString -> GenericQ Diff

91 hsDocStringEq :: HsDocString -> GenericQ Diff

102 hsDocStringEq str0 str1' =

92 hsDocStringEq str0 str1' =

103 case cast str1' :: Maybe HsDocString of

93 case cast str1' :: Maybe HsDocString of

src/Ormolu/Exception.hs+11−4

@@ -19,7 +19,9 @@ 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

22− = -- | Parsing of original source code failed

24+ | -- | Parsing of original source code failed

23 OrmoluParsingFailed GHC.SrcSpan String

25 OrmoluParsingFailed GHC.SrcSpan String

24 | -- | Parsing of formatted source code failed

26 | -- | Parsing of formatted source code failed

25 OrmoluOutputParsingFailed GHC.SrcSpan String

27 OrmoluOutputParsingFailed GHC.SrcSpan String

@@ -33,8 +35,13 @@ data OrmoluException

33

35

34instance Exception OrmoluException where

36instance Exception OrmoluException where

35 displayException = \case

37 displayException = \case

38+ OrmoluCppEnabled path ->

39+ unlines

40+ [ "CPP is not supported:",

41+ withIndent path

42+ ]

36 OrmoluParsingFailed s e ->

43 OrmoluParsingFailed s e ->

37− showParsingErr "The GHC parser (in Haddock mode) failed:" s [e]

44+ showParsingErr "Parsing of source code failed:" s [e]

38 OrmoluOutputParsingFailed s e ->

45 OrmoluOutputParsingFailed s e ->

39 showParsingErr "Parsing of formatted code failed:" s [e]

46 showParsingErr "Parsing of formatted code failed:" s [e]

40 ++ "Please, consider reporting the bug.\n"

47 ++ "Please, consider reporting the bug.\n"

@@ -74,8 +81,8 @@ withPrettyOrmoluExceptions m = m `catch` h

74 hPutStrLn stderr (displayException e)

81 hPutStrLn stderr (displayException e)

75 exitWith . ExitFailure $

82 exitWith . ExitFailure $

76 case e of

83 case e of

77− -- Error code 1 is for 'error' or 'notImplemented'

84+ -- Error code 1 is for `error` or `notImplemented`

78− -- 2 used to be for erroring out on CPP

85+ OrmoluCppEnabled {} -> 2

79 OrmoluParsingFailed {} -> 3

86 OrmoluParsingFailed {} -> 3

80 OrmoluOutputParsingFailed {} -> 4

87 OrmoluOutputParsingFailed {} -> 4

81 OrmoluASTDiffers {} -> 5

88 OrmoluASTDiffers {} -> 5

src/Ormolu/Imports.hs+51−168

@@ -4,199 +4,82 @@

4

5-- | Manipulations on import lists.

6module Ormolu.Imports

7− ( normalizeImports,

7+ ( sortImports,

8 )

9where

10

11import Data.Bifunctor

12−import Data.Char (isAlphaNum)

13import Data.Function (on)

12import Data.Function (on)

14−import Data.List (foldl', nubBy, sortBy, sortOn)

13+import Data.Generics (gcompare)

15−import Data.Map.Strict (Map)

14+import Data.List (sortBy)

16−import qualified Data.Map.Strict as M

17−import FastString (FastString)

18import GHC hiding (GhcPs, IE)

15import GHC hiding (GhcPs, IE)

19−import GHC.Hs.Extension

16+import HsExtension

20−import GHC.Hs.ImpExp (IE (..))

17+import HsImpExp (IE (..))

21−import Ormolu.Utils (notImplemented, showOutputable)

18+import Ormolu.Utils (notImplemented)

22

19

23−-- | Sort and normalize imports.

20+-- | Sort imports by module name. This also sorts explicit import lists for

21+-- each declaration.

24−normalizeImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]

22+sortImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]

25−normalizeImports =

23+sortImports = sortBy compareIdecl . fmap (fmap sortImportLists)

26− fmap snd

27− . M.toAscList

28− . M.fromListWith combineImports

29− . fmap (\x -> (importId x, g x))

30 where

24 where

31− g (L l ImportDecl {..}) =

25+ sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs

32− L

26+ sortImportLists = \case

33− l

27+ ImportDecl {..} ->

34 ImportDecl

28 ImportDecl

35− { ideclHiding = second (fmap normalizeLies) <$> ideclHiding,

29+ { ideclHiding = second (fmap sortLies) <$> ideclHiding,

36 ..

30 ..

37 }

31 }

38− g _ = notImplemented "XImportDecl"

32+ XImportDecl {} -> notImplemented "XImportDecl"

39

33

40−-- | Combine two import declarations. It should be assumed that 'ImportId's

41−-- are equal.

42−combineImports ::

43− LImportDecl GhcPs ->

44− LImportDecl GhcPs ->

34+-- | Compare two @'LImportDecl' 'GhcPs'@ things.

45− LImportDecl GhcPs

35+compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering

46−combineImports (L lx ImportDecl {..}) (L _ y) =

36+compareIdecl (L _ m0) (L _ m1) =

47− L

37+ case (isPrelude n0, isPrelude n1) of

48− lx

38+ (False, False) -> n0 `compare` n1

49− ImportDecl

39+ (True, False) -> GT

50− { ideclHiding = case (ideclHiding, GHC.ideclHiding y) of

40+ (False, True) -> LT

51− (Just (hiding, L l' xs), Just (_, L _ ys)) ->

41+ (True, True) -> m0 `gcompare` m1

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− }

91 where

42 where

43+ n0 = unLoc (ideclName m0)

44+ n1 = unLoc (ideclName m1)

92− isPrelude = moduleNameString moduleName == "Prelude"

45+ isPrelude = (== "Prelude") . moduleNameString

93− moduleName = unLoc ideclName

94−importId _ = notImplemented "XImportDecl"

95

46

96−-- | Normalize a collection of import\/export items.

47+-- | Sort located import or export.

97−normalizeLies :: [LIE GhcPs] -> [LIE GhcPs]

48+sortLies :: [LIE GhcPs] -> [LIE GhcPs]

98−normalizeLies = sortOn (getIewn . unLoc) . M.elems . foldl' combine M.empty

49+sortLies = sortBy (compareIE `on` unLoc) . fmap (fmap sortThings)

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

151

50

152−-- | A wrapper for @'IEWrappedName' 'RdrName'@ that allows us to define an

51+-- | Sort imports\/exports inside of 'IEThingWith'.

153−-- 'Ord' instance for it.

52+sortThings :: IE GhcPs -> IE GhcPs

154−newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName RdrName)

53+sortThings = \case

155− deriving (Eq)

54+ IEThingWith NoExt x w xs fl ->

55+ IEThingWith NoExt x w (sortBy (compareIewn `on` unLoc) xs) fl

56+ other -> other

156

57

157−instance Ord IEWrappedNameOrd where

58+-- | Compare two located imports or exports.

158− compare (IEWrappedNameOrd x) (IEWrappedNameOrd y) = compareIewn x y

59+compareIE :: IE GhcPs -> IE GhcPs -> Ordering

60+compareIE = compareIewn `on` getIewn

159

61

160-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.

62-- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@.

161−getIewn :: IE GhcPs -> IEWrappedNameOrd

63+getIewn :: IE GhcPs -> IEWrappedName RdrName

162getIewn = \case

64getIewn = \case

163− IEVar NoExtField x -> IEWrappedNameOrd (unLoc x)

65+ IEVar NoExt x -> unLoc x

164− IEThingAbs NoExtField x -> IEWrappedNameOrd (unLoc x)

66+ IEThingAbs NoExt x -> unLoc x

165− IEThingAll NoExtField x -> IEWrappedNameOrd (unLoc x)

67+ IEThingAll NoExt x -> unLoc x

166− IEThingWith NoExtField x _ _ _ -> IEWrappedNameOrd (unLoc x)

68+ IEThingWith NoExt x _ _ _ -> unLoc x

167− IEModuleContents NoExtField _ -> notImplemented "IEModuleContents"

69+ IEModuleContents NoExt _ -> notImplemented "IEModuleContents"

168− IEGroup NoExtField _ _ -> notImplemented "IEGroup"

70+ IEGroup NoExt _ _ -> notImplemented "IEGroup"

169− IEDoc NoExtField _ -> notImplemented "IEDoc"

71+ IEDoc NoExt _ -> notImplemented "IEDoc"

170− IEDocNamed NoExtField _ -> notImplemented "IEDocNamed"

72+ IEDocNamed NoExt _ -> notImplemented "IEDocNamed"

171− XIE x -> noExtCon x

73+ XIE NoExt -> notImplemented "XIE"

172−

173−-- | Like 'compareIewn' for located wrapped names.

174−compareLIewn :: LIEWrappedName RdrName -> LIEWrappedName RdrName -> Ordering

175−compareLIewn = compareIewn `on` unLoc

176

74

177-- | Compare two @'IEWrapppedName' 'RdrName'@ things.

75-- | Compare two @'IEWrapppedName' 'RdrName'@ things.

178compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering

76compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering

179−compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y

77+compareIewn (IEName x) (IEName y) = unLoc x `compare` unLoc y

180compareIewn (IEName _) (IEPattern _) = LT

78compareIewn (IEName _) (IEPattern _) = LT

181compareIewn (IEName _) (IEType _) = LT

79compareIewn (IEName _) (IEType _) = LT

182compareIewn (IEPattern _) (IEName _) = GT

80compareIewn (IEPattern _) (IEName _) = GT

183−compareIewn (IEPattern x) (IEPattern y) = unLoc x `compareRdrName` unLoc y

81+compareIewn (IEPattern x) (IEPattern y) = unLoc x `compare` unLoc y

184compareIewn (IEPattern _) (IEType _) = LT

82compareIewn (IEPattern _) (IEType _) = LT

185compareIewn (IEType _) (IEName _) = GT

83compareIewn (IEType _) (IEName _) = GT

186compareIewn (IEType _) (IEPattern _) = GT

84compareIewn (IEType _) (IEPattern _) = GT

187−compareIewn (IEType x) (IEType y) = unLoc x `compareRdrName` unLoc y

85+compareIewn (IEType x) (IEType y) = unLoc x `compare` 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+84−78

@@ -9,16 +9,14 @@ module Ormolu.Parser

9 )

10where

11

12−import Bag (bagToList)

13import qualified CmdLineParser as GHC

12import qualified CmdLineParser as GHC

14import Control.Exception

13import Control.Exception

14+import Control.Monad

15import Control.Monad.IO.Class

16−import qualified Data.List as L

16+import Data.List ((\\), foldl', isPrefixOf)

17import qualified Data.List.NonEmpty as NE

18−import Data.Ord (Down (Down))

18+import Data.Maybe (catMaybes)

19−import qualified Data.Text as T

20import DynFlags as GHC

19import DynFlags as GHC

21−import ErrUtils (Severity (..), errMsgSeverity, errMsgSpan)

22import qualified FastString as GHC

20import qualified FastString as GHC

23import GHC hiding (IE, UnicodeSyntax)

21import GHC hiding (IE, UnicodeSyntax)

24import GHC.DynFlags (baseDynFlags)

22import GHC.DynFlags (baseDynFlags)

@@ -31,8 +29,7 @@ import Ormolu.Exception

31import Ormolu.Parser.Anns

29import Ormolu.Parser.Anns

32import Ormolu.Parser.CommentStream

30import Ormolu.Parser.CommentStream

33import Ormolu.Parser.Result

31import Ormolu.Parser.Result

34−import Ormolu.Processing.Preprocess (preprocess)

32+import qualified Outputable as GHC

35−import Ormolu.Utils (incSpanLine, removeIndentation)

36import qualified Panic as GHC

33import qualified Panic as GHC

37import qualified Parser as GHC

34import qualified Parser as GHC

38import qualified StringBuffer as GHC

35import qualified StringBuffer as GHC

@@ -41,7 +38,7 @@ import qualified StringBuffer as GHC

41parseModule ::

38parseModule ::

42 MonadIO m =>

39 MonadIO m =>

43 -- | Ormolu configuration

40 -- | Ormolu configuration

44− Config RegionDeltas ->

41+ Config ->

45 -- | File name (only for source location annotations)

42 -- | File name (only for source location annotations)

46 FilePath ->

43 FilePath ->

47 -- | Input for parser

44 -- | Input for parser

@@ -50,10 +47,8 @@ parseModule ::

50 ( [GHC.Warn],

47 ( [GHC.Warn],

51 Either (SrcSpan, String) ParseResult

48 Either (SrcSpan, String) ParseResult

52 )

49 )

53−parseModule Config {..} path rawInput = liftIO $ do

50+parseModule Config {..} path input' = liftIO $ do

54− let (literalPrefix, indentedInput, literalSuffix, extraComments) =

51+ let (input, extraComments) = extractCommentsFromLines path input'

55− preprocess path rawInput cfgRegion

56− (input, indent) = removeIndentation indentedInput

57 -- It's important that 'setDefaultExts' is done before

52 -- It's important that 'setDefaultExts' is done before

58 -- 'parsePragmasIntoDynFlags', because otherwise we might enable an

53 -- 'parsePragmasIntoDynFlags', because otherwise we might enable an

59 -- extension that was explicitly disabled in the file.

54 -- extension that was explicitly disabled in the file.

@@ -63,7 +58,7 @@ parseModule Config {..} path rawInput = liftIO $ do

63 (setDefaultExts baseDynFlags)

58 (setDefaultExts baseDynFlags)

64 extraOpts = dynOptionToLocatedStr <$> cfgDynOptions

59 extraOpts = dynOptionToLocatedStr <$> cfgDynOptions

65 (warnings, dynFlags) <-

60 (warnings, dynFlags) <-

66− parsePragmasIntoDynFlags baseFlags extraOpts path rawInput >>= \case

61+ parsePragmasIntoDynFlags baseFlags extraOpts path input' >>= \case

67 Right res -> pure res

62 Right res -> pure res

68 Left err ->

63 Left err ->

69 let loc =

64 let loc =

@@ -71,59 +66,29 @@ parseModule Config {..} path rawInput = liftIO $ do

71 (mkSrcLoc (GHC.mkFastString path) 1 1)

66 (mkSrcLoc (GHC.mkFastString path) 1 1)

72 (mkSrcLoc (GHC.mkFastString path) 1 1)

67 (mkSrcLoc (GHC.mkFastString path) 1 1)

73 in throwIO (OrmoluParsingFailed loc err)

68 in throwIO (OrmoluParsingFailed loc err)

69+ when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $

70+ throwIO (OrmoluCppEnabled path)

74 let useRecordDot =

71 let useRecordDot =

75 "record-dot-preprocessor" == pgm_F dynFlags

72 "record-dot-preprocessor" == pgm_F dynFlags

76 || any

73 || any

77 (("RecordDotPreprocessor" ==) . moduleNameString)

74 (("RecordDotPreprocessor" ==) . moduleNameString)

78 (pluginModNames dynFlags)

75 (pluginModNames dynFlags)

79− pStateErrors = \pstate ->

80− let errs = bagToList $ GHC.getErrorMessages pstate dynFlags

81− fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion)

82− in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of

83− [] -> Nothing

84− err : _ ->

85− -- Show instance returns a short error message

86− Just (fixupErrSpan (errMsgSpan err), show err)

87 r = case runParser GHC.parseModule dynFlags path input of

76 r = case runParser GHC.parseModule dynFlags path input of

88− GHC.PFailed pstate ->

77+ GHC.PFailed _ ss m ->

89− case pStateErrors pstate of

78+ Left (ss, GHC.showSDoc dynFlags m)

90− Just err -> Left err

91− Nothing -> error "PFailed does not have an error"

92− GHC.POk pstate (L _ hsModule) ->

79+ GHC.POk pstate pmod ->

93− case pStateErrors pstate of

94− -- Some parse errors (pattern/arrow syntax in expr context)

95− -- do not cause a parse error, but they are replaced with "_"

96− -- by the parser and the modified AST is propagated to the

97− -- later stages; but we fail in those cases.

98− Just err -> Left err

99− Nothing ->

100− let (stackHeader, shebangs, pragmas, comments) =

101− mkCommentStream input extraComments pstate

80+ let (comments, exts, shebangs) = mkCommentStream extraComments pstate

102− in Right

81+ in Right

103− ParseResult

82+ ParseResult

104− { prParsedSource = hsModule,

83+ { prParsedSource = pmod,

105− prAnns = mkAnns pstate,

84+ prAnns = mkAnns pstate,

106− prStackHeader = stackHeader,

85+ prCommentStream = comments,

86+ prExtensions = exts,

107− prShebangs = shebangs,

87+ prShebangs = shebangs,

108− prPragmas = pragmas,

109− prCommentStream = comments,

110− prUseRecordDot = useRecordDot,

88+ prUseRecordDot = useRecordDot

111− prImportQualifiedPost =

112− GHC.xopt ImportQualifiedPost dynFlags,

113− prLiteralPrefix = T.pack literalPrefix,

114− prLiteralSuffix = T.pack literalSuffix,

115− prIndent = indent

116− }

89+ }

117 return (warnings, r)

90 return (warnings, r)

118

91

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−

127-- | Extensions that are not enabled automatically and should be activated

92-- | Extensions that are not enabled automatically and should be activated

128-- by user.

93-- by user.

129manualExts :: [Extension]

94manualExts :: [Extension]

@@ -143,13 +108,14 @@ manualExts =

143 MonadComprehensions,

108 MonadComprehensions,

144 UnboxedSums,

109 UnboxedSums,

145 UnicodeSyntax, -- gives special meanings to operators like (→)

110 UnicodeSyntax, -- gives special meanings to operators like (→)

146− TemplateHaskellQuotes, -- enables TH subset of quasi-quotes, this

111+ TemplateHaskellQuotes -- enables TH subset of quasi-quotes, this

147 -- apparently interferes with QuasiQuotes in

112 -- apparently interferes with QuasiQuotes in

148 -- weird ways

113 -- weird ways

149− ImportQualifiedPost -- affects how Ormolu renders imports, so the

150− -- decision of enabling this style is left to the user

151 ]

114 ]

152

115

116+----------------------------------------------------------------------------

117+-- Helpers (taken from ghc-exactprint)

118+

153-- | Run a 'GHC.P' computation.

119-- | Run a 'GHC.P' computation.

154runParser ::

120runParser ::

155 -- | Computation to run

121 -- | Computation to run

@@ -168,27 +134,67 @@ runParser parser flags filename input = GHC.unP parser parseState

168 buffer = GHC.stringToStringBuffer input

134 buffer = GHC.stringToStringBuffer input

169 parseState = GHC.mkPState flags buffer location

135 parseState = GHC.mkPState flags buffer location

170

136

171−-- | Wrap GHC's 'Severity' to add 'Ord' instance.

137+-- | Transform given lines possibly returning comments extracted from them.

172−newtype SeverityOrd = SeverityOrd Severity

138+-- This handles LINE pragmas and shebangs.

139+extractCommentsFromLines ::

140+ -- | File name, just to use in the spans

141+ FilePath ->

142+ -- | List of lines from that file

143+ String ->

144+ -- | Adjusted lines together with comments extracted from them

145+ (String, [Located String])

146+extractCommentsFromLines path =

147+ unlines' . unzip . zipWith (extractCommentFromLine path) [1 ..] . lines

148+ where

149+ unlines' (a, b) = (unlines a, catMaybes b)

173

150

174−instance Eq SeverityOrd where

151+-- | Transform a given line possibly returning a comment extracted from it.

175− s1 == s2 = compare s1 s2 == EQ

152+extractCommentFromLine ::

153+ -- | File name, just to use in the spans

154+ FilePath ->

155+ -- | Line number of this line

156+ Int ->

157+ -- | The actual line

158+ String ->

159+ -- | Adjusted line and possibly a comment extracted from it

160+ (String, Maybe (Located String))

161+extractCommentFromLine path line s

162+ | "{-# LINE" `isPrefixOf` s =

163+ let (pragma, res) = getPragma s

164+ size = length pragma

165+ ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))

166+ in (res, Just $ L ss pragma)

167+ | isShebang s =

168+ let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length s))

169+ in ("", Just $ L ss s)

170+ | otherwise = (s, Nothing)

171+ where

172+ mkSrcLoc' = mkSrcLoc (GHC.mkFastString path) line

173+

174+-- | Take a line pragma and output its replacement (where line pragma is

175+-- replaced with spaces) and the contents of the pragma itself.

176+getPragma ::

177+ -- | Pragma line to analyze

178+ String ->

179+ -- | Contents of the pragma and its replacement line

180+ (String, String)

181+getPragma [] = error "Ormolu.Parser.getPragma: input must not be empty"

182+getPragma s@(x : xs)

183+ | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)

184+ | otherwise =

185+ let (prag, remline) = getPragma xs

186+ in (x : prag, ' ' : remline)

176

187

177−instance Ord SeverityOrd where

188+-- | Enable all language extensions that we think should be enabled by

178− compare (SeverityOrd s1) (SeverityOrd s2) =

189+-- default for ease of use.

179− compare (f s1) (f s2)

190+setDefaultExts :: DynFlags -> DynFlags

180− where

191+setDefaultExts flags = foldl' GHC.xopt_set flags autoExts

181− f :: Severity -> Int

192+ where

182− f SevOutput = 1

193+ autoExts = allExts \\ manualExts

183− f SevFatal = 2

194+ allExts = [minBound .. maxBound]

184− f SevInteractive = 3

185− f SevDump = 4

186− f SevInfo = 5

187− f SevWarning = 6

188− f SevError = 7

189

195

190----------------------------------------------------------------------------

196----------------------------------------------------------------------------

191−-- Helpers taken from HLint

197+-- More helpers (taken from HLint)

192

198

193parsePragmasIntoDynFlags ::

199parsePragmasIntoDynFlags ::

194 -- | Pre-set 'DynFlags'

200 -- | Pre-set 'DynFlags'

src/Ormolu/Parser/CommentStream.hs+61−147

@@ -4,74 +4,78 @@

4

5-- | Functions for working with comment stream.

6module Ormolu.Parser.CommentStream

7− ( -- * Comment stream

8− CommentStream (..),

7+ ( CommentStream (..),

9− mkCommentStream,

10− showCommentStream,

11−

12− -- * Comment

13 Comment (..),

8 Comment (..),

14− unComment,

9+ mkCommentStream,

15− hasAtomsBefore,

10+ isShebang,

11+ isPrevHaddock,

16 isMultilineComment,

12 isMultilineComment,

13+ showCommentStream,

17 )

14 )

18where

15where

19

16

20import Data.Char (isSpace)

17import Data.Char (isSpace)

21import Data.Data (Data)

18import Data.Data (Data)

22−import qualified Data.List as L

19+import Data.Either (partitionEithers)

20+import Data.List (dropWhileEnd, isPrefixOf, sortOn)

23import Data.List.NonEmpty (NonEmpty (..))

21import Data.List.NonEmpty (NonEmpty (..))

24import qualified Data.List.NonEmpty as NE

22import qualified Data.List.NonEmpty as NE

25import Data.Maybe (mapMaybe)

23import Data.Maybe (mapMaybe)

26import qualified GHC

24import qualified GHC

27import qualified Lexer as GHC

25import qualified Lexer as GHC

28import Ormolu.Parser.Pragma

26import Ormolu.Parser.Pragma

29−import Ormolu.Parser.Shebang

30−import Ormolu.Processing.Common

31−import Ormolu.Utils (onTheSameLine, showOutputable)

27+import Ormolu.Utils (showOutputable)

32import SrcLoc

28import SrcLoc

33

29

34−----------------------------------------------------------------------------

35−-- Comment stream

36−

37-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to

30-- | A stream of 'RealLocated' 'Comment's in ascending order with respect to

38-- beginning of corresponding spans.

31-- beginning of corresponding spans.

39newtype CommentStream = CommentStream [RealLocated Comment]

32newtype CommentStream = CommentStream [RealLocated Comment]

40 deriving (Eq, Data, Semigroup, Monoid)

33 deriving (Eq, Data, Semigroup, Monoid)

41

34

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+

42-- | Create 'CommentStream' from 'GHC.PState'. The pragmas and shebangs are

40-- | Create 'CommentStream' from 'GHC.PState'. The pragmas and shebangs are

43-- removed from the 'CommentStream'. Shebangs are only extracted from the

41-- removed from the 'CommentStream'. Shebangs are only extracted from the

44-- comments that come from the first argument.

42-- comments that come from the first argument.

45mkCommentStream ::

43mkCommentStream ::

46− -- | Original input

47− String ->

48 -- | Extra comments to include

44 -- | Extra comments to include

49 [Located String] ->

45 [Located String] ->

50 -- | Parser state to use for comment extraction

46 -- | Parser state to use for comment extraction

51 GHC.PState ->

47 GHC.PState ->

52− -- | Stack header, shebangs, pragmas, and comment stream

48+ -- | Comment stream, a set of extracted pragmas, and extracted shebangs

53− ( Maybe (RealLocated Comment),

49+ (CommentStream, [Pragma], [Located String])

54− [Shebang],

55− [([RealLocated Comment], Pragma)],

56− CommentStream

57− )

58−mkCommentStream input extraComments pstate =

50+mkCommentStream extraComments pstate =

59− ( mstackHeader,

51+ ( CommentStream $

60− shebangs,

52+ mkComment <$> sortOn (realSrcSpanStart . getRealSrcSpan) comments,

61 pragmas,

53 pragmas,

62− CommentStream comments

54+ shebangs

63 )

55 )

64 where

56 where

65− (comments, pragmas) = extractPragmas input rawComments1

57+ (comments, pragmas) = partitionEithers (partitionComments <$> rawComments)

66− (rawComments1, mstackHeader) = extractStackHeader rawComments0

58+ rawComments =

67− rawComments0 =

68− L.sortOn (realSrcSpanStart . getRealSrcSpan) . mapMaybe toRealSpan $

59+ mapMaybe toRealSpan $

69 otherExtraComments

60 otherExtraComments

70 ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)

61 ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate)

71 ++ concatMap

62 ++ concatMap

72 (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)

63 (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd)

73 (GHC.annotations_comments pstate)

64 (GHC.annotations_comments pstate)

74− (shebangs, otherExtraComments) = extractShebangs extraComments

65+ (shebangs, otherExtraComments) = span (isShebang . unLoc) 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

75

79

76-- | Pretty-print a 'CommentStream'.

80-- | Pretty-print a 'CommentStream'.

77showCommentStream :: CommentStream -> String

81showCommentStream :: CommentStream -> String

@@ -82,117 +86,28 @@ showCommentStream (CommentStream xs) =

82 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str

86 showComment (GHC.L l str) = showOutputable l ++ " " ++ show str

83

87

84----------------------------------------------------------------------------

88----------------------------------------------------------------------------

85−-- Comment

89+-- Helpers

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)

93

90

94-- | Normalize comment string. Sometimes one multi-line comment is turned

91-- | Normalize comment string. Sometimes one multi-line comment is turned

95-- into several lines for subsequent outputting with correct indentation for

92-- into several lines for subsequent outputting with correct indentation for

96-- each line.

93-- each line.

97−mkComment ::

94+mkComment :: RealLocated String -> RealLocated Comment

98− -- | Lines of original input with their indices

95+mkComment (L l s) =

99− [(Int, String)] ->

96+ L l . Comment . fmap dropTrailing $

100− -- | Raw comment string

97+ if "{-" `isPrefixOf` s

101− RealLocated String ->

98+ then case NE.nonEmpty (lines s) of

102− -- | Remaining lines of original input and the constructed 'Comment'

99+ Nothing -> s :| []

103− ([(Int, String)], RealLocated Comment)

100+ Just (x :| xs) ->

104−mkComment ls (L l s) = (ls', comment)

101+ let getIndent y =

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 :| []

105 where

108 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'')

131− dropTrailing = L.dropWhileEnd isSpace

109+ dropTrailing = dropWhileEnd isSpace

132 startIndent = srcSpanStartCol l - 1

110 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

196

111

197-- | Get a 'String' from 'GHC.AnnotationComment'.

112-- | Get a 'String' from 'GHC.AnnotationComment'.

198unAnnotationComment :: GHC.AnnotationComment -> Maybe String

113unAnnotationComment :: GHC.AnnotationComment -> Maybe String

@@ -214,13 +129,12 @@ toRealSpan :: Located a -> Maybe (RealLocated a)

214toRealSpan (L (RealSrcSpan l) a) = Just (L l a)

129toRealSpan (L (RealSrcSpan l) a) = Just (L l a)

215toRealSpan _ = Nothing

130toRealSpan _ = Nothing

216

131

217−-- | Remove consecutive blank lines.

132+-- | If a given comment is a pragma, return it in parsed form in 'Right'.

218−removeConseqBlanks :: NonEmpty String -> NonEmpty String

133+-- Otherwise return the original comment unchanged.

219−removeConseqBlanks (x :| xs) = x :| go (null x) id xs

134+partitionComments ::

220− where

135+ RealLocated String ->

221− go seenBlank acc = \case

136+ Either (RealLocated String) Pragma

222− [] -> acc []

137+partitionComments input =

223− (y : ys) ->

138+ case parsePragma (unRealSrcSpan input) of

224− if seenBlank && null y

139+ Nothing -> Left input

225− then go True acc ys

140+ Just pragma -> Right pragma

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 qualified Data.List as L

13+import Data.List

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 <- L.stripPrefix "{-#" input

38+ inputNoPrefix <- stripPrefix "{-#" input

39− guard ("#-}" `L.isSuffixOf` input)

39+ guard ("#-}" `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 = L.dropWhileEnd isSpace . dropWhile isSpace

49+ trimSpaces = 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+15−26

@@ -7,38 +7,27 @@ module Ormolu.Parser.Result

7 )

8where

9

10−import Data.Text (Text)

11import GHC

10import GHC

12import Ormolu.Parser.Anns

11import Ormolu.Parser.Anns

13import Ormolu.Parser.CommentStream

12import Ormolu.Parser.CommentStream

14import Ormolu.Parser.Pragma (Pragma)

13import Ormolu.Parser.Pragma (Pragma)

15−import Ormolu.Parser.Shebang (Shebang)

16

14

17-- | A collection of data that represents a parsed module in Ormolu.

15-- | A collection of data that represents a parsed module in Ormolu.

18−data ParseResult = ParseResult

16+data ParseResult

17+ = ParseResult

19− { -- | 'ParsedSource' from GHC

18+ { -- | 'ParsedSource' from GHC

20− prParsedSource :: HsModule GhcPs,

19+ prParsedSource :: ParsedSource,

21− -- | Ormolu-specfic representation of annotations

20+ -- | Ormolu-specfic representation of annotations

22− prAnns :: Anns,

21+ prAnns :: Anns,

23− -- | Stack header

22+ -- | Comment stream

24− prStackHeader :: Maybe (RealLocated Comment),

23+ prCommentStream :: CommentStream,

24+ -- | Extensions enabled in that module

25+ prExtensions :: [Pragma],

25− -- | Shebangs found in the input

26+ -- | Shebangs found in the input

26− prShebangs :: [Shebang],

27+ prShebangs :: [Located String],

27− -- | Pragmas and the associated comments

28− prPragmas :: [([RealLocated Comment], Pragma)],

29− -- | Comment stream

30− prCommentStream :: CommentStream,

31− -- | Whether or not record dot syntax is enabled

28+ -- | Whether or not record dot syntax is enabled

32− prUseRecordDot :: Bool,

29+ prUseRecordDot :: Bool

33− -- | Whether or not ImportQualifiedPost is enabled

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

41− }

30+ }

42

31

43-- | Pretty-print a 'ParseResult'.

32-- | Pretty-print a 'ParseResult'.

44prettyPrintParseResult :: ParseResult -> String

33prettyPrintParseResult :: ParseResult -> String

src/Ormolu/Parser/Shebang.hsdeleted−27

@@ -1,27 +0,0 @@

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+6−17

@@ -11,7 +11,6 @@ import Ormolu.Parser.Result

11import Ormolu.Printer.Combinators

12import Ormolu.Printer.Meat.Module

13import Ormolu.Printer.SpanStream

14−import Ormolu.Processing.Postprocess (postprocess)

15

14

16-- | Render a module.

15-- | Render a module.

17printModule ::

16printModule ::

@@ -20,19 +19,9 @@ printModule ::

20 -- | Resulting rendition

19 -- | Resulting rendition

21 Text

20 Text

22printModule ParseResult {..} =

21printModule ParseResult {..} =

23− prLiteralPrefix <> region <> prLiteralSuffix

24− where

25− region =

26− postprocess prIndent $

27− runR

22+ runR

28− ( p_hsModule

29− prStackHeader

30− prShebangs

31− prPragmas

32− prImportQualifiedPost

33− prParsedSource

23+ (p_hsModule prShebangs prExtensions prParsedSource)

34− )

35− (mkSpanStream prParsedSource)

24+ (mkSpanStream prParsedSource)

36− prCommentStream

25+ prCommentStream

37− prAnns

26+ prAnns

38− prUseRecordDot

27+ prUseRecordDot

src/Ormolu/Printer/Combinators.hs+53−39

@@ -21,9 +21,9 @@ module Ormolu.Printer.Combinators

21 space,

22 newline,

23 inci,

24− inciIf,

25 located,

24 located,

26 located',

25 located',

26+ locatedPat,

27 switchLayout,

28 Layout (..),

29 vlayout,

@@ -52,57 +52,58 @@ module Ormolu.Printer.Combinators

52

53 -- ** Literals

54 comma,

55− commaDel,

56− equals,

57

55

58− -- ** Stateful markers

56+ -- ** Comments

59− SpanMark (..),

60− spanMarkSpan,

61 HaddockStyle (..),

57 HaddockStyle (..),

62− setSpanMark,

58+ setLastCommentSpan,

63− getSpanMark,

59+ getLastCommentSpan,

64 )

60 )

65where

61where

66

62

67import Control.Monad

63import Control.Monad

64+import Data.Data (Data)

68import Data.List (intersperse)

65import Data.List (intersperse)

69import Data.Text (Text)

66import Data.Text (Text)

67+import GHC (Pat (XPat), XXPat)

70import Ormolu.Printer.Comments

68import Ormolu.Printer.Comments

71import Ormolu.Printer.Internal

69import Ormolu.Printer.Internal

70+import Ormolu.Utils (isModule)

72import SrcLoc

71import SrcLoc

73

72

74----------------------------------------------------------------------------

73----------------------------------------------------------------------------

75-- Basic

74-- Basic

76

75

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−

86-- | Enter a 'Located' entity. This combinator handles outputting comments

76-- | Enter a 'Located' entity. This combinator handles outputting comments

87-- and sets layout (single-line vs multi-line) for the inner computation.

77-- and sets layout (single-line vs multi-line) for the inner computation.

88-- Roughly, the rule for using 'located' is that every time there is a

78-- Roughly, the rule for using 'located' is that every time there is a

89-- 'Located' wrapper, it should be “discharged” with a corresponding

79-- 'Located' wrapper, it should be “discharged” with a corresponding

90-- 'located' invocation.

80-- 'located' invocation.

91located ::

81located ::

82+ Data a =>

92 -- | Thing to enter

83 -- | Thing to enter

93 Located a ->

84 Located a ->

94 -- | How to render inner value

85 -- | How to render inner value

95 (a -> R ()) ->

86 (a -> R ()) ->

96 R ()

87 R ()

97−located (L (UnhelpfulSpan _) a) f = f a

88+located loc f = do

98−located (L (RealSrcSpan l) a) f = do

89+ let withRealLocated (L l a) g =

90+ case l of

91+ UnhelpfulSpan _ -> return ()

92+ RealSrcSpan l' -> g (L l' a)

99− spitPrecedingComments l

93+ withRealLocated loc spitPrecedingComments

94+ let setEnclosingSpan =

95+ case getLoc loc of

96+ UnhelpfulSpan _ -> id

97+ RealSrcSpan orf ->

98+ if isModule (unLoc loc)

99+ then id

100− withEnclosingSpan l $

100+ else withEnclosingSpan orf

101− switchLayout [RealSrcSpan l] (f a)

101+ setEnclosingSpan $ switchLayout [getLoc loc] (f (unLoc loc))

102− spitFollowingComments l

102+ withRealLocated loc spitFollowingComments

103

104-- | A version of 'located' with arguments flipped.

105located' ::

106+ Data a =>

106 -- | How to render inner value

107 -- | How to render inner value

107 (a -> R ()) ->

108 (a -> R ()) ->

108 -- | Thing to enter

109 -- | Thing to enter

@@ -110,6 +111,28 @@ located' ::

110 R ()

111 R ()

111located' = flip located

112located' = flip located

112

113

114+-- | A version of 'located' that works on 'Pat'.

115+--

116+-- Starting from GHC 8.8, @'LPat' == 'Pat'@. Located 'Pat's are always

117+-- constructed with the 'XPat' constructor, containing a @'Located' 'Pat'@.

118+--

119+-- Most of the time, we can just use 'p_pat' directly, because it handles

120+-- located 'Pat's. However, sometimes we want to use the location to render

121+-- something other than the given 'Pat'.

122+--

123+-- If given 'Pat' does not contain a location, we error out.

124+--

125+-- This should become unnecessary if

126+-- <https://gitlab.haskell.org/ghc/ghc/issues/17330> is ever fixed.

127+locatedPat ::

128+ (Data (Pat pass), XXPat pass ~ Located (Pat pass)) =>

129+ Pat pass ->

130+ (Pat pass -> R ()) ->

131+ R ()

132+locatedPat p f = case p of

133+ XPat pat -> located pat f

134+ _ -> error "locatedPat: Pat does not contain a location"

135+

113-- | Set layout according to combination of given 'SrcSpan's for a given.

136-- | Set layout according to combination of given 'SrcSpan's for a given.

114-- Use this only when you need to set layout based on e.g. combined span of

137-- Use this only when you need to set layout based on e.g. combined span of

115-- several elements when there is no corresponding 'Located' wrapper

138-- several elements when there is no corresponding 'Located' wrapper

@@ -185,12 +208,10 @@ sepSemi f xs = vlayout singleLine multiLine

185 xs' ->

208 xs' ->

186 if ub

209 if ub

187 then do

210 then do

188− txt "{"

211+ txt "{ "

189− space

190− sep (txt ";" >> space) (dontUseBraces . f) xs'

212+ sep (txt "; ") (dontUseBraces . f) xs'

191− space

192− txt "}"

213+ txt " }"

193− else sep (txt ";" >> space) f xs'

214+ else sep (txt "; ") f xs'

194 multiLine =

215 multiLine =

195 sep newline (dontUseBraces . f) xs

216 sep newline (dontUseBraces . f) xs

196

217

@@ -203,7 +224,6 @@ data BracketStyle

203 N

224 N

204 | -- | Shifted one level

225 | -- | Shifted one level

205 S

226 S

206− deriving (Eq, Show)

207

227

208-- | Surround given entity by backticks.

228-- | Surround given entity by backticks.

209backticks :: R () -> R ()

229backticks :: R () -> R ()

@@ -280,7 +300,9 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)

280 then newline >> inci m

300 then newline >> inci m

281 else space >> sitcc m

301 else space >> sitcc m

282 newline

302 newline

303+ case style of

304+ N -> txt close

283− inciIf (style == S) (txt close)

305+ S -> inci (txt close)

284

306

285----------------------------------------------------------------------------

307----------------------------------------------------------------------------

286-- Literals

308-- Literals

@@ -288,11 +310,3 @@ brackets_ needBreaks open close style m = sitcc (vlayout singleLine multiLine)

288-- | Print @,@.

310-- | Print @,@.

289comma :: R ()

311comma :: R ()

290comma = txt ","

312comma = 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+76−62

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

1−{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

3

2

4-- | Helpers for formatting of comments. This is low-level code, use

3-- | Helpers for formatting of comments. This is low-level code, use

@@ -7,17 +6,21 @@ module Ormolu.Printer.Comments

7 ( spitPrecedingComments,

6 ( spitPrecedingComments,

8 spitFollowingComments,

7 spitFollowingComments,

9 spitRemainingComments,

8 spitRemainingComments,

10− spitCommentNow,

9+ spitStackHeader,

11− spitCommentPending,

12 )

10 )

13where

11where

14

12

15import Control.Monad

13import Control.Monad

14+import Data.Char (isSpace)

15+import Data.Coerce (coerce)

16+import Data.Data (Data)

17+import Data.List (isPrefixOf)

16import qualified Data.List.NonEmpty as NE

18import qualified Data.List.NonEmpty as NE

17−import Data.Maybe (listToMaybe)

19+import Data.List.NonEmpty (NonEmpty (..))

18import qualified Data.Text as T

20import qualified Data.Text as T

19import Ormolu.Parser.CommentStream

21import Ormolu.Parser.CommentStream

20import Ormolu.Printer.Internal

22import Ormolu.Printer.Internal

23+import Ormolu.Utils (isModule)

21import SrcLoc

24import SrcLoc

22

25

23----------------------------------------------------------------------------

26----------------------------------------------------------------------------

@@ -25,91 +28,108 @@ import SrcLoc

25

28

26-- | Output all preceding comments for an element at given location.

29-- | Output all preceding comments for an element at given location.

27spitPrecedingComments ::

30spitPrecedingComments ::

31+ Data a =>

28− -- | Span of the element to attach comments to

32+ -- | AST element to attach comments to

29− RealSrcSpan ->

33+ RealLocated a ->

30 R ()

34 R ()

31spitPrecedingComments ref = do

35spitPrecedingComments ref = do

32 gotSome <- handleCommentSeries (spitPrecedingComment ref)

36 gotSome <- handleCommentSeries (spitPrecedingComment ref)

33 when gotSome $ do

37 when gotSome $ do

34− lastMark <- getSpanMark

35 -- Insert a blank line between the preceding comments and the thing

38 -- Insert a blank line between the preceding comments and the thing

36 -- after them if there was a blank line in the input.

39 -- after them if there was a blank line in the input.

40+ lastSpn <- fmap snd <$> getLastCommentSpan

37− when (needsNewlineBefore ref lastMark) newline

41+ when (needsNewlineBefore (getRealSrcSpan ref) lastSpn) newline

38

42

39-- | Output all comments following an element at given location.

43-- | Output all comments following an element at given location.

40spitFollowingComments ::

44spitFollowingComments ::

45+ Data a =>

41− -- | Span of the element to attach comments to

46+ -- | AST element of attach comments to

42− RealSrcSpan ->

47+ RealLocated a ->

43 R ()

48 R ()

44spitFollowingComments ref = do

49spitFollowingComments ref = do

45− trimSpanStream ref

50+ trimSpanStream (getRealSrcSpan ref)

46 void $ handleCommentSeries (spitFollowingComment ref)

51 void $ handleCommentSeries (spitFollowingComment ref)

47

52

48-- | Output all remaining comments in the comment stream.

53-- | Output all remaining comments in the comment stream.

49spitRemainingComments :: R ()

54spitRemainingComments :: R ()

50−spitRemainingComments = do

51− -- Make sure we have a blank a line between the last definition and the

52− -- trailing comments.

53− newline

54− void $ handleCommentSeries spitRemainingComment

55+spitRemainingComments = 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

55

66

56----------------------------------------------------------------------------

67----------------------------------------------------------------------------

57-- Single-comment functions

68-- Single-comment functions

58

69

59-- | Output a single preceding comment for an element at given location.

70-- | Output a single preceding comment for an element at given location.

60spitPrecedingComment ::

71spitPrecedingComment ::

72+ Data a =>

61− -- | Span of the element to attach comments to

73+ -- | AST element to attach comments to

74+ RealLocated a ->

75+ -- | Location of last comment in the series

62− RealSrcSpan ->

76+ Maybe RealSrcSpan ->

63 -- | Are we done?

77 -- | Are we done?

64 R Bool

78 R Bool

65−spitPrecedingComment ref = do

79+spitPrecedingComment (L ref a) mlastSpn = do

66− mlastMark <- getSpanMark

67 let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref

80 let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref

68 withPoppedComment p $ \l comment -> do

81 withPoppedComment p $ \l comment -> do

69− lineSpans <- thisLineSpans

82+ dirtyLine <-

70− let thisCommentLine = srcLocLine (realSrcSpanStart l)

83+ case mlastSpn of

71− needsNewline =

84+ -- When the current line is dirty it means that something that can

72− case listToMaybe lineSpans of

85+ -- have comments attached to it is already on the line. To avoid

73− Nothing -> False

86+ -- problems with idempotence we cannot output the first comment

74− Just spn -> srcLocLine (realSrcSpanEnd spn) /= thisCommentLine

87+ -- immediately because it'll be attached to the previous element (on

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

75− when (needsNewline || needsNewlineBefore l mlastMark) newline

92+ when (dirtyLine || needsNewlineBefore l mlastSpn) newline

76 spitCommentNow l comment

93 spitCommentNow l comment

77− if theSameLinePre l ref

94+ if theSameLinePre l ref && not (isModule a)

78 then space

95 then space

79 else newline

96 else newline

80

97

81-- | Output a comment that follows element at given location immediately on

98-- | Output a comment that follows element at given location immediately on

82-- the same line, if there is any.

99-- the same line, if there is any.

83spitFollowingComment ::

100spitFollowingComment ::

101+ Data a =>

84 -- | AST element to attach comments to

102 -- | AST element to attach comments to

103+ RealLocated a ->

104+ -- | Location of last comment in the series

85− RealSrcSpan ->

105+ Maybe RealSrcSpan ->

86 -- | Are we done?

106 -- | Are we done?

87 R Bool

107 R Bool

88−spitFollowingComment ref = do

108+spitFollowingComment (L ref a) mlastSpn = do

89− mlastMark <- getSpanMark

90 mnSpn <- nextEltSpan

109 mnSpn <- nextEltSpan

91 -- Get first enclosing span that is not equal to reference span, i.e. it's

110 -- Get first enclosing span that is not equal to reference span, i.e. it's

92 -- truly something enclosing the AST element.

111 -- truly something enclosing the AST element.

93 meSpn <- getEnclosingSpan (/= ref)

112 meSpn <- getEnclosingSpan (/= ref)

94− withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastMark) $ \l comment ->

113+ withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastSpn) $ \l comment ->

95− if theSameLinePost l ref

114+ if theSameLinePost l ref && not (isModule a)

96 then

115 then

97 if isMultilineComment comment

116 if isMultilineComment comment

98 then space >> spitCommentNow l comment

117 then space >> spitCommentNow l comment

99 else spitCommentPending OnTheSameLine l comment

118 else spitCommentPending OnTheSameLine l comment

100 else do

119 else do

101− when (needsNewlineBefore l mlastMark) $

120+ when (needsNewlineBefore l mlastSpn) $

102 registerPendingCommentLine OnNextLine ""

121 registerPendingCommentLine OnNextLine ""

103 spitCommentPending OnNextLine l comment

122 spitCommentPending OnNextLine l comment

104

123

105-- | Output a single remaining comment from the comment stream.

124-- | Output a single remaining comment from the comment stream.

106spitRemainingComment ::

125spitRemainingComment ::

126+ -- | Location of last comment in the series

127+ Maybe RealSrcSpan ->

107 -- | Are we done?

128 -- | Are we done?

108 R Bool

129 R Bool

109−spitRemainingComment = do

130+spitRemainingComment mlastSpn =

110− mlastMark <- getSpanMark

111 withPoppedComment (const True) $ \l comment -> do

131 withPoppedComment (const True) $ \l comment -> do

112− when (needsNewlineBefore l mlastMark) newline

132+ when (needsNewlineBefore l mlastSpn) newline

113 spitCommentNow l comment

133 spitCommentNow l comment

114 newline

134 newline

115

135

@@ -120,13 +140,13 @@ spitRemainingComment = do

120handleCommentSeries ::

140handleCommentSeries ::

121 -- | Given location of previous comment, output the next comment

141 -- | Given location of previous comment, output the next comment

122 -- returning 'True' if we're done

142 -- returning 'True' if we're done

123− R Bool ->

143+ (Maybe RealSrcSpan -> R Bool) ->

124 -- | Whether we printed any comments

144 -- | Whether we printed any comments

125 R Bool

145 R Bool

126handleCommentSeries f = go False

146handleCommentSeries f = go False

127 where

147 where

128 go gotSome = do

148 go gotSome = do

129− done <- f

149+ done <- getLastCommentSpan >>= f . fmap snd

130 if done

150 if done

131 then return gotSome

151 then return gotSome

132 else go True

152 else go True

@@ -152,14 +172,13 @@ needsNewlineBefore ::

152 -- | Current comment span

172 -- | Current comment span

153 RealSrcSpan ->

173 RealSrcSpan ->

154 -- | Last printed comment span

174 -- | Last printed comment span

155− Maybe SpanMark ->

175+ Maybe RealSrcSpan ->

156 Bool

176 Bool

157−needsNewlineBefore _ (Just (HaddockSpan _ _)) = True

177+needsNewlineBefore l mlastSpn =

158−needsNewlineBefore l mlastMark =

178+ case mlastSpn of

159− case spanMarkSpan <$> mlastMark of

160 Nothing -> False

179 Nothing -> False

161− Just lastMark ->

180+ Just lastSpn ->

162− srcSpanStartLine l > srcSpanEndLine lastMark + 1

181+ srcSpanStartLine l > srcSpanEndLine lastSpn + 1

163

182

164-- | Is the preceding comment and AST element are on the same line?

183-- | Is the preceding comment and AST element are on the same line?

165theSameLinePre ::

184theSameLinePre ::

@@ -190,11 +209,11 @@ commentFollowsElt ::

190 -- | Location of enclosing AST element

209 -- | Location of enclosing AST element

191 Maybe RealSrcSpan ->

210 Maybe RealSrcSpan ->

192 -- | Location of last comment in the series

211 -- | Location of last comment in the series

193− Maybe SpanMark ->

212+ Maybe RealSrcSpan ->

194 -- | Comment to test

213 -- | Comment to test

195 RealLocated Comment ->

214 RealLocated Comment ->

196 Bool

215 Bool

197−commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =

216+commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) =

198 -- A comment follows a AST element if all 4 conditions are satisfied:

217 -- A comment follows a AST element if all 4 conditions are satisfied:

199 goesAfter

218 goesAfter

200 && logicallyFollows

219 && logicallyFollows

@@ -207,8 +226,9 @@ commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =

207 -- 2) The comment logically belongs to the element, four cases:

226 -- 2) The comment logically belongs to the element, four cases:

208 logicallyFollows =

227 logicallyFollows =

209 theSameLinePost l ref -- a) it's on the same line

228 theSameLinePost l ref -- a) it's on the same line

229+ || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^

210− || continuation -- b) it's a continuation of a comment block

230+ || continuation -- c) it's a continuation of a comment block

211− || lastInEnclosing -- c) it's the last element in the enclosing construct

231+ || lastInEnclosing -- d) it's the last element in the enclosing construct

212

232

213 -- 3) There is no other AST element between this element and the comment:

233 -- 3) There is no other AST element between this element and the comment:

214 noEltBetween =

234 noEltBetween =

@@ -235,15 +255,9 @@ commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) =

235 >= abs (startColumn ref - startColumn l)

255 >= abs (startColumn ref - startColumn l)

236 )

256 )

237 continuation =

257 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)

241− && ( case mlastMark of

258+ case mlastSpn of

242− Just (HaddockSpan _ _) -> False

259+ Nothing -> False

243− Just (CommentSpan spn) ->

244− srcSpanEndLine spn + 1 == srcSpanStartLine l

260+ Just spn -> srcSpanEndLine spn + 1 == srcSpanStartLine l

245− _ -> False

246− )

247 lastInEnclosing =

261 lastInEnclosing =

248 case meSpn of

262 case meSpn of

249 -- When there is no enclosing element, return false

263 -- When there is no enclosing element, return false

@@ -265,9 +279,9 @@ spitCommentNow spn comment = do

265 . sequence_

279 . sequence_

266 . NE.intersperse newline

280 . NE.intersperse newline

267 . fmap (txt . T.pack)

281 . fmap (txt . T.pack)

268− . unComment

282+ . coerce

269 $ comment

283 $ comment

270− setSpanMark (CommentSpan spn)

284+ setLastCommentSpan Nothing spn

271

285

272-- | Output a 'Comment' at the end of correct line or after it depending on

286-- | Output a 'Comment' at the end of correct line or after it depending on

273-- 'CommentPosition'. Used for comments that may potentially follow on the

287-- 'CommentPosition'. Used for comments that may potentially follow on the

@@ -281,6 +295,6 @@ spitCommentPending position spn comment = do

281 . sequence_

295 . sequence_

282 . NE.toList

296 . NE.toList

283 . fmap (registerPendingCommentLine position . T.pack)

297 . fmap (registerPendingCommentLine position . T.pack)

284− . unComment

298+ . coerce

285 $ comment

299 $ comment

286− setSpanMark (CommentSpan spn)

300+ setLastCommentSpan Nothing spn

src/Ormolu/Printer/Internal.hs+96−149

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

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RankNTypes #-}

5

4

@@ -14,10 +13,10 @@ module Ormolu.Printer.Internal

14

13

15 -- * Internal functions

14 -- * Internal functions

16 txt,

15 txt,

17− interferingTxt,

18 atom,

16 atom,

19 space,

17 space,

20 newline,

18 newline,

19+ isLineDirty,

21 useRecordDot,

20 useRecordDot,

22 inci,

21 inci,

23 sitcc,

22 sitcc,

@@ -39,14 +38,9 @@ module Ormolu.Printer.Internal

39 popComment,

38 popComment,

40 getEnclosingSpan,

39 getEnclosingSpan,

41 withEnclosingSpan,

40 withEnclosingSpan,

42− thisLineSpans,

43−

44− -- * Stateful markers

45− SpanMark (..),

46− spanMarkSpan,

47 HaddockStyle (..),

41 HaddockStyle (..),

48− setSpanMark,

42+ setLastCommentSpan,

49− getSpanMark,

43+ getLastCommentSpan,

50

44

51 -- * Annotations

45 -- * Annotations

52 getAnns,

46 getAnns,

@@ -79,44 +73,45 @@ newtype R a = R (ReaderT RC (State SC) a)

79

73

80-- | Reader context of 'R'. This should be used when we control rendering by

74-- | Reader context of 'R'. This should be used when we control rendering by

81-- enclosing certain expressions with wrappers.

75-- enclosing certain expressions with wrappers.

82−data RC = RC

76+data RC

77+ = RC

83− { -- | Indentation level, as the column index we need to start from after

78+ { -- | Indentation level, as the column index we need to start from after

84− -- a newline if we break lines

79+ -- a newline if we break lines

85− rcIndent :: !Int,

80+ rcIndent :: !Int,

86− -- | Current layout

81+ -- | Current layout

87− rcLayout :: Layout,

82+ rcLayout :: Layout,

88− -- | Spans of enclosing elements of AST

83+ -- | Spans of enclosing elements of AST

89− rcEnclosingSpans :: [RealSrcSpan],

84+ rcEnclosingSpans :: [RealSrcSpan],

90− -- | Collection of annotations

85+ -- | Collection of annotations

91− rcAnns :: Anns,

86+ rcAnns :: Anns,

92− -- | Whether the last expression in the layout can use braces

87+ -- | Whether the last expression in the layout can use braces

93− rcCanUseBraces :: Bool,

88+ rcCanUseBraces :: Bool,

94− -- | Whether the source could have used the record dot preprocessor

89+ -- | Whether the source could have used the record dot preprocessor

95− rcUseRecDot :: Bool

90+ rcUseRecDot :: Bool

96− }

91+ }

97

92

98-- | State context of 'R'.

93-- | State context of 'R'.

99−data SC = SC

94+data SC

95+ = SC

100− { -- | Index of the next column to render

96+ { -- | Index of the next column to render

101− scColumn :: !Int,

97+ scColumn :: !Int,

102− -- | Indentation level that was used for the current line

103− scIndent :: !Int,

104− -- | Rendered source code so far

98+ -- | Rendered source code so far

105− scBuilder :: Builder,

99+ scBuilder :: Builder,

106− -- | Span stream

100+ -- | Span stream

107− scSpanStream :: SpanStream,

101+ scSpanStream :: SpanStream,

108− -- | Spans of atoms that have been printed on the current line so far

109− scThisLineSpans :: [RealSrcSpan],

110− -- | Comment stream

102+ -- | Comment stream

111− scCommentStream :: CommentStream,

103+ scCommentStream :: CommentStream,

112− -- | Pending comment lines (in reverse order) to be inserted before next

104+ -- | Pending comment lines (in reverse order) to be inserted before next

113− -- newline, 'Int' is the indentation level

105+ -- newline, 'Int' is the indentation level

114− scPendingComments :: ![(CommentPosition, Text)],

106+ scPendingComments :: ![(CommentPosition, Int, Text)],

107+ -- | Whether the current line is “dirty”, that is, already contains

108+ -- atoms that can have comments attached to them

109+ scDirtyLine :: !Bool,

115− -- | Whether to output a space before the next output

110+ -- | Whether to output a space before the next output

116− scRequestedDelimiter :: !RequestedDelimiter,

111+ scRequestedDelimiter :: !RequestedDelimiter,

117− -- | An auxiliary marker for keeping track of last output element

112+ -- | Span of last output comment

118− scSpanMark :: !(Maybe SpanMark)

113+ scLastCommentSpan :: !(Maybe (Maybe HaddockStyle, RealSrcSpan))

119− }

114+ }

120

115

121-- | Make sure next output is delimited by one of the following.

116-- | Make sure next output is delimited by one of the following.

122data RequestedDelimiter

117data RequestedDelimiter

@@ -177,36 +172,18 @@ runR (R m) sstream cstream anns recDot =

177 sc =

172 sc =

178 SC

173 SC

179 { scColumn = 0,

174 { scColumn = 0,

180− scIndent = 0,

181 scBuilder = mempty,

175 scBuilder = mempty,

182 scSpanStream = sstream,

176 scSpanStream = sstream,

183− scThisLineSpans = [],

184 scCommentStream = cstream,

177 scCommentStream = cstream,

185 scPendingComments = [],

178 scPendingComments = [],

179+ scDirtyLine = False,

186 scRequestedDelimiter = VeryBeginning,

180 scRequestedDelimiter = VeryBeginning,

187− scSpanMark = Nothing

181+ scLastCommentSpan = Nothing

188 }

182 }

189

183

190----------------------------------------------------------------------------

184----------------------------------------------------------------------------

191-- Internal functions

185-- Internal functions

192

186

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−

210-- | Output a fixed 'Text' fragment. The argument may not contain any line

187-- | Output a fixed 'Text' fragment. The argument may not contain any line

211-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like

188-- breaks. 'txt' is used to output all sorts of “fixed” bits of syntax like

212-- keywords and pipes @|@ in functional dependencies.

189-- keywords and pipes @|@ in functional dependencies.

@@ -218,15 +195,7 @@ txt ::

218 -- | 'Text' to output

195 -- | 'Text' to output

219 Text ->

196 Text ->

220 R ()

197 R ()

221−txt = spit SimpleText

198+txt = spit False False

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

230

199

231-- | Output 'Outputable' fragment of AST. This can be used to output numeric

200-- | Output 'Outputable' fragment of AST. This can be used to output numeric

232-- literals and similar. Everything that doesn't have inner structure but

201-- literals and similar. Everything that doesn't have inner structure but

@@ -235,61 +204,48 @@ atom ::

235 Outputable a =>

204 Outputable a =>

236 a ->

205 a ->

237 R ()

206 R ()

238−atom = spit Atom . T.pack . showOutputable

207+atom = spit True False . T.pack . showOutputable

239

208

240-- | Low-level non-public helper to define 'txt' and 'atom'.

209-- | Low-level non-public helper to define 'txt' and 'atom'.

241spit ::

210spit ::

242− -- | Type of the thing to spit

211+ -- | Should we mark the line as dirty?

243− SpitType ->

212+ Bool ->

213+ -- | Used during outputting of pending comments?

214+ Bool ->

244 -- | 'Text' to output

215 -- | 'Text' to output

245 Text ->

216 Text ->

246 R ()

217 R ()

247−spit _ "" = return ()

218+spit dirty printingComments txt' = do

248−spit stype text = do

249 requestedDel <- R (gets scRequestedDelimiter)

219 requestedDel <- R (gets scRequestedDelimiter)

250− pendingComments <- R (gets scPendingComments)

251− when (stype == InterferingText && not (null pendingComments)) newline

252 case requestedDel of

220 case requestedDel of

253 RequestedNewline -> do

221 RequestedNewline -> do

254 R . modify $ \sc ->

222 R . modify $ \sc ->

255 sc

223 sc

256 { scRequestedDelimiter = RequestedNothing

224 { scRequestedDelimiter = RequestedNothing

257 }

225 }

258− case stype of

226+ if printingComments

259− CommentPart -> newlineRaw

227+ then newlineRaw

260− _ -> newline

228+ else newline

261 _ -> return ()

229 _ -> return ()

262 R $ do

230 R $ do

263 i <- asks rcIndent

231 i <- asks rcIndent

264 c <- gets scColumn

232 c <- gets scColumn

265− closestEnclosing <- listToMaybe <$> asks rcEnclosingSpans

233+ let spaces =

266− let indentedTxt = spaces <> text

234+ if c < i

267− spaces = T.replicate spacesN " "

235+ then T.replicate (i - c) " "

268− spacesN =

269− if c == 0

270− then i

271− else bool 0 1 (requestedDel == RequestedSpace)

236+ else bool mempty " " (requestedDel == RequestedSpace)

237+ indentedTxt = spaces <> txt'

272 modify $ \sc ->

238 modify $ \sc ->

273 sc

239 sc

274 { scBuilder = scBuilder sc <> fromText indentedTxt,

240 { scBuilder = scBuilder sc <> fromText indentedTxt,

275 scColumn = scColumn sc + T.length indentedTxt,

241 scColumn = scColumn sc + T.length indentedTxt,

276− scIndent =

242+ scDirtyLine = scDirtyLine sc || dirty,

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,

287 scRequestedDelimiter = RequestedNothing,

243 scRequestedDelimiter = RequestedNothing,

288− scSpanMark =

244+ scLastCommentSpan =

289 -- If there are pending comments, do not reset last comment

245 -- If there are pending comments, do not reset last comment

290 -- location.

246 -- location.

291− if (stype == CommentPart) || (not . null . scPendingComments) sc

247+ if printingComments || (not . null . scPendingComments) sc

292− then scSpanMark sc

248+ then scLastCommentSpan sc

293 else Nothing

249 else Nothing

294 }

250 }

295

251

@@ -320,22 +276,21 @@ space = R . modify $ \sc ->

320-- hard to output more than one blank newline in a row.

276-- hard to output more than one blank newline in a row.

321newline :: R ()

277newline :: R ()

322newline = do

278newline = do

323− indent <- R (gets scIndent)

324 cs <- reverse <$> R (gets scPendingComments)

279 cs <- reverse <$> R (gets scPendingComments)

325 case cs of

280 case cs of

326 [] -> newlineRaw

281 [] -> newlineRaw

327− ((position, _) : _) -> do

282+ ((position, _, _) : _) -> do

328 case position of

283 case position of

329 OnTheSameLine -> space

284 OnTheSameLine -> space

330 OnNextLine -> newlineRaw

285 OnNextLine -> newlineRaw

331− R . forM_ cs $ \(_, text) ->

286+ R . forM_ cs $ \(_, indent, txt') ->

332 let modRC rc =

287 let modRC rc =

333 rc

288 rc

334 { rcIndent = indent

289 { rcIndent = indent

335 }

290 }

336 R m = do

291 R m = do

337− unless (T.null text) $

292+ unless (T.null txt') $

338− spit CommentPart text

293+ spit False True txt'

339 newlineRaw

294 newlineRaw

340 in local modRC m

295 in local modRC m

341 R . modify $ \sc ->

296 R . modify $ \sc ->

@@ -356,8 +311,7 @@ newlineRaw = R . modify $ \sc ->

356 VeryBeginning -> builderSoFar

311 VeryBeginning -> builderSoFar

357 _ -> builderSoFar <> "\n",

312 _ -> builderSoFar <> "\n",

358 scColumn = 0,

313 scColumn = 0,

359− scIndent = 0,

314+ scDirtyLine = False,

360− scThisLineSpans = [],

361 scRequestedDelimiter = case scRequestedDelimiter sc of

315 scRequestedDelimiter = case scRequestedDelimiter sc of

362 AfterNewline -> RequestedNewline

316 AfterNewline -> RequestedNewline

363 RequestedNewline -> RequestedNewline

317 RequestedNewline -> RequestedNewline

@@ -365,9 +319,14 @@ newlineRaw = R . modify $ \sc ->

365 _ -> AfterNewline

319 _ -> AfterNewline

366 }

320 }

367

321

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+

368-- | Return 'True' if we should print record dot syntax.

327-- | Return 'True' if we should print record dot syntax.

369useRecordDot :: R Bool

328useRecordDot :: R Bool

370−useRecordDot = R (asks rcUseRecDot)

329+useRecordDot = R $ asks rcUseRecDot

371

330

372-- | Increase indentation level by one indentation step for the inner

331-- | Increase indentation level by one indentation step for the inner

373-- computation. 'inci' should be used when a part of code must be more

332-- computation. 'inci' should be used when a part of code must be more

@@ -384,7 +343,8 @@ inci (R m) = R (local modRC m)

384

343

385-- | Set indentation level for the inner computation equal to current

344-- | Set indentation level for the inner computation equal to current

386-- column. This makes sure that the entire inner block is uniformly

345-- column. This makes sure that the entire inner block is uniformly

387−-- \"shifted\" to the right.

346+-- \"shifted\" to the right. Only works (and makes sense) when enclosing

347+-- layout is multi-line.

388sitcc :: R () -> R ()

348sitcc :: R () -> R ()

389sitcc (R m) = do

349sitcc (R m) = do

390 requestedDel <- R (gets scRequestedDelimiter)

350 requestedDel <- R (gets scRequestedDelimiter)

@@ -392,9 +352,16 @@ sitcc (R m) = do

392 c <- R (gets scColumn)

352 c <- R (gets scColumn)

393 let modRC rc =

353 let modRC rc =

394 rc

354 rc

395− { rcIndent = max i (c + bool 0 1 (requestedDel == RequestedSpace))

355+ { rcIndent = max i c + bool 0 1 (requestedDel == RequestedSpace)

396 }

356 }

357+ vlayout (R m) . R $ do

358+ modify $ \sc ->

359+ sc

360+ { scRequestedDelimiter = case requestedDel of

361+ RequestedSpace -> RequestedNothing

362+ other -> other

363+ }

397− R (local modRC m)

364+ local modRC m

398

365

399-- | Set 'Layout' for internal computation.

366-- | Set 'Layout' for internal computation.

400enterLayout :: Layout -> R () -> R ()

367enterLayout :: Layout -> R () -> R ()

@@ -435,10 +402,11 @@ registerPendingCommentLine ::

435 -- | 'Text' to output

402 -- | 'Text' to output

436 Text ->

403 Text ->

437 R ()

404 R ()

438−registerPendingCommentLine position text = R $ do

405+registerPendingCommentLine position txt' = R $ do

406+ i <- asks rcIndent

439 modify $ \sc ->

407 modify $ \sc ->

440 sc

408 sc

441− { scPendingComments = (position, text) : scPendingComments sc

409+ { scPendingComments = (position, i, txt') : scPendingComments sc

442 }

410 }

443

411

444-- | Drop elements that begin before or at the same place as given

412-- | Drop elements that begin before or at the same place as given

@@ -497,29 +465,6 @@ withEnclosingSpan spn (R m) = R (local modRC m)

497 { rcEnclosingSpans = spn : rcEnclosingSpans rc

465 { rcEnclosingSpans = spn : rcEnclosingSpans rc

498 }

466 }

499

467

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−

523-- | Haddock string style.

468-- | Haddock string style.

524data HaddockStyle

469data HaddockStyle

525 = -- | @-- |@

470 = -- | @-- |@

@@ -532,18 +477,20 @@ data HaddockStyle

532 Named String

477 Named String

533

478

534-- | Set span of last output comment.

479-- | Set span of last output comment.

535−setSpanMark ::

480+setLastCommentSpan ::

536− -- | Span mark to set

481+ -- | 'HaddockStyle' or 'Nothing' if it's a non-Haddock comment

537− SpanMark ->

482+ Maybe HaddockStyle ->

483+ -- | Location of last printed comment

484+ RealSrcSpan ->

538 R ()

485 R ()

539−setSpanMark spnMark = R . modify $ \sc ->

486+setLastCommentSpan mhStyle spn = R . modify $ \sc ->

540 sc

487 sc

541− { scSpanMark = Just spnMark

488+ { scLastCommentSpan = Just (mhStyle, spn)

542 }

489 }

543

490

544-- | Get span of last output comment.

491-- | Get span of last output comment.

545−getSpanMark :: R (Maybe SpanMark)

492+getLastCommentSpan :: R (Maybe (Maybe HaddockStyle, RealSrcSpan))

546−getSpanMark = R (gets scSpanMark)

493+getLastCommentSpan = R (gets scLastCommentSpan)

547

494

548----------------------------------------------------------------------------

495----------------------------------------------------------------------------

549-- Annotations

496-- Annotations

@@ -567,7 +514,7 @@ dontUseBraces (R r) = R (local (\i -> i {rcCanUseBraces = False}) r)

567

514

568-- | Return 'True' if we can use braces in this context.

515-- | Return 'True' if we can use braces in this context.

569canUseBraces :: R Bool

516canUseBraces :: R Bool

570−canUseBraces = R (asks rcCanUseBraces)

517+canUseBraces = R $ asks rcCanUseBraces

571

518

572----------------------------------------------------------------------------

519----------------------------------------------------------------------------

573-- Constants

520-- Constants

src/Ormolu/Printer/Meat/Common.hs+11−13

@@ -17,12 +17,14 @@ where

17

18import Control.Monad

19import Data.List (isPrefixOf)

20+import Data.Maybe (isJust)

20import qualified Data.Text as T

21import qualified Data.Text as T

21import GHC hiding (GhcPs, IE)

22import GHC hiding (GhcPs, IE)

22import Name (nameStableString)

23import Name (nameStableString)

23import OccName (OccName (..))

24import OccName (OccName (..))

24import Ormolu.Printer.Combinators

25import Ormolu.Printer.Combinators

25import Ormolu.Utils

26import Ormolu.Utils

27+import RdrName (RdrName (..))

26

28

27-- | Data and type family style.

29-- | Data and type family style.

28data FamilyStyle

30data FamilyStyle

@@ -114,14 +116,14 @@ p_qualName mname occName = do

114p_infixDefHelper ::

116p_infixDefHelper ::

115 -- | Whether to format in infix style

117 -- | Whether to format in infix style

116 Bool ->

118 Bool ->

117− -- | Whether to bump indentation for arguments

119+ -- | Indentation-bumping wrapper

118− Bool ->

120+ (R () -> R ()) ->

119 -- | How to print the operator\/name

121 -- | How to print the operator\/name

120 R () ->

122 R () ->

121 -- | How to print the arguments

123 -- | How to print the arguments

122 [R ()] ->

124 [R ()] ->

123 R ()

125 R ()

124−p_infixDefHelper isInfix indentArgs name args =

126+p_infixDefHelper isInfix inci' name args =

125 case (isInfix, args) of

127 case (isInfix, args) of

126 (True, p0 : p1 : ps) -> do

128 (True, p0 : p1 : ps) -> do

127 let parens' =

129 let parens' =

@@ -131,18 +133,18 @@ p_infixDefHelper isInfix indentArgs name args =

131 parens' $ do

133 parens' $ do

132 p0

134 p0

133 breakpoint

135 breakpoint

134− inci . sitcc $ do

136+ inci $ sitcc $ do

135 name

137 name

136 space

138 space

137 p1

139 p1

138− unless (null ps) . inciIf indentArgs $ do

140+ unless (null ps) . inci' $ do

139 breakpoint

141 breakpoint

140 sitcc (sep breakpoint sitcc ps)

142 sitcc (sep breakpoint sitcc ps)

141 (_, ps) -> do

143 (_, ps) -> do

142 name

144 name

143 unless (null ps) $ do

145 unless (null ps) $ do

144 breakpoint

146 breakpoint

145− inciIf indentArgs $ sitcc (sep breakpoint sitcc args)

147+ inci' $ sitcc (sep breakpoint sitcc args)

146

148

147-- | Print a Haddock.

149-- | Print a Haddock.

148p_hsDocString ::

150p_hsDocString ::

@@ -154,11 +156,7 @@ p_hsDocString ::

154 LHsDocString ->

156 LHsDocString ->

155 R ()

157 R ()

156p_hsDocString hstyle needsNewline (L l str) = do

158p_hsDocString hstyle needsNewline (L l str) = do

157− let isCommentSpan = \case

159+ goesAfterComment <- isJust <$> getLastCommentSpan

158− HaddockSpan _ _ -> True

159− CommentSpan _ -> True

160− _ -> False

161− goesAfterComment <- maybe False isCommentSpan <$> getSpanMark

162 -- Make sure the Haddock is separated by a newline from other comments.

160 -- Make sure the Haddock is separated by a newline from other comments.

163 when goesAfterComment newline

161 when goesAfterComment newline

164 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do

162 forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do

@@ -177,8 +175,8 @@ p_hsDocString hstyle needsNewline (L l str) = do

177 -- It's often the case that the comment itself doesn't have a span

175 -- It's often the case that the comment itself doesn't have a span

178 -- attached to it and instead its location can be obtained from

176 -- attached to it and instead its location can be obtained from

179 -- nearest enclosing span.

177 -- nearest enclosing span.

180− getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle)

178+ getEnclosingSpan (const True) >>= mapM_ (setLastCommentSpan (Just hstyle))

181− RealSrcSpan spn -> setSpanMark (HaddockSpan hstyle spn)

179+ RealSrcSpan spn -> setLastCommentSpan (Just hstyle) spn

182

180

183-- | Print anchor of named doc section.

181-- | Print anchor of named doc section.

184p_hsDocName :: String -> R ()

182p_hsDocName :: String -> R ()

src/Ormolu/Printer/Meat/Declaration.hs+110−138

@@ -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)

@@ -34,6 +34,7 @@ import Ormolu.Printer.Meat.Declaration.Value

34import Ormolu.Printer.Meat.Declaration.Warning

35import Ormolu.Printer.Meat.Type

36import Ormolu.Utils

37+import RdrName (rdrNameOcc)

37

38

38data UserGrouping

39data UserGrouping

39 = -- | Always put newlines where we think they should be

40 = -- | Always put newlines where we think they should be

@@ -54,27 +55,25 @@ p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

54p_hsDeclsRespectGrouping = p_hsDecls' Respect

55p_hsDeclsRespectGrouping = p_hsDecls' Respect

55

56

56p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()

57p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()

57−p_hsDecls' grouping style decls =

58+p_hsDecls' grouping style decls = sepSemi id $

58− sepSemi id $

59− -- Return a list of rendered declarations, adding a newline to separate

59+ -- Return a list of rendered declarations, adding a newline to separate

60− -- groups.

60+ -- groups.

61− case groupDecls decls of

61+ case groupDecls decls of

62− [] -> []

62+ [] -> []

63− (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)

63+ (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)

64 where

65 renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)

66 renderGroupWithPrev prev curr =

67 -- We can omit a blank line when the user didn't add one, but we must

68 -- ensure we always add blank lines around documented declarations

69− case grouping of

69+ if or

70− Disregard ->

70+ [ grouping == Disregard,

71− breakpoint : renderGroup curr

72− Respect ->

73− if separatedByBlankNE getLoc prev curr

71+ separatedByBlank getLoc prev curr,

74− || isDocumented prev

72+ isDocumented prev,

75− || isDocumented curr

73+ isDocumented curr

74+ ]

76− then breakpoint : renderGroup curr

75+ then breakpoint : renderGroup curr

77− else renderGroup curr

76+ else renderGroup curr

78

77

79-- | Is a declaration group documented?

78-- | Is a declaration group documented?

80isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool

79isDocumented :: NonEmpty (LHsDecl GhcPs) -> Bool

@@ -85,6 +84,9 @@ isDocumented = any (isHaddock . unLoc)

85 isHaddock _ = False

84 isHaddock _ = False

86

85

87-- | Group relevant declarations together.

86-- | Group relevant declarations together.

87+--

88+-- Add a declaration to a group iff it is relevant to either the first or

89+-- the last declaration of the group.

88groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]

90groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)]

89groupDecls [] = []

91groupDecls [] = []

90groupDecls (l@(L _ DocNext) : xs) =

92groupDecls (l@(L _ DocNext) : xs) =

@@ -93,40 +95,44 @@ groupDecls (l@(L _ DocNext) : xs) =

93 case groupDecls xs of

95 case groupDecls xs of

94 [] -> [l :| []]

96 [] -> [l :| []]

95 (x : xs') -> (l <| x) : xs'

97 (x : xs') -> (l <| x) : xs'

96−groupDecls (header : xs) =

98+groupDecls (lhdr : xs) =

97− let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) ->

99+ let -- Pick the first decl as the group header

100+ hdr = unLoc lhdr

101+ -- Zip rest of the decls with their previous decl

102+ zipped = zip (lhdr : xs) xs

103+ -- Pick decls from the tail if they are relevant to the group header

104+ -- or the previous decl.

105+ (grp, rest) = flip span zipped $ \(L _ prev, L _ cur) ->

98− let relevantToHdr = groupedDecls header current

106+ let relevantToHdr = groupedDecls hdr cur

99− relevantToPrev = groupedDecls previous current

107+ relevantToPrev = groupedDecls prev cur

100− isDeclSeries = declSeries previous current

101− in isDeclSeries || relevantToHdr || relevantToPrev

108+ in relevantToHdr || relevantToPrev

102− in (header :| map snd grp) : groupDecls (map snd rest)

109+ in (lhdr :| map snd grp) : groupDecls (map snd rest)

103

110

104p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()

111p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R ()

105p_hsDecl style = \case

112p_hsDecl style = \case

106− TyClD NoExtField x -> p_tyClDecl style x

113+ TyClD NoExt x -> p_tyClDecl style x

107− ValD NoExtField x -> p_valDecl x

114+ ValD NoExt x -> p_valDecl x

108− SigD NoExtField x -> p_sigDecl x

115+ SigD NoExt x -> p_sigDecl x

109− InstD NoExtField x -> p_instDecl style x

116+ InstD NoExt x -> p_instDecl style x

110− DerivD NoExtField x -> p_derivDecl x

117+ DerivD NoExt x -> p_derivDecl x

111− DefD NoExtField x -> p_defaultDecl x

118+ DefD NoExt x -> p_defaultDecl x

112− ForD NoExtField x -> p_foreignDecl x

119+ ForD NoExt x -> p_foreignDecl x

113− WarningD NoExtField x -> p_warnDecls x

120+ WarningD NoExt x -> p_warnDecls x

114− AnnD NoExtField x -> p_annDecl x

121+ AnnD NoExt x -> p_annDecl x

115− RuleD NoExtField x -> p_ruleDecls x

122+ RuleD NoExt x -> p_ruleDecls x

116− SpliceD NoExtField x -> p_spliceDecl x

123+ SpliceD NoExt x -> p_spliceDecl x

117− DocD NoExtField docDecl ->

124+ DocD NoExt docDecl ->

118 case docDecl of

125 case docDecl of

119 DocCommentNext str -> p_hsDocString Pipe False (noLoc str)

126 DocCommentNext str -> p_hsDocString Pipe False (noLoc str)

120 DocCommentPrev str -> p_hsDocString Caret False (noLoc str)

127 DocCommentPrev str -> p_hsDocString Caret False (noLoc str)

121 DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)

128 DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str)

122 DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)

129 DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str)

123− RoleAnnotD NoExtField x -> p_roleAnnot x

130+ RoleAnnotD NoExt x -> p_roleAnnot x

124− KindSigD NoExtField s -> p_standaloneKindSig s

131+ XHsDecl _ -> notImplemented "XHsDecl"

125− XHsDecl x -> noExtCon x

126

132

127p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()

133p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R ()

128p_tyClDecl style = \case

134p_tyClDecl style = \case

129− FamDecl NoExtField x -> p_famDecl style x

135+ FamDecl NoExt x -> p_famDecl style x

130 SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs

136 SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs

131 DataDecl {..} ->

137 DataDecl {..} ->

132 p_dataDecl

138 p_dataDecl

@@ -147,65 +153,43 @@ p_tyClDecl style = \case

147 tcdATs

153 tcdATs

148 tcdATDefs

154 tcdATDefs

149 tcdDocs

155 tcdDocs

150− XTyClDecl x -> noExtCon x

156+ XTyClDecl {} -> notImplemented "XTyClDecl"

151

157

152p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()

158p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R ()

153p_instDecl style = \case

159p_instDecl style = \case

154− ClsInstD NoExtField x -> p_clsInstDecl x

160+ ClsInstD NoExt x -> p_clsInstDecl x

155− TyFamInstD NoExtField x -> p_tyFamInstDecl style x

161+ TyFamInstD NoExt x -> p_tyFamInstDecl style x

156− DataFamInstD NoExtField x -> p_dataFamInstDecl style x

162+ DataFamInstD NoExt x -> p_dataFamInstDecl style x

157− XInstDecl x -> noExtCon x

163+ XInstDecl _ -> notImplemented "XInstDecl"

158

164

159p_derivDecl :: DerivDecl GhcPs -> R ()

165p_derivDecl :: DerivDecl GhcPs -> R ()

160p_derivDecl = \case

166p_derivDecl = \case

161− d@DerivDecl {} -> p_standaloneDerivDecl d

167+ d@DerivDecl {..} -> p_standaloneDerivDecl d

162− XDerivDecl x -> noExtCon x

168+ XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"

163

169

164-- | Determine if these declarations should be grouped together.

170-- | Determine if these declarations should be grouped together.

165groupedDecls ::

171groupedDecls ::

166− LHsDecl GhcPs ->

172+ HsDecl GhcPs ->

167− LHsDecl GhcPs ->

168− Bool

169−groupedDecls (L l_x x') (L l_y y') =

170− case (x', y') of

171− (TypeSignature ns, FunctionBody ns') -> ns `intersects` ns'

172− (TypeSignature ns, DefaultSignature ns') -> ns `intersects` ns'

173− (DefaultSignature ns, TypeSignature ns') -> ns `intersects` ns'

174− (DefaultSignature ns, FunctionBody ns') -> ns `intersects` ns'

175− (x, FunctionBody ns) | Just ns' <- isPragma x -> ns `intersects` ns'

176− (FunctionBody ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'

177− (x, DataDeclaration n) | Just ns <- isPragma x -> n `elem` ns

178− (DataDeclaration n, x)

179− | Just ns <- isPragma x ->

180− let f = occNameFS . rdrNameOcc in f n `elem` map f ns

181− (x, y)

182− | Just ns <- isPragma x,

183− Just ns' <- isPragma y ->

184− ns `intersects` ns'

185− (x, TypeSignature ns) | Just ns' <- isPragma x -> ns `intersects` ns'

186− (TypeSignature ns, x) | Just ns' <- isPragma x -> ns `intersects` ns'

187− (PatternSignature ns, Pattern n) -> n `elem` ns

188− (KindSignature n, DataDeclaration n') -> n == n'

189− (KindSignature n, ClassDeclaration 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)

193− -- This looks only at Haddocks, normal comments are handled elsewhere

194− (DocNext, _) -> 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 ->

173+ HsDecl GhcPs ->

202 Bool

174 Bool

203−declSeries (L _ x) (L _ y) =

175+groupedDecls (TypeSignature ns) (FunctionBody ns') = ns `intersects` ns'

204− case (x, y) of

176+groupedDecls (TypeSignature ns) (DefaultSignature ns') = ns `intersects` ns'

205− ( SigD NoExtField (TypeSig NoExtField _ _),

177+groupedDecls (DefaultSignature ns) (TypeSignature ns') = ns `intersects` ns'

206− SigD NoExtField (TypeSig NoExtField _ _)

178+groupedDecls (DefaultSignature ns) (FunctionBody ns') = ns `intersects` ns'

207− ) -> True

179+groupedDecls x (FunctionBody ns) | Just ns' <- isPragma x = ns `intersects` ns'

180+groupedDecls (FunctionBody ns) x | Just ns' <- isPragma x = ns `intersects` ns'

181+groupedDecls x (DataDeclaration n) | Just ns <- isPragma x = n `elem` ns

182+groupedDecls (DataDeclaration n) x

183+ | Just ns <- isPragma x =

184+ let f = occNameFS . rdrNameOcc in f n `elem` map f ns

185+groupedDecls x y | Just ns <- isPragma x, Just ns' <- isPragma y = ns `intersects` ns'

186+groupedDecls x (TypeSignature ns) | Just ns' <- isPragma x = ns `intersects` ns'

187+groupedDecls (TypeSignature ns) x | Just ns' <- isPragma x = ns `intersects` ns'

188+groupedDecls (PatternSignature ns) (Pattern n) = n `elem` ns

189+-- This looks only at Haddocks, normal comments are handled elsewhere

190+groupedDecls DocNext _ = True

191+groupedDecls _ DocPrev = True

208− _ -> False

192+groupedDecls _ _ = False

209

193

210intersects :: Ord a => [a] -> [a] -> Bool

194intersects :: Ord a => [a] -> [a] -> Bool

211intersects a b = go (sort a) (sort b)

195intersects a b = go (sort a) (sort b)

@@ -230,11 +214,6 @@ isPragma = \case

230 WarningPragma n -> Just n

214 WarningPragma n -> Just n

231 _ -> Nothing

215 _ -> Nothing

232

216

233−-- Declarations that do not refer to names

234−

235−pattern Splice :: HsDecl GhcPs

236−pattern Splice <- SpliceD NoExtField (SpliceDecl NoExtField _ _)

237−

238-- Declarations referring to a single name

217-- Declarations referring to a single name

239

218

240pattern

219pattern

@@ -244,21 +223,15 @@ pattern

244 AnnTypePragma,

223 AnnTypePragma,

245 AnnValuePragma,

224 AnnValuePragma,

246 Pattern,

225 Pattern,

247− DataDeclaration,

226+ DataDeclaration ::

248− ClassDeclaration,

249− KindSignature,

250− FamilyDeclaration ::

251 RdrName -> HsDecl GhcPs

227 RdrName -> HsDecl GhcPs

252−pattern InlinePragma n <- SigD NoExtField (InlineSig NoExtField (L _ n) _)

228+pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)

253−pattern SpecializePragma n <- SigD NoExtField (SpecSig NoExtField (L _ n) _ _)

229+pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)

254−pattern SCCPragma n <- SigD NoExtField (SCCFunSig NoExtField _ (L _ n) _)

230+pattern SCCPragma n <- SigD NoExt (SCCFunSig NoExt _ (L _ n) _)

255−pattern AnnTypePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (TypeAnnProvenance (L _ n)) _)

231+pattern AnnTypePragma n <- AnnD NoExt (HsAnnotation NoExt _ (TypeAnnProvenance (L _ n)) _)

256−pattern AnnValuePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (ValueAnnProvenance (L _ n)) _)

232+pattern AnnValuePragma n <- AnnD NoExt (HsAnnotation NoExt _ (ValueAnnProvenance (L _ n)) _)

257−pattern Pattern n <- ValD NoExtField (PatSynBind NoExtField (PSB _ (L _ n) _ _ _))

233+pattern Pattern n <- ValD NoExt (PatSynBind NoExt (PSB _ (L _ n) _ _ _))

258−pattern DataDeclaration n <- TyClD NoExtField (DataDecl NoExtField (L _ n) _ _ _)

234+pattern DataDeclaration n <- TyClD NoExt (DataDecl NoExt (L _ n) _ _ _)

259−pattern ClassDeclaration n <- TyClD NoExtField (ClassDecl NoExtField _ (L _ n) _ _ _ _ _ _ _ _)

260−pattern KindSignature n <- KindSigD NoExtField (StandaloneKindSig NoExtField (L _ n) _)

261−pattern FamilyDeclaration n <- TyClD NoExtField (FamDecl NoExtField (FamilyDecl NoExtField _ (L _ n) _ _ _ _))

262

235

263-- Declarations which can refer to multiple names

236-- Declarations which can refer to multiple names

264

237

@@ -276,52 +249,51 @@ pattern PatternSignature n <- (patSigRdrNames -> Just n)

276pattern WarningPragma n <- (warnSigRdrNames -> Just n)

249pattern WarningPragma n <- (warnSigRdrNames -> Just n)

277

250

278pattern DocNext, DocPrev :: HsDecl GhcPs

251pattern DocNext, DocPrev :: HsDecl GhcPs

279−pattern DocNext <- (DocD NoExtField (DocCommentNext _))

252+pattern DocNext <- (DocD NoExt (DocCommentNext _))

280−pattern DocPrev <- (DocD NoExtField (DocCommentPrev _))

253+pattern DocPrev <- (DocD NoExt (DocCommentPrev _))

281

254

282sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

255sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

283−sigRdrNames (SigD NoExtField (TypeSig NoExtField ns _)) = Just $ map unLoc ns

256+sigRdrNames (SigD NoExt (TypeSig NoExt ns _)) = Just $ map unLoc ns

284−sigRdrNames (SigD NoExtField (ClassOpSig NoExtField _ ns _)) = Just $ map unLoc ns

257+sigRdrNames (SigD NoExt (ClassOpSig NoExt _ ns _)) = Just $ map unLoc ns

285−sigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns

258+sigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns

286sigRdrNames _ = Nothing

259sigRdrNames _ = Nothing

287

260

288defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

261defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

289−defSigRdrNames (SigD NoExtField (ClassOpSig NoExtField True ns _)) = Just $ map unLoc ns

262+defSigRdrNames (SigD NoExt (ClassOpSig NoExt True ns _)) = Just $ map unLoc ns

290defSigRdrNames _ = Nothing

263defSigRdrNames _ = Nothing

291

264

292funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

265funRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

293−funRdrNames (ValD NoExtField (FunBind NoExtField (L _ n) _ _ _)) = Just [n]

266+funRdrNames (ValD NoExt (FunBind NoExt (L _ n) _ _ _)) = Just [n]

294−funRdrNames (ValD NoExtField (PatBind NoExtField (L _ n) _ _)) = Just $ patBindNames n

267+funRdrNames (ValD NoExt (PatBind NoExt n _ _)) = Just $ patBindNames n

295funRdrNames _ = Nothing

268funRdrNames _ = Nothing

296

269

297patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

270patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

298−patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns

271+patSigRdrNames (SigD NoExt (PatSynSig NoExt ns _)) = Just $ map unLoc ns

299patSigRdrNames _ = Nothing

272patSigRdrNames _ = Nothing

300

273

301warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

274warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]

302−warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $

275+warnSigRdrNames (WarningD NoExt (Warnings NoExt _ ws)) = Just $ flip concatMap ws $ \case

303− flip concatMap ws $ \case

304− L _ (Warning NoExtField ns _) -> map unLoc ns

276+ L _ (Warning NoExt ns _) -> map unLoc ns

305− L _ (XWarnDecl x) -> noExtCon x

277+ L _ (XWarnDecl NoExt) -> []

306warnSigRdrNames _ = Nothing

278warnSigRdrNames _ = Nothing

307

279

308patBindNames :: Pat GhcPs -> [RdrName]

280patBindNames :: Pat GhcPs -> [RdrName]

309−patBindNames (TuplePat NoExtField ps _) = concatMap (patBindNames . unLoc) ps

281+patBindNames (TuplePat NoExt ps _) = concatMap (patBindNames . unLoc) ps

310−patBindNames (VarPat NoExtField (L _ n)) = [n]

282+patBindNames (VarPat NoExt (L _ n)) = [n]

311−patBindNames (WildPat NoExtField) = []

283+patBindNames (WildPat NoExt) = []

312−patBindNames (LazyPat NoExtField (L _ p)) = patBindNames p

284+patBindNames (LazyPat NoExt p) = patBindNames p

313−patBindNames (BangPat NoExtField (L _ p)) = patBindNames p

285+patBindNames (BangPat NoExt p) = patBindNames p

314−patBindNames (ParPat NoExtField (L _ p)) = patBindNames p

286+patBindNames (ParPat NoExt p) = patBindNames p

315−patBindNames (ListPat NoExtField ps) = concatMap (patBindNames . unLoc) ps

287+patBindNames (ListPat NoExt ps) = concatMap (patBindNames . unLoc) ps

316−patBindNames (AsPat NoExtField (L _ n) (L _ p)) = n : patBindNames p

288+patBindNames (AsPat NoExt (L _ n) p) = n : patBindNames p

317−patBindNames (SumPat NoExtField (L _ p) _ _) = patBindNames p

289+patBindNames (SumPat NoExt p _ _) = patBindNames p

318−patBindNames (ViewPat NoExtField _ (L _ p)) = patBindNames p

290+patBindNames (ViewPat NoExt _ p) = patBindNames p

319−patBindNames (SplicePat NoExtField _) = []

291+patBindNames (SplicePat NoExt _) = []

320−patBindNames (LitPat NoExtField _) = []

292+patBindNames (LitPat NoExt _) = []

321−patBindNames (SigPat _ (L _ p) _) = patBindNames p

293+patBindNames (SigPat _ p _) = patBindNames p

322−patBindNames (NPat NoExtField _ _ _) = []

294+patBindNames (NPat NoExt _ _ _) = []

323−patBindNames (NPlusKPat NoExtField (L _ n) _ _ _ _) = [n]

295+patBindNames (NPlusKPat NoExt (L _ n) _ _ _ _) = [n]

324patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)

296patBindNames (ConPatIn _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)

325patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer

297patBindNames ConPatOut {} = notImplemented "ConPatOut" -- created by renamer

326−patBindNames (CoPat NoExtField _ p _) = patBindNames p

298+patBindNames (CoPat NoExt _ p _) = patBindNames p

327−patBindNames (XPat x) = noExtCon x

299+patBindNames (XPat p) = patBindNames (unLoc p)

src/Ormolu/Printer/Meat/Declaration.hs-boot+1

@@ -9,4 +9,5 @@ import Ormolu.Printer.Combinators

9import Ormolu.Printer.Meat.Common

10

11p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

12+

12p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

13p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()

src/Ormolu/Printer/Meat/Declaration/Annotation.hs+3−2

@@ -10,14 +10,15 @@ import GHC

10import Ormolu.Printer.Combinators

11import Ormolu.Printer.Meat.Common

12import Ormolu.Printer.Meat.Declaration.Value

13+import Ormolu.Utils

13

14

14p_annDecl :: AnnDecl GhcPs -> R ()

15p_annDecl :: AnnDecl GhcPs -> R ()

15p_annDecl = \case

16p_annDecl = \case

16− HsAnnotation NoExtField _ annProv expr -> pragma "ANN" . inci $ do

17+ HsAnnotation NoExt _ annProv expr -> pragma "ANN" . inci $ do

17 p_annProv annProv

18 p_annProv annProv

18 breakpoint

19 breakpoint

19 located expr p_hsExpr

20 located expr p_hsExpr

20− XAnnDecl x -> noExtCon x

21+ XAnnDecl {} -> notImplemented "XAnnDecl"

21

22

22p_annProv :: AnnProvenance (IdP GhcPs) -> R ()

23p_annProv :: AnnProvenance (IdP GhcPs) -> R ()

23p_annProv = \case

24p_annProv = \case

src/Ormolu/Printer/Meat/Declaration/Class.hs+29−21

@@ -18,6 +18,8 @@ import Ormolu.Printer.Combinators

18import Ormolu.Printer.Meat.Common

19import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration

20import Ormolu.Printer.Meat.Type

21+import Ormolu.Utils

22+import RdrName (RdrName (..))

21

23

22p_classDecl ::

24p_classDecl ::

23 LHsContext GhcPs ->

25 LHsContext GhcPs ->

@@ -28,7 +30,7 @@ p_classDecl ::

28 [LSig GhcPs] ->

30 [LSig GhcPs] ->

29 LHsBinds GhcPs ->

31 LHsBinds GhcPs ->

30 [LFamilyDecl GhcPs] ->

32 [LFamilyDecl GhcPs] ->

31− [LTyFamDefltDecl GhcPs] ->

33+ [LTyFamDefltEqn GhcPs] ->

32 [LDocDecl] ->

34 [LDocDecl] ->

33 R ()

35 R ()

34p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do

36p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do

@@ -36,20 +38,6 @@ p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = d

36 signatureSpans = getLoc name : variableSpans

38 signatureSpans = getLoc name : variableSpans

37 dependencySpans = getLoc <$> fdeps

39 dependencySpans = getLoc <$> fdeps

38 combinedSpans = getLoc ctx : (signatureSpans ++ dependencySpans)

40 combinedSpans = getLoc ctx : (signatureSpans ++ dependencySpans)

39− -- GHC's AST does not necessarily store each kind of element in source

40− -- location order. This happens because different declarations are stored

41− -- in different lists. Consequently, to get all the declarations in proper

42− -- order, they need to be manually sorted.

43− sigs = (getLoc &&& fmap (SigD NoExtField)) <$> csigs

44− vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cdefs

45− tyFams = (getLoc &&& fmap (TyClD NoExtField . FamDecl NoExtField)) <$> cats

46− docs = (getLoc &&& fmap (DocD NoExtField)) <$> cdocs

47− tyFamDefs =

48− ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)

49− )

50− <$> catdefs

51− allDecls =

52− snd <$> sortOn fst (sigs <> vals <> tyFams <> tyFamDefs <> docs)

53 txt "class"

41 txt "class"

54 switchLayout combinedSpans $ do

42 switchLayout combinedSpans $ do

55 breakpoint

43 breakpoint

@@ -58,17 +46,30 @@ p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = d

58 switchLayout signatureSpans $

46 switchLayout signatureSpans $

59 p_infixDefHelper

47 p_infixDefHelper

60 (isInfix fixity)

48 (isInfix fixity)

61− True

49+ inci

62 (p_rdrName name)

50 (p_rdrName name)

63 (located' p_hsTyVarBndr <$> hsq_explicit)

51 (located' p_hsTyVarBndr <$> hsq_explicit)

64 inci (p_classFundeps fdeps)

52 inci (p_classFundeps fdeps)

53+ -- GHC's AST does not necessarily store each kind of element in source

54+ -- location order. This happens because different declarations are stored

55+ -- in different lists. Consequently, to get all the declarations in proper

56+ -- order, they need to be manually sorted.

57+ let sigs = (getLoc &&& fmap (SigD NoExt)) <$> csigs

58+ vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cdefs

59+ tyFams = (getLoc &&& fmap (TyClD NoExt . FamDecl NoExt)) <$> cats

60+ docs = (getLoc &&& fmap (DocD NoExt)) <$> cdocs

61+ tyFamDefs =

62+ ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt . defltEqnToInstDecl)

63+ )

64+ <$> catdefs

65− unless (null allDecls) $ do

65+ allDecls =

66− breakpoint

66+ snd <$> sortOn fst (sigs <> vals <> tyFams <> tyFamDefs <> docs)

67− txt "where"

68 unless (null allDecls) $ do

67 unless (null allDecls) $ do

68+ space

69+ txt "where"

69 breakpoint -- Ensure whitespace is added after where clause.

70 breakpoint -- Ensure whitespace is added after where clause.

70 inci (p_hsDeclsRespectGrouping Associated allDecls)

71 inci (p_hsDeclsRespectGrouping Associated allDecls)

71−p_classDecl _ _ (XLHsQTyVars c) _ _ _ _ _ _ _ = noExtCon c

72+p_classDecl _ _ XLHsQTyVars {} _ _ _ _ _ _ _ = notImplemented "XLHsQTyVars"

72

73

73p_classContext :: LHsContext GhcPs -> R ()

74p_classContext :: LHsContext GhcPs -> R ()

74p_classContext ctx = unless (null (unLoc ctx)) $ do

75p_classContext ctx = unless (null (unLoc ctx)) $ do

@@ -82,7 +83,7 @@ p_classFundeps fdeps = unless (null fdeps) $ do

82 breakpoint

83 breakpoint

83 txt "|"

84 txt "|"

84 space

85 space

85− inci $ sep commaDel (sitcc . located' p_funDep) fdeps

86+ sitcc $ sep (comma >> breakpoint) (sitcc . located' p_funDep) fdeps

86

87

87p_funDep :: FunDep (Located RdrName) -> R ()

88p_funDep :: FunDep (Located RdrName) -> R ()

88p_funDep (before, after) = do

89p_funDep (before, after) = do

@@ -95,6 +96,13 @@ p_funDep (before, after) = do

95----------------------------------------------------------------------------

96----------------------------------------------------------------------------

96-- Helpers

97-- Helpers

97

98

99+defltEqnToInstDecl :: TyFamDefltEqn GhcPs -> TyFamInstDecl GhcPs

100+defltEqnToInstDecl FamEqn {..} = TyFamInstDecl {..}

101+ where

102+ eqn = FamEqn {feqn_pats = map HsValArg (tyVarsToTypes feqn_pats), ..}

103+ tfid_eqn = HsIB {hsib_ext = NoExt, hsib_body = eqn}

104+defltEqnToInstDecl XFamEqn {} = notImplemented "XFamEqn"

105+

98isInfix :: LexicalFixity -> Bool

106isInfix :: LexicalFixity -> Bool

99isInfix = \case

107isInfix = \case

100 Infix -> True

108 Infix -> True

src/Ormolu/Printer/Meat/Declaration/Data.hs+43−68

@@ -15,6 +15,8 @@ import Ormolu.Printer.Combinators

15import Ormolu.Printer.Meat.Common

16import Ormolu.Printer.Meat.Type

17import Ormolu.Utils

18+import RdrName (RdrName (..))

19+import SrcLoc (Located)

18

20

19p_dataDecl ::

21p_dataDecl ::

20 -- | Whether to format as data family

22 -- | Whether to format as data family

@@ -35,13 +37,12 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do

35 txt $ case style of

37 txt $ case style of

36 Associated -> mempty

38 Associated -> mempty

37 Free -> " instance"

39 Free -> " instance"

38− let constructorSpans = getLoc name : fmap getLoc tpats

40+ switchLayout (getLoc name : fmap getLoc tpats) $ do

39− switchLayout constructorSpans $ do

40 breakpoint

41 breakpoint

41 inci $

42 inci $

42 p_infixDefHelper

43 p_infixDefHelper

43 (isInfix fixity)

44 (isInfix fixity)

44− True

45+ inci

45 (p_rdrName name)

46 (p_rdrName name)

46 (located' p_hsType <$> tpats)

47 (located' p_hsType <$> tpats)

47 case dd_kindSig of

48 case dd_kindSig of

@@ -54,42 +55,29 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do

54 let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons

55 let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons

55 unless (null dd_cons) $

56 unless (null dd_cons) $

56 if gadt

57 if gadt

57− then inci $ do

58+ then do

58− switchLayout constructorSpans $ do

59− breakpoint

60− txt "where"

61− breakpoint

62− sepSemi (located' (p_conDecl False)) dd_cons

63− else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do

64− let singleConstRec = isSingleConstRec dd_cons

65− if singleConstRec

66− then space

67− else

68− if hasHaddocks dd_cons

69− then newline

70− else breakpoint

71− equals

72 space

59 space

73− layout <- getLayout

60+ txt "where"

61+ breakpoint

62+ inci $ sepSemi (located' p_conDecl) dd_cons

63+ else switchLayout (getLoc name : (getLoc <$> dd_cons))

64+ $ inci

65+ $ do

66+ breakpoint

67+ txt "="

68+ space

74− let s =

69+ let s =

75− if layout == MultiLine || hasHaddocks dd_cons

70+ vlayout

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

82− sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons

73+ sep s (sitcc . located' p_conDecl) dd_cons

83 unless (null $ unLoc dd_derivs) breakpoint

74 unless (null $ unLoc dd_derivs) breakpoint

84 inci . located dd_derivs $ \xs ->

75 inci . located dd_derivs $ \xs ->

85 sep newline (located' p_hsDerivingClause) xs

76 sep newline (located' p_hsDerivingClause) xs

86−p_dataDecl _ _ _ _ (XHsDataDefn x) = noExtCon x

77+p_dataDecl _ _ _ _ (XHsDataDefn NoExt) = notImplemented "XHsDataDefn"

87

78

88−p_conDecl ::

89− Bool ->

90− ConDecl GhcPs ->

79+p_conDecl :: ConDecl GhcPs -> R ()

91− R ()

92−p_conDecl singleConstRec = \case

80+p_conDecl = \case

93 ConDeclGADT {..} -> do

81 ConDeclGADT {..} -> do

94 mapM_ (p_hsDocString Pipe True) con_doc

82 mapM_ (p_hsDocString Pipe True) con_doc

95 let conDeclSpn =

83 let conDeclSpn =

@@ -104,10 +92,11 @@ p_conDecl singleConstRec = \case

104 (c : cs) -> do

92 (c : cs) -> do

105 p_rdrName c

93 p_rdrName c

106 unless (null cs) . inci $ do

94 unless (null cs) . inci $ do

107− commaDel

95+ comma

96+ breakpoint

108− sep commaDel p_rdrName cs

97+ sitcc $ sep (comma >> breakpoint) p_rdrName cs

98+ space

109 inci $ do

99 inci $ do

110− space

111 txt "::"

100 txt "::"

112 let interArgBreak =

101 let interArgBreak =

113 if hasDocStrings (unLoc con_res_ty)

102 if hasDocStrings (unLoc con_res_ty)

@@ -115,7 +104,7 @@ p_conDecl singleConstRec = \case

115 else breakpoint

104 else breakpoint

116 interArgBreak

105 interArgBreak

117 when (unLoc con_forall) $ do

106 when (unLoc con_forall) $ do

118− p_forallBndrs ForallInvis p_hsTyVarBndr (hsq_explicit con_qvars)

107+ p_forallBndrs p_hsTyVarBndr (hsq_explicit con_qvars)

119 interArgBreak

108 interArgBreak

120 forM_ con_mb_cxt p_lhsContext

109 forM_ con_mb_cxt p_lhsContext

121 case con_args of

110 case con_args of

@@ -135,27 +124,26 @@ p_conDecl singleConstRec = \case

135 p_hsType (unLoc con_res_ty)

124 p_hsType (unLoc con_res_ty)

136 ConDeclH98 {..} -> do

125 ConDeclH98 {..} -> do

137 mapM_ (p_hsDocString Pipe True) con_doc

126 mapM_ (p_hsDocString Pipe True) con_doc

138− let conDeclWithContextSpn =

127+ let conDeclSpn =

128+ [getLoc con_name]

139− [getLoc con_forall]

129+ <> [getLoc con_forall]

140 <> fmap getLoc con_ex_tvs

130 <> fmap getLoc con_ex_tvs

141 <> maybeToList (fmap getLoc con_mb_cxt)

131 <> maybeToList (fmap getLoc con_mb_cxt)

142− <> conDeclSpn

143− conDeclSpn =

144− getLoc con_name : conArgsSpans con_args

132+ <> conArgsSpans con_args

145− switchLayout conDeclWithContextSpn $ do

133+ switchLayout conDeclSpn $ do

146 when (unLoc con_forall) $ do

134 when (unLoc con_forall) $ do

147− p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs

135+ p_forallBndrs p_hsTyVarBndr con_ex_tvs

148 breakpoint

136 breakpoint

149 forM_ con_mb_cxt p_lhsContext

137 forM_ con_mb_cxt p_lhsContext

150− switchLayout conDeclSpn $ case con_args of

138+ case con_args of

151 PrefixCon xs -> do

139 PrefixCon xs -> do

152 p_rdrName con_name

140 p_rdrName con_name

153 unless (null xs) breakpoint

141 unless (null xs) breakpoint

154− inci . sitcc $ sep breakpoint (sitcc . located' p_hsTypePostDoc) xs

142+ inci . sitcc $ sep breakpoint (sitcc . located' p_hsType) xs

155 RecCon l -> do

143 RecCon l -> do

156 p_rdrName con_name

144 p_rdrName con_name

157 breakpoint

145 breakpoint

158− inciIf (not singleConstRec) (located l p_conDeclFields)

146+ inci $ located l p_conDeclFields

159 InfixCon x y -> do

147 InfixCon x y -> do

160 located x p_hsType

148 located x p_hsType

161 breakpoint

149 breakpoint

@@ -163,7 +151,7 @@ p_conDecl singleConstRec = \case

163 p_rdrName con_name

151 p_rdrName con_name

164 space

152 space

165 located y p_hsType

153 located y p_hsType

166− XConDecl x -> noExtCon x

154+ XConDecl NoExt -> notImplemented "XConDecl"

167

155

168conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]

156conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan]

169conArgsSpans = \case

157conArgsSpans = \case

@@ -177,7 +165,7 @@ conArgsSpans = \case

177conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]

165conTyVarsSpans :: LHsQTyVars GhcPs -> [SrcSpan]

178conTyVarsSpans = \case

166conTyVarsSpans = \case

179 HsQTvs {..} -> getLoc <$> hsq_explicit

167 HsQTvs {..} -> getLoc <$> hsq_explicit

180− XLHsQTyVars x -> noExtCon x

168+ XLHsQTyVars NoExt -> []

181

169

182p_lhsContext ::

170p_lhsContext ::

183 LHsContext GhcPs ->

171 LHsContext GhcPs ->

@@ -204,9 +192,9 @@ p_hsDerivingClause HsDerivingClause {..} = do

204 let derivingWhat = located deriv_clause_tys $ \case

192 let derivingWhat = located deriv_clause_tys $ \case

205 [] -> txt "()"

193 [] -> txt "()"

206 xs ->

194 xs ->

207− parens N $

195+ parens N . sitcc $

208 sep

196 sep

209− commaDel

197+ (comma >> breakpoint)

210 (sitcc . located' p_hsType . hsib_body)

198 (sitcc . located' p_hsType . hsib_body)

211 xs

199 xs

212 space

200 space

@@ -235,9 +223,9 @@ p_hsDerivingClause HsDerivingClause {..} = do

235 txt "via"

223 txt "via"

236 space

224 space

237 located hsib_body p_hsType

225 located hsib_body p_hsType

238− ViaStrategy (XHsImplicitBndrs x) ->

226+ ViaStrategy (XHsImplicitBndrs NoExt) ->

239− noExtCon x

227+ notImplemented "XHsImplicitBndrs"

240−p_hsDerivingClause (XHsDerivingClause x) = noExtCon x

228+p_hsDerivingClause (XHsDerivingClause NoExt) = notImplemented "XHsDerivingClause"

241

229

242----------------------------------------------------------------------------

230----------------------------------------------------------------------------

243-- Helpers

231-- Helpers

@@ -246,16 +234,3 @@ isInfix :: LexicalFixity -> Bool

246isInfix = \case

234isInfix = \case

247 Infix -> True

235 Infix -> True

248 Prefix -> False

236 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+5−4

@@ -9,12 +9,13 @@ where

9import GHC

10import Ormolu.Printer.Combinators

11import Ormolu.Printer.Meat.Type

12+import Ormolu.Utils

12

13

13p_defaultDecl :: DefaultDecl GhcPs -> R ()

14p_defaultDecl :: DefaultDecl GhcPs -> R ()

14p_defaultDecl = \case

15p_defaultDecl = \case

15− DefaultDecl NoExtField ts -> do

16+ DefaultDecl NoExt ts -> do

16 txt "default"

17 txt "default"

17 breakpoint

18 breakpoint

18− inci . parens N $

19+ inci . parens N . sitcc $

19− sep commaDel (sitcc . located' p_hsType) ts

20+ sep (comma >> breakpoint) (sitcc . located' p_hsType) ts

20− XDefaultDecl x -> noExtCon x

21+ XDefaultDecl {} -> notImplemented "XDefaultDecl"

src/Ormolu/Printer/Meat/Declaration/Foreign.hs+3−2

@@ -15,6 +15,7 @@ import GHC

15import Ormolu.Printer.Combinators

16import Ormolu.Printer.Meat.Common

17import Ormolu.Printer.Meat.Declaration.Signature

18+import Ormolu.Utils

18

19

19p_foreignDecl :: ForeignDecl GhcPs -> R ()

20p_foreignDecl :: ForeignDecl GhcPs -> R ()

20p_foreignDecl = \case

21p_foreignDecl = \case

@@ -24,7 +25,7 @@ p_foreignDecl = \case

24 fd@ForeignExport {fd_fe} -> do

25 fd@ForeignExport {fd_fe} -> do

25 p_foreignExport fd_fe

26 p_foreignExport fd_fe

26 p_foreignTypeSig fd

27 p_foreignTypeSig fd

27− XForeignDecl x -> noExtCon x

28+ XForeignDecl {} -> notImplemented "XForeignDecl"

28

29

29-- | Printer for the last part of an import\/export, which is function name

30-- | Printer for the last part of an import\/export, which is function name

30-- and type signature.

31-- and type signature.

@@ -38,7 +39,7 @@ p_foreignTypeSig fd = do

38 ]

39 ]

39 $ do

40 $ do

40 p_rdrName (fd_name fd)

41 p_rdrName (fd_name fd)

41− p_typeAscription (HsWC NoExtField (fd_sig_ty fd))

42+ p_typeAscription (HsWC NoExt (fd_sig_ty fd))

42

43

43-- | Printer for 'ForeignImport'.

44-- | Printer for 'ForeignImport'.

44--

45--

src/Ormolu/Printer/Meat/Declaration/Instance.hs+17−13

@@ -32,7 +32,9 @@ p_standaloneDerivDecl DerivDecl {..} = do

32 txt "instance"

33 breakpoint

34 match_overlap_mode deriv_overlap_mode breakpoint

35+ if toIndent

36+ then inci typesAfterInstance

35− inciIf toIndent typesAfterInstance

37+ else typesAfterInstance

36 txt "deriving"

38 txt "deriving"

37 space

39 space

38 case deriv_strategy of

40 case deriv_strategy of

@@ -54,8 +56,8 @@ p_standaloneDerivDecl DerivDecl {..} = do

54 inci (located hsib_body p_hsType)

56 inci (located hsib_body p_hsType)

55 breakpoint

57 breakpoint

56 instTypes True

58 instTypes True

57− ViaStrategy (XHsImplicitBndrs x) ->

59+ ViaStrategy (XHsImplicitBndrs NoExt) ->

58− noExtCon x

60+ notImplemented "XHsImplicitBndrs"

59p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl"

61p_standaloneDerivDecl (XDerivDecl _) = notImplemented "XDerivDecl"

60

62

61p_clsInstDecl :: ClsInstDecl GhcPs -> R ()

63p_clsInstDecl :: ClsInstDecl GhcPs -> R ()

@@ -68,14 +70,14 @@ p_clsInstDecl = \case

68 -- location order. This happens because different declarations are stored in

70 -- location order. This happens because different declarations are stored in

69 -- different lists. Consequently, to get all the declarations in proper

71 -- different lists. Consequently, to get all the declarations in proper

70 -- order, they need to be manually sorted.

72 -- order, they need to be manually sorted.

71− let sigs = (getLoc &&& fmap (SigD NoExtField)) <$> cid_sigs

73+ let sigs = (getLoc &&& fmap (SigD NoExt)) <$> cid_sigs

72− vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cid_binds

74+ vals = (getLoc &&& fmap (ValD NoExt)) <$> toList cid_binds

73 tyFamInsts =

75 tyFamInsts =

74− ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField)

76+ ( getLoc &&& fmap (InstD NoExt . TyFamInstD NoExt)

75 )

77 )

76 <$> cid_tyfam_insts

78 <$> cid_tyfam_insts

77 dataFamInsts =

79 dataFamInsts =

78− ( getLoc &&& fmap (InstD NoExtField . DataFamInstD NoExtField)

80+ ( getLoc &&& fmap (InstD NoExt . DataFamInstD NoExt)

79 )

81 )

80 <$> cid_datafam_insts

82 <$> cid_datafam_insts

81 allDecls =

83 allDecls =

@@ -88,12 +90,14 @@ p_clsInstDecl = \case

88 unless (null allDecls) $ do

90 unless (null allDecls) $ do

89 breakpoint

91 breakpoint

90 txt "where"

92 txt "where"

91− unless (null allDecls) . inci $ do

93+ unless (null allDecls)

94+ $ inci

95+ $ do

92− -- Ensure whitespace is added after where clause.

96+ -- Ensure whitespace is added after where clause.

93− breakpoint

97+ breakpoint

94− dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls

98+ dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls

95− XHsImplicitBndrs x -> noExtCon x

99+ XHsImplicitBndrs NoExt -> notImplemented "XHsImplicitBndrs"

96− XClsInstDecl x -> noExtCon x

100+ XClsInstDecl NoExt -> notImplemented "XClsInstDecl"

97

101

98p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()

102p_tyFamInstDecl :: FamilyStyle -> TyFamInstDecl GhcPs -> R ()

99p_tyFamInstDecl style = \case

103p_tyFamInstDecl style = \case

src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs+5−2

@@ -12,11 +12,14 @@ import CoAxiom

12import GHC

13import Ormolu.Printer.Combinators

14import Ormolu.Printer.Meat.Common

15+import Ormolu.Utils

16+import RdrName (RdrName (..))

17+import SrcLoc (Located)

15

18

16p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()

19p_roleAnnot :: RoleAnnotDecl GhcPs -> R ()

17p_roleAnnot = \case

20p_roleAnnot = \case

18− RoleAnnotDecl NoExtField l_name anns -> p_roleAnnot' l_name anns

21+ RoleAnnotDecl NoExt l_name anns -> p_roleAnnot' l_name anns

19− XRoleAnnotDecl x -> noExtCon x

22+ XRoleAnnotDecl _ -> notImplemented "XRoleAnnotDecl"

20

23

21p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()

24p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R ()

22p_roleAnnot' l_name anns = do

25p_roleAnnot' l_name anns = do

src/Ormolu/Printer/Meat/Declaration/Rule.hs+13−12

@@ -14,17 +14,18 @@ import Ormolu.Printer.Meat.Common

14import Ormolu.Printer.Meat.Declaration.Signature

15import Ormolu.Printer.Meat.Declaration.Value

16import Ormolu.Printer.Meat.Type

17+import Ormolu.Utils

17

18

18p_ruleDecls :: RuleDecls GhcPs -> R ()

19p_ruleDecls :: RuleDecls GhcPs -> R ()

19p_ruleDecls = \case

20p_ruleDecls = \case

20− HsRules NoExtField _ xs ->

21+ HsRules NoExt _ xs ->

21− pragma "RULES" $

22+ pragma "RULES" . sitcc $

22 sep breakpoint (sitcc . located' p_ruleDecl) xs

23 sep breakpoint (sitcc . located' p_ruleDecl) xs

23− XRuleDecls x -> noExtCon x

24+ XRuleDecls NoExt -> notImplemented "XRuleDecls"

24

25

25p_ruleDecl :: RuleDecl GhcPs -> R ()

26p_ruleDecl :: RuleDecl GhcPs -> R ()

26p_ruleDecl = \case

27p_ruleDecl = \case

27− HsRule NoExtField ruleName activation tyvars ruleBndrs lhs rhs -> do

28+ HsRule NoExt ruleName activation tyvars ruleBndrs lhs rhs -> do

28 located ruleName p_ruleName

29 located ruleName p_ruleName

29 space

30 space

30 p_activation activation

31 p_activation activation

@@ -32,30 +33,30 @@ p_ruleDecl = \case

32 case tyvars of

33 case tyvars of

33 Nothing -> return ()

34 Nothing -> return ()

34 Just xs -> do

35 Just xs -> do

35− p_forallBndrs ForallInvis p_hsTyVarBndr xs

36+ p_forallBndrs p_hsTyVarBndr xs

36 space

37 space

37 -- It appears that there is no way to tell if there was an empty forall

38 -- It appears that there is no way to tell if there was an empty forall

38 -- in the input or no forall at all. We do not want to add redundant

39 -- in the input or no forall at all. We do not want to add redundant

39 -- foralls, so let's just skip the empty ones.

40 -- foralls, so let's just skip the empty ones.

40 unless (null ruleBndrs) $

41 unless (null ruleBndrs) $

41− p_forallBndrs ForallInvis p_ruleBndr ruleBndrs

42+ p_forallBndrs p_ruleBndr ruleBndrs

42 breakpoint

43 breakpoint

43 inci $ do

44 inci $ do

44 located lhs p_hsExpr

45 located lhs p_hsExpr

45 space

46 space

46− equals

47+ txt "="

47 inci $ do

48 inci $ do

48 breakpoint

49 breakpoint

49 located rhs p_hsExpr

50 located rhs p_hsExpr

50− XRuleDecl x -> noExtCon x

51+ XRuleDecl NoExt -> notImplemented "XRuleDecl"

51

52

52p_ruleName :: (SourceText, RuleName) -> R ()

53p_ruleName :: (SourceText, RuleName) -> R ()

53−p_ruleName (_, name) = atom $ (HsString NoSourceText name :: HsLit GhcPs)

54+p_ruleName (_, name) = atom $ HsString NoSourceText name

54

55

55p_ruleBndr :: RuleBndr GhcPs -> R ()

56p_ruleBndr :: RuleBndr GhcPs -> R ()

56p_ruleBndr = \case

57p_ruleBndr = \case

57− RuleBndr NoExtField x -> p_rdrName x

58+ RuleBndr NoExt x -> p_rdrName x

58− RuleBndrSig NoExtField x hswc -> parens N $ do

59+ RuleBndrSig NoExt x hswc -> parens N $ do

59 p_rdrName x

60 p_rdrName x

60 p_typeAscription hswc

61 p_typeAscription hswc

61− XRuleBndr x -> noExtCon x

62+ XRuleBndr NoExt -> notImplemented "XRuleBndr"

src/Ormolu/Printer/Meat/Declaration/Signature.hs+33−49

@@ -7,13 +7,13 @@ module Ormolu.Printer.Meat.Declaration.Signature

7 ( p_sigDecl,

8 p_typeAscription,

9 p_activation,

10− p_standaloneKindSig,

11 )

10 )

12where

11where

13

12

14import BasicTypes

13import BasicTypes

15import BooleanFormula

14import BooleanFormula

16import Control.Monad

15import Control.Monad

16+import Data.Bool (bool)

17import GHC

18import Ormolu.Printer.Combinators

19import Ormolu.Printer.Meat.Common

@@ -22,16 +22,16 @@ import Ormolu.Utils

22

23p_sigDecl :: Sig GhcPs -> R ()

24p_sigDecl = \case

25− TypeSig NoExtField names hswc -> p_typeSig True names hswc

25+ TypeSig NoExt names hswc -> p_typeSig True names hswc

26− PatSynSig NoExtField names hsib -> p_patSynSig names hsib

26+ PatSynSig NoExt names hsib -> p_patSynSig names hsib

27− ClassOpSig NoExtField def names hsib -> p_classOpSig def names hsib

27+ ClassOpSig NoExt def names hsib -> p_classOpSig def names hsib

28− FixSig NoExtField sig -> p_fixSig sig

28+ FixSig NoExt sig -> p_fixSig sig

29− InlineSig NoExtField name inlinePragma -> p_inlineSig name inlinePragma

29+ InlineSig NoExt name inlinePragma -> p_inlineSig name inlinePragma

30− SpecSig NoExtField name ts inlinePragma -> p_specSig name ts inlinePragma

30+ SpecSig NoExt name ts inlinePragma -> p_specSig name ts inlinePragma

31− SpecInstSig NoExtField _ hsib -> p_specInstSig hsib

31+ SpecInstSig NoExt _ hsib -> p_specInstSig hsib

32− MinimalSig NoExtField _ booleanFormula -> p_minimalSig booleanFormula

32+ MinimalSig NoExt _ booleanFormula -> p_minimalSig booleanFormula

33− CompleteMatchSig NoExtField _sourceText cs ty -> p_completeSig cs ty

33+ CompleteMatchSig NoExt _sourceText cs ty -> p_completeSig cs ty

34− SCCFunSig NoExtField _ name literal -> p_sccSig name literal

34+ SCCFunSig NoExt _ name literal -> p_sccSig name literal

35 _ -> notImplemented "certain types of signature declarations"

36

37p_typeSig ::

@@ -47,23 +47,25 @@ p_typeSig indentTail (n : ns) hswc = do

47 p_rdrName n

48 if null ns

49 then p_typeAscription hswc

50− else inciIf indentTail $ do

50+ else bool id inci indentTail $ do

51− commaDel

51+ comma

52+ breakpoint

52− sep commaDel p_rdrName ns

53+ sep (comma >> breakpoint) p_rdrName ns

53 p_typeAscription hswc

54 p_typeAscription hswc

54

55

55p_typeAscription ::

56p_typeAscription ::

56 LHsSigWcType GhcPs ->

57 LHsSigWcType GhcPs ->

57 R ()

58 R ()

58−p_typeAscription HsWC {..} = inci $ do

59+p_typeAscription HsWC {..} = do

59 space

60 space

61+ inci $ do

60− txt "::"

62+ txt "::"

61− let t = hsib_body hswc_body

63+ let t = hsib_body hswc_body

62− if hasDocStrings (unLoc t)

64+ if hasDocStrings (unLoc t)

63− then newline

65+ then newline

64− else breakpoint

66+ else breakpoint

65− located t p_hsType

67+ located t p_hsType

66−p_typeAscription (XHsWildCardBndrs x) = noExtCon x

68+p_typeAscription (XHsWildCardBndrs NoExt) = notImplemented "XHsWildCardBndrs"

67

69

68p_patSynSig ::

70p_patSynSig ::

69 [Located RdrName] ->

71 [Located RdrName] ->

@@ -71,11 +73,7 @@ p_patSynSig ::

71 R ()

73 R ()

72p_patSynSig names hsib = do

74p_patSynSig names hsib = do

73 txt "pattern"

75 txt "pattern"

74− let body =

75− p_typeSig

76− False

77− names

78− HsWC {hswc_ext = NoExtField, hswc_body = hsib}

76+ let body = p_typeSig False names HsWC {hswc_ext = NoExt, hswc_body = hsib}

79 if length names > 1

77 if length names > 1

80 then breakpoint >> inci body

78 then breakpoint >> inci body

81 else space >> body

79 else space >> body

@@ -90,13 +88,13 @@ p_classOpSig ::

90 R ()

88 R ()

91p_classOpSig def names hsib = do

89p_classOpSig def names hsib = do

92 when def (txt "default" >> space)

90 when def (txt "default" >> space)

93− p_typeSig True names HsWC {hswc_ext = NoExtField, hswc_body = hsib}

91+ p_typeSig True names HsWC {hswc_ext = NoExt, hswc_body = hsib}

94

92

95p_fixSig ::

93p_fixSig ::

96 FixitySig GhcPs ->

94 FixitySig GhcPs ->

97 R ()

95 R ()

98p_fixSig = \case

96p_fixSig = \case

99− FixitySig NoExtField names (Fixity _ n dir) -> do

97+ FixitySig NoExt names (Fixity _ n dir) -> do

100 txt $ case dir of

98 txt $ case dir of

101 InfixL -> "infixl"

99 InfixL -> "infixl"

102 InfixR -> "infixr"

100 InfixR -> "infixr"

@@ -104,8 +102,8 @@ p_fixSig = \case

104 space

102 space

105 atom n

103 atom n

106 space

104 space

107− sitcc $ sep commaDel p_rdrName names

105+ sitcc $ sep (comma >> breakpoint) p_rdrName names

108− XFixitySig x -> noExtCon x

106+ XFixitySig NoExt -> notImplemented "XFixitySig"

109

107

110p_inlineSig ::

108p_inlineSig ::

111 -- | Name

109 -- | Name

@@ -143,7 +141,7 @@ p_specSig name ts InlinePragma {..} = pragmaBraces $ do

143 space

141 space

144 txt "::"

142 txt "::"

145 breakpoint

143 breakpoint

146− inci $ sep commaDel (located' p_hsType . hsib_body) ts

144+ inci $ sep (comma >> breakpoint) (located' p_hsType . hsib_body) ts

147

145

148p_inlineSpec :: InlineSpec -> R ()

146p_inlineSpec :: InlineSpec -> R ()

149p_inlineSpec = \case

147p_inlineSpec = \case

@@ -187,13 +185,13 @@ p_booleanFormula = \case

187 And xs ->

185 And xs ->

188 sitcc $

186 sitcc $

189 sep

187 sep

190− commaDel

188+ (comma >> breakpoint)

191 (located' p_booleanFormula)

189 (located' p_booleanFormula)

192 xs

190 xs

193 Or xs ->

191 Or xs ->

194 sitcc $

192 sitcc $

195 sep

193 sep

196− (breakpoint >> txt "|" >> space)

194+ (breakpoint >> txt "| ")

197 (located' p_booleanFormula)

195 (located' p_booleanFormula)

198 xs

196 xs

199 Parens l -> located l (parens N . p_booleanFormula)

197 Parens l -> located l (parens N . p_booleanFormula)

@@ -207,7 +205,7 @@ p_completeSig ::

207p_completeSig cs' mty =

205p_completeSig cs' mty =

208 located cs' $ \cs ->

206 located cs' $ \cs ->

209 pragma "COMPLETE" . inci $ do

207 pragma "COMPLETE" . inci $ do

210− sep commaDel p_rdrName cs

208+ sitcc $ sep (comma >> breakpoint) p_rdrName cs

211 forM_ mty $ \ty -> do

209 forM_ mty $ \ty -> do

212 space

210 space

213 txt "::"

211 txt "::"

@@ -220,17 +218,3 @@ p_sccSig loc literal = pragma "SCC" . inci $ do

220 forM_ literal $ \x -> do

218 forM_ literal $ \x -> do

221 breakpoint

219 breakpoint

222 atom x

220 atom x

223−

224−p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()

225−p_standaloneKindSig (StandaloneKindSig NoExtField name bndrs) = do

226− txt "type"

227− inci $ do

228− space

229− p_rdrName name

230− space

231− txt "::"

232− breakpoint

233− case bndrs of

234− HsIB NoExtField sig -> located sig p_hsType

235− XHsImplicitBndrs x -> noExtCon x

236−p_standaloneKindSig (XStandaloneKindSig c) = noExtCon c

src/Ormolu/Printer/Meat/Declaration/Splice.hs+3−2

@@ -8,8 +8,9 @@ where

8import GHC

9import Ormolu.Printer.Combinators

10import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)

11+import Ormolu.Utils

11

12

12p_spliceDecl :: SpliceDecl GhcPs -> R ()

13p_spliceDecl :: SpliceDecl GhcPs -> R ()

13p_spliceDecl = \case

14p_spliceDecl = \case

14− SpliceDecl NoExtField splice _explicit -> located splice p_hsSplice

15+ SpliceDecl NoExt splice _explicit -> located splice p_hsSplice

15− XSpliceDecl x -> noExtCon x

16+ XSpliceDecl {} -> notImplemented "XSpliceDecl"

src/Ormolu/Printer/Meat/Declaration/Type.hs+7−6

@@ -11,6 +11,9 @@ import GHC

11import Ormolu.Printer.Combinators

12import Ormolu.Printer.Meat.Common

13import Ormolu.Printer.Meat.Type

14+import Ormolu.Utils (notImplemented)

15+import RdrName (RdrName (..))

16+import SrcLoc (Located)

14

17

15p_synDecl ::

18p_synDecl ::

16 -- | Type constructor

19 -- | Type constructor

@@ -28,13 +31,11 @@ p_synDecl name fixity HsQTvs {..} t = do

28 switchLayout (getLoc name : map getLoc hsq_explicit) $

31 switchLayout (getLoc name : map getLoc hsq_explicit) $

29 p_infixDefHelper

32 p_infixDefHelper

30 (case fixity of Infix -> True; _ -> False)

33 (case fixity of Infix -> True; _ -> False)

31− True

34+ inci

32 (p_rdrName name)

35 (p_rdrName name)

33 (map (located' p_hsTyVarBndr) hsq_explicit)

36 (map (located' p_hsTyVarBndr) hsq_explicit)

34 space

37 space

35− equals

38+ txt "="

36− if hasDocStrings (unLoc t)

37− then newline

38− else breakpoint

39+ breakpoint

39 inci (located t p_hsType)

40 inci (located t p_hsType)

40−p_synDecl _ _ (XLHsQTyVars x) _ = noExtCon x

41+p_synDecl _ _ XLHsQTyVars {} _ = notImplemented "XLHsQTyVars"

src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs+23−22

@@ -9,13 +9,15 @@ module Ormolu.Printer.Meat.Declaration.TypeFamily

9 )

10where

11

12+import BasicTypes (LexicalFixity (..))

12import Control.Monad

13import Control.Monad

13−import Data.Maybe (isNothing)

14+import Data.Maybe (isJust, isNothing)

14import GHC

15import GHC

15import Ormolu.Printer.Combinators

16import Ormolu.Printer.Combinators

16import Ormolu.Printer.Meat.Common

17import Ormolu.Printer.Meat.Common

17import Ormolu.Printer.Meat.Type

18import Ormolu.Printer.Meat.Type

18import Ormolu.Utils

19import Ormolu.Utils

20+import SrcLoc (GenLocated (..), Located)

19

21

20p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()

22p_famDecl :: FamilyStyle -> FamilyDecl GhcPs -> R ()

21p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do

23p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do

@@ -31,21 +33,20 @@ p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do

31 switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $

33 switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $

32 p_infixDefHelper

34 p_infixDefHelper

33 (isInfix fdFixity)

35 (isInfix fdFixity)

34− True

36+ inci

35 (p_rdrName fdLName)

37 (p_rdrName fdLName)

36 (located' p_hsTyVarBndr <$> hsq_explicit)

38 (located' p_hsTyVarBndr <$> hsq_explicit)

37− let resultSig = p_familyResultSigL fdResultSig

39+ let rsig = p_familyResultSigL fdResultSig

38− unless (isNothing resultSig && isNothing fdInjectivityAnn) space

40+ unless (isNothing rsig && isNothing fdInjectivityAnn) space

39 inci $ do

41 inci $ do

40− sequence_ resultSig

42+ sequence_ rsig

41− space

43+ when (isJust rsig && isJust fdInjectivityAnn) breakpoint

42 forM_ fdInjectivityAnn (located' p_injectivityAnn)

44 forM_ fdInjectivityAnn (located' p_injectivityAnn)

43 case mmeqs of

45 case mmeqs of

44 Nothing -> return ()

46 Nothing -> return ()

45 Just meqs -> do

47 Just meqs -> do

46− inci $ do

48+ space

47− breakpoint

48− txt "where"

49+ txt "where"

49 case meqs of

50 case meqs of

50 Nothing -> do

51 Nothing -> do

51 space

52 space

@@ -55,7 +56,7 @@ p_famDecl style FamilyDecl {fdTyVars = HsQTvs {..}, ..} = do

55 sep newline (located' (inci . p_tyFamInstEqn)) eqs

56 sep newline (located' (inci . p_tyFamInstEqn)) eqs

56p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} =

57p_famDecl _ FamilyDecl {fdTyVars = XLHsQTyVars {}} =

57 notImplemented "XLHsQTyVars"

58 notImplemented "XLHsQTyVars"

58−p_famDecl _ (XFamilyDecl x) = noExtCon x

59+p_famDecl _ (XFamilyDecl NoExt) = notImplemented "XFamilyDecl"

59

60

60p_familyResultSigL ::

61p_familyResultSigL ::

61 Located (FamilyResultSig GhcPs) ->

62 Located (FamilyResultSig GhcPs) ->

@@ -63,17 +64,17 @@ p_familyResultSigL ::

63p_familyResultSigL l =

64p_familyResultSigL l =

64 case l of

65 case l of

65 L _ a -> case a of

66 L _ a -> case a of

66− NoSig NoExtField -> Nothing

67+ NoSig NoExt -> Nothing

67− KindSig NoExtField k -> Just $ do

68+ KindSig NoExt k -> Just $ do

68 txt "::"

69 txt "::"

69 breakpoint

70 breakpoint

70 located k p_hsType

71 located k p_hsType

71− TyVarSig NoExtField bndr -> Just $ do

72+ TyVarSig NoExt bndr -> Just $ do

72− equals

73+ txt "="

73 breakpoint

74 breakpoint

74 located bndr p_hsTyVarBndr

75 located bndr p_hsTyVarBndr

75− XFamilyResultSig x ->

76+ XFamilyResultSig NoExt ->

76− noExtCon x

77+ notImplemented "XFamilyResultSig"

77

78

78p_injectivityAnn :: InjectivityAnn GhcPs -> R ()

79p_injectivityAnn :: InjectivityAnn GhcPs -> R ()

79p_injectivityAnn (InjectivityAnn a bs) = do

80p_injectivityAnn (InjectivityAnn a bs) = do

@@ -90,22 +91,22 @@ p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do

90 case feqn_bndrs of

91 case feqn_bndrs of

91 Nothing -> return ()

92 Nothing -> return ()

92 Just bndrs -> do

93 Just bndrs -> do

93− p_forallBndrs ForallInvis p_hsTyVarBndr bndrs

94+ p_forallBndrs p_hsTyVarBndr bndrs

94 breakpoint

95 breakpoint

95− inciIf (not $ null feqn_bndrs) $ do

96+ (if null feqn_bndrs then id else inci) $ do

96 let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats

97 let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats

97 switchLayout famLhsSpn $

98 switchLayout famLhsSpn $

98 p_infixDefHelper

99 p_infixDefHelper

99 (isInfix feqn_fixity)

100 (isInfix feqn_fixity)

100− True

101+ inci

101 (p_rdrName feqn_tycon)

102 (p_rdrName feqn_tycon)

102 (located' p_hsType . typeArgToType <$> feqn_pats)

103 (located' p_hsType . typeArgToType <$> feqn_pats)

103 space

104 space

104− equals

105+ txt "="

105 breakpoint

106 breakpoint

106 inci (located feqn_rhs p_hsType)

107 inci (located feqn_rhs p_hsType)

107−p_tyFamInstEqn HsIB {hsib_body = XFamEqn x} = noExtCon x

108+p_tyFamInstEqn HsIB {hsib_body = XFamEqn {}} = notImplemented "HsIB XFamEqn"

108−p_tyFamInstEqn (XHsImplicitBndrs x) = noExtCon x

109+p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs"

109

110

110----------------------------------------------------------------------------

111----------------------------------------------------------------------------

111-- Helpers

112-- Helpers

src/Ormolu/Printer/Meat/Declaration/Value.hs+361−375

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

1{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE MultiWayIf #-}

3{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE TypeApplications #-}

6

4

7module Ormolu.Printer.Meat.Declaration.Value

5module Ormolu.Printer.Meat.Declaration.Value

8 ( p_valDecl,

6 ( p_valDecl,

@@ -22,12 +20,12 @@ import Data.Char (isPunctuation, isSymbol)

22import Data.Data hiding (Infix, Prefix)

20import Data.Data hiding (Infix, Prefix)

23import Data.Functor ((<&>))

21import Data.Functor ((<&>))

24import Data.List (intersperse, sortOn)

22import Data.List (intersperse, sortOn)

25−import Data.List.NonEmpty (NonEmpty (..), (<|))

23+import Data.List.NonEmpty ((<|), NonEmpty ((:|)))

26import qualified Data.List.NonEmpty as NE

24import qualified Data.List.NonEmpty as NE

27import Data.Text (Text)

25import Data.Text (Text)

28import qualified Data.Text as Text

26import qualified Data.Text as Text

29import GHC

27import GHC

30−import OccName (occNameString)

28+import OccName (mkVarOcc)

31import Ormolu.Printer.Combinators

29import Ormolu.Printer.Combinators

32import Ormolu.Printer.Internal

30import Ormolu.Printer.Internal

33import Ormolu.Printer.Meat.Common

31import Ormolu.Printer.Meat.Common

@@ -36,6 +34,8 @@ import Ormolu.Printer.Meat.Declaration.Signature

36import Ormolu.Printer.Meat.Type

34import Ormolu.Printer.Meat.Type

37import Ormolu.Printer.Operators

35import Ormolu.Printer.Operators

38import Ormolu.Utils

36import Ormolu.Utils

37+import RdrName (RdrName (..), rdrNameOcc)

38+import SrcLoc (combineSrcSpans, isOneLineSpan)

39

40-- | Style of a group of equations.

41data MatchGroupStyle

@@ -61,16 +61,16 @@ data Placement

61 -- should use it and avoid bumping one level

62 -- of indentation

63 Hanging

64− deriving (Eq, Show)

64+ deriving (Eq)

65

66p_valDecl :: HsBindLR GhcPs GhcPs -> R ()

67p_valDecl = \case

68− FunBind NoExtField funId funMatches _ _ -> p_funBind funId funMatches

68+ FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches

69− PatBind NoExtField pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss

69+ PatBind NoExt pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss

70 VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker

71 AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker

72− PatSynBind NoExtField psb -> p_patSynBind psb

72+ PatSynBind NoExt psb -> p_patSynBind psb

73− XHsBindsLR x -> noExtCon x

73+ XHsBindsLR NoExt -> notImplemented "XHsBindsLR"

74

75p_funBind ::

76 Located RdrName ->

@@ -114,8 +114,8 @@ p_matchGroup' placer render style MG {..} = do

114 (matchStrictness m)

115 m_pats

116 m_grhss

117− p_Match (XMatch x) = noExtCon x

117+ p_Match _ = notImplemented "XMatch"

118−p_matchGroup' _ _ _ (XMatchGroup x) = noExtCon x

118+p_matchGroup' _ _ _ (XMatchGroup NoExt) = notImplemented "XMatchGroup"

119

120-- | Function id obtained through pattern matching on 'FunBind' should not

121-- be used to print the actual equations because the different ‘RdrNames’

@@ -180,26 +180,27 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do

180 NoSrcStrict -> return ()

181 SrcStrict -> txt "!"

182 SrcLazy -> txt "~"

183− indentBody <- case NE.nonEmpty m_pats of

183+ inci' <- case NE.nonEmpty m_pats of

184− Nothing ->

185− False <$ case style of

184+ Nothing -> id <$ case style of

186− Function name -> p_rdrName name

185+ Function name -> p_rdrName name

187− _ -> return ()

186+ _ -> return ()

188 Just ne_pats -> do

187 Just ne_pats -> do

189− let combinedSpans = case style of

188+ let combinedSpans =

190− Function name -> combineSrcSpans (getLoc name) patSpans

189+ combineSrcSpans' $

191− _ -> patSpans

192− patSpans = combineSrcSpans' (getLoc <$> ne_pats)

190+ getLoc <$> ne_pats

191+ inci' =

193− indentBody = not (isOneLineSpan combinedSpans)

192+ if isOneLineSpan combinedSpans

193+ then id

194+ else inci

194 switchLayout [combinedSpans] $ do

195 switchLayout [combinedSpans] $ do

195− let stdCase = sep breakpoint (located' p_pat) m_pats

196+ let stdCase = sep breakpoint p_pat m_pats

196 case style of

197 case style of

197 Function name ->

198 Function name ->

198 p_infixDefHelper

199 p_infixDefHelper

199 isInfix

200 isInfix

200− indentBody

201+ inci'

201 (p_rdrName name)

202 (p_rdrName name)

202− (located' p_pat <$> m_pats)

203+ (p_pat <$> m_pats)

203 PatternBind -> stdCase

204 PatternBind -> stdCase

204 Case -> stdCase

205 Case -> stdCase

205 Lambda -> do

206 Lambda -> do

@@ -212,32 +213,40 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do

212 when needsSpace space

213 when needsSpace space

213 sitcc stdCase

214 sitcc stdCase

214 LambdaCase -> stdCase

215 LambdaCase -> stdCase

215− return indentBody

216+ return inci'

216 let -- Calculate position of end of patterns. This is useful when we decide

217 let -- Calculate position of end of patterns. This is useful when we decide

217 -- about putting certain constructions in hanging positions.

218 -- about putting certain constructions in hanging positions.

218 endOfPats = case NE.nonEmpty m_pats of

219 endOfPats = case NE.nonEmpty m_pats of

219 Nothing -> case style of

220 Nothing -> case style of

220− Function name -> Just (getLoc name)

221+ Function name -> (Just . srcSpanEnd . getLoc) name

221 _ -> Nothing

222 _ -> Nothing

222− Just pats -> (Just . getLoc . NE.last) pats

223+ Just pats -> (Just . srcSpanEnd . getLoc . NE.last) pats

223 isCase = \case

224 isCase = \case

224 Case -> True

225 Case -> True

225 LambdaCase -> True

226 LambdaCase -> True

226 _ -> False

227 _ -> False

227− hasGuards = withGuards grhssGRHSs

228+ let hasGuards = withGuards grhssGRHSs

229+ unless (length grhssGRHSs > 1) $

230+ case style of

231+ Function _ | hasGuards -> return ()

232+ Function _ -> space >> txt "="

233+ PatternBind -> space >> txt "="

234+ s | isCase s && hasGuards -> return ()

235+ _ -> space >> txt "->"

228− grhssSpan =

236+ let grhssSpan =

229 combineSrcSpans' $

237 combineSrcSpans' $

230 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs

238 getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs

231 patGrhssSpan =

239 patGrhssSpan =

232 maybe

240 maybe

233 grhssSpan

241 grhssSpan

234− (combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd)

242+ (combineSrcSpans grhssSpan . srcLocSpan)

235 endOfPats

243 endOfPats

236 placement =

244 placement =

237 case endOfPats of

245 case endOfPats of

238 Nothing -> blockPlacement placer grhssGRHSs

246 Nothing -> blockPlacement placer grhssGRHSs

239 Just spn ->

247 Just spn ->

248+ if isOneLineSpan

240− if onTheSameLine spn grhssSpan

249+ (mkSrcSpan spn (srcSpanStart grhssSpan))

241 then blockPlacement placer grhssGRHSs

250 then blockPlacement placer grhssGRHSs

242 else Normal

251 else Normal

243 p_body = do

252 p_body = do

@@ -253,18 +262,11 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do

253 txt "where"

262 txt "where"

254 unless whereIsEmpty breakpoint

263 unless whereIsEmpty breakpoint

255 inci $ located grhssLocalBinds p_hsLocalBinds

264 inci $ located grhssLocalBinds p_hsLocalBinds

256− inciIf indentBody $ do

265+ inci' $ 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 "->"

264 switchLayout [patGrhssSpan] $

266 switchLayout [patGrhssSpan] $

265 placeHanging placement p_body

267 placeHanging placement p_body

266 inci p_where

268 inci p_where

267−p_match' _ _ _ _ _ _ (XGRHSs x) = noExtCon x

269+p_match' _ _ _ _ _ _ XGRHSs {} = notImplemented "XGRHSs"

268

270

269p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()

271p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R ()

270p_grhs = p_grhs' exprPlacement p_hsExpr

272p_grhs = p_grhs' exprPlacement p_hsExpr

@@ -278,109 +280,79 @@ p_grhs' ::

278 GroupStyle ->

280 GroupStyle ->

279 GRHS GhcPs (Located body) ->

281 GRHS GhcPs (Located body) ->

280 R ()

282 R ()

281−p_grhs' placer render style (GRHS NoExtField guards body) =

283+p_grhs' placer render style (GRHS NoExt guards body) =

282 case guards of

284 case guards of

283 [] -> p_body

285 [] -> p_body

284 xs -> do

286 xs -> do

285 txt "|"

287 txt "|"

286 space

288 space

287− sitcc (sep commaDel (sitcc . located' p_stmt) xs)

289+ sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs)

288 space

290 space

289− inci $ case style of

291+ txt $ case style of

290− EqualSign -> equals

292+ EqualSign -> "="

291− RightArrow -> txt "->"

293+ RightArrow -> "->"

292 placeHanging placement p_body

294 placeHanging placement p_body

293 where

295 where

294 placement =

296 placement =

295 case endOfGuards of

297 case endOfGuards of

296 Nothing -> placer (unLoc body)

298 Nothing -> placer (unLoc body)

297 Just spn ->

299 Just spn ->

298− if onTheSameLine spn (getLoc body)

300+ if isOneLineSpan (mkSrcSpan spn (srcSpanStart (getLoc body)))

299 then placer (unLoc body)

301 then placer (unLoc body)

300 else Normal

302 else Normal

301 endOfGuards =

303 endOfGuards =

302 case NE.nonEmpty guards of

304 case NE.nonEmpty guards of

303 Nothing -> Nothing

305 Nothing -> Nothing

304− Just gs -> (Just . getLoc . NE.last) gs

306+ Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs

305 p_body = located body render

307 p_body = located body render

306−p_grhs' _ _ _ (XGRHS x) = noExtCon x

308+p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"

307

309

308p_hsCmd :: HsCmd GhcPs -> R ()

310p_hsCmd :: HsCmd GhcPs -> R ()

309p_hsCmd = \case

311p_hsCmd = \case

310− HsCmdArrApp NoExtField body input arrType _ -> do

312+ HsCmdArrApp NoExt body input arrType _ -> do

311 located body p_hsExpr

313 located body p_hsExpr

312− breakpoint

314+ space

313− inci $ do

314− case arrType of

315+ case arrType of

315− HsFirstOrderApp -> txt "-<"

316+ HsFirstOrderApp -> txt "-<"

316− HsHigherOrderApp -> txt "-<<"

317+ HsHigherOrderApp -> txt "-<<"

317− placeHanging (exprPlacement (unLoc input)) $

318+ placeHanging (exprPlacement (unLoc input)) $

318− located input p_hsExpr

319+ located input p_hsExpr

319− HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ do

320+ HsCmdArrForm NoExt form Prefix _ cmds -> banana $ sitcc $ do

320 located form p_hsExpr

321 located form p_hsExpr

321 unless (null cmds) $ do

322 unless (null cmds) $ do

322 breakpoint

323 breakpoint

323 inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))

324 inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds)))

324− HsCmdArrForm NoExtField form Infix _ [left, right] -> do

325+ HsCmdArrForm NoExt form Infix _ [left, right] -> do

325 located left p_hsCmdTop

326 located left p_hsCmdTop

326 space

327 space

327 located form p_hsExpr

328 located form p_hsExpr

328 placeHanging (cmdTopPlacement (unLoc right)) $

329 placeHanging (cmdTopPlacement (unLoc right)) $

329 located right p_hsCmdTop

330 located right p_hsCmdTop

330− HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm"

331+ HsCmdArrForm NoExt _ Infix _ _ -> notImplemented "HsCmdArrForm"

331 HsCmdApp {} ->

332 HsCmdApp {} ->

332 -- XXX Does this ever occur in the syntax tree? It does not seem like it

333 -- XXX Does this ever occur in the syntax tree? It does not seem like it

333 -- does. Open an issue and ping @yumiova if this ever occurs in output.

334 -- does. Open an issue and ping @yumiova if this ever occurs in output.

334 notImplemented "HsCmdApp"

335 notImplemented "HsCmdApp"

335− HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup

336+ HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup

336− HsCmdPar NoExtField c -> parens N (located c p_hsCmd)

337+ HsCmdPar NoExt c -> parens N (located c p_hsCmd)

337− HsCmdCase NoExtField e mgroup ->

338+ HsCmdCase NoExt e mgroup ->

338 p_case cmdPlacement p_hsCmd e mgroup

339 p_case cmdPlacement p_hsCmd e mgroup

339− HsCmdIf NoExtField _ if' then' else' ->

340+ HsCmdIf NoExt _ if' then' else' ->

340 p_if cmdPlacement p_hsCmd if' then' else'

341 p_if cmdPlacement p_hsCmd if' then' else'

341− HsCmdLet NoExtField localBinds c ->

342+ HsCmdLet NoExt localBinds c ->

342 p_let p_hsCmd localBinds c

343 p_let p_hsCmd localBinds c

343− HsCmdDo NoExtField es -> do

344+ HsCmdDo NoExt es -> do

344 txt "do"

345 txt "do"

345 newline

346 newline

346 inci . located es $

347 inci . located es $

347− sitcc . sep newline (sitcc . withSpacing (p_stmt' cmdPlacement p_hsCmd))

348+ sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))

348 HsCmdWrap {} -> notImplemented "HsCmdWrap"

349 HsCmdWrap {} -> notImplemented "HsCmdWrap"

349− XCmd x -> noExtCon x

350+ XCmd {} -> notImplemented "XCmd"

350

351

351p_hsCmdTop :: HsCmdTop GhcPs -> R ()

352p_hsCmdTop :: HsCmdTop GhcPs -> R ()

352p_hsCmdTop = \case

353p_hsCmdTop = \case

353− HsCmdTop NoExtField cmd -> located cmd p_hsCmd

354+ HsCmdTop NoExt cmd -> located cmd p_hsCmd

354− XCmdTop x -> noExtCon x

355+ XCmdTop {} -> notImplemented "XHsCmdTop"

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

356

385p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()

357p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()

386p_stmt = p_stmt' exprPlacement p_hsExpr

358p_stmt = p_stmt' exprPlacement p_hsExpr

@@ -395,13 +367,16 @@ p_stmt' ::

395 Stmt GhcPs (Located body) ->

367 Stmt GhcPs (Located body) ->

396 R ()

368 R ()

397p_stmt' placer render = \case

369p_stmt' placer render = \case

398− LastStmt NoExtField body _ _ -> located body render

370+ LastStmt NoExt body _ _ -> located body render

399− BindStmt NoExtField p f _ _ -> do

371+ BindStmt NoExt p f _ _ -> do

400− located p p_pat

372+ p_pat p

401 space

373 space

402 txt "<-"

374 txt "<-"

375+ -- https://gitlab.haskell.org/ghc/ghc/issues/17330

403− let loc = getLoc p

376+ let loc = case p of

377+ XPat pat -> getLoc pat

378+ _ -> error "p_stmt': BindStmt: Pat does not contain a location"

404− placement =

379+ let placement =

405 case f of

380 case f of

406 L l' x ->

381 L l' x ->

407 if isOneLineSpan

382 if isOneLineSpan

@@ -411,8 +386,8 @@ p_stmt' placer render = \case

411 switchLayout [loc, getLoc f] $

386 switchLayout [loc, getLoc f] $

412 placeHanging placement (located f render)

387 placeHanging placement (located f render)

413 ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer

388 ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer

414− BodyStmt NoExtField body _ _ -> located body render

389+ BodyStmt NoExt body _ _ -> located body render

415− LetStmt NoExtField binds -> do

390+ LetStmt NoExt binds -> do

416 txt "let"

391 txt "let"

417 space

392 space

418 sitcc $ located binds p_hsLocalBinds

393 sitcc $ located binds p_hsLocalBinds

@@ -453,11 +428,11 @@ p_stmt' placer render = \case

453 RecStmt {..} -> do

428 RecStmt {..} -> do

454 txt "rec"

429 txt "rec"

455 space

430 space

456− sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts

431+ sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts

457− XStmtLR c -> noExtCon c

432+ XStmtLR {} -> notImplemented "XStmtLR"

458

433

459gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]

434gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]

460−gatherStmt (L _ (ParStmt NoExtField block _ _)) =

435+gatherStmt (L _ (ParStmt NoExt block _ _)) =

461 foldr ((<>) . gatherStmtBlock) [] block

436 foldr ((<>) . gatherStmtBlock) [] block

462gatherStmt (L s stmt@TransStmt {..}) =

437gatherStmt (L s stmt@TransStmt {..}) =

463 foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])

438 foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])

@@ -466,46 +441,46 @@ gatherStmt stmt = [[stmt]]

466gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]

441gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]

467gatherStmtBlock (ParStmtBlock _ stmts _ _) =

442gatherStmtBlock (ParStmtBlock _ stmts _ _) =

468 foldr (liftAppend . gatherStmt) [] stmts

443 foldr (liftAppend . gatherStmt) [] stmts

469−gatherStmtBlock (XParStmtBlock x) = noExtCon x

444+gatherStmtBlock XParStmtBlock {} = notImplemented "XParStmtBlock"

470

445

471p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()

446p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R ()

472p_hsLocalBinds = \case

447p_hsLocalBinds = \case

473− HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do

448+ HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do

449+ let ssStart =

450+ either

451+ (srcSpanStart . getLoc)

452+ (srcSpanStart . getLoc)

453+ items =

454+ (Left <$> bagToList bag) ++ (Right <$> lsigs)

455+ p_item (Left x) = located x p_valDecl

456+ p_item (Right x) = located x p_sigDecl

457+ -- Assigns 'False' to the last element, 'True' to the rest.

458+ markInit :: [a] -> [(Bool, a)]

459+ markInit [] = []

460+ markInit [x] = [(False, x)]

461+ markInit (x : xs) = (True, x) : markInit xs

474 -- When in a single-line layout, there is a chance that the inner

462 -- When in a single-line layout, there is a chance that the inner

475 -- elements will also contain semicolons and they will confuse the

463 -- elements will also contain semicolons and they will confuse the

476 -- parser. so we request braces around every element except the last.

464 -- parser. so we request braces around every element except the last.

477 br <- layoutToBraces <$> getLayout

465 br <- layoutToBraces <$> getLayout

478− let items =

466+ sitcc $

479− let injectLeft (L l x) = L l (Left x)

467+ sepSemi

480− injectRight (L l x) = L l (Right x)

468+ (\(m, i) -> (if m then br else id) $ p_item i)

481− in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs)

469+ (markInit $ sortOn ssStart items)

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)

492− HsValBinds NoExtField _ -> notImplemented "HsValBinds"

470+ HsValBinds NoExt _ -> notImplemented "HsValBinds"

493− HsIPBinds NoExtField (IPBinds NoExtField xs) ->

471+ HsIPBinds NoExt (IPBinds NoExt xs) ->

494 -- Second argument of IPBind is always Left before type-checking.

472 -- Second argument of IPBind is always Left before type-checking.

495− let p_ipBind (IPBind NoExtField (Left name) expr) = do

473+ let p_ipBind (IPBind NoExt (Left name) expr) = do

496 atom name

474 atom name

497 space

475 space

498− equals

476+ txt "="

499 breakpoint

477 breakpoint

500 useBraces $ inci $ located expr p_hsExpr

478 useBraces $ inci $ located expr p_hsExpr

501− p_ipBind (IPBind NoExtField (Right _) _) =

502− -- Should only occur after the type checker

503− notImplemented "IPBind _ (Right _) _"

479+ p_ipBind _ = notImplemented "XHsIPBinds"

504− p_ipBind (XIPBind x) = noExtCon x

505 in sepSemi (located' p_ipBind) xs

480 in sepSemi (located' p_ipBind) xs

506− HsIPBinds NoExtField _ -> notImplemented "HsIpBinds"

481+ HsIPBinds NoExt _ -> notImplemented "HsIpBinds"

507− EmptyLocalBinds NoExtField -> return ()

482+ EmptyLocalBinds NoExt -> return ()

508− XHsLocalBindsLR x -> noExtCon x

483+ XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR"

509

484

510p_hsRecField ::

485p_hsRecField ::

511 HsRecField' RdrName (LHsExpr GhcPs) ->

486 HsRecField' RdrName (LHsExpr GhcPs) ->

@@ -514,45 +489,48 @@ p_hsRecField HsRecField {..} = do

514 p_rdrName hsRecFieldLbl

489 p_rdrName hsRecFieldLbl

515 unless hsRecPun $ do

490 unless hsRecPun $ do

516 space

491 space

517− equals

492+ txt "="

518− let placement =

519− if onTheSameLine (getLoc hsRecFieldLbl) (getLoc hsRecFieldArg)

520− then exprPlacement (unLoc hsRecFieldArg)

493+ let placement = exprPlacement (unLoc hsRecFieldArg)

521− else Normal

522− placeHanging placement (located hsRecFieldArg p_hsExpr)

494+ placeHanging placement $ located hsRecFieldArg p_hsExpr

495+

496+p_hsTupArg :: HsTupArg GhcPs -> R ()

497+p_hsTupArg = \case

498+ Present NoExt x -> located x p_hsExpr

499+ Missing NoExt -> pure ()

500+ XTupArg {} -> notImplemented "XTupArg"

523

501

524p_hsExpr :: HsExpr GhcPs -> R ()

502p_hsExpr :: HsExpr GhcPs -> R ()

525p_hsExpr = p_hsExpr' N

503p_hsExpr = p_hsExpr' N

526

504

527p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()

505p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R ()

528p_hsExpr' s = \case

506p_hsExpr' s = \case

529− HsVar NoExtField name -> p_rdrName name

507+ HsVar NoExt name -> p_rdrName name

530− HsUnboundVar NoExtField v -> atom (unboundVarOcc v)

508+ HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar"

531− HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut"

509+ HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut"

532− HsRecFld NoExtField x ->

510+ HsRecFld NoExt x ->

533 case x of

511 case x of

534− Unambiguous NoExtField name -> p_rdrName name

512+ Unambiguous NoExt name -> p_rdrName name

535− Ambiguous NoExtField name -> p_rdrName name

513+ Ambiguous NoExt name -> p_rdrName name

536− XAmbiguousFieldOcc xx -> noExtCon xx

514+ XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc"

537− HsOverLabel NoExtField _ v -> do

515+ HsOverLabel NoExt _ v -> do

538 txt "#"

516 txt "#"

539 atom v

517 atom v

540− HsIPVar NoExtField (HsIPName name) -> do

518+ HsIPVar NoExt (HsIPName name) -> do

541 txt "?"

519 txt "?"

542 atom name

520 atom name

543− HsOverLit NoExtField v -> atom (ol_val v)

521+ HsOverLit NoExt v -> atom (ol_val v)

544− HsLit NoExtField lit ->

522+ HsLit NoExt lit ->

545 case lit of

523 case lit of

546 HsString (SourceText stxt) _ -> p_stringLit stxt

524 HsString (SourceText stxt) _ -> p_stringLit stxt

547 HsStringPrim (SourceText stxt) _ -> p_stringLit stxt

525 HsStringPrim (SourceText stxt) _ -> p_stringLit stxt

548 r -> atom r

526 r -> atom r

549− HsLam NoExtField mgroup ->

527+ HsLam NoExt mgroup ->

550 p_matchGroup Lambda mgroup

528 p_matchGroup Lambda mgroup

551− HsLamCase NoExtField mgroup -> do

529+ HsLamCase NoExt mgroup -> do

552 txt "\\case"

530 txt "\\case"

553 breakpoint

531 breakpoint

554 inci (p_matchGroup LambdaCase mgroup)

532 inci (p_matchGroup LambdaCase mgroup)

555− HsApp NoExtField f x -> do

533+ HsApp NoExt f x -> do

556 let -- In order to format function applications with multiple parameters

534 let -- In order to format function applications with multiple parameters

557 -- nicer, traverse the AST to gather the function and all the

535 -- nicer, traverse the AST to gather the function and all the

558 -- parameters together.

536 -- parameters together.

@@ -584,21 +562,23 @@ p_hsExpr' s = \case

584 -- do-block or case expression it is not a good idea. It seems

562 -- do-block or case expression it is not a good idea. It seems

585 -- to be safe to always bump indentation when the function

563 -- to be safe to always bump indentation when the function

586 -- expression is parenthesised.

564 -- expression is parenthesised.

587− doIndent =

565+ indent =

588 case func of

566 case func of

589− L _ (HsPar NoExtField _) -> True

567+ L _ (HsPar NoExt _) -> inci

590− L _ (HsAppType NoExtField _ _) -> True

568+ L _ (HsAppType NoExt _ _) -> inci

591− L _ (HsMultiIf NoExtField _) -> True

569+ L _ (HsMultiIf NoExt _) -> inci

570+ L spn _ ->

592− L spn _ -> isOneLineSpan spn

571+ if isOneLineSpan spn

593− ub <-

572+ then inci

573+ else id

594− getLayout <&> \case

574+ ub <- getLayout <&> \case

595− SingleLine -> useBraces

575+ SingleLine -> useBraces

596− MultiLine -> id

576+ MultiLine -> id

597 ub $ do

577 ub $ do

598 located func (p_hsExpr' s)

578 located func (p_hsExpr' s)

599 breakpoint

579 breakpoint

600− inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp

580+ indent $ sep breakpoint (located' p_hsExpr) initp

601− inciIf doIndent $ do

581+ indent $ do

602 unless (null initp) breakpoint

582 unless (null initp) breakpoint

603 located lastp p_hsExpr

583 located lastp p_hsExpr

604 Hanging -> do

584 Hanging -> do

@@ -608,87 +588,76 @@ p_hsExpr' s = \case

608 sep breakpoint (located' p_hsExpr) initp

588 sep breakpoint (located' p_hsExpr) initp

609 placeHanging placement $

589 placeHanging placement $

610 located lastp p_hsExpr

590 located lastp p_hsExpr

611− HsAppType NoExtField e a -> do

591+ HsAppType NoExt e a -> do

612 located e p_hsExpr

592 located e p_hsExpr

613 breakpoint

593 breakpoint

614 inci $ do

594 inci $ do

615 txt "@"

595 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 ()

621 located (hswc_body a) p_hsType

596 located (hswc_body a) p_hsType

622− OpApp NoExtField x op y -> do

597+ OpApp NoExt x op y -> do

623 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)

598 let opTree = OpBranch (exprOpTree x) op (exprOpTree y)

624− p_exprOpTree s (reassociateOpTree getOpName opTree)

599+ p_exprOpTree True s (reassociateOpTree getOpName opTree)

625− NegApp NoExtField e _ -> do

600+ NegApp NoExt e _ -> do

626 txt "-"

601 txt "-"

627 space

602 space

628 located e p_hsExpr

603 located e p_hsExpr

629− HsPar NoExtField e ->

604+ HsPar NoExt e ->

630 parens s (located e (dontUseBraces . p_hsExpr))

605 parens s (located e (dontUseBraces . p_hsExpr))

631− SectionL NoExtField x op -> do

606+ SectionL NoExt x op -> do

632 located x p_hsExpr

607 located x p_hsExpr

633 breakpoint

608 breakpoint

634 inci (located op p_hsExpr)

609 inci (located op p_hsExpr)

635− SectionR NoExtField op x -> do

610+ SectionR NoExt op x -> do

636 located op p_hsExpr

611 located op p_hsExpr

637 useRecordDot' <- useRecordDot

612 useRecordDot' <- useRecordDot

638 let isRecordDot' = isRecordDot (unLoc op) (getLoc x)

613 let isRecordDot' = isRecordDot (unLoc op) (getLoc x)

639 unless (useRecordDot' && isRecordDot') breakpoint

614 unless (useRecordDot' && isRecordDot') breakpoint

640 inci (located x p_hsExpr)

615 inci (located x p_hsExpr)

641− ExplicitTuple NoExtField args boxity ->

616+ ExplicitTuple NoExt args boxity -> do

642 let isSection = any (isMissing . unLoc) args

617 let isSection = any (isMissing . unLoc) args

643 isMissing = \case

618 isMissing = \case

644− Missing NoExtField -> True

619+ Missing NoExt -> True

645 _ -> False

620 _ -> 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

651− parens' =

621+ let parens' =

652 case boxity of

622 case boxity of

653 Boxed -> parens

623 Boxed -> parens

654 Unboxed -> parensHash

624 Unboxed -> parensHash

655− in if isSection

625+ if isSection

656− then

626+ then

657− switchLayout [] . parens' s $

627+ switchLayout [] . parens' s $

658− sep comma p_larg args

628+ sep comma (located' p_hsTupArg) args

659− else

629+ else

660− switchLayout (getLoc <$> args) . parens' s $

630+ switchLayout (getLoc <$> args) . parens' s . sitcc $

661− sep commaDel p_larg args

631+ sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args

662− ExplicitSum NoExtField tag arity e ->

632+ ExplicitSum NoExt tag arity e ->

663 p_unboxedSum N tag arity (located e p_hsExpr)

633 p_unboxedSum N tag arity (located e p_hsExpr)

664− HsCase NoExtField e mgroup ->

634+ HsCase NoExt e mgroup ->

665 p_case exprPlacement p_hsExpr e mgroup

635 p_case exprPlacement p_hsExpr e mgroup

666− HsIf NoExtField _ if' then' else' ->

636+ HsIf NoExt _ if' then' else' ->

667 p_if exprPlacement p_hsExpr if' then' else'

637 p_if exprPlacement p_hsExpr if' then' else'

668− HsMultiIf NoExtField guards -> do

638+ HsMultiIf NoExt guards -> do

669− txt "if"

639+ txt "if "

670− breakpoint

671− inci . inci $ sep newline (located' (p_grhs RightArrow)) guards

640+ inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards

672− HsLet NoExtField localBinds e ->

641+ HsLet NoExt localBinds e ->

673 p_let p_hsExpr localBinds e

642 p_let p_hsExpr localBinds e

674− HsDo NoExtField ctx es -> do

643+ HsDo NoExt ctx es -> do

675 let doBody header = do

644 let doBody header = do

676 txt header

645 txt header

677 breakpoint

646 breakpoint

678 ub <- layoutToBraces <$> getLayout

647 ub <- layoutToBraces <$> getLayout

679 inci $

648 inci $

680 sepSemi

649 sepSemi

681− (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))

650+ (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))

682 (unLoc es)

651 (unLoc es)

683− compBody = brackets N . located es $ \xs -> do

652+ compBody = brackets N $ located es $ \xs -> do

684 let p_parBody =

653 let p_parBody =

685 sep

654 sep

686− (breakpoint >> txt "|" >> space)

655+ (breakpoint >> txt "| ")

687 p_seqBody

656 p_seqBody

688 p_seqBody =

657 p_seqBody =

689 sitcc

658 sitcc

690 . sep

659 . sep

691− commaDel

660+ (comma >> breakpoint)

692 (located' (sitcc . p_stmt))

661 (located' (sitcc . p_stmt))

693 stmts = init xs

662 stmts = init xs

694 yield = last xs

663 yield = last xs

@@ -709,25 +678,25 @@ p_hsExpr' s = \case

709 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"

678 ParStmtCtxt _ -> notImplemented "ParStmtCtxt"

710 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"

679 TransStmtCtxt _ -> notImplemented "TransStmtCtxt"

711 ExplicitList _ _ xs ->

680 ExplicitList _ _ xs ->

712− brackets s $

681+ brackets s . sitcc $

713− sep commaDel (sitcc . located' p_hsExpr) xs

682+ sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs

714 RecordCon {..} -> do

683 RecordCon {..} -> do

715 located rcon_con_name atom

684 located rcon_con_name atom

716 breakpoint

685 breakpoint

717 let HsRecFields {..} = rcon_flds

686 let HsRecFields {..} = rcon_flds

718 updName f =

687 updName f =

719− (f :: HsRecField GhcPs (LHsExpr GhcPs))

688+ f

720 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of

689 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of

721 FieldOcc _ n -> n

690 FieldOcc _ n -> n

722− XFieldOcc x -> noExtCon x

691+ XFieldOcc _ -> notImplemented "XFieldOcc"

723 }

692 }

724 fields = located' (p_hsRecField . updName) <$> rec_flds

693 fields = located' (p_hsRecField . updName) <$> rec_flds

725 dotdot =

694 dotdot =

726 case rec_dotdot of

695 case rec_dotdot of

727 Just {} -> [txt ".."]

696 Just {} -> [txt ".."]

728 Nothing -> []

697 Nothing -> []

729− inci . braces N $

698+ inci . braces N . sitcc $

730− sep commaDel sitcc (fields <> dotdot)

699+ sep (comma >> breakpoint) sitcc (fields <> dotdot)

731 RecordUpd {..} -> do

700 RecordUpd {..} -> do

732 located rupd_expr p_hsExpr

701 located rupd_expr p_hsExpr

733 useRecordDot' <- useRecordDot

702 useRecordDot' <- useRecordDot

@@ -739,66 +708,67 @@ p_hsExpr' s = \case

739 == (srcSpanStartCol <$> mrs (head rupd_flds))

708 == (srcSpanStartCol <$> mrs (head rupd_flds))

740 unless (useRecordDot' && isPluginForm) breakpoint

709 unless (useRecordDot' && isPluginForm) breakpoint

741 let updName f =

710 let updName f =

742− (f :: HsRecUpdField GhcPs)

711+ f

743 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of

712 { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of

744 Ambiguous _ n -> n

713 Ambiguous _ n -> n

745 Unambiguous _ n -> n

714 Unambiguous _ n -> n

746− XAmbiguousFieldOcc x -> noExtCon x

715+ XAmbiguousFieldOcc _ -> notImplemented "XAmbiguousFieldOcc"

747 }

716 }

748− inci . braces N $

717+ inci . braces N . sitcc $

749 sep

718 sep

750− commaDel

719+ (comma >> breakpoint)

751 (sitcc . located' (p_hsRecField . updName))

720 (sitcc . located' (p_hsRecField . updName))

752 rupd_flds

721 rupd_flds

753− ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do

722+ ExprWithTySig NoExt x HsWC {hswc_body = HsIB {..}} -> sitcc $ do

754 located x p_hsExpr

723 located x p_hsExpr

755 space

724 space

756 txt "::"

725 txt "::"

757 breakpoint

726 breakpoint

758 inci $ located hsib_body p_hsType

727 inci $ located hsib_body p_hsType

759− ExprWithTySig NoExtField _ HsWC {hswc_body = XHsImplicitBndrs x} -> noExtCon x

728+ ExprWithTySig NoExt _ HsWC {hswc_body = XHsImplicitBndrs {}} ->

729+ notImplemented "XHsImplicitBndrs"

760− ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x

730+ ExprWithTySig NoExt _ XHsWildCardBndrs {} -> notImplemented "XHsWildCardBndrs"

761− ArithSeq NoExtField _ x ->

731+ ArithSeq NoExt _ x ->

762 case x of

732 case x of

763− From from -> brackets s $ do

733+ From from -> brackets s . sitcc $ do

764 located from p_hsExpr

734 located from p_hsExpr

765 breakpoint

735 breakpoint

766 txt ".."

736 txt ".."

767− FromThen from next -> brackets s $ do

737+ FromThen from next -> brackets s . sitcc $ do

768− sep commaDel (located' p_hsExpr) [from, next]

738+ sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]

769 breakpoint

739 breakpoint

770 txt ".."

740 txt ".."

771− FromTo from to -> brackets s $ do

741+ FromTo from to -> brackets s . sitcc $ do

772 located from p_hsExpr

742 located from p_hsExpr

773 breakpoint

743 breakpoint

774 txt ".."

744 txt ".."

775 space

745 space

776 located to p_hsExpr

746 located to p_hsExpr

777− FromThenTo from next to -> brackets s $ do

747+ FromThenTo from next to -> brackets s . sitcc $ do

778− sep commaDel (located' p_hsExpr) [from, next]

748+ sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next]

779 breakpoint

749 breakpoint

780 txt ".."

750 txt ".."

781 space

751 space

782 located to p_hsExpr

752 located to p_hsExpr

783− HsSCC NoExtField _ name x -> do

753+ HsSCC NoExt _ name x -> do

784 txt "{-# SCC "

754 txt "{-# SCC "

785 atom name

755 atom name

786 txt " #-}"

756 txt " #-}"

787 breakpoint

757 breakpoint

788 located x p_hsExpr

758 located x p_hsExpr

789− HsCoreAnn NoExtField _ value x -> do

759+ HsCoreAnn NoExt _ value x -> do

790 txt "{-# CORE "

760 txt "{-# CORE "

791 atom value

761 atom value

792 txt " #-}"

762 txt " #-}"

793 breakpoint

763 breakpoint

794 located x p_hsExpr

764 located x p_hsExpr

795− HsBracket NoExtField x -> p_hsBracket x

765+ HsBracket NoExt x -> p_hsBracket x

796 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"

766 HsRnBracketOut {} -> notImplemented "HsRnBracketOut"

797 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"

767 HsTcBracketOut {} -> notImplemented "HsTcBracketOut"

798− HsSpliceE NoExtField splice -> p_hsSplice splice

768+ HsSpliceE NoExt splice -> p_hsSplice splice

799− HsProc NoExtField p e -> do

769+ HsProc NoExt p e -> do

800 txt "proc"

770 txt "proc"

801− located p $ \x -> do

771+ locatedPat p $ \x -> do

802 breakpoint

772 breakpoint

803 inci (p_pat x)

773 inci (p_pat x)

804 breakpoint

774 breakpoint

@@ -809,11 +779,31 @@ p_hsExpr' s = \case

809 txt "static"

779 txt "static"

810 breakpoint

780 breakpoint

811 inci (located e p_hsExpr)

781 inci (located e p_hsExpr)

782+ HsArrApp NoExt body input arrType cond ->

783+ p_hsCmd (HsCmdArrApp NoExt body input arrType cond)

784+ HsArrForm NoExt form mfixity cmds ->

785+ p_hsCmd (HsCmdArrForm NoExt form Prefix mfixity cmds)

812 HsTick {} -> notImplemented "HsTick"

786 HsTick {} -> notImplemented "HsTick"

813 HsBinTick {} -> notImplemented "HsBinTick"

787 HsBinTick {} -> notImplemented "HsBinTick"

814 HsTickPragma {} -> notImplemented "HsTickPragma"

788 HsTickPragma {} -> notImplemented "HsTickPragma"

789+ -- These four constructs should never appear in correct programs.

790+ -- See: https://github.com/tweag/ormolu/issues/343

791+ EWildPat NoExt -> txt "_"

792+ EAsPat NoExt n p -> do

793+ p_rdrName n

794+ txt "@"

795+ located p p_hsExpr

796+ EViewPat NoExt p e -> do

797+ located p p_hsExpr

798+ space

799+ txt "->"

800+ breakpoint

801+ inci (located e p_hsExpr)

802+ ELazyPat NoExt p -> do

803+ txt "~"

804+ located p p_hsExpr

815 HsWrap {} -> notImplemented "HsWrap"

805 HsWrap {} -> notImplemented "HsWrap"

816− XExpr x -> noExtCon x

806+ XExpr {} -> notImplemented "XExpr"

817

807

818p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()

808p_patSynBind :: PatSynBind GhcPs GhcPs -> R ()

819p_patSynBind PSB {..} = do

809p_patSynBind PSB {..} = do

@@ -823,15 +813,15 @@ p_patSynBind PSB {..} = do

823 Unidirectional -> do

813 Unidirectional -> do

824 txt "<-"

814 txt "<-"

825 breakpoint

815 breakpoint

826− located psb_def p_pat

816+ p_pat psb_def

827 ImplicitBidirectional -> do

817 ImplicitBidirectional -> do

828− equals

818+ txt "="

829 breakpoint

819 breakpoint

830− located psb_def p_pat

820+ p_pat psb_def

831 ExplicitBidirectional mgroup -> do

821 ExplicitBidirectional mgroup -> do

832 txt "<-"

822 txt "<-"

833 breakpoint

823 breakpoint

834− located psb_def p_pat

824+ p_pat psb_def

835 newline

825 newline

836 txt "where"

826 txt "where"

837 newline

827 newline

@@ -852,8 +842,8 @@ p_patSynBind PSB {..} = do

852 inci $ do

842 inci $ do

853 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do

843 switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do

854 unless (null xs) breakpoint

844 unless (null xs) breakpoint

855− braces N $

845+ braces N . sitcc $

856− sep commaDel (p_rdrName . recordPatSynPatVar) xs

846+ sep (comma >> breakpoint) (p_rdrName . recordPatSynPatVar) xs

857 rhs

847 rhs

858 InfixCon l r -> do

848 InfixCon l r -> do

859 switchLayout [getLoc l, getLoc r] $ do

849 switchLayout [getLoc l, getLoc r] $ do

@@ -865,7 +855,7 @@ p_patSynBind PSB {..} = do

865 space

855 space

866 p_rdrName r

856 p_rdrName r

867 inci rhs

857 inci rhs

868−p_patSynBind (XPatSynBind x) = noExtCon x

858+p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"

869

859

870p_case ::

860p_case ::

871 Data body =>

861 Data body =>

@@ -907,12 +897,10 @@ p_if placer render if' then' else' = do

907 breakpoint

897 breakpoint

908 inci $ do

898 inci $ do

909 txt "then"

899 txt "then"

910− space

911 located then' $ \x ->

900 located then' $ \x ->

912 placeHanging (placer x) (render x)

901 placeHanging (placer x) (render x)

913 breakpoint

902 breakpoint

914 txt "else"

903 txt "else"

915− space

916 located else' $ \x ->

904 located else' $ \x ->

917 placeHanging (placer x) (render x)

905 placeHanging (placer x) (render x)

918

906

@@ -934,77 +922,77 @@ p_let render localBinds e = sitcc $ do

934

922

935p_pat :: Pat GhcPs -> R ()

923p_pat :: Pat GhcPs -> R ()

936p_pat = \case

924p_pat = \case

925+ -- Note: starting from GHC 8.8, 'LPat' == 'Pat'. Located 'Pat's are always

926+ -- constructed with the 'XPat' constructor, containing a @Located Pat@.

927+ XPat pat -> located pat p_pat

937− WildPat NoExtField -> txt "_"

928+ WildPat NoExt -> txt "_"

938− VarPat NoExtField name -> p_rdrName name

929+ VarPat NoExt name -> p_rdrName name

939− LazyPat NoExtField pat -> do

930+ LazyPat NoExt pat -> do

940 txt "~"

931 txt "~"

941− located pat p_pat

932+ p_pat pat

942− AsPat NoExtField name pat -> do

933+ AsPat NoExt name pat -> do

943 p_rdrName name

934 p_rdrName name

944 txt "@"

935 txt "@"

945− located pat p_pat

936+ p_pat pat

946− ParPat NoExtField pat ->

937+ ParPat NoExt pat ->

947− located pat (parens S . p_pat)

938+ locatedPat pat (parens S . p_pat)

948− BangPat NoExtField pat -> do

939+ BangPat NoExt pat -> do

949 txt "!"

940 txt "!"

950− located pat p_pat

941+ p_pat pat

951− ListPat NoExtField pats ->

942+ ListPat NoExt pats ->

952− brackets S $ sep commaDel (located' p_pat) pats

943+ brackets S . sitcc $ sep (comma >> breakpoint) p_pat pats

953− TuplePat NoExtField pats boxing -> do

944+ TuplePat NoExt pats boxing -> do

954− let parens' =

945+ let f =

955 case boxing of

946 case boxing of

956 Boxed -> parens S

947 Boxed -> parens S

957 Unboxed -> parensHash S

948 Unboxed -> parensHash S

958− parens' $ sep commaDel (sitcc . located' p_pat) pats

949+ f . sitcc $ sep (comma >> breakpoint) (sitcc . p_pat) pats

959− SumPat NoExtField pat tag arity ->

950+ SumPat NoExt pat tag arity ->

960− p_unboxedSum S tag arity (located pat p_pat)

951+ p_unboxedSum S tag arity (p_pat pat)

961 ConPatIn pat details ->

952 ConPatIn pat details ->

962 case details of

953 case details of

963 PrefixCon xs -> sitcc $ do

954 PrefixCon xs -> sitcc $ do

964 p_rdrName pat

955 p_rdrName pat

965 unless (null xs) $ do

956 unless (null xs) $ do

966 breakpoint

957 breakpoint

967− inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs

958+ inci . sitcc $ sep breakpoint (sitcc . p_pat) xs

968 RecCon (HsRecFields fields dotdot) -> do

959 RecCon (HsRecFields fields dotdot) -> do

969 p_rdrName pat

960 p_rdrName pat

970 breakpoint

961 breakpoint

971 let f = \case

962 let f = \case

972 Nothing -> txt ".."

963 Nothing -> txt ".."

973 Just x -> located x p_pat_hsRecField

964 Just x -> located x p_pat_hsRecField

974− inci . braces N . sep commaDel f $

965+ inci . braces N . sitcc . sep (comma >> breakpoint) f $

975 case dotdot of

966 case dotdot of

976 Nothing -> Just <$> fields

967 Nothing -> Just <$> fields

977− Just (L _ n) -> (Just <$> take n fields) ++ [Nothing]

968+ Just n -> (Just <$> take n fields) ++ [Nothing]

978− InfixCon l r -> do

969+ InfixCon x y -> do

979− switchLayout [getLoc l, getLoc r] $ do

970+ p_pat x

980− located l p_pat

971+ space

972+ p_rdrName pat

981− breakpoint

973+ breakpoint

982− inci $ do

974+ inci (p_pat y)

983− p_rdrName pat

984− space

985− located r p_pat

986 ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?

975 ConPatOut {} -> notImplemented "ConPatOut" -- presumably created by renamer?

987− ViewPat NoExtField expr pat -> sitcc $ do

976+ ViewPat NoExt expr pat -> sitcc $ do

988 located expr p_hsExpr

977 located expr p_hsExpr

989 space

978 space

990 txt "->"

979 txt "->"

991 breakpoint

980 breakpoint

992− inci (located pat p_pat)

981+ inci (p_pat pat)

993− SplicePat NoExtField splice -> p_hsSplice splice

982+ SplicePat NoExt splice -> p_hsSplice splice

994− LitPat NoExtField p -> atom p

983+ LitPat NoExt p -> atom p

995− NPat NoExtField v _ _ -> located v (atom . ol_val)

984+ NPat NoExt v _ _ -> located v (atom . ol_val)

996− NPlusKPat NoExtField n k _ _ _ -> sitcc $ do

985+ NPlusKPat NoExt n k _ _ _ -> sitcc $ do

997 p_rdrName n

986 p_rdrName n

998 breakpoint

987 breakpoint

999 inci $ do

988 inci $ do

1000 txt "+"

989 txt "+"

1001 space

990 space

1002 located k (atom . ol_val)

991 located k (atom . ol_val)

1003− SigPat NoExtField pat hswc -> do

992+ SigPat NoExt pat hswc -> do

1004− located pat p_pat

993+ p_pat pat

1005 p_typeAscription hswc

994 p_typeAscription hswc

1006 CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage

995 CoPat {} -> notImplemented "CoPat" -- apparently created at some later stage

1007− XPat x -> noExtCon x

1008

996

1009p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()

997p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R ()

1010p_pat_hsRecField HsRecField {..} = do

998p_pat_hsRecField HsRecField {..} = do

@@ -1012,30 +1000,32 @@ p_pat_hsRecField HsRecField {..} = do

1012 p_rdrName (rdrNameFieldOcc x)

1000 p_rdrName (rdrNameFieldOcc x)

1013 unless hsRecPun $ do

1001 unless hsRecPun $ do

1014 space

1002 space

1015− equals

1003+ txt "="

1016 breakpoint

1004 breakpoint

1017− inci (located hsRecFieldArg p_pat)

1005+ inci (p_pat hsRecFieldArg)

1018

1006

1019p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()

1007p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R ()

1020p_unboxedSum s tag arity m = do

1008p_unboxedSum s tag arity m = do

1021 let before = tag - 1

1009 let before = tag - 1

1022 after = arity - before - 1

1010 after = arity - before - 1

1023 args = replicate before Nothing <> [Just m] <> replicate after Nothing

1011 args = replicate before Nothing <> [Just m] <> replicate after Nothing

1024− f x =

1012+ f (x, i) = do

1013+ let isFirst = i == 0

1014+ isLast = i == arity - 1

1025 case x :: Maybe (R ()) of

1015 case x :: Maybe (R ()) of

1026 Nothing ->

1016 Nothing ->

1027− space

1017+ unless (isFirst || isLast) space

1028 Just m' -> do

1018 Just m' -> do

1029− space

1019+ unless isFirst space

1030 m'

1020 m'

1031− space

1021+ unless isLast space

1032− parensHash s $ sep (txt "|") f args

1022+ parensHash s $ sep (txt "|") f (zip args [0 ..])

1033

1023

1034p_hsSplice :: HsSplice GhcPs -> R ()

1024p_hsSplice :: HsSplice GhcPs -> R ()

1035p_hsSplice = \case

1025p_hsSplice = \case

1036− HsTypedSplice NoExtField deco _ expr -> p_hsSpliceTH True expr deco

1026+ HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco

1037− HsUntypedSplice NoExtField deco _ expr -> p_hsSpliceTH False expr deco

1027+ HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco

1038− HsQuasiQuote NoExtField _ quoterName srcSpan str -> do

1028+ HsQuasiQuote NoExt _ quoterName srcSpan str -> do

1039 txt "["

1029 txt "["

1040 p_rdrName (L srcSpan quoterName)

1030 p_rdrName (L srcSpan quoterName)

1041 txt "|"

1031 txt "|"

@@ -1045,7 +1035,7 @@ p_hsSplice = \case

1045 txt "|]"

1035 txt "|]"

1046 HsSpliced {} -> notImplemented "HsSpliced"

1036 HsSpliced {} -> notImplemented "HsSpliced"

1047 HsSplicedT {} -> notImplemented "HsSplicedT"

1037 HsSplicedT {} -> notImplemented "HsSplicedT"

1048− XSplice x -> noExtCon x

1038+ XSplice {} -> notImplemented "XSplice"

1049

1039

1050p_hsSpliceTH ::

1040p_hsSpliceTH ::

1051 -- | Typed splice?

1041 -- | Typed splice?

@@ -1069,17 +1059,17 @@ p_hsSpliceTH isTyped expr = \case

1069

1059

1070p_hsBracket :: HsBracket GhcPs -> R ()

1060p_hsBracket :: HsBracket GhcPs -> R ()

1071p_hsBracket = \case

1061p_hsBracket = \case

1072− ExpBr NoExtField expr -> do

1062+ ExpBr NoExt expr -> do

1073 anns <- getEnclosingAnns

1063 anns <- getEnclosingAnns

1074 let name = case anns of

1064 let name = case anns of

1075 AnnOpenEQ : _ -> ""

1065 AnnOpenEQ : _ -> ""

1076 _ -> "e"

1066 _ -> "e"

1077 quote name (located expr p_hsExpr)

1067 quote name (located expr p_hsExpr)

1078− PatBr NoExtField pat -> located pat (quote "p" . p_pat)

1068+ PatBr NoExt pat -> quote "p" (p_pat pat)

1079− DecBrL NoExtField decls -> quote "d" (p_hsDecls Free decls)

1069+ DecBrL NoExt decls -> quote "d" (p_hsDecls Free decls)

1080− DecBrG NoExtField _ -> notImplemented "DecBrG" -- result of renamer

1070+ DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer

1081− TypBr NoExtField ty -> quote "t" (located ty p_hsType)

1071+ TypBr NoExt ty -> quote "t" (located ty p_hsType)

1082− VarBr NoExtField isSingleQuote name -> do

1072+ VarBr NoExt isSingleQuote name -> do

1083 txt (bool "''" "'" isSingleQuote)

1073 txt (bool "''" "'" isSingleQuote)

1084 -- HACK As you can see we use 'noLoc' here to be able to pass name into

1074 -- HACK As you can see we use 'noLoc' here to be able to pass name into

1085 -- 'p_rdrName' since the latter expects a "located" thing. The problem

1075 -- 'p_rdrName' since the latter expects a "located" thing. The problem

@@ -1094,13 +1084,13 @@ p_hsBracket = \case

1094 && not (doesNotNeedExtraParens name)

1084 && not (doesNotNeedExtraParens name)

1095 wrapper = if isOperator then parens N else id

1085 wrapper = if isOperator then parens N else id

1096 wrapper $ p_rdrName (noLoc name)

1086 wrapper $ p_rdrName (noLoc name)

1097− TExpBr NoExtField expr -> do

1087+ TExpBr NoExt expr -> do

1098 txt "[||"

1088 txt "[||"

1099 breakpoint'

1089 breakpoint'

1100 located expr p_hsExpr

1090 located expr p_hsExpr

1101 breakpoint'

1091 breakpoint'

1102 txt "||]"

1092 txt "||]"

1103− XBracket x -> noExtCon x

1093+ XBracket {} -> notImplemented "XBracket"

1104 where

1094 where

1105 quote :: Text -> R () -> R ()

1095 quote :: Text -> R () -> R ()

1106 quote name body = do

1096 quote name body = do

@@ -1179,9 +1169,9 @@ liftAppend (x : xs) [] = x : xs

1179liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys

1169liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys

1180

1170

1181getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan

1171getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan

1182−getGRHSSpan (GRHS NoExtField guards body) =

1172+getGRHSSpan (GRHS NoExt guards body) =

1183 combineSrcSpans' $ getLoc body :| map getLoc guards

1173 combineSrcSpans' $ getLoc body :| map getLoc guards

1184−getGRHSSpan (XGRHS x) = noExtCon x

1174+getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS"

1185

1175

1186-- | Place a thing that may have a hanging form. This function handles how

1176-- | Place a thing that may have a hanging form. This function handles how

1187-- to separate it from preceding expressions and whether to bump indentation

1177-- to separate it from preceding expressions and whether to bump indentation

@@ -1202,74 +1192,78 @@ blockPlacement ::

1202 (body -> Placement) ->

1192 (body -> Placement) ->

1203 [LGRHS GhcPs (Located body)] ->

1193 [LGRHS GhcPs (Located body)] ->

1204 Placement

1194 Placement

1205−blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x

1195+blockPlacement placer [L _ (GRHS NoExt _ (L _ x))] = placer x

1206blockPlacement _ _ = Normal

1196blockPlacement _ _ = Normal

1207

1197

1208-- | Check if given command has a hanging form.

1198-- | Check if given command has a hanging form.

1209cmdPlacement :: HsCmd GhcPs -> Placement

1199cmdPlacement :: HsCmd GhcPs -> Placement

1210cmdPlacement = \case

1200cmdPlacement = \case

1211− HsCmdLam NoExtField _ -> Hanging

1201+ HsCmdLam NoExt _ -> Hanging

1212− HsCmdCase NoExtField _ _ -> Hanging

1202+ HsCmdCase NoExt _ _ -> Hanging

1213− HsCmdDo NoExtField _ -> Hanging

1203+ HsCmdDo NoExt _ -> Hanging

1214 _ -> Normal

1204 _ -> Normal

1215

1205

1216cmdTopPlacement :: HsCmdTop GhcPs -> Placement

1206cmdTopPlacement :: HsCmdTop GhcPs -> Placement

1217cmdTopPlacement = \case

1207cmdTopPlacement = \case

1218− HsCmdTop NoExtField (L _ x) -> cmdPlacement x

1208+ HsCmdTop NoExt (L _ x) -> cmdPlacement x

1219− XCmdTop x -> noExtCon x

1209+ XCmdTop {} -> notImplemented "XCmdTop"

1220

1210

1221-- | Check if given expression has a hanging form.

1211-- | Check if given expression has a hanging form.

1222exprPlacement :: HsExpr GhcPs -> Placement

1212exprPlacement :: HsExpr GhcPs -> Placement

1223exprPlacement = \case

1213exprPlacement = \case

1224 -- Only hang lambdas with single line parameter lists

1214 -- Only hang lambdas with single line parameter lists

1225− HsLam NoExtField mg -> case mg of

1215+ HsLam NoExt mg -> case mg of

1226− MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _

1216+ MG _ (L _ [L _ (Match NoExt _ (x : xs) _)]) _

1227 | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->

1217 | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) ->

1228 Hanging

1218 Hanging

1229 _ -> Normal

1219 _ -> Normal

1230− HsLamCase NoExtField _ -> Hanging

1220+ HsLamCase NoExt _ -> Hanging

1231− HsCase NoExtField _ _ -> Hanging

1221+ HsCase NoExt _ _ -> Hanging

1232− HsDo NoExtField DoExpr _ -> Hanging

1222+ HsDo NoExt DoExpr _ -> Hanging

1233− HsDo NoExtField MDoExpr _ -> Hanging

1223+ HsDo NoExt MDoExpr _ -> Hanging

1234− OpApp NoExtField _ op y ->

1224+ -- If the rightmost expression in an operator chain is hanging, make the

1235− case (fmap getOpNameStr . getOpName . unLoc) op of

1225+ -- whole block hanging; so that we can use the common @f = foo $ do@

1236− Just "$" -> exprPlacement (unLoc y)

1226+ -- style.

1237− _ -> Normal

1227+ OpApp NoExt _ _ y -> exprPlacement (unLoc y)

1238− HsApp NoExtField _ y -> exprPlacement (unLoc y)

1228+ -- Same thing for function applications (usually with -XBlockArguments)

1239− HsProc NoExtField p _ ->

1229+ HsApp NoExt _ y -> exprPlacement (unLoc y)

1230+ HsProc NoExt p _ ->

1231+ -- https://gitlab.haskell.org/ghc/ghc/issues/17330

1232+ let loc = case p of

1233+ XPat pat -> getLoc pat

1234+ _ -> error "exprPlacement: HsProc: Pat does not contain a location"

1240− -- Indentation breaks if pattern is longer than one line and left

1235+ in -- Indentation breaks if pattern is longer than one line and left

1241− -- hanging. Consequently, only apply hanging when it is safe.

1236+ -- hanging. Consequently, only apply hanging when it is safe.

1242− if isOneLineSpan (getLoc p)

1237+ if isOneLineSpan loc

1243− then Hanging

1238+ then Hanging

1244− else Normal

1239+ else Normal

1245 _ -> Normal

1240 _ -> Normal

1246

1241

1247withGuards :: [LGRHS GhcPs (Located body)] -> Bool

1242withGuards :: [LGRHS GhcPs (Located body)] -> Bool

1248withGuards = any (checkOne . unLoc)

1243withGuards = any (checkOne . unLoc)

1249 where

1244 where

1250 checkOne :: GRHS GhcPs (Located body) -> Bool

1245 checkOne :: GRHS GhcPs (Located body) -> Bool

1251− checkOne (GRHS NoExtField [] _) = False

1246+ checkOne (GRHS NoExt [] _) = False

1252 checkOne _ = True

1247 checkOne _ = True

1253

1248

1254exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)

1249exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs)

1255−exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)

1250+exprOpTree (L _ (OpApp NoExt x op y)) = OpBranch (exprOpTree x) op (exprOpTree y)

1256exprOpTree n = OpNode n

1251exprOpTree n = OpNode n

1257

1252

1258getOpName :: HsExpr GhcPs -> Maybe RdrName

1253getOpName :: HsExpr GhcPs -> Maybe RdrName

1259getOpName = \case

1254getOpName = \case

1260− HsVar NoExtField (L _ a) -> Just a

1255+ HsVar NoExt (L _ a) -> Just a

1261 _ -> Nothing

1256 _ -> Nothing

1262

1257

1263−getOpNameStr :: RdrName -> String

1264−getOpNameStr = occNameString . rdrNameOcc

1265−

1266p_exprOpTree ::

1258p_exprOpTree ::

1259+ -- | Can use special handling of dollar?

1260+ Bool ->

1267 -- | Bracket style to use

1261 -- | Bracket style to use

1268 BracketStyle ->

1262 BracketStyle ->

1269 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->

1263 OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->

1270 R ()

1264 R ()

1271−p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)

1265+p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)

1272−p_exprOpTree s (OpBranch x op y) = do

1266+p_exprOpTree isDollarSpecial s (OpBranch x op y) = do

1273 -- If the beginning of the first argument and the second argument are on

1267 -- If the beginning of the first argument and the second argument are on

1274 -- the same line, and the second argument has a hanging form, use hanging

1268 -- the same line, and the second argument has a hanging form, use hanging

1275 -- placement.

1269 -- placement.

@@ -1280,10 +1274,8 @@ p_exprOpTree s (OpBranch x op y) = do

1280 OpNode (L _ n) -> exprPlacement n

1274 OpNode (L _ n) -> exprPlacement n

1281 _ -> Normal

1275 _ -> Normal

1282 else Normal

1276 else Normal

1283− -- Distinguish holes used in infix notation.

1284− -- eg. '1 _foo 2' and '1 `_foo` 2'

1285 opWrapper = case unLoc op of

1277 opWrapper = case unLoc op of

1286− HsUnboundVar NoExtField _ -> backticks

1278+ EWildPat NoExt -> backticks

1287 _ -> id

1279 _ -> id

1288 layout <- getLayout

1280 layout <- getLayout

1289 let ub = case layout of

1281 let ub = case layout of

@@ -1291,54 +1283,44 @@ p_exprOpTree s (OpBranch x op y) = do

1291 MultiLine -> case placement of

1283 MultiLine -> case placement of

1292 Hanging -> useBraces

1284 Hanging -> useBraces

1293 Normal -> dontUseBraces

1285 Normal -> dontUseBraces

1294− opNameStr = (fmap getOpNameStr . getOpName . unLoc) op

1286+ gotDollar = case getOpName (unLoc op) of

1295− gotDollar = opNameStr == Just "$"

1287+ Just rname -> mkVarOcc "$" == rdrNameOcc rname

1296− gotColon = opNameStr == Just ":"

1288+ _ -> False

1297− gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)

1298 lhs =

1289 lhs =

1299 switchLayout [opTreeLoc x] $

1290 switchLayout [opTreeLoc x] $

1300− p_exprOpTree s x

1291+ p_exprOpTree (not gotDollar) s x

1301− p_op = located op (opWrapper . p_hsExpr)

1292+ let p_op = located op (opWrapper . p_hsExpr)

1302− p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)

1293+ p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)

1303 isSection = case (opTreeLoc x, getLoc op) of

1294 isSection = case (opTreeLoc x, getLoc op) of

1304 (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->

1295 (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->

1305 srcSpanEndCol treeSpan /= srcSpanStartCol opSpan

1296 srcSpanEndCol treeSpan /= srcSpanStartCol opSpan

1306 _ -> False

1297 _ -> False

1307− isDoBlock = \case

1308− OpNode (L _ HsDo {}) -> True

1309− _ -> False

1310 useRecordDot' <- useRecordDot

1298 useRecordDot' <- useRecordDot

1311− if

1299+ let isRecordDot' = isRecordDot (unLoc op) (opTreeLoc y)

1312− | gotColon -> do

1300+ if useRecordDot' && isRecordDot'

1313− lhs

1301+ then do

1302+ lhs

1303+ when isSection space

1304+ p_op

1305+ p_y

1306+ else

1307+ if isDollarSpecial

1308+ && gotDollar

1309+ && placement

1310+ == Normal

1311+ && isOneLineSpan (opTreeLoc x)

1312+ then do

1313+ useBraces lhs

1314− space

1314+ space

1315− p_op

1315+ p_op

1316− case placement of

1316+ breakpoint

1317− Hanging -> do

1317+ inci p_y

1318+ else do

1319+ ub lhs

1320+ placeHanging placement $ do

1321+ p_op

1318 space

1322 space

1319 p_y

1323 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

1342

1324

1343-- | Return 'True' if given expression is a record-dot operator expression.

1325-- | Return 'True' if given expression is a record-dot operator expression.

1344isRecordDot ::

1326isRecordDot ::

@@ -1348,11 +1330,15 @@ isRecordDot ::

1348 SrcSpan ->

1330 SrcSpan ->

1349 Bool

1331 Bool

1350isRecordDot op (RealSrcSpan ySpan) = case op of

1332isRecordDot op (RealSrcSpan ySpan) = case op of

1351− HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->

1333+ HsVar NoExt (L (RealSrcSpan opSpan) opName) ->

1352− (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)

1334+ isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)

1353 _ -> False

1335 _ -> False

1354isRecordDot _ _ = False

1336isRecordDot _ _ = False

1355

1337

1338+-- | Check whether a given 'RdrName' is the dot operator.

1339+isDot :: RdrName -> Bool

1340+isDot name = rdrNameOcc name == mkVarOcc "."

1341+

1356-- | Get annotations for the enclosing element.

1342-- | Get annotations for the enclosing element.

1357getEnclosingAnns :: R [AnnKeywordId]

1343getEnclosingAnns :: R [AnnKeywordId]

1358getEnclosingAnns = do

1344getEnclosingAnns = do

src/Ormolu/Printer/Meat/Declaration/Value.hs-boot+4

@@ -11,7 +11,11 @@ import GHC

11import Ormolu.Printer.Combinators

12

13p_valDecl :: HsBindLR GhcPs GhcPs -> R ()

14+

14p_pat :: Pat GhcPs -> R ()

15p_pat :: Pat GhcPs -> R ()

16+

15p_hsExpr :: HsExpr GhcPs -> R ()

17p_hsExpr :: HsExpr GhcPs -> R ()

18+

16p_hsSplice :: HsSplice GhcPs -> R ()

19p_hsSplice :: HsSplice GhcPs -> R ()

20+

17p_stringLit :: String -> R ()

21p_stringLit :: String -> R ()

src/Ormolu/Printer/Meat/Declaration/Warning.hs+13−9

@@ -13,28 +13,32 @@ import Data.Text (Text)

13import GHC

14import Ormolu.Printer.Combinators

15import Ormolu.Printer.Meat.Common

16+import Ormolu.Utils

16

17

17p_warnDecls :: WarnDecls GhcPs -> R ()

18p_warnDecls :: WarnDecls GhcPs -> R ()

18−p_warnDecls (Warnings NoExtField _ warnings) =

19+p_warnDecls (Warnings NoExt _ warnings) =

19 traverse_ (located' p_warnDecl) warnings

20 traverse_ (located' p_warnDecl) warnings

20−p_warnDecls (XWarnDecls x) = noExtCon x

21+p_warnDecls XWarnDecls {} = notImplemented "XWarnDecls"

21

22

22p_warnDecl :: WarnDecl GhcPs -> R ()

23p_warnDecl :: WarnDecl GhcPs -> R ()

23−p_warnDecl (Warning NoExtField functions warningTxt) =

24+p_warnDecl (Warning NoExt functions warningTxt) =

24 p_topLevelWarning functions warningTxt

25 p_topLevelWarning functions warningTxt

25−p_warnDecl (XWarnDecl x) = noExtCon x

26+p_warnDecl XWarnDecl {} = notImplemented "XWarnDecl"

26

27

27p_moduleWarning :: WarningTxt -> R ()

28p_moduleWarning :: WarningTxt -> R ()

28p_moduleWarning wtxt = do

29p_moduleWarning wtxt = do

29 let (pragmaText, lits) = warningText wtxt

30 let (pragmaText, lits) = warningText wtxt

31+ switchLayout (getLoc <$> lits)

32+ $ inci

30− inci $ pragma pragmaText $ inci $ p_lits lits

33+ $ pragma pragmaText (inci $ p_lits lits)

31

34

32p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()

35p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()

33p_topLevelWarning fnames wtxt = do

36p_topLevelWarning fnames wtxt = do

34 let (pragmaText, lits) = warningText wtxt

37 let (pragmaText, lits) = warningText wtxt

35− switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $

38+ switchLayout (fmap getLoc fnames ++ fmap getLoc lits)

36− pragma pragmaText . inci $ do

39+ $ pragma pragmaText . inci

40+ $ do

37− sep commaDel p_rdrName fnames

41+ sitcc $ sep (comma >> breakpoint) p_rdrName fnames

38 breakpoint

42 breakpoint

39 p_lits lits

43 p_lits lits

40

44

@@ -46,4 +50,4 @@ warningText = \case

46p_lits :: [Located StringLiteral] -> R ()

50p_lits :: [Located StringLiteral] -> R ()

47p_lits = \case

51p_lits = \case

48 [l] -> atom l

52 [l] -> atom l

49− ls -> brackets N $ sep commaDel atom ls

53+ ls -> brackets N . sitcc $ sep (comma >> breakpoint) atom ls

src/Ormolu/Printer/Meat/ImportExport.hs+35−44

@@ -11,9 +11,10 @@ where

11

12import Control.Monad

13import GHC

14+import HsImpExp (IE (..))

14import Ormolu.Printer.Combinators

15import Ormolu.Printer.Combinators

15import Ormolu.Printer.Meat.Common

16import Ormolu.Printer.Meat.Common

16−import Ormolu.Utils (RelativePos (..), attachRelativePos)

17+import Ormolu.Utils

17

18

18p_hsmodExports :: [LIE GhcPs] -> R ()

19p_hsmodExports :: [LIE GhcPs] -> R ()

19p_hsmodExports [] = do

20p_hsmodExports [] = do

@@ -21,24 +22,19 @@ p_hsmodExports [] = do

21 breakpoint'

22 breakpoint'

22 txt ")"

23 txt ")"

23p_hsmodExports xs =

24p_hsmodExports xs =

24− parens N $ do

25+ parens N . sitcc $ do

25 layout <- getLayout

26 layout <- getLayout

26− sep

27− breakpoint

28− (\(p, l) -> sitcc (located l (p_lie layout p)))

27+ sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)

29− (attachRelativePos xs)

30

28

31−p_hsmodImport :: Bool -> ImportDecl GhcPs -> R ()

29+p_hsmodImport :: ImportDecl GhcPs -> R ()

32−p_hsmodImport useQualifiedPost ImportDecl {..} = do

30+p_hsmodImport ImportDecl {..} = do

33 txt "import"

31 txt "import"

34 space

32 space

35 when ideclSource (txt "{-# SOURCE #-}")

33 when ideclSource (txt "{-# SOURCE #-}")

36 space

34 space

37 when ideclSafe (txt "safe")

35 when ideclSafe (txt "safe")

38 space

36 space

39− when

40− (isImportDeclQualified ideclQualified && not useQualifiedPost)

41− (txt "qualified")

37+ when ideclQualified (txt "qualified")

42 space

38 space

43 case ideclPkgQual of

39 case ideclPkgQual of

44 Nothing -> return ()

40 Nothing -> return ()

@@ -46,9 +42,6 @@ p_hsmodImport useQualifiedPost ImportDecl {..} = do

46 space

42 space

47 inci $ do

43 inci $ do

48 located ideclName atom

44 located ideclName atom

49− when

50− (isImportDeclQualified ideclQualified && useQualifiedPost)

51− (space >> txt "qualified")

52 case ideclAs of

45 case ideclAs of

53 Nothing -> return ()

46 Nothing -> return ()

54 Just l -> do

47 Just l -> do

@@ -65,62 +58,60 @@ p_hsmodImport useQualifiedPost ImportDecl {..} = do

65 Nothing -> return ()

58 Nothing -> return ()

66 Just (_, L _ xs) -> do

59 Just (_, L _ xs) -> do

67 breakpoint

60 breakpoint

68− parens N $ do

61+ parens N . sitcc $ do

69 layout <- getLayout

62 layout <- getLayout

70− sep

71− breakpoint

72− (\(p, l) -> sitcc (located l (p_lie layout p)))

63+ sep breakpoint (sitcc . located' (uncurry (p_lie layout))) (attachPositions xs)

73− (attachRelativePos xs)

74 newline

64 newline

75−p_hsmodImport _ (XImportDecl x) = noExtCon x

65+p_hsmodImport (XImportDecl NoExt) = notImplemented "XImportDecl"

76

66

77−p_lie :: Layout -> RelativePos -> IE GhcPs -> R ()

67+p_lie :: Layout -> (Int, Int) -> IE GhcPs -> R ()

78−p_lie encLayout relativePos = \case

68+p_lie encLayout (i, totalItems) = \case

79− IEVar NoExtField l1 -> do

69+ IEVar NoExt l1 -> do

80 located l1 p_ieWrappedName

70 located l1 p_ieWrappedName

81 p_comma

71 p_comma

82− IEThingAbs NoExtField l1 -> do

72+ IEThingAbs NoExt l1 -> do

83 located l1 p_ieWrappedName

73 located l1 p_ieWrappedName

84 p_comma

74 p_comma

85− IEThingAll NoExtField l1 -> do

75+ IEThingAll NoExt l1 -> do

86 located l1 p_ieWrappedName

76 located l1 p_ieWrappedName

87 space

77 space

88 txt "(..)"

78 txt "(..)"

89 p_comma

79 p_comma

90− IEThingWith NoExtField l1 w xs _ -> sitcc $ do

80+ IEThingWith NoExt l1 w xs _ -> sitcc $ do

91 located l1 p_ieWrappedName

81 located l1 p_ieWrappedName

92 breakpoint

82 breakpoint

93 inci $ do

83 inci $ do

94 let names :: [R ()]

84 let names :: [R ()]

95 names = located' p_ieWrappedName <$> xs

85 names = located' p_ieWrappedName <$> xs

96− parens N . sep commaDel sitcc $

86+ parens N . sitcc

87+ $ sep (comma >> breakpoint) sitcc

97− case w of

88+ $ case w of

98 NoIEWildcard -> names

89 NoIEWildcard -> names

99 IEWildcard n ->

90 IEWildcard n ->

100 let (before, after) = splitAt n names

91 let (before, after) = splitAt n names

101 in before ++ [txt ".."] ++ after

92 in before ++ [txt ".."] ++ after

102 p_comma

93 p_comma

103− IEModuleContents NoExtField l1 -> do

94+ IEModuleContents NoExt l1 -> do

104 located l1 p_hsmodName

95 located l1 p_hsmodName

105 p_comma

96 p_comma

106− IEGroup NoExtField n str -> do

97+ IEGroup NoExt n str -> do

107− case relativePos of

108− SinglePos -> return ()

109− FirstPos -> return ()

110− MiddlePos -> newline

111− LastPos -> newline

98+ unless (i == 0) newline

112 p_hsDocString (Asterisk n) False (noLoc str)

99 p_hsDocString (Asterisk n) False (noLoc str)

113− IEDoc NoExtField str ->

100+ IEDoc NoExt str ->

114 p_hsDocString Pipe False (noLoc str)

101 p_hsDocString Pipe False (noLoc str)

115− IEDocNamed NoExtField str -> p_hsDocName str

102+ IEDocNamed NoExt str -> p_hsDocName str

116− XIE x -> noExtCon x

103+ XIE NoExt -> notImplemented "XIE"

117 where

104 where

118 p_comma =

105 p_comma =

119 case encLayout of

106 case encLayout of

120− SingleLine ->

107+ SingleLine -> unless (i + 1 == totalItems) comma

121− case relativePos of

122− SinglePos -> return ()

123− FirstPos -> comma

124− MiddlePos -> comma

125− LastPos -> return ()

126 MultiLine -> comma

108 MultiLine -> comma

109+

110+-- | Attach positions to 'Located' things in a list.

111+attachPositions ::

112+ [Located a] ->

113+ [Located ((Int, Int), a)]

114+attachPositions xs =

115+ let f i (L l x) = L l ((i, n), x)

116+ n = length xs

117+ in zipWith f [0 ..] xs

src/Ormolu/Printer/Meat/Module.hs+20−26

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

1−{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE RecordWildCards #-}

4

3

@@ -11,10 +10,8 @@ where

11import Control.Monad

10import Control.Monad

12import qualified Data.Text as T

11import qualified Data.Text as T

13import GHC

12import GHC

14−import Ormolu.Imports (normalizeImports)

13+import Ormolu.Imports

15−import Ormolu.Parser.CommentStream

16import Ormolu.Parser.Pragma

14import Ormolu.Parser.Pragma

17−import Ormolu.Parser.Shebang

18import Ormolu.Printer.Combinators

15import Ormolu.Printer.Combinators

19import Ormolu.Printer.Comments

16import Ormolu.Printer.Comments

20import Ormolu.Printer.Meat.Common

17import Ormolu.Printer.Meat.Common

@@ -25,28 +22,26 @@ import Ormolu.Printer.Meat.Pragma

25

22

26-- | Render a module.

23-- | Render a module.

27p_hsModule ::

24p_hsModule ::

28− -- | Stack header

29− Maybe (RealLocated Comment) ->

30 -- | Shebangs

25 -- | Shebangs

31− [Shebang] ->

26+ [Located String] ->

32− -- | Pragmas and the associated comments

27+ -- | Pragmas

33− [([RealLocated Comment], Pragma)] ->

28+ [Pragma] ->

34− -- | Whether to use postfix qualified imports

35− Bool ->

36 -- | AST to print

29 -- | AST to print

37− HsModule GhcPs ->

30+ ParsedSource ->

38 R ()

31 R ()

39−p_hsModule mstackHeader shebangs pragmas qualifiedPost HsModule {..} = do

32+p_hsModule shebangs pragmas (L moduleSpan HsModule {..}) = do

33+ -- If span of exports in multiline, the whole thing is multiline. This is

34+ -- especially important because span of module itself always seems to have

35+ -- length zero, so it's not reliable for layout selection.

36+ let exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports

40− let deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage

37+ deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage

41− exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports

38+ spans' = exportSpans ++ deprecSpan ++ [moduleSpan]

42− switchLayout (deprecSpan <> exportSpans) $ do

39+ switchLayout spans' $ do

43− forM_ shebangs $ \(Shebang x) ->

40+ forM_ shebangs $ \x ->

44 located x $ \shebang -> do

41 located x $ \shebang -> do

45 txt (T.pack shebang)

42 txt (T.pack shebang)

46 newline

43 newline

47− forM_ mstackHeader $ \(L spn comment) -> do

44+ spitStackHeader

48− spitCommentNow spn comment

49− newline

50 newline

45 newline

51 p_pragmas pragmas

46 p_pragmas pragmas

52 newline

47 newline

@@ -56,20 +51,19 @@ p_hsModule mstackHeader shebangs pragmas qualifiedPost HsModule {..} = do

56 located hsmodName' $ \name -> do

51 located hsmodName' $ \name -> do

57 forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)

52 forM_ hsmodHaddockModHeader (p_hsDocString Pipe True)

58 p_hsmodName name

53 p_hsmodName name

59− breakpoint

60 forM_ hsmodDeprecMessage $ \w -> do

54 forM_ hsmodDeprecMessage $ \w -> do

61− located' p_moduleWarning w

62 breakpoint

55 breakpoint

56+ located' p_moduleWarning w

63 case hsmodExports of

57 case hsmodExports of

64 Nothing -> return ()

58 Nothing -> return ()

65− Just l -> do

59+ Just hsmodExports' -> do

66− located l $ \exports -> do

67− inci (p_hsmodExports exports)

68 breakpoint

60 breakpoint

61+ inci (p_hsmodExports (unLoc hsmodExports'))

62+ breakpoint

69 txt "where"

63 txt "where"

70 newline

64 newline

71 newline

65 newline

72− forM_ (normalizeImports hsmodImports) (located' (p_hsmodImport qualifiedPost))

66+ forM_ (sortImports hsmodImports) (located' p_hsmodImport)

73 newline

67 newline

74 switchLayout (getLoc <$> hsmodDecls) $ do

68 switchLayout (getLoc <$> hsmodDecls) $ do

75 p_hsDecls Free hsmodDecls

69 p_hsDecls Free hsmodDecls

src/Ormolu/Printer/Meat/Pragma.hs+12−22

@@ -8,16 +8,12 @@ module Ormolu.Printer.Meat.Pragma

8 )

9where

10

11−import Control.Monad

12import Data.Char (isUpper)

11import Data.Char (isUpper)

13−import qualified Data.List as L

14import Data.Maybe (listToMaybe)

12import Data.Maybe (listToMaybe)

13+import qualified Data.Set as S

15import qualified Data.Text as T

14import qualified Data.Text as T

16−import Ormolu.Parser.CommentStream

17import Ormolu.Parser.Pragma (Pragma (..))

15import Ormolu.Parser.Pragma (Pragma (..))

18import Ormolu.Printer.Combinators

16import Ormolu.Printer.Combinators

19−import Ormolu.Printer.Comments

20−import SrcLoc

21

17

22-- | Pragma classification.

18-- | Pragma classification.

23data PragmaTy

19data PragmaTy

@@ -46,31 +42,25 @@ data LanguagePragmaClass

46 Final

42 Final

47 deriving (Eq, Ord)

43 deriving (Eq, Ord)

48

44

49−-- | Print a collection of 'Pragma's with their associated comments.

50−p_pragmas :: [([RealLocated Comment], Pragma)] -> R ()

45+p_pragmas :: [Pragma] -> R ()

51−p_pragmas ps = do

46+p_pragmas ps =

52− let prepare = L.sortOn snd . L.nub . concatMap analyze

47+ let prepare = concatMap $ \case

53− analyze = \case

54− (cs, PragmaLanguage xs) ->

48+ PragmaLanguage xs ->

55− let f x = (cs, (Language (classifyLanguagePragma x), x))

49+ let f x = (Language (classifyLanguagePragma x), x)

56 in f <$> xs

50 in f <$> xs

57− (cs, PragmaOptionsGHC x) -> [(cs, (OptionsGHC, x))]

51+ PragmaOptionsGHC x -> [(OptionsGHC, x)]

58− (cs, PragmaOptionsHaddock x) -> [(cs, (OptionsHaddock, x))]

52+ PragmaOptionsHaddock x -> [(OptionsHaddock, x)]

59− forM_ (prepare ps) $ \(cs, (pragmaTy, x)) ->

53+ in mapM_ (uncurry p_pragma) (S.toAscList . S.fromList . prepare $ ps)

60− p_pragma cs pragmaTy x

61

54

62−p_pragma :: [RealLocated Comment] -> PragmaTy -> String -> R ()

55+p_pragma :: PragmaTy -> String -> R ()

63−p_pragma comments ty x = do

56+p_pragma ty c = do

64− forM_ comments $ \(L l comment) -> do

65− spitCommentNow l comment

66− newline

67 txt "{-# "

57 txt "{-# "

68 txt $ case ty of

58 txt $ case ty of

69 Language _ -> "LANGUAGE"

59 Language _ -> "LANGUAGE"

70 OptionsGHC -> "OPTIONS_GHC"

60 OptionsGHC -> "OPTIONS_GHC"

71 OptionsHaddock -> "OPTIONS_HADDOCK"

61 OptionsHaddock -> "OPTIONS_HADDOCK"

72 space

62 space

73− txt (T.pack x)

63+ txt (T.pack c)

74 txt " #-}"

64 txt " #-}"

75 newline

65 newline

76

66

src/Ormolu/Printer/Meat/Type.hs+61−85

@@ -5,7 +5,6 @@

5-- | Rendering of types.

6module Ormolu.Printer.Meat.Type

7 ( p_hsType,

8− p_hsTypePostDoc,

9 hasDocStrings,

8 hasDocStrings,

10 p_hsContext,

9 p_hsContext,

11 p_hsTyVarBndr,

10 p_hsTyVarBndr,

@@ -24,23 +23,15 @@ import Ormolu.Printer.Operators

24import Ormolu.Utils

23import Ormolu.Utils

25

24

26p_hsType :: HsType GhcPs -> R ()

25p_hsType :: HsType GhcPs -> R ()

27−p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t

26+p_hsType t = p_hsType' (hasDocStrings t) t

28

27

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−

37−p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R ()

28+p_hsType' :: Bool -> HsType GhcPs -> R ()

38−p_hsType' multilineArgs docStyle = \case

29+p_hsType' multilineArgs = \case

39− HsForAllTy NoExtField visibility bndrs t -> do

30+ HsForAllTy NoExt bndrs t -> do

40− p_forallBndrs visibility p_hsTyVarBndr bndrs

31+ p_forallBndrs p_hsTyVarBndr bndrs

41 interArgBreak

32 interArgBreak

42− p_hsTypeR (unLoc t)

33+ p_hsType' multilineArgs (unLoc t)

43− HsQualTy NoExtField qs t -> do

34+ HsQualTy NoExt qs t -> do

44 located qs p_hsContext

35 located qs p_hsContext

45 space

36 space

46 txt "=>"

37 txt "=>"

@@ -49,7 +40,7 @@ p_hsType' multilineArgs docStyle = \case

49 HsQualTy {} -> p_hsTypeR (unLoc t)

40 HsQualTy {} -> p_hsTypeR (unLoc t)

50 HsFunTy {} -> p_hsTypeR (unLoc t)

41 HsFunTy {} -> p_hsTypeR (unLoc t)

51 _ -> located t p_hsTypeR

42 _ -> located t p_hsTypeR

52− HsTyVar NoExtField p n -> do

43+ HsTyVar NoExt p n -> do

53 case p of

44 case p of

54 IsPromoted -> do

45 IsPromoted -> do

55 txt "'"

46 txt "'"

@@ -58,20 +49,10 @@ p_hsType' multilineArgs docStyle = \case

58 _ -> return ()

49 _ -> return ()

59 NotPromoted -> return ()

50 NotPromoted -> return ()

60 p_rdrName n

51 p_rdrName n

61− HsAppTy NoExtField f x -> do

52+ HsAppTy NoExt f x -> sitcc $ 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

71− located func p_hsType

53+ located f p_hsType

72− breakpoint

54+ breakpoint

73− inci $

74− sep breakpoint (located' p_hsType) args

55+ inci (located x p_hsType)

75 HsAppKindTy _ ty kd -> sitcc $ do

56 HsAppKindTy _ ty kd -> sitcc $ do

76 -- The first argument is the location of the "@..." part. Not 100% sure,

57 -- The first argument is the location of the "@..." part. Not 100% sure,

77 -- but I think we can ignore it as long as we use 'located' on both the

58 -- but I think we can ignore it as long as we use 'located' on both the

@@ -81,7 +62,7 @@ p_hsType' multilineArgs docStyle = \case

81 inci $ do

62 inci $ do

82 txt "@"

63 txt "@"

83 located kd p_hsType

64 located kd p_hsType

84− HsFunTy NoExtField x y@(L _ y') -> do

65+ HsFunTy NoExt x y@(L _ y') -> do

85 located x p_hsType

66 located x p_hsType

86 space

67 space

87 txt "->"

68 txt "->"

@@ -89,49 +70,44 @@ p_hsType' multilineArgs docStyle = \case

89 case y' of

70 case y' of

90 HsFunTy {} -> p_hsTypeR y'

71 HsFunTy {} -> p_hsTypeR y'

91 _ -> located y p_hsTypeR

72 _ -> located y p_hsTypeR

92− HsListTy NoExtField t ->

73+ HsListTy NoExt t ->

93 located t (brackets N . p_hsType)

74 located t (brackets N . p_hsType)

94− HsTupleTy NoExtField tsort xs ->

75+ HsTupleTy NoExt tsort xs ->

95 let parens' =

76 let parens' =

96 case tsort of

77 case tsort of

97 HsUnboxedTuple -> parensHash N

78 HsUnboxedTuple -> parensHash N

98 HsBoxedTuple -> parens N

79 HsBoxedTuple -> parens N

99 HsConstraintTuple -> parens N

80 HsConstraintTuple -> parens N

100 HsBoxedOrConstraintTuple -> parens N

81 HsBoxedOrConstraintTuple -> parens N

82+ in parens' . sitcc $

101− in parens' $ sep commaDel (sitcc . located' p_hsType) xs

83+ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs

102− HsSumTy NoExtField xs ->

84+ HsSumTy NoExt xs ->

103− parensHash N $

85+ parensHash N . sitcc $

104 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs

86 sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs

105− HsOpTy NoExtField x op y ->

87+ HsOpTy NoExt x op y ->

106 sitcc $

88 sitcc $

107 let opTree = OpBranch (tyOpTree x) op (tyOpTree y)

89 let opTree = OpBranch (tyOpTree x) op (tyOpTree y)

108 in p_tyOpTree (reassociateOpTree Just opTree)

90 in p_tyOpTree (reassociateOpTree Just opTree)

109− HsParTy NoExtField t ->

91+ HsParTy NoExt t ->

110 parens N (located t p_hsType)

92 parens N (located t p_hsType)

111− HsIParamTy NoExtField n t -> sitcc $ do

93+ HsIParamTy NoExt n t -> sitcc $ do

112 located n atom

94 located n atom

113 space

95 space

114 txt "::"

96 txt "::"

115 breakpoint

97 breakpoint

116 inci (located t p_hsType)

98 inci (located t p_hsType)

117− HsStarTy NoExtField _ -> txt "*"

99+ HsStarTy NoExt _ -> txt "*"

118− HsKindSig NoExtField t k -> sitcc $ do

100+ HsKindSig NoExt t k -> sitcc $ do

119 located t p_hsType

101 located t p_hsType

120− space

102+ space -- FIXME

121 txt "::"

103 txt "::"

122− breakpoint

104+ space

123 inci (located k p_hsType)

105 inci (located k p_hsType)

124− HsSpliceTy NoExtField splice -> p_hsSplice splice

106+ HsSpliceTy NoExt splice -> p_hsSplice splice

125− HsDocTy NoExtField t str ->

107+ HsDocTy NoExt t str -> do

126− case docStyle of

127− PipeStyle -> do

128− p_hsDocString Pipe True str

108+ p_hsDocString Pipe True str

129− located t p_hsType

130− CaretStyle -> do

131− located t p_hsType

109+ located t p_hsType

132− newline

133− p_hsDocString Caret False str

134− HsBangTy NoExtField (HsSrcBang _ u s) t -> do

110+ HsBangTy NoExt (HsSrcBang _ u s) t -> do

135 case u of

111 case u of

136 SrcUnpack -> txt "{-# UNPACK #-}" >> space

112 SrcUnpack -> txt "{-# UNPACK #-}" >> space

137 SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space

113 SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space

@@ -141,9 +117,9 @@ p_hsType' multilineArgs docStyle = \case

141 SrcStrict -> txt "!"

117 SrcStrict -> txt "!"

142 NoSrcStrict -> return ()

118 NoSrcStrict -> return ()

143 located t p_hsType

119 located t p_hsType

144− HsRecTy NoExtField fields ->

120+ HsRecTy NoExt fields ->

145 p_conDeclFields fields

121 p_conDeclFields fields

146− HsExplicitListTy NoExtField p xs -> do

122+ HsExplicitListTy NoExt p xs -> do

147 case p of

123 case p of

148 IsPromoted -> txt "'"

124 IsPromoted -> txt "'"

149 NotPromoted -> return ()

125 NotPromoted -> return ()

@@ -153,31 +129,31 @@ p_hsType' multilineArgs docStyle = \case

153 case (p, xs) of

129 case (p, xs) of

154 (IsPromoted, L _ t : _) | isPromoted t -> space

130 (IsPromoted, L _ t : _) | isPromoted t -> space

155 _ -> return ()

131 _ -> return ()

156− sep commaDel (sitcc . located' p_hsType) xs

132+ sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs

157− HsExplicitTupleTy NoExtField xs -> do

133+ HsExplicitTupleTy NoExt xs -> do

158 txt "'"

134 txt "'"

159 parens N $ do

135 parens N $ do

160 case xs of

136 case xs of

161 L _ t : _ | isPromoted t -> space

137 L _ t : _ | isPromoted t -> space

162 _ -> return ()

138 _ -> return ()

163− sep commaDel (located' p_hsType) xs

139+ sep (comma >> breakpoint) (located' p_hsType) xs

164− HsTyLit NoExtField t ->

140+ HsTyLit NoExt t ->

165 case t of

141 case t of

166 HsStrTy (SourceText s) _ -> p_stringLit s

142 HsStrTy (SourceText s) _ -> p_stringLit s

167 a -> atom a

143 a -> atom a

168− HsWildCardTy NoExtField -> txt "_"

144+ HsWildCardTy NoExt -> txt "_"

169 XHsType (NHsCoreTy t) -> atom t

145 XHsType (NHsCoreTy t) -> atom t

170 where

146 where

171 isPromoted = \case

147 isPromoted = \case

172 HsTyVar _ IsPromoted _ -> True

148 HsTyVar _ IsPromoted _ -> True

173− HsExplicitTupleTy {} -> True

174 HsExplicitListTy {} -> True

149 HsExplicitListTy {} -> True

150+ HsExplicitTupleTy {} -> True

175 _ -> False

151 _ -> False

176 interArgBreak =

152 interArgBreak =

177 if multilineArgs

153 if multilineArgs

178 then newline

154 then newline

179 else breakpoint

155 else breakpoint

180− p_hsTypeR = p_hsType' multilineArgs docStyle

156+ p_hsTypeR = p_hsType' multilineArgs

181

157

182-- | Return 'True' if at least one argument in 'HsType' has a doc string

158-- | Return 'True' if at least one argument in 'HsType' has a doc string

183-- attached to it.

159-- attached to it.

@@ -191,54 +167,54 @@ p_hsContext :: HsContext GhcPs -> R ()

191p_hsContext = \case

167p_hsContext = \case

192 [] -> txt "()"

168 [] -> txt "()"

193 [x] -> located x p_hsType

169 [x] -> located x p_hsType

170+ xs ->

171+ parens N . sitcc $

194− xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs

172+ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs

195

173

196p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()

174p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R ()

197p_hsTyVarBndr = \case

175p_hsTyVarBndr = \case

198− UserTyVar NoExtField x ->

176+ UserTyVar NoExt x ->

199 p_rdrName x

177 p_rdrName x

200− KindedTyVar NoExtField l k -> parens N $ do

178+ KindedTyVar NoExt l k -> parens N $ do

201 located l atom

179 located l atom

202 space

180 space

203 txt "::"

181 txt "::"

204 breakpoint

182 breakpoint

205 inci (located k p_hsType)

183 inci (located k p_hsType)

206− XTyVarBndr x -> noExtCon x

184+ XTyVarBndr NoExt -> notImplemented "XTyVarBndr"

207

185

208-- | Render several @forall@-ed variables.

186-- | Render several @forall@-ed variables.

209−p_forallBndrs :: Data a => ForallVisFlag -> (a -> R ()) -> [Located a] -> R ()

187+p_forallBndrs :: Data a => (a -> R ()) -> [Located a] -> R ()

210−p_forallBndrs ForallInvis _ [] = txt "forall."

188+p_forallBndrs _ [] = txt "forall."

211−p_forallBndrs ForallVis _ [] = txt "forall ->"

189+p_forallBndrs p tyvars =

212−p_forallBndrs vis p tyvars =

213 switchLayout (getLoc <$> tyvars) $ do

190 switchLayout (getLoc <$> tyvars) $ do

214 txt "forall"

191 txt "forall"

215 breakpoint

192 breakpoint

216 inci $ do

193 inci $ do

217 sitcc $ sep breakpoint (sitcc . located' p) tyvars

194 sitcc $ sep breakpoint (sitcc . located' p) tyvars

218− case vis of

195+ txt "."

219− ForallInvis -> txt "."

220− ForallVis -> space >> txt "->"

221

196

222p_conDeclFields :: [LConDeclField GhcPs] -> R ()

197p_conDeclFields :: [LConDeclField GhcPs] -> R ()

223p_conDeclFields xs =

198p_conDeclFields xs =

199+ braces N . sitcc $

224− braces N $ sep commaDel (sitcc . located' p_conDeclField) xs

200+ sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs

225

201

226p_conDeclField :: ConDeclField GhcPs -> R ()

202p_conDeclField :: ConDeclField GhcPs -> R ()

227p_conDeclField ConDeclField {..} = do

203p_conDeclField ConDeclField {..} = do

228 mapM_ (p_hsDocString Pipe True) cd_fld_doc

204 mapM_ (p_hsDocString Pipe True) cd_fld_doc

229 sitcc $

205 sitcc $

230 sep

206 sep

231− commaDel

207+ (comma >> breakpoint)

232 (located' (p_rdrName . rdrNameFieldOcc))

208 (located' (p_rdrName . rdrNameFieldOcc))

233 cd_fld_names

209 cd_fld_names

234 space

210 space

235 txt "::"

211 txt "::"

236 breakpoint

212 breakpoint

237 sitcc . inci $ p_hsType (unLoc cd_fld_type)

213 sitcc . inci $ p_hsType (unLoc cd_fld_type)

238−p_conDeclField (XConDeclField x) = noExtCon x

214+p_conDeclField (XConDeclField NoExt) = notImplemented "XConDeclField"

239

215

240tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)

216tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName)

241−tyOpTree (L _ (HsOpTy NoExtField l op r)) =

217+tyOpTree (L _ (HsOpTy NoExt l op r)) =

242 OpBranch (tyOpTree l) op (tyOpTree r)

218 OpBranch (tyOpTree l) op (tyOpTree r)

243tyOpTree n = OpNode n

219tyOpTree n = OpNode n

244

220

@@ -259,17 +235,17 @@ p_tyOpTree (OpBranch l op r) = do

259tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]

235tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs]

260tyVarsToTypes = \case

236tyVarsToTypes = \case

261 HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit

237 HsQTvs {..} -> fmap tyVarToType <$> hsq_explicit

262− XLHsQTyVars x -> noExtCon x

238+ XLHsQTyVars {} -> notImplemented "XLHsQTyVars"

263

239

264tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs

240tyVarToType :: HsTyVarBndr GhcPs -> HsType GhcPs

265tyVarToType = \case

241tyVarToType = \case

266− UserTyVar NoExtField tvar -> HsTyVar NoExtField NotPromoted tvar

242+ UserTyVar NoExt tvar -> HsTyVar NoExt NotPromoted tvar

267− KindedTyVar NoExtField tvar kind ->

243+ KindedTyVar NoExt tvar kind ->

268 -- Note: we always add parentheses because for whatever reason GHC does

244 -- Note: we always add parentheses because for whatever reason GHC does

269 -- not use HsParTy for left-hand sides of declarations. Please see

245 -- not use HsParTy for left-hand sides of declarations. Please see

270 -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as

246 -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as

271 -- long as 'tyVarToType' does not get applied to right-hand sides of

247 -- long as 'tyVarToType' does not get applied to right-hand sides of

272 -- declarations.

248 -- declarations.

273− HsParTy NoExtField . noLoc $

249+ HsParTy NoExt $ noLoc $

274− HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind

250+ HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted tvar)) kind

275− XTyVarBndr x -> noExtCon x

251+ XTyVarBndr {} -> notImplemented "XTyVarBndr"

src/Ormolu/Printer/Operators.hs+66−50

@@ -10,14 +10,16 @@ module Ormolu.Printer.Operators

10 )

11where

12

13+import BasicTypes (Fixity (..), SourceText (NoSourceText), compareFixity, defaultFixity)

13import Data.Function (on)

14import Data.Function (on)

14−import qualified Data.List as L

15+import Data.List

15−import Data.Map.Strict (Map)

16−import qualified Data.Map.Strict as M

17import Data.Maybe (fromMaybe, mapMaybe)

16import Data.Maybe (fromMaybe, mapMaybe)

17+import Data.Ord (Down (Down), comparing)

18import GHC

19−import OccName (occNameString)

19+import OccName (mkVarOcc)

20import Ormolu.Utils (unSrcSpan)

21+import RdrName (mkRdrUnqual)

22+import SrcLoc (combineSrcSpans)

21

23

22-- | Intermediate representation of operator trees. It has two type

24-- | Intermediate representation of operator trees. It has two type

23-- parameters: @ty@ is the type of sub-expressions, while @op@ is the type

25-- parameters: @ty@ is the type of sub-expressions, while @op@ is the type

@@ -57,7 +59,7 @@ reassociateOpTree getOpName opTree =

57reassociateOpTreeWith ::

59reassociateOpTreeWith ::

58 forall ty op.

60 forall ty op.

59 -- | Fixity map for operators

61 -- | Fixity map for operators

60− Map String Fixity ->

62+ [(RdrName, Fixity)] ->

61 -- | How to get the name of an operator

63 -- | How to get the name of an operator

62 (op -> Maybe RdrName) ->

64 (op -> Maybe RdrName) ->

63 -- | Original 'OpTree'

65 -- | Original 'OpTree'

@@ -68,13 +70,13 @@ reassociateOpTreeWith fixityMap getOpName = go

68 where

70 where

69 fixityOf :: op -> Fixity

71 fixityOf :: op -> Fixity

70 fixityOf op = fromMaybe defaultFixity $ do

72 fixityOf op = fromMaybe defaultFixity $ do

71− s <- occNameString . rdrNameOcc <$> getOpName op

73+ opName <- getOpName op

72− M.lookup s fixityMap

74+ lookup opName fixityMap

73 -- Here, left branch is already associated and the root alongside with

75 -- Here, left branch is already associated and the root alongside with

74 -- the right branch is right-associated. This function picks up one item

76 -- the right branch is right-associated. This function picks up one item

75 -- from the right and inserts it correctly to the left.

77 -- from the right and inserts it correctly to the left.

76 --

78 --

77− -- Also, we are using the 'compareFixity' function which tells if the

79+ -- Also, we are using the 'compareFixity' function which returns if the

78 -- expression should associate to right.

80 -- expression should associate to right.

79 go :: OpTree ty op -> OpTree ty op

81 go :: OpTree ty op -> OpTree ty op

80 -- base cases

82 -- base cases

@@ -94,16 +96,6 @@ reassociateOpTreeWith fixityMap getOpName = go

94 then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'

96 then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r'

95 else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'

97 else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r'

96

98

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−

107-- | Build a map of inferred 'Fixity's from an 'OpTree'.

99-- | Build a map of inferred 'Fixity's from an 'OpTree'.

108buildFixityMap ::

100buildFixityMap ::

109 forall ty op.

101 forall ty op.

@@ -112,26 +104,23 @@ buildFixityMap ::

112 -- | Operator tree

104 -- | Operator tree

113 OpTree (Located ty) (Located op) ->

105 OpTree (Located ty) (Located op) ->

114 -- | Fixity map

106 -- | Fixity map

115− Map String Fixity

107+ [(RdrName, Fixity)]

116buildFixityMap getOpName opTree =

108buildFixityMap getOpName opTree =

117− addOverrides

118− . M.fromList

119− . concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)

109+ concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)

120− . zip [2 ..]

110+ . zip [0 ..]

121− . L.groupBy ((==) `on` snd)

111+ . groupBy (doubleWithinEps 0.00001 `on` snd)

122− . selectScores

112+ . (overrides ++)

113+ . modeScores

123 $ score opTree

114 $ score opTree

124 where

115 where

125− addOverrides :: Map String Fixity -> Map String Fixity

116+ -- Add a special case for ($), since it is pretty unlikely for someone

126− addOverrides m =

117+ -- to override it.

127− M.fromList

118+ overrides :: [(RdrName, Double)]

128− [ ("$", fixity 0 InfixR),

119+ overrides =

129− (":", fixity 1 InfixR),

120+ [ (mkRdrUnqual $ mkVarOcc "$", -1)

130− (".", fixity 100 InfixL)

121+ ]

131− ]

122+ -- Assign scores to operators based on their location in the source.

132− `M.union` m

133− fixity = Fixity NoSourceText

134− score :: OpTree (Located ty) (Located op) -> [(String, Score)]

123+ score :: OpTree (Located ty) (Located op) -> [(RdrName, Double)]

135 score (OpNode _) = []

124 score (OpNode _) = []

136 score (OpBranch l o r) = fromMaybe (score r) $ do

125 score (OpBranch l o r) = fromMaybe (score r) $ do

137 -- If we fail to get any of these, 'defaultFixity' will be used by

126 -- If we fail to get any of these, 'defaultFixity' will be used by

@@ -141,27 +130,48 @@ buildFixityMap getOpName opTree =

141 oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end

130 oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end

142 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin

131 rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin

143 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column

132 oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column

144− opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o)

133+ opName <- getOpName (unLoc o)

145 let s

134 let s

146− | le < ob = AtBeginning oc

135+ | le < ob =

136+ -- if the operator is in the beginning of a line, assign

137+ -- a score relative to its column within range [0, 1).

138+ fromIntegral oc / fromIntegral (maxCol + 1)

147− | oe < rb = AtEnd

139+ | oe < rb =

140+ -- if the operator is in the end of the line, assign the

141+ -- score 1.

142+ 1

148− | otherwise = InBetween

143+ | otherwise =

144+ 2 -- otherwise, assign a high score.

149 return $ (opName, s) : score r

145 return $ (opName, s) : score r

150− selectScores :: [(String, Score)] -> [(String, Score)]

146+ -- Pick the most common score per 'RdrName'.

151− selectScores =

147+ modeScores :: [(RdrName, Double)] -> [(RdrName, Double)]

148+ modeScores =

152− L.sortOn snd

149+ sortOn snd

153 . mapMaybe

150 . mapMaybe

154 ( \case

151 ( \case

155 [] -> Nothing

152 [] -> Nothing

156− xs@((n, _) : _) -> Just (n, selectScore $ map snd xs)

153+ xs@((n, _) : _) -> Just (n, mode $ map snd xs)

157 )

154 )

158− . L.groupBy ((==) `on` fst)

155+ . groupBy ((==) `on` fst)

159− . L.sort

156+ . sort

160− selectScore :: [Score] -> Score

157+ -- Return the most common number, leaning to the smaller

161− selectScore xs =

158+ -- one in case of a tie.

162− case filter (/= InBetween) xs of

159+ mode :: [Double] -> Double

163− [] -> InBetween

160+ mode =

161+ head

162+ . minimumBy (comparing (Down . length))

163+ . groupBy (doubleWithinEps 0.0001)

164+ . sort

165+ -- The start column of the rightmost operator.

166+ maxCol = go opTree

167+ where

168+ go (OpNode (L _ _)) = 0

169+ go (OpBranch l (L o _) r) =

164− xs' -> maximum xs'

170+ maximum

171+ [ go l,

172+ maybe 0 srcSpanStartCol (unSrcSpan o),

173+ go r

174+ ]

165

175

166----------------------------------------------------------------------------

176----------------------------------------------------------------------------

167-- Helpers

177-- Helpers

@@ -175,3 +185,9 @@ normalizeOpTree (OpBranch (OpNode l) lop r) =

175 OpBranch (OpNode l) lop (normalizeOpTree r)

185 OpBranch (OpNode l) lop (normalizeOpTree r)

176normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =

186normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) =

177 normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))

187 normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r))

188+

189+fixity :: Int -> FixityDirection -> Fixity

190+fixity = Fixity NoSourceText

191+

192+doubleWithinEps :: Double -> Double -> Double -> Bool

193+doubleWithinEps eps a b = abs (a - b) < eps

src/Ormolu/Processing/Common.hsdeleted−27

@@ -1,27 +0,0 @@

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.hsdeleted−70

@@ -1,70 +0,0 @@

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.hsdeleted−31

@@ -1,31 +0,0 @@

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.hsdeleted−149

@@ -1,149 +0,0 @@

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+16−74

@@ -1,66 +1,45 @@

1{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE ViewPatterns #-}

4

3

5-- | Random utilities used by the code.

4-- | Random utilities used by the code.

6module Ormolu.Utils

5module Ormolu.Utils

7− ( RelativePos (..),

8− attachRelativePos,

9− combineSrcSpans',

6+ ( combineSrcSpans',

7+ isModule,

10 notImplemented,

8 notImplemented,

11 showOutputable,

9 showOutputable,

12 splitDocString,

10 splitDocString,

13 typeArgToType,

11 typeArgToType,

14 unSrcSpan,

12 unSrcSpan,

15− incSpanLine,

16 separatedByBlank,

13 separatedByBlank,

17− separatedByBlankNE,

18− onTheSameLine,

19− removeIndentation,

20 )

14 )

21where

15where

22

16

23−import Data.Char (isSpace)

17+import Data.Data (Data, showConstr, toConstr)

24import Data.List (dropWhileEnd)

18import Data.List (dropWhileEnd)

25−import Data.List.NonEmpty (NonEmpty (..))

26import qualified Data.List.NonEmpty as NE

19import qualified Data.List.NonEmpty as NE

20+import Data.List.NonEmpty (NonEmpty (..))

27import Data.Maybe (fromMaybe)

21import Data.Maybe (fromMaybe)

28import Data.Text (Text)

22import Data.Text (Text)

29import qualified Data.Text as T

23import qualified Data.Text as T

30import GHC

24import GHC

31−import GHC.DynFlags (baseDynFlags)

25+import HsDoc (HsDocString, unpackHDS)

32import qualified Outputable as GHC

26import qualified Outputable as GHC

33

27

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−

53-- | Combine all source spans from the given list.

28-- | Combine all source spans from the given list.

54combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan

29combineSrcSpans' :: NonEmpty SrcSpan -> SrcSpan

55combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs

30combineSrcSpans' (x :| xs) = foldr combineSrcSpans x xs

56

31

32+-- | Return 'True' if given element of AST is module.

33+isModule :: Data a => a -> Bool

34+isModule x = showConstr (toConstr x) == "HsModule"

35+

57-- | Placeholder for things that are not yet implemented.

36-- | Placeholder for things that are not yet implemented.

58notImplemented :: String -> a

37notImplemented :: String -> a

59notImplemented msg = error $ "not implemented yet: " ++ msg

38notImplemented msg = error $ "not implemented yet: " ++ msg

60

39

61-- | Pretty-print an 'GHC.Outputable' thing.

40-- | Pretty-print an 'GHC.Outputable' thing.

62showOutputable :: GHC.Outputable o => o -> String

41showOutputable :: GHC.Outputable o => o -> String

63−showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr

42+showOutputable = GHC.showSDocUnsafe . GHC.ppr

64

43

65-- | Split and normalize a doc string. The result is a list of lines that

44-- | Split and normalize a doc string. The result is a list of lines that

66-- make up the comment.

45-- make up the comment.

@@ -99,57 +78,20 @@ splitDocString docStr =

99 then dropSpace <$> xs

78 then dropSpace <$> xs

100 else xs

79 else xs

101

80

102−-- | Get 'LHsType' out of 'LHsTypeArg'.

103typeArgToType :: LHsTypeArg p -> LHsType p

81typeArgToType :: LHsTypeArg p -> LHsType p

104typeArgToType = \case

82typeArgToType = \case

105 HsValArg tm -> tm

83 HsValArg tm -> tm

106 HsTypeArg _ ty -> ty

84 HsTypeArg _ ty -> ty

107 HsArgPar _ -> notImplemented "HsArgPar"

85 HsArgPar _ -> notImplemented "HsArgPar"

108

86

109−-- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”.

110unSrcSpan :: SrcSpan -> Maybe RealSrcSpan

87unSrcSpan :: SrcSpan -> Maybe RealSrcSpan

111−unSrcSpan = \case

112− RealSrcSpan r -> Just r

88+unSrcSpan (RealSrcSpan r) = Just r

113− UnhelpfulSpan _ -> Nothing

89+unSrcSpan (UnhelpfulSpan _) = Nothing

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

129−-- | Do two declarations have a blank between them?

91+-- | Do two declaration groups have a blank between them?

130−separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool

92+separatedByBlank :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool

131separatedByBlank loc a b =

93separatedByBlank loc a b =

132 fromMaybe False $ do

94 fromMaybe False $ do

133− endA <- srcSpanEndLine <$> unSrcSpan (loc a)

95+ endA <- srcSpanEndLine <$> unSrcSpan (loc $ NE.last a)

134− startB <- srcSpanStartLine <$> unSrcSpan (loc b)

96+ startB <- srcSpanStartLine <$> unSrcSpan (loc $ NE.head b)

135 pure (startB - endA >= 2)

97 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+7−4

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

1{-# LANGUAGE TemplateHaskell #-}

2

3−module Ormolu.PrinterSpec (spec) where

3+module Ormolu.PrinterSpec

4+ ( spec,

5+ )

6+where

4

7

5import Control.Exception

8import Control.Exception

6import Control.Monad

9import Control.Monad

@@ -62,7 +65,7 @@ deriveOutput path =

62-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.

65-- | A version of 'shouldBe' that is specialized to comparing 'Text' values.

63-- It also prints multi-line snippets in a more readable form.

66-- It also prints multi-line snippets in a more readable form.

64shouldMatch :: Bool -> Text -> Text -> Expectation

67shouldMatch :: Bool -> Text -> Text -> Expectation

65−shouldMatch idempotenceTest actual expected =

68+shouldMatch idempotencyTest actual expected =

66 when (actual /= expected) . expectationFailure $

69 when (actual /= expected) . expectationFailure $

67 unlines

70 unlines

68 [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",

71 [ ">>>>>>>>>>>>>>>>>>>>>> expected (" ++ pass ++ "):",

@@ -72,8 +75,8 @@ shouldMatch idempotenceTest actual expected =

72 ]

75 ]

73 where

76 where

74 pass =

77 pass =

75− if idempotenceTest

78+ if idempotencyTest

76− then "idempotence pass"

79+ then "idempotency pass"

77 else "first pass"

80 else "first pass"

78

81

79examplesDir :: Path Rel Dir

82examplesDir :: Path Rel Dir